Commit 14c258a7778ebb443a57ecc09ffc0ea4e99e3ffa - s-cargot

Modified cabal file + module contents to be 7.{8,10} compatible Getty Ritter 10 years ago

10 changed file(s) with 122 addition(s) and 95 deletion(s). Collapse all Expand all

-2

Data/SCargot/Comments.hs less more

26	26	, simpleBlockComment
27	27	) where
28	28
29		import Control.Monad (void)
30		import Data.Text (Text)
31	29	import Text.Parsec ( (<\|>)
32	30	, anyChar
33	31	, manyTill

-1

Data/SCargot/Common.hs less more

19	19	, signedHexNumber
20	20	) where
21	21
	22	#if !MIN_VERSION_base(4,8,0)
	23	import Control.Applicative hiding ((<\|>), many)
	24	#endif
22	25	import Data.Char
23	26	import Data.Text (Text)
24	27	import qualified Data.Text as T
25	28	import Text.Parsec
26		import Text.Parsec.Char (satisfy)
27	29	import Text.Parsec.Text (Parser)
28	30
29	31	-- \| Parse an identifier according to the R5RS Scheme standard. This

184	186	signedDecNumber :: Parser Integer
185	187	signedDecNumber = ($) <$> sign <*> decNumber
186	188
	189	dozDigit :: Parser Char
187	190	dozDigit = digit <\|> oneOf "AaBb\x218a\x218b"
188	191
189	192	-- \| A parser for non-signed duodecimal (dozenal) numbers. This understands both

-1

Data/SCargot/Language/Basic.hs less more

18	18	, mkParser
19	19	, flatPrint
20	20	)
21		import Data.SCargot.Comments (withLispComments)
22	21
23	22	isAtomChar :: Char -> Bool
24	23	isAtomChar c = isAlphaNum c

-7

Data/SCargot/Language/HaskLike.hs less more

7	7	, haskLikePrinter
8	8	) where
9	9
10		~~import Control.Applicative ((<$>), (<*>), (<$)~~)
	10	#if !MIN_VERSION_base(4,8,0)
	11	import Control.Applicative ((<$>), (<$))
	12	#endif
11	13	import Data.Maybe (catMaybes)
12	14	import Data.String (IsString(..))
13	15	import Data.Text (Text, pack)

52	54	pString :: Parser Text
53	55	pString = pack . catMaybes <$> between (char '"') (char '"') (many (val <\|> esc))
54	56	where val = Just <$> satisfy (\ c -> c /= '"' && c /= '\\' && c > '\026')
55		esc = do char '\\'
	57	esc = do _ <- char '\\'
56	58	Nothing <$ (gap <\|> char '&') <\|>
57	59	Just <$> code
58	60	gap = many1 space >> char '\\'

84	86	n <- decNumber
85	87	withDot n <\|> noDot n
86	88	where withDot n = do
87		char '.'
	89	_ <- char '.'
88	90	m <- decNumber
89		e <- option 1.0 exp~~onent~~
	91	e <- option 1.0 expn
90	92	return ((fromIntegral n + asDec m 0) * e)
91	93	noDot n = do
92		e <- exp~~onent~~
	94	e <- expn
93	95	return (fromIntegral n * e)
94		exponent = do
95		oneOf "eE"
	96	expn = do
	97	_ <- oneOf "eE"
96	98	s <- power
97	99	x <- decNumber
98	100	return (10 ** s (fromIntegral x))

-11

Data/SCargot/Parse.hs less more

19	19	, withQuote
20	20	) where
21	21
22		~~import Control.Applicative ((<), (>), (<*>), (<$>), pure~~)
	22	#if !MIN_VERSION_base(4,8,0)
	23	import Control.Applicative ((<$>), (<*), pure)
	24	#endif
23	25	import Control.Monad ((>=>))
24		import Data.Char (isAlpha, isDigit, isAlphaNum)
25	26	import Data.Map.Strict (Map)
26	27	import qualified Data.Map.Strict as M
27		import Data.Maybe (fromJust)
28		import Data.Monoid ((<>))
	28	import Data.Text (Text)
