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

module Data.SCargot.Repr.Basic
       ( -- * Basic 'SExpr' representation
         R.SExpr(..)
         -- * Constructing and Deconstructing
       , cons
       , uncons
         -- * Shorthand Patterns
       , pattern (:::)
       , pattern A
       , pattern L
       , pattern DL
       , pattern Nil
         -- * Lenses
       , _car
       , _cdr
         -- * Useful processing functions
       , fromPair
       , fromList
       , fromAtom
       , asPair
       , asList
       , isAtom
       , asAtom
       , asAssoc
       ) 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") (A "one" ::: A "two" ::: A "three" ::: Nil)
-- A "elelphant" ::: A "two" ::: A "three" ::: Nil
-- >>> set _car (A "two" ::: A "three" ::: Nil) (A "one" ::: A "elephant")
-- (A "two" ::: A "three" ::: Nil) ::: A "elephant"
_car :: Applicative f => (SExpr a -> f (SExpr a)) -> SExpr a -> f (SExpr a)
_car :: forall (f :: * -> *) a.
Applicative f =>
(SExpr a -> f (SExpr a)) -> SExpr a -> f (SExpr a)
_car SExpr a -> f (SExpr a)
f (SCons SExpr a
x SExpr a
xs) = forall a. SExpr a -> SExpr a -> SExpr a
(:::) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr a -> f (SExpr a)
f SExpr a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SExpr a
xs
_car SExpr a -> f (SExpr a)
_ (SAtom a
a)    = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> SExpr a
A a
a)
_car SExpr a -> f (SExpr a)
_ SExpr a
SNil         = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall atom. SExpr atom
SNil

-- | A traversal with access to the second element of a pair.
--
-- >>> import Lens.Family
-- >>> set _cdr (A "elephant") (A "one" ::: A "two" ::: A "three" ::: Nil)
-- A "one" ::: A "elephant"
-- >>> set _cdr (A "two" ::: A "three" ::: Nil) (A "one" ::: A "elephant")
-- A "one" ::: A "two" ::: A "three" ::: Nil
_cdr :: Applicative f => (SExpr a -> f (SExpr a)) -> SExpr a -> f (SExpr a)
_cdr :: forall (f :: * -> *) a.
Applicative f =>
(SExpr a -> f (SExpr a)) -> SExpr a -> f (SExpr a)
_cdr SExpr a -> f (SExpr a)
f (SCons SExpr a
x SExpr a
xs) = forall a. SExpr a -> SExpr a -> SExpr a
(:::) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure SExpr a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr a -> f (SExpr a)
f SExpr a
xs
_cdr SExpr a -> f (SExpr a)
_ (SAtom a
a)    = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> SExpr a
A a
a)
_cdr SExpr a -> f (SExpr a)
_ SExpr a
SNil         = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall atom. SExpr atom
Nil

-- | Produce the head and tail of the s-expression (if possible).
--
-- >>> uncons (A "el" ::: A "eph" ::: A "ant" ::: Nil)
-- Just (A "el",SCons (SAtom "eph") (SCons (SAtom "ant") SNil))
uncons :: SExpr a -> Maybe (SExpr a, SExpr a)
uncons :: forall a. SExpr a -> Maybe (SExpr a, SExpr a)
uncons (SCons SExpr a
x SExpr a
xs) = forall a. a -> Maybe a
Just (SExpr a
x, SExpr a
xs)
uncons SExpr a
_            = forall a. Maybe a
Nothing

-- | Combine the two s-expressions into a new one.
--
-- >>> cons (A "el") (L ["eph", A "ant"])
-- SCons (SAtom "el) (SCons (SAtom "eph") (SCons (SAtom "ant") SNil))
cons :: SExpr a -> SExpr a -> SExpr a
cons :: forall a. SExpr a -> SExpr a -> SExpr a
cons = forall a. SExpr a -> SExpr a -> SExpr a
SCons

gatherDList :: SExpr a -> Maybe ([SExpr a], a)
gatherDList :: forall a. SExpr a -> Maybe ([SExpr a], a)
gatherDList SExpr a
SNil     = forall a. Maybe a
Nothing
gatherDList SAtom {} = forall a. Maybe a
Nothing
gatherDList SExpr a
sx       = forall a. SExpr a -> Maybe ([SExpr a], a)
go SExpr a
sx
  where go :: SExpr b -> Maybe ([SExpr b], b)
go SExpr b
SNil = forall a. Maybe a
Nothing
        go (SAtom b
a) = forall (m :: * -> *) a. Monad m => a -> m a
return ([], b
a)
        go (SCons SExpr b
x SExpr b
xs) = do
          ([SExpr b]
ys, b
a) <- SExpr b -> Maybe ([SExpr b], b)
go SExpr b
xs
          forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr b
xforall a. a -> [a] -> [a]
:[SExpr b]
ys, b
a)

infixr 5 :::

