Cabal-described/src/Distribution/Utils/GrammarRegex.hs

   1 {-# LANGUAGE DeriveTraversable   #-}
   2 {-# LANGUAGE OverloadedStrings   #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 module Distribution.Utils.GrammarRegex (
   5     -- * Regular expressions
   6     GrammarRegex (..),
   7     reEps,
   8     reChar,
   9     reChars,
  10     reMunchCS,
  11     reMunch1CS,
  12     -- * Variables
  13     reVar0,
  14     reVar1,
  15     -- * Pretty-printing
  16     regexDoc,
  17     ) where
  18
  19 import Data.Char                     (isAlphaNum, isControl, ord)
  20 import Data.Foldable                 (Foldable)
  21 import Data.Maybe                    (fromMaybe)
  22 import Data.Monoid                   (Monoid (..))
  23 import Data.String                   (IsString (..))
  24 import Data.Traversable              (Traversable)
  25 import Data.Void                     (Void, vacuous)
  26 import Distribution.Compat.Semigroup (Semigroup (..))
  27 import Prelude                       (Bool (..), Char, Eq (..), Functor, Int, Maybe (..), Ord (..), Show, String, fmap, length, map, otherwise, ($), (++), (.))
  28
  29 import qualified Distribution.Utils.CharSet as CS
  30 import qualified Text.PrettyPrint           as PP
  31
  32 (<<>>) :: PP.Doc -> PP.Doc -> PP.Doc
  33 (<<>>) = (PP.<>)
  34
  35 -------------------------------------------------------------------------------
  36 -- GrammarRegex
  37 -------------------------------------------------------------------------------
  38
  39 -- | Recursive regular expressions tuned for 'Described' use-case.
  40 data GrammarRegex a
  41     = REAppend  [GrammarRegex a]          -- ^ append @ab@
  42     | REUnion   [GrammarRegex a]          -- ^ union @a|b@
  43
  44     -- repetition
  45     | REMunch   (GrammarRegex a) (GrammarRegex a)       -- ^ star @a*@, with a separator
  46     | REMunch1  (GrammarRegex a) (GrammarRegex a)       -- ^ plus @a+@, with a separator
  47     | REMunchR Int (GrammarRegex a) (GrammarRegex a)    -- ^ 1-n, with a separator
  48     | REOpt     (GrammarRegex a)                        -- ^ optional @r?@
  49
  50     | REString  String                           -- ^ literal string @abcd@
  51     | RECharSet CS.CharSet                       -- ^ charset @[:alnum:]@
  52     | REVar     a                                -- ^ variable
  53     | RENamed   String (GrammarRegex a)          -- ^ named expression
  54     | RERec     String (GrammarRegex (Maybe a))  -- ^ recursive expressions
  55
  56     -- cabal syntax specifics
  57     | RESpaces                            -- ^ zero-or-more spaces
  58     | RESpaces1                           -- ^ one-or-more spaces
  59     | RECommaList (GrammarRegex a)        -- ^ comma list (note, leading or trailing commas)
  60     | RECommaNonEmpty (GrammarRegex a)    -- ^ comma non-empty list (note, leading or trailing commas)
  61     | REOptCommaList (GrammarRegex a)     -- ^ opt comma list
  62
  63     | RETodo                              -- ^ unspecified
  64   deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
  65
  66 -------------------------------------------------------------------------------
  67 -- Instances
  68 -------------------------------------------------------------------------------
  69
  70 instance IsString (GrammarRegex a)  where
  71     fromString = REString
  72
  73 instance Semigroup (GrammarRegex a) where
  74     x <> y = REAppend (unAppend x ++ unAppend y) where
  75         unAppend (REAppend rs) = rs
  76         unAppend r             = [r]
  77
  78 instance Monoid (GrammarRegex a) where
  79     mempty = REAppend []
  80     mappend = (<>)
  81
  82 -------------------------------------------------------------------------------
  83 -- Smart constructors
  84 -------------------------------------------------------------------------------
  85
  86 reEps :: GrammarRegex a
  87 reEps = REAppend []
  88
  89 reChar :: Char -> GrammarRegex a
  90 reChar = RECharSet . CS.singleton
  91
  92 reChars :: [Char] -> GrammarRegex a
  93 reChars = RECharSet . CS.fromList
  94
  95 reMunch1CS :: CS.CharSet -> GrammarRegex a
  96 reMunch1CS = REMunch1 reEps . RECharSet
  97
  98 reMunchCS :: CS.CharSet -> GrammarRegex a
  99 reMunchCS = REMunch reEps . RECharSet
 100
 101 -------------------------------------------------------------------------------
 102 -- Variables
 103 -------------------------------------------------------------------------------
 104
 105 reVar0 :: GrammarRegex (Maybe a)
 106 reVar0 = REVar Nothing
 107
 108 reVar1 :: GrammarRegex (Maybe (Maybe a))
 109 reVar1 = REVar (Just Nothing)
 110
 111 -------------------------------------------------------------------------------
 112 -- Pretty-printing
 113 -------------------------------------------------------------------------------
 114
 115 -- |
 116 --
 117 -- >>> regexDoc $ REString "True"
 118 -- \mathop{\mathord{``}\mathtt{True}\mathord{"}}
 119 --
 120 -- Note: we don't simplify regexps yet:
 121 --
 122 -- >>> regexDoc $ REString "foo" <> REString "bar"
 123 -- \mathop{\mathord{``}\mathtt{foo}\mathord{"}}\mathop{\mathord{``}\mathtt{bar}\mathord{"}}
 124 --
 125 regexDoc :: GrammarRegex Void -> PP.Doc
 126 regexDoc = go 0 . vacuous where
 127     go :: Int -> GrammarRegex PP.Doc -> PP.Doc
 128     go _ (REAppend [])    = ""
 129     go d (REAppend rs)    = parensIf (d > 2) $ PP.hcat (map (go 2) rs)
 130     go d (REUnion [r])    = go d r
 131     go _ (REUnion rs)     = PP.hsep
 132         [ "\\left\\{"
 133         , if length rs < 4
 134           then PP.hcat (PP.punctuate (PP.text "\\mid") (map (go 0) rs))
 135           else "\\begin{gathered}" <<>>
 136                PP.hcat (PP.punctuate "\\\\" (map (go 0) rs)) <<>>
 137               "\\end{gathered}"
 138         , "\\right\\}" ]
 139
 140     go d (REMunch sep r)  = parensIf (d > 3) $
 141         PP.text "{" <<>> go 4 r <<>> PP.text "}^\\ast_{" <<>> go 4 sep <<>> PP.text "}"
 142     go d (REMunch1 sep r) = parensIf (d > 3) $
 143         PP.text "{" <<>> go 4 r <<>> PP.text "}^+_{" <<>> go 4 sep <<>> PP.text "}"
 144     go d (REMunchR n sep r) = parensIf (d > 3) $
 145         PP.text "{" <<>> go 4 r <<>> PP.text "}^{\\in [0\\ldots" <<>> PP.int n <<>> "]}_{" <<>> go 4 sep <<>> PP.text "}"
 146     go d (REOpt r)        = parensIf (d > 3) $
 147         PP.text "{" <<>> go 4 r <<>> PP.text "}^?"
 148
 149     go _ (REString s)     = PP.text "\\mathop{\\mathord{``}\\mathtt{" <<>> PP.hcat (map charDoc s) <<>> PP.text "}\\mathord{\"}}"
 150     go _ (RECharSet cs)   = charsetDoc cs
 151
 152     go _ RESpaces         = "\\circ"
 153     go _ RESpaces1        = "\\bullet"
 154
 155     go _ (RECommaList r)  =
 156         "\\mathrm{commalist}" <<>> go 4 r
 157     go _ (RECommaNonEmpty r)  =
 158         "\\mathrm{commanonempty}" <<>> go 4 r
 159     go _ (REOptCommaList r) =
 160         "\\mathrm{optcommalist}" <<>> go 4 r
 161
 162     go _ (REVar a)         = a
 163     go _ (RENamed n _)     = terminalDoc n
 164     go d (RERec n r)       = parensIf (d > 0) $
 165         "\\mathbf{fix}\\;" <<>> n' <<>> "\\;\\mathbf{in}\\;" <<>>
 166         go 0 (fmap (fromMaybe n') r)
 167       where
 168         n' = terminalDoc n
 169
 170     go _ RETodo            = PP.text "\\mathsf{\\color{red}{TODO}}"
 171
 172     parensIf :: Bool -> PP.Doc -> PP.Doc
 173     parensIf True  d = PP.text "\\left(" <<>> d <<>> PP.text "\\right)"
 174     parensIf False d = d
 175
 176 terminalDoc :: String -> PP.Doc
 177 terminalDoc s = PP.text "\\mathop{\\mathit{" <<>> PP.hcat (map charDoc s) <<>> PP.text "}}"
 178
 179 charDoc :: Char -> PP.Doc
 180 charDoc ' ' = PP.text "\\ "
 181 charDoc '{' = PP.text "\\{"
 182 charDoc '}' = PP.text "\\}"
 183 charDoc '\\' = PP.text "\\text{\\\\}"
 184 charDoc c
 185     | isAlphaNum c = PP.char c
 186     | isControl  c = PP.int (ord c) -- TODO: some syntax
 187     | otherwise    = PP.text ("\\text{" ++ c : "}")
 188
 189 inquotes :: PP.Doc -> PP.Doc
 190 inquotes d = "\\mathop{\\mathord{``}" <<>> d <<>> "\\mathord{\"}}"
 191
 192 mathtt :: PP.Doc -> PP.Doc
 193 mathtt d = "\\mathtt{" <<>> d <<>> "}"
 194
 195 charsetDoc :: CS.CharSet -> PP.Doc
 196 charsetDoc acs
 197     | acs == CS.alpha    = terminalDoc "alpha"
 198     | acs == CS.alphanum = terminalDoc "alpha-num"
 199     | acs == CS.upper    = terminalDoc "upper"
 200 charsetDoc acs = case CS.toIntervalList acs of
 201     []               -> "\\emptyset"
 202     [(x,y)] | x == y -> inquotes $ mathtt $ charDoc x
 203     rs
 204         | CS.size acs <= CS.size notAcs
 205         -> PP.brackets $ PP.hcat $ map rangeDoc rs
 206         | otherwise
 207         -> PP.braces $ PP.brackets (PP.hcat $ map rangeDoc (CS.toIntervalList notAcs)) <<>> PP.text "^c"
 208   where
 209     notAcs = CS.complement acs
 210
 211     rangeDoc :: (Char, Char) -> PP.Doc
 212     rangeDoc (x, y) | x == y    = inquotes (mathtt $ charDoc x)
 213                     | otherwise = inquotes (mathtt $ charDoc x) <<>> PP.text "\\cdots" <<>> inquotes (mathtt $ charDoc y)