Rich.hs 9.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275
  1. {-# LANGUAGE PatternSynonyms #-}
  2. {-# LANGUAGE ViewPatterns #-}
  3. module Data.SCargot.Repr.Rich
  4. ( -- * 'RichSExpr' representation
  5. R.RichSExpr(..)
  6. , R.toRich
  7. , R.fromRich
  8. -- * Constructing and Deconstructing
  9. , cons
  10. , uncons
  11. -- * Useful pattern synonyms
  12. , pattern (:::)
  13. , pattern A
  14. , pattern L
  15. , pattern DL
  16. , pattern Nil
  17. -- * Lenses
  18. , _car
  19. , _cdr
  20. -- * Useful processing functions
  21. , fromPair
  22. , fromList
  23. , fromAtom
  24. , asPair
  25. , asList
  26. , isAtom
  27. , isNil
  28. , asAtom
  29. , asAssoc
  30. , car
  31. , cdr
  32. ) where
  33. #if !MIN_VERSION_base(4,8,0)
  34. import Control.Applicative (Applicative, (<$>), (<*>), pure)
  35. #endif
  36. import Data.SCargot.Repr as R
  37. -- | A traversal with access to the first element of a pair.
  38. --
  39. -- >>> import Lens.Family
  40. -- >>> set _car (A "elephant") (L [A "one", A "two", A "three"])
  41. -- L [A "elelphant",A "two",A "three"]
  42. -- >>> set _car (L [A "two", A "three"]) (DL [A "one"] "elephant")
  43. -- DL [L[A "two",A "three"]] "elephant"
  44. _car :: Applicative f => (RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)
  45. _car f (RSList (x:xs)) = (\ y -> L (y:xs)) `fmap` f x
  46. _car f (RSDotted (x:xs) a) = (\ y -> DL (y:xs) a) `fmap` f x
  47. _car _ (RSAtom a) = pure (A a)
  48. _car _ (RSList []) = pure Nil
  49. _car _ (RSDotted [] a) = pure (A a)
  50. -- | A traversal with access to the second element of a pair. Using
  51. -- this to modify an s-expression may result in changing the
  52. -- constructor used, changing a list to a dotted list or vice
  53. -- versa.
  54. --
  55. -- >>> import Lens.Family
  56. -- >>> set _cdr (A "elephant") (L [A "one", A "two", A "three"])
  57. -- DL [A "one"] "elephant"
  58. -- >>> set _cdr (L [A "two", A "three"]) (DL [A "one"] "elephant")
  59. -- L [A "one",A "two",A "three"]
  60. _cdr :: Applicative f => (RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)
  61. _cdr f (RSList (x:xs)) =
  62. let go (RSList []) = L [x]
  63. go (RSAtom a) = DL [x] a
  64. go (RSList xs') = L (x:xs')
  65. go (RSDotted ys a') = DL (x:ys) a'
  66. in go `fmap` f (L xs)
  67. _cdr f (RSDotted [x] a) =
  68. let go (RSList []) = L [x]
  69. go (RSAtom a') = DL [x] a'
  70. go (RSList xs) = L (x:xs)
  71. go (RSDotted ys a') = DL (x:ys) a'
  72. in go `fmap` f (A a)
  73. _cdr f (RSDotted (x:xs) a) =
  74. let go (RSList []) = L [x]
  75. go (RSAtom a') = DL [x] a'
  76. go (RSList ys) = L (x:ys)
  77. go (RSDotted ys a') = DL (x:ys) a'
  78. in go `fmap` f (DL xs a)
  79. _cdr _ (RSAtom a) = pure (A a)
  80. _cdr _ (RSList []) = pure Nil
  81. _cdr _ (RSDotted [] a) = pure (A a)
  82. -- | Produce the head and tail of the s-expression (if possible).
  83. --
  84. -- >>> uncons (L [A "el", A "eph", A "ant"])
  85. -- Just (A "el",L [A "eph",A "ant"])
  86. uncons :: RichSExpr a -> Maybe (RichSExpr a, RichSExpr a)
  87. uncons (R.RSList (x:xs)) = Just (x, R.RSList xs)
  88. uncons (R.RSDotted (x:xs) a) = Just (x, R.RSDotted xs a)
  89. uncons _ = Nothing
  90. -- | Combine the two s-expressions into a new one.
  91. --
  92. -- >>> cons (A "el") (L [A "eph", A "ant"])
  93. -- L [A "el",A "eph",A "ant"]
  94. cons :: RichSExpr a -> RichSExpr a -> RichSExpr a
  95. cons x (R.RSList xs) = R.RSList (x:xs)
  96. cons x (R.RSDotted xs a) = R.RSDotted (x:xs) a
  97. cons x (R.RSAtom a) = R.RSDotted [x] a
  98. -- | A shorter infix alias to grab the head
  99. -- and tail of an `RSList`.
  100. --
  101. -- >>> A "one" ::: L [A "two", A "three"]
  102. -- RSList [RSAtom "one",RSAtom "two",RSAtom "three"]
  103. #if MIN_VERSION_base(4,8,0)
  104. pattern (:::) :: RichSExpr a -> RichSExpr a -> RichSExpr a
  105. #endif
  106. pattern x ::: xs <- (uncons -> Just (x, xs))
  107. #if MIN_VERSION_base(4,8,0)
  108. where x ::: xs = cons x xs
  109. #endif
  110. -- | A shorter alias for `RSAtom`
  111. --
  112. -- >>> A "elephant"
  113. -- RSAtom "elephant"
  114. #if MIN_VERSION_base(4,8,0)
  115. pattern A :: a -> RichSExpr a
  116. #endif
  117. pattern A a = R.RSAtom a
  118. -- | A shorter alias for `RSList`
  119. --
  120. -- >>> L [A "pachy", A "derm"]
  121. -- RSList [RSAtom "pachy",RSAtom "derm"]
  122. #if MIN_VERSION_base(4,8,0)
  123. pattern L :: [RichSExpr a] -> RichSExpr a
  124. #endif
  125. pattern L xs = R.RSList xs
  126. -- | A shorter alias for `RSDotted`
  127. --
  128. -- >>> DL [A "pachy"] "derm"
  129. -- RSDotted [RSAtom "pachy"] "derm"
  130. #if MIN_VERSION_base(4,8,0)
  131. pattern DL :: [RichSExpr a] -> a -> RichSExpr a
  132. #endif
  133. pattern DL xs x = R.RSDotted xs x
  134. -- | A shorter alias for `RSList` @[]@
  135. --
  136. -- >>> Nil
  137. -- RSList []
  138. #if MIN_VERSION_base(4,8,0)
  139. pattern Nil :: RichSExpr a
  140. #endif
  141. pattern Nil = R.RSList []
  142. -- | Utility function for parsing a pair of things: this parses a two-element list,
  143. -- and not a cons pair.
  144. --
  145. -- >>> fromPair (isAtom "pachy") (asAtom return) (L [A "pachy", A "derm"])
  146. -- Right ((), "derm")
  147. -- >>> fromPair (isAtom "pachy") fromAtom (L [A "pachy"])
  148. -- Left "Expected two-element list"
  149. fromPair :: (RichSExpr t -> Either String a)
  150. -> (RichSExpr t -> Either String b)
  151. -> RichSExpr t -> Either String (a, b)
  152. fromPair pl pr = asPair $ \(l,r) -> (,) <$> pl l <*> pr r
  153. -- | Utility function for parsing a proper list of things.
  154. --
  155. -- >>> fromList fromAtom (L [A "this", A "that", A "the-other"])
  156. -- Right ["this","that","the-other"]
  157. -- >>> fromList fromAtom (DL [A "this", A "that"] "the-other"])
  158. -- Left "asList: expected proper list; found dotted list"
  159. fromList :: (RichSExpr t -> Either String a) -> RichSExpr t -> Either String [a]
  160. fromList p = asList $ \ss -> mapM p ss
  161. -- | Utility function for parsing a single atom
  162. --
  163. -- >>> fromAtom (A "elephant")
  164. -- Right "elephant"
  165. -- >>> fromAtom (L [A "elephant"])
  166. -- Left "fromAtom: expected atom; found list"
  167. fromAtom :: RichSExpr t -> Either String t
  168. fromAtom (RSList _) = Left "fromAtom: expected atom; found list"
  169. fromAtom (RSDotted _ _) = Left "fromAtom: expected atom; found dotted list"
  170. fromAtom (RSAtom a) = return a
  171. -- | Parses a two-element list using the provided function.
  172. --
  173. -- >>> let go (A l) (A r) = return (l ++ r); go _ _ = Left "expected atoms"
  174. -- >>> asPair go (L [A "pachy", A "derm"])
  175. -- Right "pachyderm"
  176. -- >>> asPair go (L [A "elephant"])
  177. -- Left "asPair: expected two-element list; found list of length 1"
  178. asPair :: ((RichSExpr t, RichSExpr t) -> Either String a)
  179. -> RichSExpr t -> Either String a
  180. asPair f (RSList [l, r]) = f (l, r)
  181. asPair _ (RSList ls) = Left ("asPair: expected two-element list; found list of lenght " ++ show (length ls))
  182. asPair _ RSDotted {} = Left ("asPair: expected two-element list; found dotted list")
  183. asPair _ RSAtom {} = Left ("asPair: expected two-element list; found atom")
  184. -- | Parse an arbitrary-length list using the provided function.
  185. --
  186. -- >>> let go xs = concat <$> mapM fromAtom xs
  187. -- >>> asList go (L [A "el", A "eph", A "ant"])
  188. -- Right "elephant"
  189. -- >>> asList go (DL [A "el", A "eph"] "ant")
  190. -- Left "asList: expected list; found dotted list"
  191. asList :: ([RichSExpr t] -> Either String a)
  192. -> RichSExpr t -> Either String a
  193. asList f (RSList ls) = f ls
  194. asList _ RSDotted {} = Left ("asList: expected list; found dotted list")
  195. asList _ RSAtom { } = Left ("asList: expected list; found dotted list")
  196. -- | Match a given literal atom, failing otherwise.
  197. --
  198. -- >>> isAtom "elephant" (A "elephant")
  199. -- Right ()
  200. -- >>> isAtom "elephant" (L [A "elephant"])
  201. -- Left "isAtom: expected atom; found list"
  202. isAtom :: Eq t => t -> RichSExpr t -> Either String ()
  203. isAtom s (RSAtom s')
  204. | s == s' = return ()
  205. | otherwise = Left "isAtom: failed to match atom"
  206. isAtom _ RSList {} = Left "isAtom: expected atom; found list"
  207. isAtom _ RSDotted {} = Left "isAtom: expected atom; found dotted list"
  208. -- | Match an empty list, failing otherwise.
  209. --
  210. -- >>> isNil (L [])
  211. -- Right ()
  212. -- >>> isNil (A "elephant")
  213. -- Left "isNil: expected nil; found atom"
  214. isNil :: RichSExpr t -> Either String ()
  215. isNil (RSList []) = return ()
  216. isNil RSList {} = Left "isNil: expected nil; found non-nil list"
  217. isNil RSDotted {} = Left "isNil: expected nil; found dotted list"
  218. isNil RSAtom {} = Left "isNil: expected nil; found atom"
  219. -- | Parse an atom using the provided function.
  220. --
  221. -- >>> import Data.Char (toUpper)
  222. -- >>> asAtom (return . map toUpper) (A "elephant")
  223. -- Right "ELEPHANT"
  224. -- >>> asAtom (return . map toUpper) (L [])
  225. -- Left "asAtom: expected atom; found list"
  226. asAtom :: (t -> Either String a) -> RichSExpr t -> Either String a
  227. asAtom f (RSAtom s) = f s
  228. asAtom _ RSList {} = Left ("asAtom: expected atom; found list")
  229. asAtom _ RSDotted {} = Left ("asAtom: expected atom; found dotted list")
  230. -- | Parse an assoc-list using the provided function.
  231. --
  232. -- >>> let def (x, y) = do { a <- fromAtom x; b <- fromAtom y; return (a ++ ": " ++ b) }
  233. -- >>> let defList xs = do { defs <- mapM def xs; return (unlines defs) }
  234. -- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "trunk", A "one"] ])
  235. -- Right "legs: four\ntrunk: one\n"
  236. -- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "elephant"] ])
  237. -- Left "asAssoc: expected pair; found list of length 1"
  238. asAssoc :: ([(RichSExpr t, RichSExpr t)] -> Either String a)
  239. -> RichSExpr t -> Either String a
  240. asAssoc f (RSList ss) = gatherPairs ss >>= f
  241. where gatherPairs (RSList [a, b] : ts) = (:) <$> pure (a, b) <*> gatherPairs ts
  242. gatherPairs [] = pure []
  243. gatherPairs (RSAtom {} : _) = Left ("asAssoc: expected pair; found atom")
  244. gatherPairs (RSDotted {} : _) = Left ("asAssoc: expected pair; found dotted list")
  245. gatherPairs (RSList ls : _) = Left ("asAssoc: expected pair; found list of length " ++ show (length ls))
  246. asAssoc _ RSDotted {} = Left "asAssoc: expected assoc list; found dotted list"
  247. asAssoc _ RSAtom {} = Left "asAssoc: expected assoc list; found atom"
  248. car :: (RichSExpr t -> Either String t') -> [RichSExpr t] -> Either String t'
  249. car f (x:_) = f x
  250. car _ [] = Left "car: Taking car of zero-element list"
  251. cdr :: ([RichSExpr t] -> Either String t') -> [RichSExpr t] -> Either String t'
  252. cdr f (_:xs) = f xs
  253. cdr _ [] = Left "cdr: Taking cdr of zero-element list"