123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275 |
- {-# LANGUAGE PatternSynonyms #-}
- {-# LANGUAGE ViewPatterns #-}
- module Data.SCargot.Repr.Rich
- ( -- * 'RichSExpr' representation
- R.RichSExpr(..)
- , R.toRich
- , R.fromRich
- -- * Constructing and Deconstructing
- , cons
- , uncons
- -- * Useful pattern synonyms
- , pattern (:::)
- , pattern A
- , pattern L
- , pattern DL
- , pattern Nil
- -- * Lenses
- , _car
- , _cdr
- -- * Useful processing functions
- , fromPair
- , fromList
- , fromAtom
- , asPair
- , asList
- , isAtom
- , isNil
- , asAtom
- , asAssoc
- , car
- , cdr
- ) where
- #if !MIN_VERSION_base(4,8,0)
- import Control.Applicative (Applicative, (<$>), (<*>), pure)
- #endif
- import Data.SCargot.Repr as R
- -- | A traversal with access to the first element of a pair.
- --
- -- >>> import Lens.Family
- -- >>> set _car (A "elephant") (L [A "one", A "two", A "three"])
- -- L [A "elelphant",A "two",A "three"]
- -- >>> set _car (L [A "two", A "three"]) (DL [A "one"] "elephant")
- -- DL [L[A "two",A "three"]] "elephant"
- _car :: Applicative f => (RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)
- _car f (RSList (x:xs)) = (\ y -> L (y:xs)) `fmap` f x
- _car f (RSDotted (x:xs) a) = (\ y -> DL (y:xs) a) `fmap` f x
- _car _ (RSAtom a) = pure (A a)
- _car _ (RSList []) = pure Nil
- _car _ (RSDotted [] a) = pure (A a)
- -- | A traversal with access to the second element of a pair. Using
- -- this to modify an s-expression may result in changing the
- -- constructor used, changing a list to a dotted list or vice
- -- versa.
- --
- -- >>> import Lens.Family
- -- >>> set _cdr (A "elephant") (L [A "one", A "two", A "three"])
- -- DL [A "one"] "elephant"
- -- >>> set _cdr (L [A "two", A "three"]) (DL [A "one"] "elephant")
- -- L [A "one",A "two",A "three"]
- _cdr :: Applicative f => (RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)
- _cdr f (RSList (x:xs)) =
- let go (RSList []) = L [x]
- go (RSAtom a) = DL [x] a
- go (RSList xs') = L (x:xs')
- go (RSDotted ys a') = DL (x:ys) a'
- in go `fmap` f (L xs)
- _cdr f (RSDotted [x] a) =
- let go (RSList []) = L [x]
- go (RSAtom a') = DL [x] a'
- go (RSList xs) = L (x:xs)
- go (RSDotted ys a') = DL (x:ys) a'
- in go `fmap` f (A a)
- _cdr f (RSDotted (x:xs) a) =
- let go (RSList []) = L [x]
- go (RSAtom a') = DL [x] a'
- go (RSList ys) = L (x:ys)
- go (RSDotted ys a') = DL (x:ys) a'
- in go `fmap` f (DL xs a)
- _cdr _ (RSAtom a) = pure (A a)
- _cdr _ (RSList []) = pure Nil
- _cdr _ (RSDotted [] a) = pure (A a)
- -- | Produce the head and tail of the s-expression (if possible).
- --
- -- >>> uncons (L [A "el", A "eph", A "ant"])
- -- Just (A "el",L [A "eph",A "ant"])
- uncons :: RichSExpr a -> Maybe (RichSExpr a, RichSExpr a)
- uncons (R.RSList (x:xs)) = Just (x, R.RSList xs)
- uncons (R.RSDotted (x:xs) a) = Just (x, R.RSDotted xs a)
- uncons _ = Nothing
- -- | Combine the two s-expressions into a new one.
- --
- -- >>> cons (A "el") (L [A "eph", A "ant"])
- -- L [A "el",A "eph",A "ant"]
- cons :: RichSExpr a -> RichSExpr a -> RichSExpr a
- cons x (R.RSList xs) = R.RSList (x:xs)
- cons x (R.RSDotted xs a) = R.RSDotted (x:xs) a
- cons x (R.RSAtom a) = R.RSDotted [x] a
- -- | A shorter infix alias to grab the head
- -- and tail of an `RSList`.
- --
- -- >>> A "one" ::: L [A "two", A "three"]
- -- RSList [RSAtom "one",RSAtom "two",RSAtom "three"]
- #if MIN_VERSION_base(4,8,0)
- pattern (:::) :: RichSExpr a -> RichSExpr a -> RichSExpr a
- #endif
- pattern x ::: xs <- (uncons -> Just (x, xs))
- #if MIN_VERSION_base(4,8,0)
- where x ::: xs = cons x xs
- #endif
- -- | A shorter alias for `RSAtom`
- --
- -- >>> A "elephant"
- -- RSAtom "elephant"
- #if MIN_VERSION_base(4,8,0)
- pattern A :: a -> RichSExpr a
- #endif
- pattern A a = R.RSAtom a
- -- | A shorter alias for `RSList`
- --
- -- >>> L [A "pachy", A "derm"]
- -- RSList [RSAtom "pachy",RSAtom "derm"]
- #if MIN_VERSION_base(4,8,0)
- pattern L :: [RichSExpr a] -> RichSExpr a
- #endif
- pattern L xs = R.RSList xs
- -- | A shorter alias for `RSDotted`
- --
- -- >>> DL [A "pachy"] "derm"
- -- RSDotted [RSAtom "pachy"] "derm"
- #if MIN_VERSION_base(4,8,0)
- pattern DL :: [RichSExpr a] -> a -> RichSExpr a
- #endif
- pattern DL xs x = R.RSDotted xs x
- -- | A shorter alias for `RSList` @[]@
- --
- -- >>> Nil
- -- RSList []
- #if MIN_VERSION_base(4,8,0)
- pattern Nil :: RichSExpr a
- #endif
- pattern Nil = R.RSList []
- -- | Utility function for parsing a pair of things: this parses a two-element list,
- -- and not a cons pair.
- --
- -- >>> fromPair (isAtom "pachy") (asAtom return) (L [A "pachy", A "derm"])
- -- Right ((), "derm")
- -- >>> fromPair (isAtom "pachy") fromAtom (L [A "pachy"])
- -- Left "Expected two-element list"
- fromPair :: (RichSExpr t -> Either String a)
- -> (RichSExpr t -> Either String b)
- -> RichSExpr t -> Either String (a, b)
- fromPair pl pr = asPair $ \(l,r) -> (,) <$> pl l <*> pr r
- -- | Utility function for parsing a proper list of things.
- --
- -- >>> fromList fromAtom (L [A "this", A "that", A "the-other"])
- -- Right ["this","that","the-other"]
- -- >>> fromList fromAtom (DL [A "this", A "that"] "the-other"])
- -- Left "asList: expected proper list; found dotted list"
- fromList :: (RichSExpr t -> Either String a) -> RichSExpr t -> Either String [a]
- fromList p = asList $ \ss -> mapM p ss
- -- | Utility function for parsing a single atom
- --
- -- >>> fromAtom (A "elephant")
- -- Right "elephant"
- -- >>> fromAtom (L [A "elephant"])
- -- Left "fromAtom: expected atom; found list"
- fromAtom :: RichSExpr t -> Either String t
- fromAtom (RSList _) = Left "fromAtom: expected atom; found list"
- fromAtom (RSDotted _ _) = Left "fromAtom: expected atom; found dotted list"
- fromAtom (RSAtom a) = return a
- -- | Parses a two-element list using the provided function.
- --
- -- >>> let go (A l) (A r) = return (l ++ r); go _ _ = Left "expected atoms"
- -- >>> asPair go (L [A "pachy", A "derm"])
- -- Right "pachyderm"
- -- >>> asPair go (L [A "elephant"])
- -- Left "asPair: expected two-element list; found list of length 1"
- asPair :: ((RichSExpr t, RichSExpr t) -> Either String a)
- -> RichSExpr t -> Either String a
- asPair f (RSList [l, r]) = f (l, r)
- asPair _ (RSList ls) = Left ("asPair: expected two-element list; found list of lenght " ++ show (length ls))
- asPair _ RSDotted {} = Left ("asPair: expected two-element list; found dotted list")
- asPair _ RSAtom {} = Left ("asPair: expected two-element list; found atom")
- -- | Parse an arbitrary-length list using the provided function.
- --
- -- >>> let go xs = concat <$> mapM fromAtom xs
- -- >>> asList go (L [A "el", A "eph", A "ant"])
- -- Right "elephant"
- -- >>> asList go (DL [A "el", A "eph"] "ant")
- -- Left "asList: expected list; found dotted list"
- asList :: ([RichSExpr t] -> Either String a)
- -> RichSExpr t -> Either String a
- asList f (RSList ls) = f ls
- asList _ RSDotted {} = Left ("asList: expected list; found dotted list")
- asList _ RSAtom { } = Left ("asList: expected list; found dotted list")
- -- | Match a given literal atom, failing otherwise.
- --
- -- >>> isAtom "elephant" (A "elephant")
- -- Right ()
- -- >>> isAtom "elephant" (L [A "elephant"])
- -- Left "isAtom: expected atom; found list"
- isAtom :: Eq t => t -> RichSExpr t -> Either String ()
- isAtom s (RSAtom s')
- | s == s' = return ()
- | otherwise = Left "isAtom: failed to match atom"
- isAtom _ RSList {} = Left "isAtom: expected atom; found list"
- isAtom _ RSDotted {} = Left "isAtom: expected atom; found dotted list"
- -- | Match an empty list, failing otherwise.
- --
- -- >>> isNil (L [])
- -- Right ()
- -- >>> isNil (A "elephant")
- -- Left "isNil: expected nil; found atom"
- isNil :: RichSExpr t -> Either String ()
- isNil (RSList []) = return ()
- isNil RSList {} = Left "isNil: expected nil; found non-nil list"
- isNil RSDotted {} = Left "isNil: expected nil; found dotted list"
- isNil RSAtom {} = Left "isNil: expected nil; found atom"
- -- | Parse an atom using the provided function.
- --
- -- >>> import Data.Char (toUpper)
- -- >>> asAtom (return . map toUpper) (A "elephant")
- -- Right "ELEPHANT"
- -- >>> asAtom (return . map toUpper) (L [])
- -- Left "asAtom: expected atom; found list"
- asAtom :: (t -> Either String a) -> RichSExpr t -> Either String a
- asAtom f (RSAtom s) = f s
- asAtom _ RSList {} = Left ("asAtom: expected atom; found list")
- asAtom _ RSDotted {} = Left ("asAtom: expected atom; found dotted list")
- -- | Parse an assoc-list using the provided function.
- --
- -- >>> let def (x, y) = do { a <- fromAtom x; b <- fromAtom y; return (a ++ ": " ++ b) }
- -- >>> let defList xs = do { defs <- mapM def xs; return (unlines defs) }
- -- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "trunk", A "one"] ])
- -- Right "legs: four\ntrunk: one\n"
- -- >>> asAssoc defList (L [ L [A "legs", A "four"], L [ A "elephant"] ])
- -- Left "asAssoc: expected pair; found list of length 1"
- asAssoc :: ([(RichSExpr t, RichSExpr t)] -> Either String a)
- -> RichSExpr t -> Either String a
- asAssoc f (RSList ss) = gatherPairs ss >>= f
- where gatherPairs (RSList [a, b] : ts) = (:) <$> pure (a, b) <*> gatherPairs ts
- gatherPairs [] = pure []
- gatherPairs (RSAtom {} : _) = Left ("asAssoc: expected pair; found atom")
- gatherPairs (RSDotted {} : _) = Left ("asAssoc: expected pair; found dotted list")
- gatherPairs (RSList ls : _) = Left ("asAssoc: expected pair; found list of length " ++ show (length ls))
- asAssoc _ RSDotted {} = Left "asAssoc: expected assoc list; found dotted list"
- asAssoc _ RSAtom {} = Left "asAssoc: expected assoc list; found atom"
- car :: (RichSExpr t -> Either String t') -> [RichSExpr t] -> Either String t'
- car f (x:_) = f x
- car _ [] = Left "car: Taking car of zero-element list"
- cdr :: ([RichSExpr t] -> Either String t') -> [RichSExpr t] -> Either String t'
- cdr f (_:xs) = f xs
- cdr _ [] = Left "cdr: Taking cdr of zero-element list"
|