{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

module Data.SCargot.Repr.WellFormed
       ( -- * 'WellFormedSExpr' representation
         R.WellFormedSExpr(..)
       , R.toWellFormed
       , R.fromWellFormed
         -- * Constructing and Deconstructing
       , cons
       , uncons
         -- * Useful pattern synonyms
       , pattern (:::)
       , pattern L
       , pattern A
       , pattern Nil
         -- * 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 ((<$>), (<*>), pure)
#endif
import Data.SCargot.Repr as R

-- | Produce the head and tail of the s-expression (if possible).
--
-- >>> uncons (L [A "el", A "eph", A "ant"])
-- Just (WFSAtom "el",WFSList [WFSAtom "eph",WFSAtom "ant"])
uncons :: WellFormedSExpr a -> Maybe (WellFormedSExpr a, WellFormedSExpr a)
uncons :: forall a.
WellFormedSExpr a -> Maybe (WellFormedSExpr a, WellFormedSExpr a)
uncons R.WFSAtom {}       = forall a. Maybe a
Nothing
uncons (R.WFSList [])     = forall a. Maybe a
Nothing
uncons (R.WFSList (WellFormedSExpr a
x:[WellFormedSExpr a]
xs)) = forall a. a -> Maybe a
Just (WellFormedSExpr a
x, forall atom. [WellFormedSExpr atom] -> WellFormedSExpr atom
R.WFSList [WellFormedSExpr a]
xs)

-- | Combine the two-expressions into a new one. This will return
--   @Nothing@ if the resulting s-expression is not well-formed.
--
-- >>> cons (A "el") (L [A "eph", A "ant"])
-- Just (WFSList [WFSAtom "el",WFSAtom "eph",WFSAtom "ant"])
-- >>> cons (A "pachy") (A "derm"))
-- Nothing
cons :: WellFormedSExpr a -> WellFormedSExpr a -> Maybe (WellFormedSExpr a)
cons :: forall a.
WellFormedSExpr a -> WellFormedSExpr a -> Maybe (WellFormedSExpr a)
cons WellFormedSExpr a
_ (R.WFSAtom {}) = forall a. Maybe a
Nothing
cons WellFormedSExpr a
x (R.WFSList [WellFormedSExpr a]
xs) = forall a. a -> Maybe a
Just (forall atom. [WellFormedSExpr atom] -> WellFormedSExpr atom
R.WFSList (WellFormedSExpr a
xforall a. a -> [a] -> [a]
:[WellFormedSExpr a]
xs))

-- | A shorter infix alias to grab the head and tail of a `WFSList`. This
--   pattern is unidirectional, because it cannot be guaranteed that it
--   is used to construct well-formed s-expressions; use the function "cons"
--   instead.
--
-- >>> let sum (x ::: xs) = x + sum xs; sum Nil = 0
#if MIN_VERSION_base(4,8,0)
pattern (:::) :: WellFormedSExpr a -> WellFormedSExpr a -> WellFormedSExpr a
#endif
pattern x $m::: :: forall {r} {a}.
WellFormedSExpr a
-> (WellFormedSExpr a -> WellFormedSExpr a -> r)
-> ((# #) -> r)
-> r
::: xs <- (uncons -> Just (x, xs))

-- | A shorter alias for `WFSList`
--
-- >>> L [A "pachy", A "derm"]
-- WFSList [WFSAtom "pachy",WFSAtom "derm"]
#if MIN_VERSION_base(4,8,0)
pattern L :: [WellFormedSExpr t] -> WellFormedSExpr t
#endif
pattern $bL :: forall atom. [WellFormedSExpr atom] -> WellFormedSExpr atom
$mL :: forall {r} {t}.
WellFormedSExpr t
-> ([WellFormedSExpr t] -> r) -> ((# #) -> r) -> r
L xs = R.WFSList xs

-- | A shorter alias for `WFSAtom`
--
-- >>> A "elephant"
-- WFSAtom "elephant"
#if MIN_VERSION_base(4,8,0)
pattern A :: t -> WellFormedSExpr t
#endif
pattern $bA :: forall t. t -> WellFormedSExpr t
$mA :: forall {r} {t}. WellFormedSExpr t -> (t -> r) -> ((# #) -> r) -> r
A a  = R.WFSAtom a

-- | A shorter alias for `WFSList` @[]@
--
-- >>> Nil
-- WFSList []
#if MIN_VERSION_base(4,8,0)
pattern Nil :: WellFormedSExpr t
#endif
pattern $bNil :: forall t. WellFormedSExpr t
$mNil :: forall {r} {t}.
WellFormedSExpr t -> ((# #) -> r) -> ((# #) -> r) -> r
Nil = R.WFSList []

getShape :: WellFormedSExpr a -> String
getShape :: forall a. WellFormedSExpr a -> String
getShape WFSAtom {}   = String
"atom"
getShape (WFSList []) = String
"empty list"
getShape (WFSList [WellFormedSExpr a]
sx) = String
"list of length " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [WellFormedSExpr a]
sx)

-- | Utility function for parsing a pair of things.
--
-- >>> 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 :: (WellFormedSExpr t -> Either String a)
         -> (WellFormedSExpr t -> Either String b)
         -> WellFormedSExpr t -> Either String (a, b)
fromPair :: forall t a b.
(WellFormedSExpr t -> Either String a)
-> (WellFormedSExpr t -> Either String b)
-> WellFormedSExpr t
-> Either String (a, b)
fromPair WellFormedSExpr t -> Either String a
pl WellFormedSExpr t -> Either String b
pr (L [WellFormedSExpr t
l, WellFormedSExpr t
r]) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WellFormedSExpr t -> Either String a
pl WellFormedSExpr t
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> WellFormedSExpr t -> Either String b
pr WellFormedSExpr t
r
fromPair WellFormedSExpr t -> Either String a
_  WellFormedSExpr t -> Either String b
_  WellFormedSExpr t
sx = forall a b. a -> Either a b
Left (String
"fromPair: expected two-element list; found " forall a. [a] -> [a] -> [a]
++ forall a. WellFormedSExpr a -> String
getShape WellFormedSExpr t
sx)

-- | Utility function for parsing a list of things.
--
-- >>> fromList fromAtom (L [A "this", A "that", A "the-other"])
-- Right ["this","that","the-other"]
-- >>> fromList fromAtom (A "pachyderm")
-- Left "asList: expected proper list; found dotted list"
fromList :: (WellFormedSExpr t -> Either String a)
         -> WellFormedSExpr t -> Either String [a]
fromList :: forall t a.
(WellFormedSExpr t -> Either String a)
-> WellFormedSExpr t -> Either String [a]
fromList WellFormedSExpr t -> Either String a
p (L [WellFormedSExpr t]
ss) = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WellFormedSExpr t -> Either String a
p [WellFormedSExpr t]
ss
fromList WellFormedSExpr t -> Either String a
_ WellFormedSExpr t
sx     = forall a b. a -> Either a b
Left (String
"fromList: expected list; found " forall a. [a] -> [a] -> [a]
++ forall a. WellFormedSExpr a -> String
getShape WellFormedSExpr t
sx)

-- | Utility function for parsing a single atom
--
-- >>> fromAtom (A "elephant")
-- Right "elephant"
-- >>> fromAtom (L [A "elephant"])
-- Left "fromAtom: expected atom; found list"
fromAtom :: WellFormedSExpr t -> Either String t
fromAtom :: forall t. WellFormedSExpr t -> Either String t
fromAtom (A t
a) = forall (m :: * -> *) a. Monad m => a -> m a
return t
a
fromAtom WellFormedSExpr t
sx    = forall a b. a -> Either a b
Left (String
"fromAtom: expected atom; found " forall a. [a] -> [a] -> [a]
++ forall a. WellFormedSExpr a -> String
getShape WellFormedSExpr t
sx)

-- | 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 :: ((WellFormedSExpr t, WellFormedSExpr t) -> Either String a)
       -> WellFormedSExpr t -> Either String a
asPair :: forall t a.
((WellFormedSExpr t, WellFormedSExpr t) -> Either String a)
-> WellFormedSExpr t -> Either String a
asPair (WellFormedSExpr t, WellFormedSExpr t) -> Either String a
f (L [WellFormedSExpr t
l, WellFormedSExpr t
r]) = (WellFormedSExpr t, WellFormedSExpr t) -> Either String a
f (WellFormedSExpr t
l, WellFormedSExpr t
r)
asPair (WellFormedSExpr t, WellFormedSExpr t) -> Either String a
_ WellFormedSExpr t
sx         = forall a b. a -> Either a b
Left (String
"asPair: expected two-element list; found " forall a. [a] -> [a] -> [a]
++ forall a. WellFormedSExpr a -> String
getShape WellFormedSExpr t
sx)

-- | 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 (A "pachyderm")
-- Left "asList: expected list; found atom"
asList :: ([WellFormedSExpr t] -> Either String a)
       -> WellFormedSExpr t -> Either String a
asList :: forall t a.
([WellFormedSExpr t] -> Either String a)
-> WellFormedSExpr t -> Either String a
asList [WellFormedSExpr t] -> Either String a
f (L [WellFormedSExpr t]
ls) = [WellFormedSExpr t] -> Either String a
f [WellFormedSExpr t]
ls
asList [WellFormedSExpr t] -> Either String a
_ WellFormedSExpr t
sx     = forall a b. a -> Either a b
Left (String
"asList: expected list; found " forall a. [a] -> [a] -> [a]
++ forall a. WellFormedSExpr a -> String
getShape WellFormedSExpr t
sx)

-- | 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 -> WellFormedSExpr t -> Either String ()
isAtom :: forall t. Eq t => t -> WellFormedSExpr t -> Either String ()
isAtom t
s (A t
s')
  | t
s forall a. Eq a => a -> a -> Bool
== t
s'   = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = forall a b. a -> Either a b
Left String
"isAtom: failed to match atom"
isAtom t
_ WellFormedSExpr t
sx  = forall a b. a -> Either a b
Left (String
"isAtom: expected atom; found " forall a. [a] -> [a] -> [a]
++ forall a. WellFormedSExpr a -> String
getShape WellFormedSExpr t
sx)

-- | Match an empty list, failing otherwise.
--
-- >>> isNil (L [])
-- Right ()
-- >>> isNil (A "elephant")
-- Left "isNil: expected nil; found atom"
isNil :: WellFormedSExpr t -> Either String ()
isNil :: forall t. WellFormedSExpr t -> Either String ()
isNil WellFormedSExpr t
Nil = forall (m :: * -> *) a. Monad m => a -> m a
return ()
isNil WellFormedSExpr t
sx  = forall a b. a -> Either a b
Left (String
"isNil: expected nil; found " forall a. [a] -> [a] -> [a]
++ forall a. WellFormedSExpr a -> String
getShape WellFormedSExpr t
sx)

-- | 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) -> WellFormedSExpr t -> Either String a
asAtom :: forall t a.
(t -> Either String a) -> WellFormedSExpr t -> Either String a
asAtom t -> Either String a
f (A t
s) = t -> Either String a
f t
s
asAtom t -> Either String a
_ WellFormedSExpr t
sx    = forall a b. a -> Either a b
Left (String
"asAtom: expected atom; found " forall a. [a] -> [a] -> [a]
++ forall a. WellFormedSExpr a -> String
getShape WellFormedSExpr t
sx)

-- | 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 :: ([(WellFormedSExpr t, WellFormedSExpr t)] -> Either String a)
        -> WellFormedSExpr t -> Either String a
asAssoc :: forall t a.
([(WellFormedSExpr t, WellFormedSExpr t)] -> Either String a)
-> WellFormedSExpr t -> Either String a
asAssoc [(WellFormedSExpr t, WellFormedSExpr t)] -> Either String a
f (L [WellFormedSExpr t]
ss) = forall {a}.
[WellFormedSExpr a]
-> Either String [(WellFormedSExpr a, WellFormedSExpr a)]
gatherPairs [WellFormedSExpr t]
ss forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(WellFormedSExpr t, WellFormedSExpr t)] -> Either String a
f
  where gatherPairs :: [WellFormedSExpr a]
-> Either String [(WellFormedSExpr a, WellFormedSExpr a)]
gatherPairs (L [WellFormedSExpr a
a, WellFormedSExpr a
b] : [WellFormedSExpr a]
ts) = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure (WellFormedSExpr a
a, WellFormedSExpr a
b) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [WellFormedSExpr a]
-> Either String [(WellFormedSExpr a, WellFormedSExpr a)]
gatherPairs [WellFormedSExpr a]
ts
        gatherPairs []              = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        gatherPairs (WellFormedSExpr a
sx:[WellFormedSExpr a]
_)          = forall a b. a -> Either a b
Left (String
"asAssoc: expected pair; found " forall a. [a] -> [a] -> [a]
++ forall a. WellFormedSExpr a -> String
getShape WellFormedSExpr a
sx)
asAssoc [(WellFormedSExpr t, WellFormedSExpr t)] -> Either String a
_ WellFormedSExpr t
sx     = forall a b. a -> Either a b
Left (String
"asAssoc: expected list; found " forall a. [a] -> [a] -> [a]
++ forall a. WellFormedSExpr a -> String
getShape WellFormedSExpr t
sx)

-- | Run the parser on the first element of a Haskell list of "WellFormedSExpr" values,
--   failing if the list is empty. This is useful in conjunction with the `asList`
--   function.
car :: (WellFormedSExpr t -> Either String t')
    -> [WellFormedSExpr t] -> Either String t'
car :: forall t t'.
(WellFormedSExpr t -> Either String t')
-> [WellFormedSExpr t] -> Either String t'
car WellFormedSExpr t -> Either String t'
f (WellFormedSExpr t
x:[WellFormedSExpr t]
_) = WellFormedSExpr t -> Either String t'
f WellFormedSExpr t
x
car WellFormedSExpr t -> Either String t'
_ []    = forall a b. a -> Either a b
Left String
"car: Taking car of zero-element list"

-- | Run the parser on all but the first element of a Haskell list of "WellFormedSExpr" values,
--   failing if the list is empty. This is useful in conjunction with the `asList`
--   function.
cdr :: ([WellFormedSExpr t] -> Either String t')
    -> [WellFormedSExpr t] -> Either String t'
cdr :: forall t t'.
([WellFormedSExpr t] -> Either String t')
-> [WellFormedSExpr t] -> Either String t'
cdr [WellFormedSExpr t] -> Either String t'
f (WellFormedSExpr t
_:[WellFormedSExpr t]
xs) = [WellFormedSExpr t] -> Either String t'
f [WellFormedSExpr t]
xs
cdr [WellFormedSExpr t] -> Either String t'
_ []     = forall a b. a -> Either a b
Left String
"cdr: Taking cdr of zero-element list"