{-# 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"