{-# 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 :: forall (f :: * -> *) a.
Applicative f =>
(RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)
_car RichSExpr a -> f (RichSExpr a)
f (RSList (RichSExpr a
x:[RichSExpr a]
xs))     = (\ RichSExpr a
y -> [RichSExpr a] -> RichSExpr a
forall a. [RichSExpr a] -> RichSExpr a
L (RichSExpr a
yRichSExpr a -> [RichSExpr a] -> [RichSExpr a]
forall a. a -> [a] -> [a]
:[RichSExpr a]
xs)) (RichSExpr a -> RichSExpr a) -> f (RichSExpr a) -> f (RichSExpr a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RichSExpr a -> f (RichSExpr a)
f RichSExpr a
x
_car RichSExpr a -> f (RichSExpr a)
f (RSDotted (RichSExpr a
x:[RichSExpr a]
xs) a
a) = (\ RichSExpr a
y -> [RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
DL (RichSExpr a
yRichSExpr a -> [RichSExpr a] -> [RichSExpr a]
forall a. a -> [a] -> [a]
:[RichSExpr a]
xs) a
a) (RichSExpr a -> RichSExpr a) -> f (RichSExpr a) -> f (RichSExpr a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RichSExpr a -> f (RichSExpr a)
f RichSExpr a
x
_car RichSExpr a -> f (RichSExpr a)
_ (RSAtom a
a)          = RichSExpr a -> f (RichSExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> RichSExpr a
forall a. a -> RichSExpr a
A a
a)
_car RichSExpr a -> f (RichSExpr a)
_ (RSList [])         = RichSExpr a -> f (RichSExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RichSExpr a
forall a. RichSExpr a
Nil
_car RichSExpr a -> f (RichSExpr a)
_ (RSDotted [] a
a)     = RichSExpr a -> f (RichSExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> RichSExpr a
forall a. a -> RichSExpr a
A 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 :: forall (f :: * -> *) a.
Applicative f =>
(RichSExpr a -> f (RichSExpr a)) -> RichSExpr a -> f (RichSExpr a)
_cdr RichSExpr a -> f (RichSExpr a)
f (RSList (RichSExpr a
x:[RichSExpr a]
xs)) =
  let go :: RichSExpr a -> RichSExpr a
go (RSList [])      = [RichSExpr a] -> RichSExpr a
forall a. [RichSExpr a] -> RichSExpr a
L [RichSExpr a
x]
      go (RSAtom a
a)       = [RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
DL [RichSExpr a
x] a
a
      go (RSList [RichSExpr a]
xs')     = [RichSExpr a] -> RichSExpr a
forall a. [RichSExpr a] -> RichSExpr a
L (RichSExpr a
xRichSExpr a -> [RichSExpr a] -> [RichSExpr a]
forall a. a -> [a] -> [a]
:[RichSExpr a]
xs')
      go (RSDotted [RichSExpr a]
ys a
a') = [RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
DL (RichSExpr a
xRichSExpr a -> [RichSExpr a] -> [RichSExpr a]
forall a. a -> [a] -> [a]
:[RichSExpr a]
ys) a
a'
  in RichSExpr a -> RichSExpr a
go (RichSExpr a -> RichSExpr a) -> f (RichSExpr a) -> f (RichSExpr a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RichSExpr a -> f (RichSExpr a)
f ([RichSExpr a] -> RichSExpr a
forall a. [RichSExpr a] -> RichSExpr a
L [RichSExpr a]
xs)
_cdr RichSExpr a -> f (RichSExpr a)
f (RSDotted [RichSExpr a
x] a
a) =
  let go :: RichSExpr a -> RichSExpr a
go (RSList [])      = [RichSExpr a] -> RichSExpr a
forall a. [RichSExpr a] -> RichSExpr a
L [RichSExpr a
x]
      go (RSAtom a
a')      = [RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
DL [RichSExpr a
x] a
a'
      go (RSList [RichSExpr a]
xs)      = [RichSExpr a] -> RichSExpr a
forall a. [RichSExpr a] -> RichSExpr a
L (RichSExpr a
xRichSExpr a -> [RichSExpr a] -> [RichSExpr a]
forall a. a -> [a] -> [a]
:[RichSExpr a]
xs)
      go (RSDotted [RichSExpr a]
ys a
a') = [RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
DL (RichSExpr a
xRichSExpr a -> [RichSExpr a] -> [RichSExpr a]
forall a. a -> [a] -> [a]
:[RichSExpr a]
ys) a
a'
  in RichSExpr a -> RichSExpr a
go (RichSExpr a -> RichSExpr a) -> f (RichSExpr a) -> f (RichSExpr a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RichSExpr a -> f (RichSExpr a)
f (a -> RichSExpr a
forall a. a -> RichSExpr a
A a
a)
_cdr RichSExpr a -> f (RichSExpr a)
f (RSDotted (RichSExpr a
x:[RichSExpr a]
xs) a
a) =
  let go :: RichSExpr a -> RichSExpr a
go (RSList [])      = [RichSExpr a] -> RichSExpr a
forall a. [RichSExpr a] -> RichSExpr a
L [RichSExpr a
x]
      go (RSAtom a
a')      = [RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
DL [RichSExpr a
x] a
a'
      go (RSList [RichSExpr a]
ys)      = [RichSExpr a] -> RichSExpr a
forall a. [RichSExpr a] -> RichSExpr a
L (RichSExpr a
xRichSExpr a -> [RichSExpr a] -> [RichSExpr a]
forall a. a -> [a] -> [a]
:[RichSExpr a]
ys)
      go (RSDotted [RichSExpr a]
ys a
a') = [RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
DL (RichSExpr a
xRichSExpr a -> [RichSExpr a] -> [RichSExpr a]
forall a. a -> [a] -> [a]
:[RichSExpr a]
ys) a
a'
  in RichSExpr a -> RichSExpr a
go (RichSExpr a -> RichSExpr a) -> f (RichSExpr a) -> f (RichSExpr a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RichSExpr a -> f (RichSExpr a)
f ([RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
DL [RichSExpr a]
xs a
a)
_cdr RichSExpr a -> f (RichSExpr a)
_ (RSAtom a
a)         = RichSExpr a -> f (RichSExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> RichSExpr a
forall a. a -> RichSExpr a
A a
a)
_cdr RichSExpr a -> f (RichSExpr a)
_ (RSList [])        = RichSExpr a -> f (RichSExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RichSExpr a
forall a. RichSExpr a
Nil
_cdr RichSExpr a -> f (RichSExpr a)
_ (RSDotted [] a
a)    = RichSExpr a -> f (RichSExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> RichSExpr a
forall a. a -> RichSExpr a
A 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 :: forall a. RichSExpr a -> Maybe (RichSExpr a, RichSExpr a)
uncons (R.RSList (RichSExpr a
x:[RichSExpr a]
xs))     = (RichSExpr a, RichSExpr a) -> Maybe (RichSExpr a, RichSExpr a)
forall a. a -> Maybe a
Just (RichSExpr a
x, [RichSExpr a] -> RichSExpr a
forall a. [RichSExpr a] -> RichSExpr a
R.RSList [RichSExpr a]
xs)
uncons (R.RSDotted (RichSExpr a
x:[RichSExpr a]
xs) a
a) = (RichSExpr a, RichSExpr a) -> Maybe (RichSExpr a, RichSExpr a)
forall a. a -> Maybe a
Just (RichSExpr a
x, [RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
R.RSDotted [RichSExpr a]
xs a
a)
uncons RichSExpr a
_                     = Maybe (RichSExpr a, RichSExpr a)
forall a. Maybe a
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 :: forall a. RichSExpr a -> RichSExpr a -> RichSExpr a
cons RichSExpr a
x (R.RSList [RichSExpr a]
xs)     = [RichSExpr a] -> RichSExpr a
forall a. [RichSExpr a] -> RichSExpr a
R.RSList (RichSExpr a
xRichSExpr a -> [RichSExpr a] -> [RichSExpr a]
forall a. a -> [a] -> [a]
:[RichSExpr a]
xs)
cons RichSExpr a
x (R.RSDotted [RichSExpr a]
xs a
a) = [RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
R.RSDotted (RichSExpr a
xRichSExpr a -> [RichSExpr a] -> [RichSExpr a]
forall a. a -> [a] -> [a]
:[RichSExpr a]
xs) a
a
cons RichSExpr a
x (R.RSAtom a
a)      = [RichSExpr a] -> a -> RichSExpr a
forall a. [RichSExpr a] -> a -> RichSExpr a
R.RSDotted [RichSExpr a
x] a
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 $m::: :: forall {r} {a}.
RichSExpr a
-> (RichSExpr a -> RichSExpr a -> r) -> ((# #) -> r) -> r
$b::: :: forall a. RichSExpr a -> RichSExpr a -> RichSExpr a
::: xs <- (uncons -> Just (x, xs))
#if MIN_VERSION_base(4,8,0)
  where RichSExpr a
x ::: RichSExpr a
xs = RichSExpr a -> RichSExpr a -> RichSExpr a
forall a. RichSExpr a -> RichSExpr a -> RichSExpr a
cons RichSExpr a
x RichSExpr a
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 $mA :: forall {r} {a}. RichSExpr a -> (a -> r) -> ((# #) -> r) -> r
$bA :: forall a. a -> RichSExpr a
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 $mL :: forall {r} {a}.
RichSExpr a -> ([RichSExpr a] -> r) -> ((# #) -> r) -> r
$bL :: forall a. [RichSExpr a] -> RichSExpr a
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 $mDL :: forall {r} {a}.
RichSExpr a -> ([RichSExpr a] -> a -> r) -> ((# #) -> r) -> r
$bDL :: forall a. [RichSExpr a] -> a -> RichSExpr a
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 $mNil :: forall {r} {a}. RichSExpr a -> ((# #) -> r) -> ((# #) -> r) -> r
$bNil :: forall a. RichSExpr a
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 :: forall t a b.
(RichSExpr t -> Either String a)
-> (RichSExpr t -> Either String b)
-> RichSExpr t
-> Either String (a, b)
fromPair RichSExpr t -> Either String a
pl RichSExpr t -> Either String b
pr = ((RichSExpr t, RichSExpr t) -> Either String (a, b))
-> RichSExpr t -> Either String (a, b)
forall t a.
((RichSExpr t, RichSExpr t) -> Either String a)
-> RichSExpr t -> Either String a
asPair (((RichSExpr t, RichSExpr t) -> Either String (a, b))
 -> RichSExpr t -> Either String (a, b))
-> ((RichSExpr t, RichSExpr t) -> Either String (a, b))
-> RichSExpr t
-> Either String (a, b)
forall a b. (a -> b) -> a -> b
$ \(RichSExpr t
l,RichSExpr t
r) -> (,) (a -> b -> (a, b))
-> Either String a -> Either String (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RichSExpr t -> Either String a
pl RichSExpr t
l Either String (b -> (a, b))
-> Either String b -> Either String (a, b)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RichSExpr t -> Either String b
pr RichSExpr t
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 :: forall t a.
(RichSExpr t -> Either String a)
-> RichSExpr t -> Either String [a]
fromList RichSExpr t -> Either String a
p = ([RichSExpr t] -> Either String [a])
-> RichSExpr t -> Either String [a]
forall t a.
([RichSExpr t] -> Either String a)
-> RichSExpr t -> Either String a
asList (([RichSExpr t] -> Either String [a])
 -> RichSExpr t -> Either String [a])
-> ([RichSExpr t] -> Either String [a])
-> RichSExpr t
-> Either String [a]
forall a b. (a -> b) -> a -> b
$ \[RichSExpr t]
ss -> (RichSExpr t -> Either String a)
-> [RichSExpr t] -> Either String [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM RichSExpr t -> Either String a
p [RichSExpr t]
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 :: forall t. RichSExpr t -> Either String t
fromAtom (RSList [RichSExpr t]
_)     = String -> Either String t
forall a b. a -> Either a b
Left String
"fromAtom: expected atom; found list"
fromAtom (RSDotted [RichSExpr t]
_ t
_) = String -> Either String t
forall a b. a -> Either a b
Left String
"fromAtom: expected atom; found dotted list"
fromAtom (RSAtom t
a)     = t -> Either String t
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return t
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 :: forall t a.
((RichSExpr t, RichSExpr t) -> Either String a)
-> RichSExpr t -> Either String a
asPair (RichSExpr t, RichSExpr t) -> Either String a
f (RSList [RichSExpr t
l, RichSExpr t
r]) = (RichSExpr t, RichSExpr t) -> Either String a
f (RichSExpr t
l, RichSExpr t
r)
asPair (RichSExpr t, RichSExpr t) -> Either String a
_ (RSList [RichSExpr t]
ls)     = String -> Either String a
forall a b. a -> Either a b
Left (String
"asPair: expected two-element list; found list of lenght " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([RichSExpr t] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RichSExpr t]
ls))
asPair (RichSExpr t, RichSExpr t) -> Either String a
_ RSDotted {}     = String -> Either String a
forall a b. a -> Either a b
Left (String
"asPair: expected two-element list; found dotted list")
asPair (RichSExpr t, RichSExpr t) -> Either String a
_ RSAtom {}       = String -> Either String a
forall a b. a -> Either a b
Left (String
"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 :: forall t a.
([RichSExpr t] -> Either String a)
-> RichSExpr t -> Either String a
asList [RichSExpr t] -> Either String a
f (RSList [RichSExpr t]
ls) = [RichSExpr t] -> Either String a
f [RichSExpr t]
ls
asList [RichSExpr t] -> Either String a
_ RSDotted {} = String -> Either String a
forall a b. a -> Either a b
Left (String
"asList: expected list; found dotted list")
asList [RichSExpr t] -> Either String a
_ RSAtom { }  = String -> Either String a
forall a b. a -> Either a b
Left (String
"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 :: forall t. Eq t => t -> RichSExpr t -> Either String ()
isAtom t
s (RSAtom t
s')
  | t
s t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
s'   = () -> Either String ()
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = String -> Either String ()
forall a b. a -> Either a b
Left String
"isAtom: failed to match atom"
isAtom t
_ RSList {}  = String -> Either String ()
forall a b. a -> Either a b
Left String
"isAtom: expected atom; found list"
isAtom t
_ RSDotted {} = String -> Either String ()
forall a b. a -> Either a b
Left String
"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 :: forall t. RichSExpr t -> Either String ()
isNil (RSList []) = () -> Either String ()
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
isNil RSList {}   = String -> Either String ()
forall a b. a -> Either a b
Left String
"isNil: expected nil; found non-nil list"
isNil RSDotted {} = String -> Either String ()
forall a b. a -> Either a b
Left String
"isNil: expected nil; found dotted list"
isNil RSAtom {}   = String -> Either String ()
forall a b. a -> Either a b
Left String
"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 :: forall t a.
(t -> Either String a) -> RichSExpr t -> Either String a
asAtom t -> Either String a
f (RSAtom t
s)  = t -> Either String a
f t
s
asAtom t -> Either String a
_ RSList {}   = String -> Either String a
forall a b. a -> Either a b
Left (String
"asAtom: expected atom; found list")
asAtom t -> Either String a
_ RSDotted {} = String -> Either String a
forall a b. a -> Either a b
Left (String
"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 :: forall t a.
([(RichSExpr t, RichSExpr t)] -> Either String a)
-> RichSExpr t -> Either String a
asAssoc [(RichSExpr t, RichSExpr t)] -> Either String a
f (RSList [RichSExpr t]
ss) = [RichSExpr t] -> Either String [(RichSExpr t, RichSExpr t)]
forall {atom}.
[RichSExpr atom]
-> Either String [(RichSExpr atom, RichSExpr atom)]
gatherPairs [RichSExpr t]
ss Either String [(RichSExpr t, RichSExpr t)]
-> ([(RichSExpr t, RichSExpr t)] -> Either String a)
-> Either String a
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(RichSExpr t, RichSExpr t)] -> Either String a
f
  where gatherPairs :: [RichSExpr atom]
-> Either String [(RichSExpr atom, RichSExpr atom)]
gatherPairs (RSList [RichSExpr atom
a, RichSExpr atom
b] : [RichSExpr atom]
ts) = (:) ((RichSExpr atom, RichSExpr atom)
 -> [(RichSExpr atom, RichSExpr atom)]
 -> [(RichSExpr atom, RichSExpr atom)])
-> Either String (RichSExpr atom, RichSExpr atom)
-> Either
     String
     ([(RichSExpr atom, RichSExpr atom)]
      -> [(RichSExpr atom, RichSExpr atom)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RichSExpr atom, RichSExpr atom)
-> Either String (RichSExpr atom, RichSExpr atom)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RichSExpr atom
a, RichSExpr atom
b) Either
  String
  ([(RichSExpr atom, RichSExpr atom)]
   -> [(RichSExpr atom, RichSExpr atom)])
-> Either String [(RichSExpr atom, RichSExpr atom)]
-> Either String [(RichSExpr atom, RichSExpr atom)]
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [RichSExpr atom]
-> Either String [(RichSExpr atom, RichSExpr atom)]
gatherPairs [RichSExpr atom]
ts
        gatherPairs []              = [(RichSExpr atom, RichSExpr atom)]
-> Either String [(RichSExpr atom, RichSExpr atom)]
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        gatherPairs (RSAtom {} : [RichSExpr atom]
_)      = String -> Either String [(RichSExpr atom, RichSExpr atom)]
forall a b. a -> Either a b
Left (String
"asAssoc: expected pair; found atom")
        gatherPairs (RSDotted {} : [RichSExpr atom]
_)     = String -> Either String [(RichSExpr atom, RichSExpr atom)]
forall a b. a -> Either a b
Left (String
"asAssoc: expected pair; found dotted list")
        gatherPairs (RSList [RichSExpr atom]
ls : [RichSExpr atom]
_)      = String -> Either String [(RichSExpr atom, RichSExpr atom)]
forall a b. a -> Either a b
Left (String
"asAssoc: expected pair; found list of length " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([RichSExpr atom] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RichSExpr atom]
ls))
asAssoc [(RichSExpr t, RichSExpr t)] -> Either String a
_ RSDotted {} = String -> Either String a
forall a b. a -> Either a b
Left String
"asAssoc: expected assoc list; found dotted list"
asAssoc [(RichSExpr t, RichSExpr t)] -> Either String a
_ RSAtom {}   = String -> Either String a
forall a b. a -> Either a b
Left String
"asAssoc: expected assoc list; found atom"

car :: (RichSExpr t -> Either String t') -> [RichSExpr t] -> Either String t'
car :: forall t t'.
(RichSExpr t -> Either String t')
-> [RichSExpr t] -> Either String t'
car RichSExpr t -> Either String t'
f (RichSExpr t
x:[RichSExpr t]
_) = RichSExpr t -> Either String t'
f RichSExpr t
x
car RichSExpr t -> Either String t'
_ []    = String -> Either String t'
forall a b. a -> Either a b
Left String
"car: Taking car of zero-element list"

cdr :: ([RichSExpr t] -> Either String t') -> [RichSExpr t] -> Either String t'
cdr :: forall t t'.
([RichSExpr t] -> Either String t')
-> [RichSExpr t] -> Either String t'
cdr [RichSExpr t] -> Either String t'
f (RichSExpr t
_:[RichSExpr t]
xs) = [RichSExpr t] -> Either String t'
f [RichSExpr t]
xs
cdr [RichSExpr t] -> Either String t'
_ []     = String -> Either String t'
forall a b. a -> Either a b
Left String
"cdr: Taking cdr of zero-element list"