gdritter repos s-cargot / f55a7c5
More useful examples in rich, and some examples in basic Getty Ritter 9 years ago
2 changed file(s) with 94 addition(s) and 15 deletion(s). Collapse all Expand all
+63
-9
Data/SCargot/Repr/Basic.hs less more
2525 import Data.SCargot.Repr as R
2626
2727 -- | A traversal with access to the first element of a pair.
28 --
29 -- >>> import Lens.Family
30 -- >>> set _car (A "elephant") (A "one" ::: A "two" ::: A "three" ::: Nil)
31 -- A "elelphant" ::: A "two" ::: A "three" ::: Nil
32 -- >>> set _car (A "two" ::: A "three" ::: Nil) (A "one" ::: A "elephant")
33 -- (A "two" ::: A "three" ::: Nil) ::: A "elephant"
2834 _car :: Applicative f => (SExpr a -> f (SExpr a)) -> SExpr a -> f (SExpr a)
2935 _car f (x ::: xs) = (:::) <$> f x <*> pure xs
3036 _car _ (A a) = pure (A a)
3137 _car _ Nil = pure Nil
3238
3339 -- | A traversal with access to the second element of a pair.
40 --
41 -- >>> import Lens.Family
42 -- >>> set _cdr (A "elephant") (A "one" ::: A "two" ::: A "three" ::: Nil)
43 -- A "one" ::: A "elephant"
44 -- >>> set _cdr (A "two" ::: A "three" ::: Nil) (A "one" ::: A "elephant")
45 -- A "one" ::: A "two" ::: A "three" ::: Nil
3446 _cdr :: Applicative f => (SExpr a -> f (SExpr a)) -> SExpr a -> f (SExpr a)
3547 _cdr f (x ::: xs) = (:::) <$> pure x <*> f xs
3648 _cdr _ (A a) = pure (A a)
4759 -- | A (slightly) shorter alias for `SNil`
4860 pattern Nil = SNil
4961
62 getShape :: SExpr a -> String
63 getShape Nil = "empty list"
64 getShape sx = go 0 sx
65 where go n Nil = "list of length " ++ show n
66 go n A {} = "dotted list of length " ++ show n
67 go n (_:::xs) = go (n+1) xs
68
5069 -- | Utility function for parsing a pair of things.
70 --
71 -- >>> fromPair (isAtom "pachy") (asAtom return) (A "pachy" ::: A "derm" ::: Nil)
72 -- Right ((), "derm")
73 -- >>> fromPair (isAtom "pachy") fromAtom (A "pachy" ::: Nil)
74 -- Left "Expected two-element list"
5175 fromPair :: (SExpr t -> Either String a)
5276 -> (SExpr t -> Either String b)
5377 -> SExpr t -> Either String (a, b)
5478 fromPair pl pr (l ::: r ::: Nil) = (,) <$> pl l <*> pr r
55 fromPair _ _ sx = Left ("Expected two-element list")
79 fromPair _ _ sx = Left ("fromPair: expected two-element list; found " ++ getShape sx)
5680
5781 -- | Utility function for parsing a list of things.
5882 fromList :: (SExpr t -> Either String a) -> SExpr t -> Either String [a]
5983 fromList p (s ::: ss) = (:) <$> p s <*> fromList p ss
6084 fromList p Nil = pure []
61 fromList _ sx = Left ("Expected list")
85 fromList _ sx = Left ("fromList: expected list; found " ++ getShape sx)
6286
6387 -- | Utility function for parsing a single atom
6488 fromAtom :: SExpr t -> Either String t
6589 fromAtom (A a) = return a
66 fromAtom _ = Left "Expected atom; found list"
90 fromAtom sx = Left ("fromAtom: expected atom; found list" ++ getShape sx)
6791
6892 gatherList :: SExpr t -> Either String [SExpr t]
6993 gatherList (x ::: xs) = (:) <$> pure x <*> gatherList xs
7094 gatherList Nil = pure []
71 gatherList sx = Left ("Expected list")
95 gatherList sx = Left ("gatherList: expected list; found " ++ getShape sx)
7296
7397 -- | Parse a two-element list (NOT a dotted pair) using the
7498 -- provided function.
99 --
100 -- >>> let go (A l) (A r) = return (l ++ r); go _ _ = Left "expected atoms"
101 -- >>> asPair go (A "pachy" ::: A "derm" ::: Nil)
102 -- Right "pachyderm"
103 -- >>> asPair go (A "elephant" ::: Nil)
104 -- Left "asPair: expected two-element list; found list of length 1"
75105 asPair :: ((SExpr t, SExpr t) -> Either String a)
76106 -> SExpr t -> Either String a
77107 asPair f (l ::: r ::: SNil) = f (l, r)
78 asPair _ sx = Left ("Expected two-element list")
108 asPair _ sx = Left ("asPair: expected two-element list; found " ++ getShape sx)
79109
80110 -- | Parse an arbitrary-length list using the provided function.
111 --
112 -- >>> let go xs = concat <$> mapM fromAtom xs
113 -- >>> asList go (A "el" ::: A "eph" ::: A "ant" ::: Nil)
114 -- Right "elephant"
115 -- >>> asList go (A "el" ::: A "eph" ::: A "ant")
116 -- Left "asList: expected list; found dotted list of length 3"
81117 asList :: ([SExpr t] -> Either String a) -> SExpr t -> Either String a
82118 asList f ls = gatherList ls >>= f
83119
84120 -- | Match a given literal atom, failing otherwise.
121 --
122 -- >>> isAtom "elephant" (A "elephant")
123 -- Right ()
124 -- >>> isAtom "elephant" (A "elephant" ::: Nil)
125 -- Left "isAtom: expected atom; found list"
85126 isAtom :: Eq t => t -> SExpr t -> Either String ()
86127 isAtom s (A s')
87128 | s == s' = return ()
88 | otherwise = Left ".."
89 isAtom _ _ = Left ".."
129 | otherwise = Left "isAtom: failed to match atom"
130 isAtom _ sx = Left ("isAtom: expected atom; found " ++ getShape sx)
90131
91132 -- | Parse an atom using the provided function.
133 --
134 -- >>> import Data.Char (toUpper)
135 -- >>> asAtom (return . map toUpper) (A "elephant")
136 -- Right "ELEPHANT"
137 -- >>> asAtom (return . map toUpper) Nil
138 -- Left "asAtom: expected atom; found empty list"
92139 asAtom :: (t -> Either String a) -> SExpr t -> Either String a
93140 asAtom f (A s) = f s
94 asAtom _ sx = Left ("Expected symbol")
141 asAtom _ sx = Left ("asAtom: expected atom; found " ++ getShape sx)
95142
96143 -- | Parse an assoc-list using the provided function.
144 --
145 -- >>> let def (x, y) = do { a <- fromAtom x; b <- fromAtom y; return (a ++ ": " ++ b) }
146 -- >>> let defList xs = do { defs <- mapM def xs; return (unlines defs) }
147 -- >>> asAssoc defList ((A "legs" ::: A "four" ::: Nil) ::: (A "trunk" ::: A "one" ::: Nil) ::: Nil)
148 -- Right "legs: four\ntrunk: one\n"
149 -- >>> asAssoc defList ((A "legs" ::: A "four" ::: Nil) ::: (A "elephant") ::: Nil)
150 -- Left "asAssoc: expected pair; found list of length 1"
97151 asAssoc :: ([(SExpr t, SExpr t)] -> Either String a)
98152 -> SExpr t -> Either String a
99153 asAssoc f ss = gatherList ss >>= mapM go >>= f
100154 where go (a ::: b ::: Nil) = return (a, b)
101 go sx = Left ("Expected two-element list")
155 go sx = Left ("asAssoc: expected pair; found " ++ getShape sx)
+31
-6
Data/SCargot/Repr/Rich.hs less more
3131
3232 -- | A traversal with access to the first element of a pair.
3333 --
34 -- >>> import Lens.Family
3435 -- >>> set _car (A "elephant") (L [A "one", A "two", A "three"])
3536 -- L [A "elelphant",A "two",A "three"]
37 -- >>> set _car (L [A "two", A "three"]) (DL [A "one"] "elephant")
38 -- DL [L[A "two",A "three"]] "elephant"
3639 _car :: Applicative f => (RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)
3740 _car f (L (x:xs)) = (\ x -> L (x:xs)) `fmap` f x
3841 _car f (DL (x:xs) a) = (\ x -> DL (x:xs) a) `fmap` f x
3942 _car _ (A a) = pure (A a)
4043 _car _ Nil = pure Nil
4144
42 -- | A traversal with access to the second element of a pair.
43 --
44 -- >>> set _car (A "elephant") (L [A "one", A "two", A "three"])
45 -- | A traversal with access to the second element of a pair. Using
46 -- this to modify an s-expression may result in changing the
47 -- constructor used, changing a list to a dotted list or vice
48 -- versa.
49 --
50 -- >>> import Lens.Family
51 -- >>> set _cdr (A "elephant") (L [A "one", A "two", A "three"])
4552 -- DL [A "one"] "elephant"
53 -- >>> set _cdr (L [A "two", A "three"]) (DL [A "one"] "elephant")
54 -- L [A "one",A "two",A "three"]
4655 _cdr :: Applicative f => (RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)
4756 _cdr f (L (x:xs)) =
4857 let go Nil = L [x]
125134 asPair _ A {} = Left ("asPair: expected two-element list; found atom")
126135
127136 -- | Parse an arbitrary-length list using the provided function.
137 --
138 -- >>> let go xs = concat <$> mapM fromAtom xs
139 -- >>> asList go (L [A "el", A "eph", A "ant"])
140 -- Right "elephant"
141 -- >>> asList go (DL [A "el", A "eph"] "ant")
142 -- Left "asList: expected list; found dotted list"
128143 asList :: ([RichSExpr t] -> Either String a)
129144 -> RichSExpr t -> Either String a
130145 asList f (L ls) = f ls
169184 asAtom _ DL {} = Left ("asAtom: expected atom; found dotted list")
170185
171186 -- | Parse an assoc-list using the provided function.
172 asAssoc :: Show t => ([(RichSExpr t, RichSExpr t)] -> Either String a)
187 --
188 -- >>> let def (x, y) = do { a <- fromAtom x; b <- fromAtom y; return (a ++ ": " ++ b) }
189 -- >>> let defList xs = do { defs <- mapM def xs; return (unlines defs) }
190 -- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "trunk", A "one"] ])
191 -- Right "legs: four\ntrunk: one\n"
192 -- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "elephant"] ])
193 -- Left "asAssoc: expected pair; found list of length 1"
194 asAssoc :: ([(RichSExpr t, RichSExpr t)] -> Either String a)
173195 -> RichSExpr t -> Either String a
174196 asAssoc f (L ss) = gatherPairs ss >>= f
175197 where gatherPairs (L [a, b] : ss) = (:) <$> pure (a, b) <*> gatherPairs ss
176198 gatherPairs [] = pure []
177 gatherPairs _ = Left "..."
178 asAssoc _ sx = Left ("Expected assoc list; got " ++ show sx)
199 gatherPairs (A {} : _) = Left ("asAssoc: expected pair; found atom")
200 gatherPairs (DL {} : _) = Left ("asAssoc: expected pair; found dotted list")
201 gatherPairs (L ls : _) = Left ("asAssoc: expected pair; found list of length " ++ show (length ls))
202 asAssoc f DL {} = Left "asAssoc: expected assoc list; found dotted list"
203 asAssoc f A {} = Left "asAssoc: expected assoc list; found atom"
179204
180205 car :: (RichSExpr t -> Either String t') -> [RichSExpr t] -> Either String t'
181206 car f (x:_) = f x