29	29	import Data.String (IsString)
30		import Data.Text (Text, pack, unpack)
31		import qualified Data.Text as T
32	30	import Text.Parsec ( (<\|>)
33	31	, (<?>)
34	32	, char

44	42	import Data.SCargot.Repr ( SExpr(..)
45	43	, RichSExpr
46	44	, WellFormedSExpr
47		, fromRich
48	45	, toRich
49		, fromWellFormed
50	46	, toWellFormed
51	47	)
52	48

197	193	c <- peekChar
198	194	case c of
199	195	Just '.' -> do
200		char '.'
	196	_ <- char '.'
201	197	cdr <- sExpr
202	198	skip
203		char ')'
	199	_ <- char ')'
204	200	skip
205	201	return (SCons car cdr)
206	202	Just ')' -> do
207		char ')'
	203	_ <- char ')'
208	204	skip
209	205	return (SCons car SNil)
210	206	_ -> do

+20

-12

Data/SCargot/Repr/Basic.hs less more

1	1	{-# LANGUAGE PatternSynonyms #-}
	2	{-# LANGUAGE ScopedTypeVariables #-}
2	3	{-# LANGUAGE ViewPatterns #-}
3	4
4	5	module Data.SCargot.Repr.Basic

27	28	, asAssoc
28	29	) where
29	30
30		~~import Control.Applicative ((<$>), (<*>), pure~~)
	31	#if !MIN_VERSION_base(4,8,0)
	32	import Control.Applicative (Applicative, (<$>), (<*>), pure)
	33	#endif
31	34	import Data.SCargot.Repr as R
32	35
33	36	-- \| A traversal with access to the first element of a pair.

38	41	-- >>> set _car (A "two" ::: A "three" ::: Nil) (A "one" ::: A "elephant")
39	42	-- (A "two" ::: A "three" ::: Nil) ::: A "elephant"
40	43	_car :: Applicative f => (SExpr a -> f (SExpr a)) -> SExpr a -> f (SExpr a)
41		_car f (x ::: xs) = (:::) <$> f x <*> pure xs
42		_car _ (A a) = pure (A a)
43		_car ~~_ Nil = pure Nil~~
	44	_car f (SCons x xs) = (:::) <$> f x <*> pure xs
	45	_car _ (SAtom a) = pure (A a)
	46	_car _ SNil = pure SNil
44	47
45	48	-- \| A traversal with access to the second element of a pair.
46	49	--

50	53	-- >>> set _cdr (A "two" ::: A "three" ::: Nil) (A "one" ::: A "elephant")
51	54	-- A "one" ::: A "two" ::: A "three" ::: Nil
52	55	_cdr :: Applicative f => (SExpr a -> f (SExpr a)) -> SExpr a -> f (SExpr a)
53		_cdr f (x ::: xs) = (:::) <$> pure x <*> f xs
54		_cdr _ (A a) = pure (A a)
55		_cdr ~~_ Nil = pure Nil~~
	56	_cdr f (SCons x xs) = (:::) <$> pure x <*> f xs
	57	_cdr _ (SAtom a) = pure (A a)
	58	_cdr _ SNil = pure Nil
56	59
57	60	-- \| Produce the head and tail of the s-expression (if possible).
58	61	--

112	115	-- >>> L [A "pachy", A "derm"]
113	116	-- SCons (SAtom "pachy") (SCons (SAtom "derm") SNil)
114	117	pattern L xs <- (gatherList -> Right xs)
	118	#if MIN_VERSION_base(4,8,0)
115	119	where L xs = mkList xs
	120	#endif
	121
116	122
117	123	-- \| An alias for matching a dotted list.
118	124	--
119	125	-- >>> DL [A "pachy"] A "derm"
120	126	-- SCons (SAtom "pachy") (SAtom "derm")
121	127	pattern DL xs x <- (gatherDList -> Just (xs, x))
	128	#if MIN_VERSION_base(4,8,0)
122	129	where DL xs x = mkDList xs x
	130	#endif
123	131
124	132	getShape :: SExpr a -> String
125	133	getShape Nil = "empty list"
126		getShape sx = go 0 sx
127		where go n Nil = "list of length " ++ show n
128		go n A {} = "dotted list of length " ++ show n
129		go n (_:::xs) = go (n+1) xs
	134	getShape sx = go (0 :: Int) sx
	135	where go n SNil = "list of length " ++ show n
	136	go n SAtom {} = "dotted list of length " ++ show n
	137	go n (SCons _ xs) = go (n+1) xs
130	138
131	139	-- \| Utility function for parsing a pair of things.
132	140	--

143	151	-- \| Utility function for parsing a list of things.
144	152	fromList :: (SExpr t -> Either String a) -> SExpr t -> Either String [a]
145	153	fromList p (s ::: ss) = (:) <$> p s <*> fromList p ss
146		fromList p Nil = pure []
	154	fromList _ Nil = pure []
147	155	fromList _ sx = Left ("fromList: expected list; found " ++ getShape sx)
148	156
149	157	-- \| Utility function for parsing a single atom

+58

-47

Data/SCargot/Repr/Rich.hs less more

28	28	, isNil
29	29	, asAtom
30	30	, asAssoc
	31	, car
	32	, cdr
31	33	) where
32	34
33		~~import Control.Applicative ((<$>), (<*>), pure~~)
	35	#if !MIN_VERSION_base(4,8,0)
	36	import Control.Applicative (Applicative, (<$>), (<*>), pure)
	37	#endif
34	38	import Data.SCargot.Repr as R
35	39
36	40	-- \| A traversal with access to the first element of a pair.

41	45	-- >>> set _car (L [A "two", A "three"]) (DL [A "one"] "elephant")
42	46	-- DL [L[A "two",A "three"]] "elephant"
43	47	_car :: Applicative f => (RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)
44		_car f (L (x:xs)) = (\ x -> L (x:xs)) `fmap` f x
45		_car f (DL (x:xs) a) = (\ x -> DL (x:xs) a) `fmap` f x
46		_car _ (A a) = pure (A a)
47		_car _ Nil = pure Nil
	48	_car f (RSList (x:xs)) = (\ y -> L (y:xs)) `fmap` f x
	49	_car f (RSDotted (x:xs) a) = (\ y -> DL (y:xs) a) `fmap` f x
	50	_car _ (RSAtom a) = pure (A a)
	51	_car _ (RSList []) = pure Nil
	52	_car _ (RSDotted [] a) = pure (A a)
48	53
49	54	-- \| A traversal with access to the second element of a pair. Using
50	55	-- this to modify an s-expression may result in changing the

57	62	-- >>> set _cdr (L [A "two", A "three"]) (DL [A "one"] "elephant")
58	63	-- L [A "one",A "two",A "three"]
59	64	_cdr :: Applicative f => (RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)
60		_cdr f (L (x:xs)) =
61		let go Nil = L [x]
62		go (A a) = DL [x] a
63		go (L xs') = L (x:xs')
	65	_cdr f (RSList (x:xs)) =
	66	let go (RSList []) = L [x]
	67	go (RSAtom a) = DL [x] a
	68	go (RSList xs') = L (x:xs')
	69	go (RSDotted ys a') = DL (x:ys) a'
64	70	in go `fmap` f (L xs)
65		_cdr f (DL [x] a) =
66		let go Nil = L [x]
67		go (A a') = DL [x] a'
68		go (L xs) = L (x:xs)
	71	_cdr f (RSDotted [x] a) =
	72	let go (RSList []) = L [x]
	73	go (RSAtom a') = DL [x] a'
	74	go (RSList xs) = L (x:xs)
	75	go (RSDotted ys a') = DL (x:ys) a'
69	76	in go `fmap` f (A a)
70		_cdr f (DL (x:xs) a) =
71		let go Nil = L [x]
72		go (A a') = DL [x] a'
73		go (L xs) = L (x:xs)
	77	_cdr f (RSDotted (x:xs) a) =
	78	let go (RSList []) = L [x]
	79	go (RSAtom a') = DL [x] a'
	80	go (RSList ys) = L (x:ys)
	81	go (RSDotted ys a') = DL (x:ys) a'
74	82	in go `fmap` f (DL xs a)
75		_cdr _ (A a) = pure (A a)
76		_cdr _ Nil = pure Nil
	83	_cdr _ (RSAtom a) = pure (A a)
	84	_cdr _ (RSList []) = pure Nil
	85	_cdr _ (RSDotted [] a) = pure (A a)
77	86
78	87	-- \| Produce the head and tail of the s-expression (if possible).
79	88	--
80	89	-- >>> uncons (L [A "el", A "eph", A "ant"])
81	90	-- Just (A "el",L [A "eph",A "ant"])
82	91	uncons :: RichSExpr a -> Maybe (RichSExpr a, RichSExpr a)
83		uncons R.RSAtom {} = Nothing
84	92	uncons (R.RSList (x:xs)) = Just (x, R.RSList xs)
85	93	uncons (R.RSDotted (x:xs) a) = Just (x, R.RSDotted xs a)
	94	uncons _ = Nothing
86	95
87	96	-- \| Combine the two s-expressions into a new one.
88	97	--

99	108	-- >>> A "one" ::: L [A "two", A "three"]
100	109	-- RSList [RSAtom "one",RSAtom "two",RSAtom "three"]
101	110	pattern x ::: xs <- (uncons -> Just (x, xs))
	111	#if MIN_VERSION_base(4,8,0)
102	112	where x ::: xs = cons x xs
	113	#endif
103	114
104	115	-- \| A shorter alias for `RSAtom`
105	116	--

153	164	-- >>> fromAtom (L [A "elephant"])
154	165	-- Left "fromAtom: expected atom; found list"
155	166	fromAtom :: RichSExpr t -> Either String t
156		fromAtom (L _) = Left "fromAtom: expected atom; found list"
157		fromAtom (DL _ _) = Left "fromAtom: expected atom; found dotted list"
158		fromAtom (~~A a) = return a~~
	167	fromAtom (RSList _) = Left "fromAtom: expected atom; found list"
	168	fromAtom (RSDotted _ _) = Left "fromAtom: expected atom; found dotted list"
	169	fromAtom (RSAtom a) = return a
159	170
160	171	-- \| Parses a two-element list using the provided function.
161	172	--

166	177	-- Left "asPair: expected two-element list; found list of length 1"
167	178	asPair :: ((RichSExpr t, RichSExpr t) -> Either String a)
168	179	-> RichSExpr t -> Either String a
169		asPair f (L [l, r]) = f (l, r)
170		asPair _ (L ls) = Left ("asPair: expected two-element list; found list of lenght " ++ show (length ls))
171		asPair _ DL {} = Left ("asPair: expected two-element list; found dotted list")
172		asPair _ A {} = Left ("asPair: expected two-element list; found atom")
	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")
173	184
174	185	-- \| Parse an arbitrary-length list using the provided function.
175	186	--

180	191	-- Left "asList: expected list; found dotted list"
181	192	asList :: ([RichSExpr t] -> Either String a)
182	193	-> RichSExpr t -> Either String a
183		asList f (L ls) = f ls
184		asList _ DL {} = Left ("asList: expected list; found dotted list")
185		asList ~~_ A { } = Left ("asList: expected list; found dotted list")~~
	194	asList f (RSList ls) = f ls
	195	asList _ RSDotted {} = Left ("asList: expected list; found dotted list")
	196	asList _ RSAtom { } = Left ("asList: expected list; found dotted list")
186	197
187	198	-- \| Match a given literal atom, failing otherwise.
188	199	--

191	202	-- >>> isAtom "elephant" (L [A "elephant"])
192	203	-- Left "isAtom: expected atom; found list"
193	204	isAtom :: Eq t => t -> RichSExpr t -> Either String ()
194		isAtom s (A s')
	205	isAtom s (RSAtom s')
195	206	\| s == s' = return ()
196	207	\| otherwise = Left "isAtom: failed to match atom"
197		isAtom _ L {} = Left "isAtom: expected atom; found list"
198		isAtom _ DL {} = Left "isAtom: expected atom; found dotted list"
	208	isAtom _ RSList {} = Left "isAtom: expected atom; found list"
	209	isAtom _ RSDotted {} = Left "isAtom: expected atom; found dotted list"
199	210
200	211	-- \| Match an empty list, failing otherwise.
201	212	--

204	215	-- >>> isNil (A "elephant")
205	216	-- Left "isNil: expected nil; found atom"
206	217	isNil :: RichSExpr t -> Either String ()
207		isNil Nil = return ()
208		isNil L {} = Left "isNil: expected nil; found non-nil list"
209		isNil DL {} = Left "isNil: expected nil; found dotted list"
210		isNil A {} = Left "isNil: expected nil; found atom"
	218	isNil (RSList []) = return ()
	219	isNil RSList {} = Left "isNil: expected nil; found non-nil list"
	220	isNil RSDotted {} = Left "isNil: expected nil; found dotted list"
	221	isNil RSAtom {} = Left "isNil: expected nil; found atom"
211	222
212	223	-- \| Parse an atom using the provided function.
213	224	--

217	228	-- >>> asAtom (return . map toUpper) (L [])
218	229	-- Left "asAtom: expected atom; found list"
219	230	asAtom :: (t -> Either String a) -> RichSExpr t -> Either String a
220		asAtom f (A s) = f s
221		asAtom _ L {} = Left ("asAtom: expected atom; found list")
222		asAtom ~~_ DL {} = Left ("asAtom: expected atom; found dotted list")~~
	231	asAtom f (RSAtom s) = f s
	232	asAtom _ RSList {} = Left ("asAtom: expected atom; found list")
	233	asAtom _ RSDotted {} = Left ("asAtom: expected atom; found dotted list")
223	234
224	235	-- \| Parse an assoc-list using the provided function.
225	236	--

231	242	-- Left "asAssoc: expected pair; found list of length 1"
232	243	asAssoc :: ([(RichSExpr t, RichSExpr t)] -> Either String a)
233	244	-> RichSExpr t -> Either String a
234		asAssoc f (L ss) = gatherPairs ss >>= f
235		where gatherPairs (L [a, b] : ss) = (:) <$> pure (a, b) <*> gatherPairs ss
	245	asAssoc f (RSList ss) = gatherPairs ss >>= f
	246	where gatherPairs (RSList [a, b] : ts) = (:) <$> pure (a, b) <*> gatherPairs ts
236	247	gatherPairs [] = pure []
237		gatherPairs (A {} : _) = Left ("asAssoc: expected pair; found atom")
238		gatherPairs (DL {} : _) = Left ("asAssoc: expected pair; found dotted list")
239		gatherPairs (L ls : _) = Left ("asAssoc: expected pair; found list of length " ++ show (length ls))
240		asAssoc f DL {} = Left "asAssoc: expected assoc list; found dotted list"
241		asAssoc f A {} = Left "asAssoc: expected assoc list; found atom"
	248	gatherPairs (RSAtom {} : _) = Left ("asAssoc: expected pair; found atom")
	249	gatherPairs (RSDotted {} : _) = Left ("asAssoc: expected pair; found dotted list")
	250	gatherPairs (RSList ls : _) = Left ("asAssoc: expected pair; found list of length " ++ show (length ls))
	251	asAssoc _ RSDotted {} = Left "asAssoc: expected assoc list; found dotted list"
	252	asAssoc _ RSAtom {} = Left "asAssoc: expected assoc list; found atom"
242	253
243	254	car :: (RichSExpr t -> Either String t') -> [RichSExpr t] -> Either String t'
244	255	car f (x:_) = f x

-4

Data/SCargot/Repr/WellFormed.hs less more

21	21	, asPair
22	22	, asList
23	23	, isAtom
	24	, isNil
24	25	, asAtom
25	26	, asAssoc
26	27	, car
27	28	, cdr
28	29	) where
29	30
	31	#if !MIN_VERSION_base(4,8,0)
30	32	import Control.Applicative ((<$>), (<*>), pure)
	33	#endif
31	34	import Data.SCargot.Repr as R
32	35
33	36	-- \| Produce the head and tail of the s-expression (if possible).

36	39	-- Just (WFSAtom "el",WFSList [WFSAtom "eph",WFSAtom "ant"])
37	40	uncons :: WellFormedSExpr a -> Maybe (WellFormedSExpr a, WellFormedSExpr a)
38	41	uncons R.WFSAtom {} = Nothing
	42	uncons (R.WFSList []) = Nothing
39	43	uncons (R.WFSList (x:xs)) = Just (x, R.WFSList xs)
40	44
41	45	-- \| Combine the two-expressions into a new one. This will return

76	80	pattern Nil = R.WFSList []
77	81
78	82	getShape :: WellFormedSExpr a -> String
79		getShape A {} = "atom"
80		getShape Nil = "empty list"
81		getShape ~~(L sx) = "list of length " ++ show (length sx)~~
	83	getShape WFSAtom {} = "atom"
	84	getShape (WFSList []) = "empty list"
	85	getShape (WFSList sx) = "list of length " ++ show (length sx)
82	86
83	87	-- \| Utility function for parsing a pair of things.
84	88	--

181	185	asAssoc :: ([(WellFormedSExpr t, WellFormedSExpr t)] -> Either String a)
182	186	-> WellFormedSExpr t -> Either String a
183	187	asAssoc f (L ss) = gatherPairs ss >>= f
184		where gatherPairs (L [a, b] : ~~ss) = (:) <$> pure (a, b) <*> gatherPairs s~~s
	188	where gatherPairs (L [a, b] : ts) = (:) <$> pure (a, b) <*> gatherPairs ts
185	189	gatherPairs [] = pure []
186	190	gatherPairs (sx:_) = Left ("asAssoc: expected pair; found " ++ getShape sx)
187	191	asAssoc _ sx = Left ("asAssoc: expected list; found " ++ getShape sx)

+10

-6

Data/SCargot/Repr.hs less more

20	20
21	21	import Data.Data (Data)
22	22	import Data.Foldable (Foldable(..))
23		import Data.Monoid (Monoid(..), (<>))
24	23	import Data.Traversable (Traversable(..))
25	24	import Data.Typeable (Typeable)
26	25	import GHC.Exts (IsList(..), IsString(..))
	26
	27	#if !MIN_VERSION_base(4,8,0)
	28	import Prelude hiding (foldr)
	29	#endif
27	30
28	31	-- \| All S-Expressions can be understood as a sequence
29	32	-- of @cons@ cells (represented here by 'SCons'), the

85	88	toRich (SCons x xs) = go xs (toRich x:)
86	89	where go (SAtom a) rs = RSDotted (rs []) a
87	90	go SNil rs = RSList (rs [])
88		go (SCons ~~x xs) rs = go xs (rs . (toRich x~~:))
	91	go (SCons y ys) rs = go ys (rs . (toRich y:))
	92	toRich SNil = RSList []
89	93
90	94	-- \| This follows the same laws as 'toRich'.
91	95	fromRich :: RichSExpr atom -> SExpr atom

128	132	toWellFormed (SCons x xs) = do
129	133	x' <- toWellFormed x
130	134	go xs (x':)
131		where go (SAtom ~~a) rs~~ = Left "Found atom in cdr position"
	135	where go (SAtom _) _ = Left "Found atom in cdr position"
132	136	go SNil rs = return (WFSList (rs []))
133		go (SCons x xs) rs = do
134		x' <- toWellFormed x
135		~~go xs (rs . (x':))~~
	137	go (SCons y ys) rs = do
	138	y' <- toWellFormed y
	139	go ys (rs . (y':))
136	140
137	141	-- \| Convert a WellFormedSExpr back into a SExpr.
138	142	fromWellFormed :: WellFormedSExpr atom -> SExpr atom

-4

s-cargot.cabal less more

35	35	Data.SCargot.Common,
36	36	Data.SCargot.Language.Basic,
37	37	Data.SCargot.Language.HaskLike
38		build-depends: base >=4.7 && <5,
39		parsec,
40		text,
41		containers
	38	build-depends: base >=4.7 && <5,
	39	parsec >=3.1 && <4,
	40	text >=1.2 && <2,
	41	containers >=0.5 && <1
42	42	default-language: Haskell2010
	43	default-extensions: CPP
	44	ghc-options: -Wall