-- | A shorter infix alias for `SCons`
--
-- >>> A "pachy" ::: A "derm"
-- SCons (SAtom "pachy") (SAtom "derm")
#if MIN_VERSION_base(4,8,0)
pattern (:::) :: SExpr a -> SExpr a -> SExpr a
#endif
pattern x $b::: :: forall a. SExpr a -> SExpr a -> SExpr a
$m::: :: forall {r} {a}.
SExpr a -> (SExpr a -> SExpr a -> r) -> ((# #) -> r) -> r
::: xs = SCons x xs

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

-- | A (slightly) shorter alias for `SNil`
--
-- >>> Nil
-- SNil
#if MIN_VERSION_base(4,8,0)
pattern Nil :: SExpr a
#endif
pattern $bNil :: forall atom. SExpr atom
$mNil :: forall {r} {a}. SExpr a -> ((# #) -> r) -> ((# #) -> r) -> r
Nil = SNil

-- | An alias for matching a proper list.
--
-- >>> L [A "pachy", A "derm"]
-- SExpr (SAtom "pachy") (SExpr (SAtom "derm") SNil)
#if MIN_VERSION_base(4,8,0)
pattern L :: [SExpr a] -> SExpr a
#endif
pattern $bL :: forall a. [SExpr a] -> SExpr a
$mL :: forall {r} {a}. SExpr a -> ([SExpr a] -> r) -> ((# #) -> r) -> r
L xs <- (gatherList -> Right xs)
#if MIN_VERSION_base(4,8,0)
  where L []     = forall atom. SExpr atom
SNil
        L (SExpr a
x:[SExpr a]
xs) = forall a. SExpr a -> SExpr a -> SExpr a
SCons SExpr a
x (forall a. [SExpr a] -> SExpr a
L [SExpr a]
xs)
#endif


-- | An alias for matching a dotted list.
--
-- >>> DL [A "pachy"] A "derm"
-- SExpr (SAtom "pachy") (SAtom "derm")
#if MIN_VERSION_base(4,8,0)
pattern DL :: [SExpr a] -> a -> SExpr a
#endif
pattern $bDL :: forall a. [SExpr a] -> a -> SExpr a
$mDL :: forall {r} {a}.
SExpr a -> ([SExpr a] -> a -> r) -> ((# #) -> r) -> r
DL xs x <- (gatherDList -> Just (xs, x))
#if MIN_VERSION_base(4,8,0)
  where DL []     a
a = forall a. a -> SExpr a
SAtom a
a
        DL (SExpr a
x:[SExpr a]
xs) a
a = forall a. SExpr a -> SExpr a -> SExpr a
SCons SExpr a
x (forall a. [SExpr a] -> a -> SExpr a
DL [SExpr a]
xs a
a)
#endif

getShape :: SExpr a -> String
getShape :: forall a. SExpr a -> String
getShape SExpr a
Nil = String
"empty list"
getShape SExpr a
sx = forall {t} {atom}. (Show t, Num t) => t -> SExpr atom -> String
go (Int
0 :: Int) SExpr a
sx
  where go :: t -> SExpr atom -> String
go t
n SExpr atom
SNil         = String
"list of length " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
n
        go t
n SAtom {}     = String
"dotted list of length " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
n
        go t
n (SCons SExpr atom
_ SExpr atom
xs) = t -> SExpr atom -> String
go (t
nforall a. Num a => a -> a -> a
+t
1) SExpr atom
xs

-- | Utility function for parsing a pair of things.
--
-- >>> fromPair (isAtom "pachy") (asAtom return) (A "pachy" ::: A "derm" ::: Nil)
-- Right ((), "derm")
-- >>> fromPair (isAtom "pachy") fromAtom (A "pachy" ::: Nil)
-- Left "Expected two-element list"
fromPair :: (SExpr t -> Either String a)
         -> (SExpr t -> Either String b)
         -> SExpr t -> Either String (a, b)
fromPair :: forall t a b.
(SExpr t -> Either String a)
-> (SExpr t -> Either String b) -> SExpr t -> Either String (a, b)
fromPair SExpr t -> Either String a
pl SExpr t -> Either String b
pr (SExpr t
l ::: SExpr t
r ::: SExpr t
Nil) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr t -> Either String a
pl SExpr t
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr t -> Either String b
pr SExpr t
r
fromPair SExpr t -> Either String a
_  SExpr t -> Either String b
_  SExpr t
sx = forall a b. a -> Either a b
Left (String
"fromPair: expected two-element list; found " forall a. [a] -> [a] -> [a]
++ forall a. SExpr a -> String
getShape SExpr t
sx)

-- | Utility function for parsing a list of things.
fromList :: (SExpr t -> Either String a) -> SExpr t -> Either String [a]
fromList :: forall t a.
(SExpr t -> Either String a) -> SExpr t -> Either String [a]
fromList SExpr t -> Either String a
p (SExpr t
s ::: SExpr t
ss) = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr t -> Either String a
p SExpr t
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t a.
(SExpr t -> Either String a) -> SExpr t -> Either String [a]
fromList SExpr t -> Either String a
p SExpr t
ss
fromList SExpr t -> Either String a
_ SExpr t
Nil        = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
fromList SExpr t -> Either String a
_ SExpr t
sx         = forall a b. a -> Either a b
Left (String
"fromList: expected list; found " forall a. [a] -> [a] -> [a]
++ forall a. SExpr a -> String
getShape SExpr t
sx)

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

gatherList :: SExpr t -> Either String [SExpr t]
gatherList :: forall t. SExpr t -> Either String [SExpr t]
gatherList (SExpr t
x ::: SExpr t
xs) = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure SExpr t
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. SExpr t -> Either String [SExpr t]
gatherList SExpr t
xs
gatherList SExpr t
Nil        = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
gatherList SExpr t
sx         = forall a b. a -> Either a b
Left (String
"gatherList: expected list; found " forall a. [a] -> [a] -> [a]
++ forall a. SExpr a -> String
getShape SExpr t
sx)

-- | Parse a two-element list (NOT a dotted pair) using the
--   provided function.
--
-- >>> let go (A l) (A r) = return (l ++ r); go _ _ = Left "expected atoms"
-- >>> asPair go (A "pachy" ::: A "derm" ::: Nil)
-- Right "pachyderm"
-- >>> asPair go (A "elephant" ::: Nil)
-- Left "asPair: expected two-element list; found list of length 1"
asPair :: ((SExpr t, SExpr t) -> Either String a)
       -> SExpr t -> Either String a
asPair :: forall t a.
((SExpr t, SExpr t) -> Either String a)
-> SExpr t -> Either String a
asPair (SExpr t, SExpr t) -> Either String a
f (SExpr t
l ::: SExpr t
r ::: SExpr t
SNil) = (SExpr t, SExpr t) -> Either String a
f (SExpr t
l, SExpr t
r)
asPair (SExpr t, SExpr t) -> Either String a
_ SExpr t
sx = forall a b. a -> Either a b
Left (String
"asPair: expected two-element list; found " forall a. [a] -> [a] -> [a]
++ forall a. SExpr a -> String
getShape SExpr t
sx)

-- | Parse an arbitrary-length list using the provided function.
--
-- >>> let go xs = concat <$> mapM fromAtom xs
-- >>> asList go (A "el" ::: A "eph" ::: A "ant" ::: Nil)
-- Right "elephant"
-- >>> asList go (A "el" ::: A "eph" ::: A "ant")
-- Left "asList: expected list; found dotted list of length 3"
asList :: ([SExpr t] -> Either String a) -> SExpr t -> Either String a
asList :: forall t a.
([SExpr t] -> Either String a) -> SExpr t -> Either String a
asList [SExpr t] -> Either String a
f SExpr t
ls = forall t. SExpr t -> Either String [SExpr t]
gatherList SExpr t
ls forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [SExpr t] -> Either String a
f

-- | Match a given literal atom, failing otherwise.
--
-- >>> isAtom "elephant" (A "elephant")
-- Right ()
-- >>> isAtom "elephant" (A "elephant" ::: Nil)
-- Left "isAtom: expected atom; found list"
isAtom :: Eq t => t -> SExpr t -> Either String ()
isAtom :: forall t. Eq t => t -> SExpr 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
_ SExpr t
sx = forall a b. a -> Either a b
Left (String
"isAtom: expected atom; found " forall a. [a] -> [a] -> [a]
++ forall a. SExpr a -> String
getShape SExpr 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) Nil
-- Left "asAtom: expected atom; found empty list"
asAtom :: (t -> Either String a) -> SExpr t -> Either String a
asAtom :: forall t a. (t -> Either String a) -> SExpr 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
_ SExpr t
sx    = forall a b. a -> Either a b
Left (String
"asAtom: expected atom; found " forall a. [a] -> [a] -> [a]
++ forall a. SExpr a -> String
getShape SExpr 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 ((A "legs" ::: A "four" ::: Nil) ::: (A "trunk" ::: A "one" ::: Nil) ::: Nil)
-- Right "legs: four\ntrunk: one\n"
-- >>> asAssoc defList ((A "legs" ::: A "four" ::: Nil) ::: (A "elephant") ::: Nil)
-- Left "asAssoc: expected pair; found list of length 1"
asAssoc :: ([(SExpr t, SExpr t)] -> Either String a)
        -> SExpr t -> Either String a
asAssoc :: forall t a.
([(SExpr t, SExpr t)] -> Either String a)
-> SExpr t -> Either String a
asAssoc [(SExpr t, SExpr t)] -> Either String a
f SExpr t
ss = forall t. SExpr t -> Either String [SExpr t]
gatherList SExpr t
ss forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. SExpr a -> Either String (SExpr a, SExpr a)
go forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(SExpr t, SExpr t)] -> Either String a
f
  where go :: SExpr a -> Either String (SExpr a, SExpr a)
go (SExpr a
a ::: SExpr a
b ::: SExpr a
Nil) = forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr a
a, SExpr a
b)
        go SExpr a
sx = forall a b. a -> Either a b
Left (String
"asAssoc: expected pair; found " forall a. [a] -> [a] -> [a]
++ forall a. SExpr a -> String
getShape SExpr a
sx)