General.hs 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286
  1. {-# LANGUAGE ViewPatterns #-}
  2. {-# LANGUAGE OverloadedStrings #-}
  3. module Data.SCargot.General
  4. ( -- * SExprSpec
  5. SExprSpec
  6. , mkSpec
  7. , convertSpec
  8. , addReader
  9. , setComment
  10. -- * Specific SExprSpec Conversions
  11. , asRich
  12. , asWellFormed
  13. , withQuote
  14. -- * Using a SExprSpec
  15. , decode
  16. , decodeOne
  17. , encode
  18. , encodeOne
  19. -- * Useful Type Aliases
  20. , Reader
  21. , Comment
  22. , Serializer
  23. ) where
  24. import Control.Applicative ((<*), (*>), (<*>), (<$>), pure)
  25. import Control.Monad ((>=>))
  26. import Data.Char (isAlpha, isDigit, isAlphaNum)
  27. import Data.Map.Strict (Map)
  28. import qualified Data.Map.Strict as M
  29. import Data.Maybe (fromJust)
  30. import Data.Monoid ((<>))
  31. import Data.String (IsString)
  32. import Data.Text (Text, pack, unpack)
  33. import qualified Data.Text as T
  34. import Text.Parsec ( (<|>)
  35. , (<?>)
  36. , char
  37. , eof
  38. , lookAhead
  39. , many1
  40. , runParser
  41. , skipMany
  42. )
  43. import Text.Parsec.Char (anyChar, space)
  44. import Text.Parsec.Text (Parser)
  45. import Data.SCargot.Repr ( SExpr(..)
  46. , RichSExpr
  47. , WellFormedSExpr
  48. , fromRich
  49. , toRich
  50. , fromWellFormed
  51. , toWellFormed
  52. )
  53. type ReaderMacroMap atom = Map Char (Reader atom)
  54. -- | A 'Reader' represents a reader macro: it takes a parser for
  55. -- the S-Expression type and performs as much or as little
  56. -- parsing as it would like, and then returns an S-expression.
  57. type Reader atom = (Parser (SExpr atom) -> Parser (SExpr atom))
  58. -- | A 'Comment' represents any kind of skippable comment. This
  59. -- parser __must__ be able to fail if a comment is not being
  60. -- recognized, and it __must__ not consume any input.
  61. type Comment = Parser ()
  62. -- | A 'Serializer' is any function which can serialize an Atom
  63. -- to 'Text'.
  64. type Serializer atom = atom -> Text
  65. -- | A 'SExprSpec' describes a parser and emitter for a particular
  66. -- variant of S-Expressions. The @atom@ type corresponds to a
  67. -- Haskell type used to represent the atoms, and the @carrier@
  68. -- type corresponds to the parsed S-Expression structure. The
  69. -- 'SExprSpec' type is deliberately opaque so that it must be
  70. -- constructed and modified with other helper functions.
  71. data SExprSpec atom carrier = SExprSpec
  72. { sesPAtom :: Parser atom
  73. , sesSAtom :: Serializer atom
  74. , readerMap :: ReaderMacroMap atom
  75. , comment :: Maybe Comment
  76. , postparse :: SExpr atom -> Either String carrier
  77. , preserial :: carrier -> SExpr atom
  78. }
  79. -- | Create a basic 'SExprSpec' when given a parser and serializer
  80. -- for an atom type. A small minimal 'SExprSpec' that recognizes
  81. -- any alphanumeric sequence as a valid atom looks like:
  82. --
  83. -- > simpleSpec :: SExprSpec Text (SExpr Text)
  84. -- > simpleSpec = mkSpec (pack <$> many1 isAlphaNum) id
  85. mkSpec :: Parser atom -> Serializer atom -> SExprSpec atom (SExpr atom)
  86. mkSpec p s = SExprSpec
  87. { sesPAtom = p <?> "atom"
  88. , sesSAtom = s
  89. , readerMap = M.empty
  90. , comment = Nothing
  91. , postparse = return
  92. , preserial = id
  93. }
  94. -- | Modify the carrier type for a 'SExprSpec'. This is
  95. -- used internally to convert between various 'SExpr' representations,
  96. -- but could also be used externally to add an extra conversion layer
  97. -- onto a 'SExprSpec'.
  98. --
  99. -- The following defines an S-expression spec that recognizes the
  100. -- language of binary addition trees. It does so by first transforming
  101. -- the internal S-expression representation using 'asWellFormed', and
  102. -- then providing a conversion between the 'WellFormedSExpr' type and
  103. -- an @Expr@ AST. Notice that the below parser uses 'String' as its
  104. -- underlying atom type, instead of some token type.
  105. --
  106. -- > data Expr = Add Expr Expr | Num Int deriving (Eq, Show)
  107. -- >
  108. -- > toExpr :: WellFormedSExpr String -> Either String Expr
  109. -- > toExpr (L [A "+", l, r]) = Add <$> toExpr l <*> toExpr r
  110. -- > toExpr (A c) | all isDigit c = pure (Num (read c))
  111. -- > toExpr c = Left ("Invalid expr: " ++ show c)
  112. -- >
  113. -- > fromExpr :: Expr -> WellFormedSExpr String
  114. -- > fromExpr (Add l r) = L [A "+", fromExpr l, fromExpr r]
  115. -- > fromExpr (Num n) = A (show n)
  116. -- >
  117. -- > mySpec :: SExprSpec String Expr
  118. -- > mySpec = convertSpec toExpr fromExpr $ asWellFormed $ mkSpec parser pack
  119. -- > where parser = many1 (satisfy isValidChar)
  120. -- > isValidChar c = isDigit c || c == '+'
  121. convertSpec :: (b -> Either String c) -> (c -> b)
  122. -> SExprSpec a b -> SExprSpec a c
  123. convertSpec f g spec = spec
  124. { postparse = postparse spec >=> f
  125. , preserial = preserial spec . g
  126. }
  127. -- | Convert the final output representation from the 'SExpr' type
  128. -- to the 'RichSExpr' type.
  129. asRich :: SExprSpec a (SExpr b) -> SExprSpec a (RichSExpr b)
  130. asRich = convertSpec (return . toRich) fromRich
  131. -- | Convert the final output representation from the 'SExpr' type
  132. -- to the 'WellFormedSExpr' type.
  133. asWellFormed :: SExprSpec a (SExpr b) -> SExprSpec a (WellFormedSExpr b)
  134. asWellFormed = convertSpec toWellFormed fromWellFormed
  135. -- | Add the ability to execute some particular reader macro, as
  136. -- defined by its initial character and the 'Parser' which returns
  137. -- the parsed S-Expression. The 'Reader' is passed a 'Parser' which
  138. -- can be recursively called to parse more S-Expressions, and begins
  139. -- parsing after the reader character has been removed from the
  140. -- stream.
  141. --
  142. -- The following defines an S-expression variant that treats
  143. -- @'expr@ as being sugar for @(quote expr)@. Note that this is done
  144. -- already in a more general way by the 'withQuote' function, but
  145. -- it is a good illustration of using reader macros in practice:
  146. --
  147. -- > mySpec :: SExprSpec String (SExpr Text)
  148. -- > mySpec = addReader '\'' reader $ mkSpec (many1 alphaNum) pack
  149. -- > where reader p = quote <$> p
  150. -- > quote e = SCons (SAtom "quote") (SCons e SNil)
  151. addReader :: Char -> Reader a -> SExprSpec a c -> SExprSpec a c
  152. addReader c reader spec = spec
  153. { readerMap = M.insert c reader (readerMap spec) }
  154. -- | Add the ability to ignore some kind of comment. This gets
  155. -- factored into whitespace parsing, and it's very important that
  156. -- the parser supplied __be able to fail__ (as otherwise it will
  157. -- cause an infinite loop), and also that it __not consume any input__
  158. -- (which may require it to be wrapped in 'try'.)
  159. --
  160. -- The following code defines an S-expression variant that skips
  161. -- C++-style comments, i.e. those which begin with @//@ and last
  162. -- until the end of a line:
  163. --
  164. -- > t :: SExprSpec String (SExpr Text)
  165. -- > t = setComment comm $ mkSpec (many1 alphaNum) pack
  166. -- > where comm = try (string "//" *> manyTill newline *> pure ())
  167. setComment :: Comment -> SExprSpec a c -> SExprSpec a c
  168. setComment c spec = spec { comment = Just (c <?> "comment") }
  169. -- | Add the ability to understand a quoted S-Expression. In general,
  170. -- many Lisps use @'sexpr@ as sugar for @(quote sexpr)@. This is
  171. -- a convenience function which allows you to easily add quoted
  172. -- expressions to a 'SExprSpec', provided that you supply which
  173. -- atom you want substituted in for the symbol @quote@.
  174. withQuote :: IsString t => SExprSpec t (SExpr t) -> SExprSpec t (SExpr t)
  175. withQuote = addReader '\'' (fmap go)
  176. where go s = SCons "quote" (SCons s SNil)
  177. peekChar :: Parser (Maybe Char)
  178. peekChar = Just <$> lookAhead anyChar <|> pure Nothing
  179. parseGenericSExpr ::
  180. Parser atom -> ReaderMacroMap atom -> Parser () -> Parser (SExpr atom)
  181. parseGenericSExpr atom reader skip = do
  182. let sExpr = parseGenericSExpr atom reader skip <?> "s-expr"
  183. skip
  184. c <- peekChar
  185. r <- case c of
  186. Nothing -> fail "Unexpected end of input"
  187. Just '(' -> char '(' >> skip >> parseList sExpr skip
  188. Just (flip M.lookup reader -> Just r) -> anyChar >> r sExpr
  189. _ -> SAtom `fmap` atom
  190. skip
  191. return r
  192. parseList :: Parser (SExpr atom) -> Parser () -> Parser (SExpr atom)
  193. parseList sExpr skip = do
  194. i <- peekChar
  195. case i of
  196. Nothing -> fail "Unexpected end of input"
  197. Just ')' -> char ')' >> return SNil
  198. _ -> do
  199. car <- sExpr
  200. skip
  201. c <- peekChar
  202. case c of
  203. Just '.' -> do
  204. char '.'
  205. cdr <- sExpr
  206. skip
  207. char ')'
  208. skip
  209. return (SCons car cdr)
  210. Just ')' -> do
  211. char ')'
  212. skip
  213. return (SCons car SNil)
  214. _ -> do
  215. cdr <- parseList sExpr skip
  216. return (SCons car cdr)
  217. -- | Given a CommentMap, create the corresponding parser to
  218. -- skip those comments (if they exist).
  219. buildSkip :: Maybe (Parser ()) -> Parser ()
  220. buildSkip Nothing = skipMany space
  221. buildSkip (Just c) = alternate
  222. where alternate = skipMany space >> ((c >> alternate) <|> return ())
  223. doParse :: Parser a -> Text -> Either String a
  224. doParse p t = case runParser p () "" t of
  225. Left err -> Left (show err)
  226. Right x -> Right x
  227. -- | Decode a single S-expression. If any trailing input is left after
  228. -- the S-expression (ignoring comments or whitespace) then this
  229. -- will fail: for those cases, use 'decode', which returns a list of
  230. -- all the S-expressions found at the top level.
  231. decodeOne :: SExprSpec atom carrier -> Text -> Either String carrier
  232. decodeOne spec = doParse (parser <* eof) >=> (postparse spec)
  233. where parser = parseGenericSExpr
  234. (sesPAtom spec)
  235. (readerMap spec)
  236. (buildSkip (comment spec))
  237. -- | Decode several S-expressions according to a given 'SExprSpec'. This
  238. -- will return a list of every S-expression that appears at the top-level
  239. -- of the document.
  240. decode :: SExprSpec atom carrier -> Text -> Either String [carrier]
  241. decode spec =
  242. doParse (many1 parser <* eof) >=> mapM (postparse spec)
  243. where parser = parseGenericSExpr
  244. (sesPAtom spec)
  245. (readerMap spec)
  246. (buildSkip (comment spec))
  247. -- | Encode (without newlines) a single S-expression.
  248. encodeSExpr :: SExpr atom -> (atom -> Text) -> Text
  249. encodeSExpr SNil _ = "()"
  250. encodeSExpr (SAtom s) t = t s
  251. encodeSExpr (SCons x xs) t = go xs (encodeSExpr x t)
  252. where go (SAtom s) rs = "(" <> rs <> " . " <> t s <> ")"
  253. go SNil rs = "(" <> rs <> ")"
  254. go (SCons x xs) rs = go xs (rs <> " " <> encodeSExpr x t)
  255. -- | Emit an S-Expression in a machine-readable way. This does no
  256. -- pretty-printing or indentation, and produces no comments.
  257. encodeOne :: SExprSpec atom carrier -> carrier -> Text
  258. encodeOne spec c = encodeSExpr (preserial spec c) (sesSAtom spec)
  259. encode :: SExprSpec atom carrier -> [carrier] -> Text
  260. encode spec cs = T.concat (map (encodeOne spec) cs)