|
| 1 | +{-# LANGUAGE OverloadedStrings #-} |
| 2 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 3 | +module Distribution.FieldGrammar.Described ( |
| 4 | + Described (..), |
| 5 | + describeDoc, |
| 6 | + -- * Regular expressions |
| 7 | + Regex (..), |
| 8 | + RTerm (..), |
| 9 | + reHsString, |
| 10 | + reEps, |
| 11 | + reChar, |
| 12 | + reChars, |
| 13 | + reDot, |
| 14 | + reComma, |
| 15 | + reSpacedComma, |
| 16 | + reMunchCS, |
| 17 | + reMunch1CS, |
| 18 | + -- * Character Sets |
| 19 | + csChar, |
| 20 | + csAlphaNum, |
| 21 | + csNotSpace, |
| 22 | + csNotSpaceOrComma, |
| 23 | + -- * Pretty-printing |
| 24 | + regexDoc, |
| 25 | + -- * Generation |
| 26 | + generate, |
| 27 | + ) where |
| 28 | + |
| 29 | +import Data.Char (isControl) |
| 30 | +import Distribution.Compat.Prelude |
| 31 | +import Prelude () |
| 32 | + |
| 33 | +import Distribution.Parsec (Parsec) |
| 34 | +import Distribution.Pretty (Pretty) |
| 35 | + |
| 36 | +import qualified Distribution.Utils.AnsiCharSet as ACS |
| 37 | +import qualified Text.PrettyPrint as PP |
| 38 | + |
| 39 | +-- | Class describing the pretty/parsec format of a. |
| 40 | +class (Pretty a, Parsec a) => Described a where |
| 41 | + -- | A pretty document of "regex" describing the field format |
| 42 | + describe :: proxy a -> Regex RTerm |
| 43 | + |
| 44 | +-- | Pretty-print description. |
| 45 | +-- |
| 46 | +-- >>> describeDoc ([] :: [Bool]) |
| 47 | +-- \mathop{\mathord{"}\mathtt{True}\mathord{"}}\mid\mathop{\mathord{"}\mathtt{False}\mathord{"}} |
| 48 | +-- |
| 49 | +describeDoc :: Described a => proxy a -> PP.Doc |
| 50 | +describeDoc p = regexDoc (describe p) |
| 51 | + |
| 52 | +instance Described Bool where |
| 53 | + describe _ = REUnion ["True", "False"] |
| 54 | + |
| 55 | +instance Described a => Described (Identity a) where |
| 56 | + describe _ = describe ([] :: [a]) |
| 57 | + |
| 58 | +------------------------------------------------------------------------------- |
| 59 | +-- Regex |
| 60 | +------------------------------------------------------------------------------- |
| 61 | + |
| 62 | +-- | Regular expressions tuned for 'Described' use-case. |
| 63 | +data Regex a |
| 64 | + = REAppend [Regex a] -- ^ append @ab@ |
| 65 | + | REUnion [Regex a] -- ^ union @a|b@ |
| 66 | + | REMunch (Regex a) (Regex a) -- ^ star @a*@, with a separator |
| 67 | + | REMunch1 (Regex a) (Regex a) -- ^ plus @a+@, with a separator |
| 68 | + | REOpt (Regex a) -- ^ optional @r?@ |
| 69 | + | REString String -- ^ literal string @abcd@ |
| 70 | + | RECharSet ACS.AnsiCharSet -- ^ charset @[:alnum:]@ |
| 71 | + | RESpaces -- ^ zero-or-more spaces |
| 72 | + | RESpaces1 -- ^ one-or-more spaces |
| 73 | + | REVar a -- ^ variable |
| 74 | + | RELet String (Regex a) |
| 75 | + (Regex (Maybe a)) -- ^ named expression |
| 76 | + | RERec String (Regex (Maybe a)) -- ^ recursive expressions |
| 77 | + |
| 78 | + | RETodo -- ^ unspecified |
| 79 | + deriving (Eq, Ord, Show) |
| 80 | + |
| 81 | +-- | Terminals used by field grammars. |
| 82 | +-- |
| 83 | +-- TODO: remove |
| 84 | +data RTerm |
| 85 | + = RHaskellString |
| 86 | + | RUnqualName |
| 87 | + deriving (Eq, Ord, Show) |
| 88 | + |
| 89 | +reHsString :: Regex RTerm |
| 90 | +reHsString = REVar RHaskellString |
| 91 | + |
| 92 | +reEps :: Regex a |
| 93 | +reEps = REAppend [] |
| 94 | + |
| 95 | +reChar :: Char -> Regex a |
| 96 | +reChar = RECharSet . ACS.singleton |
| 97 | + |
| 98 | +reChars :: [Char] -> Regex a |
| 99 | +reChars = RECharSet . ACS.fromList |
| 100 | + |
| 101 | +reDot :: Regex a |
| 102 | +reDot = reChar '.' |
| 103 | + |
| 104 | +reComma :: Regex a |
| 105 | +reComma = reChar ',' |
| 106 | + |
| 107 | +reSpacedComma :: Regex a |
| 108 | +reSpacedComma = RESpaces <> reComma <> RESpaces |
| 109 | + |
| 110 | +reMunch1CS :: ACS.AnsiCharSet -> Regex a |
| 111 | +reMunch1CS = REMunch1 reEps . RECharSet |
| 112 | + |
| 113 | +reMunchCS :: ACS.AnsiCharSet -> Regex a |
| 114 | +reMunchCS = REMunch reEps . RECharSet |
| 115 | + |
| 116 | +instance IsString (Regex a) where |
| 117 | + fromString = REString |
| 118 | + |
| 119 | +instance Semigroup (Regex a) where |
| 120 | + x <> y = REAppend (unAppend x ++ unAppend y) where |
| 121 | + unAppend (REAppend rs) = rs |
| 122 | + unAppend r = [r] |
| 123 | + |
| 124 | +instance Monoid (Regex a) where |
| 125 | + mempty = REAppend [] |
| 126 | + mappend = (<>) |
| 127 | + |
| 128 | +------------------------------------------------------------------------------- |
| 129 | +-- Character sets |
| 130 | +------------------------------------------------------------------------------- |
| 131 | + |
| 132 | +csChar :: Char -> ACS.AnsiCharSet |
| 133 | +csChar = ACS.singleton |
| 134 | + |
| 135 | +csAlphaNum :: ACS.AnsiCharSet |
| 136 | +csAlphaNum = ACS.alphanum |
| 137 | + |
| 138 | +csNotSpace :: ACS.AnsiCharSet |
| 139 | +csNotSpace = ACS.filter (\c -> not (isControl c) && c /= ' ') ACS.full |
| 140 | + |
| 141 | +csNotSpaceOrComma :: ACS.AnsiCharSet |
| 142 | +csNotSpaceOrComma = ACS.filter (/= ',') csNotSpace |
| 143 | + |
| 144 | +------------------------------------------------------------------------------- |
| 145 | +-- Pretty-printing |
| 146 | +------------------------------------------------------------------------------- |
| 147 | + |
| 148 | +-- | |
| 149 | +-- |
| 150 | +-- >>> regexDoc $ REString "True" |
| 151 | +-- \mathop{\mathord{"}\mathtt{True}\mathord{"}} |
| 152 | +-- |
| 153 | +-- Note: we don't simplify regexps yet: |
| 154 | +-- |
| 155 | +-- >>> regexDoc $ REString "foo" <> REString "bar" |
| 156 | +-- \mathop{\mathord{"}\mathtt{foo}\mathord{"}}\mathop{\mathord{"}\mathtt{bar}\mathord{"}} |
| 157 | +-- |
| 158 | +regexDoc :: Regex RTerm -> PP.Doc |
| 159 | +regexDoc = go termDoc 0 where |
| 160 | + go :: (a -> PP.Doc) -> Int -> Regex a -> PP.Doc |
| 161 | + go f d (REAppend rs) = parensIf (d > 2) $ PP.hcat (map (go f 2) rs) |
| 162 | + go f d (REUnion rs) = parensIf (d > 1) $ PP.hcat (PP.punctuate (PP.text "\\mid") (map (go f 1) rs)) |
| 163 | + |
| 164 | + go f d (REMunch sep r) = parensIf (d > 3) $ |
| 165 | + PP.text "{" <<>> go f 3 r <<>> PP.text "}^\\ast_{" <<>> go f 0 sep <<>> PP.text "}" |
| 166 | + go f d (REMunch1 sep r) = parensIf (d > 3) $ |
| 167 | + PP.text "{" <<>> go f 3 r <<>> PP.text "}^+_{" <<>> go f 0 sep <<>> PP.text "}" |
| 168 | + go f d (REOpt r) = parensIf (d > 3) $ |
| 169 | + PP.text "{" <<>> go f 3 r <<>> PP.text "}^?" |
| 170 | + |
| 171 | + go _ _ (REString s) = PP.text "\\mathop{\\mathord{\"}\\mathtt{" <<>> PP.hcat (map charDoc s) <<>> PP.text "}\\mathord{\"}}" |
| 172 | + go _ _ (RECharSet cs) = charsetDoc cs |
| 173 | + |
| 174 | + go _ _ RESpaces = "\\circ" |
| 175 | + go _ _ RESpaces1 = "\\bullet" |
| 176 | + |
| 177 | + go f _ (REVar a) = f a |
| 178 | + go f d (RELet n _ r) = go (maybe (terminalDoc n) f) d r |
| 179 | + go _ _ (RERec n _) = terminalDoc n |
| 180 | + |
| 181 | + go _ _ RETodo = PP.text "\\mathsf{\\color{red}{TODO}}" |
| 182 | + |
| 183 | + parensIf :: Bool -> PP.Doc -> PP.Doc |
| 184 | + parensIf True d = PP.text "\\left(" <<>> d <<>> PP.text "\\right)" |
| 185 | + parensIf False d = d |
| 186 | + |
| 187 | +termDoc :: RTerm -> PP.Doc |
| 188 | +termDoc RHaskellString = terminalDoc "hs-string" |
| 189 | +termDoc RUnqualName = terminalDoc "unqual-name" |
| 190 | + |
| 191 | +terminalDoc :: String -> PP.Doc |
| 192 | +terminalDoc s = PP.text "\\mathop{\\mathit{" <<>> PP.hcat (map charDoc s) <<>> PP.text "}}" |
| 193 | + |
| 194 | +charDoc :: Char -> PP.Doc |
| 195 | +charDoc ' ' = PP.text " " |
| 196 | +charDoc '{' = PP.text "\\{" |
| 197 | +charDoc '}' = PP.text "\\}" |
| 198 | +charDoc c |
| 199 | + | isAlphaNum c = PP.char c |
| 200 | + | otherwise = PP.text ("\\text{" ++ c : "}") |
| 201 | + |
| 202 | +inquotes :: PP.Doc -> PP.Doc |
| 203 | +inquotes d = "\\mathop{\\mathord{\"}" <<>> d <<>> "\\mathord{\"}}" |
| 204 | + |
| 205 | +charsetDoc :: ACS.AnsiCharSet -> PP.Doc |
| 206 | +charsetDoc acs |
| 207 | + | acs == csAlphaNum = terminalDoc "alpha-num" |
| 208 | + | acs == csNotSpace = terminalDoc "not-space" |
| 209 | + | acs == csNotSpaceOrComma = terminalDoc "not-space-nor-comma" |
| 210 | +charsetDoc acs = case ACS.ranges acs of |
| 211 | + [] -> PP.brackets PP.empty |
| 212 | + [(x,y)] | x == y -> inquotes (charDoc x) |
| 213 | + rs -> PP.brackets $ PP.hcat $ map rangeDoc rs |
| 214 | + where |
| 215 | + rangeDoc :: (Char, Char) -> PP.Doc |
| 216 | + rangeDoc (x, y) | x == y = inquotes (charDoc x) |
| 217 | + | otherwise = inquotes (charDoc x) <<>> PP.char '-' <<>> inquotes (charDoc y) |
| 218 | + |
| 219 | +------------------------------------------------------------------------------- |
| 220 | +-- Generation |
| 221 | +------------------------------------------------------------------------------- |
| 222 | + |
| 223 | +-- | Generate an example string. |
| 224 | +generate |
| 225 | + :: Monad m |
| 226 | + => (Int -> Int -> m Int) -- ^ generate integer in range |
| 227 | + -> (a -> m String) -- ^ generate variables |
| 228 | + -> Regex a -- ^ regex |
| 229 | + -> m String -- ^ an example string. |
| 230 | +generate rnd f (REAppend rs) = do |
| 231 | + xs <- traverse (generate rnd f) rs |
| 232 | + return (concat xs) |
| 233 | +generate rnd f (REUnion rs) = do |
| 234 | + n <- rnd 0 (length rs - 1) |
| 235 | + generate rnd f (rs !! n) |
| 236 | +generate rnd f (REMunch sep r) = do |
| 237 | + n <- rnd 0 5 |
| 238 | + xs <- traverse (generate rnd f) (intersperse sep (replicate n r)) |
| 239 | + return (concat xs) |
| 240 | +generate rnd f (REMunch1 sep r) = do |
| 241 | + n <- rnd 1 5 |
| 242 | + xs <- traverse (generate rnd f) (intersperse sep (replicate n r)) |
| 243 | + return (concat xs) |
| 244 | +generate rnd f (REOpt r) = do |
| 245 | + n <- rnd 0 2 |
| 246 | + case n of |
| 247 | + 0 -> return "" |
| 248 | + _ -> generate rnd f r |
| 249 | +generate _ _ (REString str) = return str |
| 250 | +generate rnd _ (RECharSet cs) = return <$> generateCS rnd cs |
| 251 | +generate rnd _ RESpaces1 = (\n -> replicate n ' ') <$> rnd 1 3 |
| 252 | +generate rnd _ RESpaces = (\n -> replicate n ' ') <$> rnd 0 3 |
| 253 | + |
| 254 | +generate _ f (REVar x) = f x |
| 255 | +generate _ _ (RELet _ _ _) = error "generate let" |
| 256 | +generate _ _ (RERec _ _) = error "generate rec" |
| 257 | +generate _ _ RETodo = return "TODO" |
| 258 | + |
| 259 | +generateCS |
| 260 | + :: Monad m |
| 261 | + => (Int -> Int -> m Int) -- ^ generate integer in range |
| 262 | + -> ACS.AnsiCharSet |
| 263 | + -> m Char |
| 264 | +generateCS rnd asc = do |
| 265 | + n <- rnd 0 (ACS.size asc - 1) |
| 266 | + return (ACS.toList asc !! n) |
0 commit comments