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

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