{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Data.SCargot.Repr.Basic
(
R.SExpr(..)
, cons
, uncons
, pattern (:::)
, pattern A
, pattern L
, pattern DL
, pattern Nil
, _car
, _cdr
, 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
_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) = SExpr a -> SExpr a -> SExpr a
forall a. SExpr a -> SExpr a -> SExpr a
(:::) (SExpr a -> SExpr a -> SExpr a)
-> f (SExpr a) -> f (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 f (SExpr a -> SExpr a) -> f (SExpr a) -> f (SExpr a)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SExpr a -> f (SExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SExpr a
xs
_car SExpr a -> f (SExpr a)
_ (SAtom a
a) = SExpr a -> f (SExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> SExpr a
forall a. a -> SExpr a
A a
a)
_car SExpr a -> f (SExpr a)
_ SExpr a
SNil = SExpr a -> f (SExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SExpr a
forall atom. SExpr atom
SNil
_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) = SExpr a -> SExpr a -> SExpr a
forall a. SExpr a -> SExpr a -> SExpr a
(:::) (SExpr a -> SExpr a -> SExpr a)
-> f (SExpr a) -> f (SExpr a -> SExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr a -> f (SExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SExpr a
x f (SExpr a -> SExpr a) -> f (SExpr a) -> f (SExpr a)
forall a b. f (a -> b) -> f a -> f b
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) = SExpr a -> f (SExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> SExpr a
forall a. a -> SExpr a
A a
a)
_cdr SExpr a -> f (SExpr a)
_ SExpr a
SNil = SExpr a -> f (SExpr a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SExpr a
forall atom. SExpr atom
Nil
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) = (SExpr a, SExpr a) -> Maybe (SExpr a, SExpr a)
forall a. a -> Maybe a
Just (SExpr a
x, SExpr a
xs)
uncons SExpr a
_ = Maybe (SExpr a, SExpr a)
forall a. Maybe a
Nothing
cons :: SExpr a -> SExpr a -> SExpr a
cons :: forall a. SExpr a -> SExpr a -> SExpr a
cons = SExpr a -> SExpr a -> SExpr a
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 = Maybe ([SExpr a], a)
forall a. Maybe a
Nothing
gatherDList SAtom {} = Maybe ([SExpr a], a)
forall a. Maybe a
Nothing
gatherDList SExpr a
sx = SExpr a -> Maybe ([SExpr a], a)
forall a. SExpr a -> Maybe ([SExpr a], a)
go SExpr a
sx
where go :: SExpr b -> Maybe ([SExpr b], b)
go SExpr b
SNil = Maybe ([SExpr b], b)
forall a. Maybe a
Nothing
go (SAtom b
a) = ([SExpr b], b) -> Maybe ([SExpr b], b)
forall a. a -> Maybe 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
([SExpr b], b) -> Maybe ([SExpr b], b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr b
xSExpr b -> [SExpr b] -> [SExpr b]
forall a. a -> [a] -> [a]
:[SExpr b]
ys, b
a)
infixr 5 :::
#if MIN_VERSION_base(4,8,0)
pattern (:::) :: SExpr a -> SExpr a -> SExpr a
#endif
pattern x $m::: :: forall {r} {a}.
SExpr a -> (SExpr a -> SExpr a -> r) -> ((# #) -> r) -> r
$b::: :: forall a. SExpr a -> SExpr a -> SExpr a
::: xs = SCons x xs
#if MIN_VERSION_base(4,8,0)
pattern A :: a -> SExpr a
#endif
pattern $mA :: forall {r} {a}. SExpr a -> (a -> r) -> ((# #) -> r) -> r
$bA :: forall a. a -> SExpr a
A x = SAtom x
#if MIN_VERSION_base(4,8,0)
pattern Nil :: SExpr a
#endif
pattern $mNil :: forall {r} {a}. SExpr a -> ((# #) -> r) -> ((# #) -> r) -> r
$bNil :: forall atom. SExpr atom
Nil = SNil
#if MIN_VERSION_base(4,8,0)
pattern L :: [SExpr a] -> SExpr a
#endif
pattern $mL :: forall {r} {a}. SExpr a -> ([SExpr a] -> r) -> ((# #) -> r) -> r
$bL :: forall a. [SExpr a] -> SExpr a
L xs <- (gatherList -> Right xs)
#if MIN_VERSION_base(4,8,0)
where L [] = SExpr a
forall atom. SExpr atom
SNil
L (SExpr a
x:[SExpr a]
xs) = SExpr a -> SExpr a -> SExpr a
forall a. SExpr a -> SExpr a -> SExpr a
SCons SExpr a
x ([SExpr a] -> SExpr a
forall a. [SExpr a] -> SExpr a
L [SExpr a]
xs)
#endif
#if MIN_VERSION_base(4,8,0)
pattern DL :: [SExpr a] -> a -> SExpr a
#endif
pattern $mDL :: forall {r} {a}.
SExpr a -> ([SExpr a] -> a -> r) -> ((# #) -> r) -> r
$bDL :: forall a. [SExpr a] -> a -> SExpr a
DL xs x <- (gatherDList -> Just (xs, x))
#if MIN_VERSION_base(4,8,0)
where DL [] a
a = a -> SExpr a
forall a. a -> SExpr a
SAtom a
a
DL (SExpr a
x:[SExpr a]
xs) a
a = SExpr a -> SExpr a -> SExpr a
forall a. SExpr a -> SExpr a -> SExpr a
SCons SExpr a
x ([SExpr a] -> a -> SExpr a
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 = Int -> SExpr a -> String
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
n
go t
n SAtom {} = String
"dotted list of length " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
n
go t
n (SCons SExpr atom
_ SExpr atom
xs) = t -> SExpr atom -> String
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) SExpr atom
xs
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) = (,) (a -> b -> (a, b))
-> Either String a -> Either String (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr t -> Either String a
pl SExpr 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
<*> SExpr t -> Either String b
pr SExpr t
r
fromPair SExpr t -> Either String a
_ SExpr t -> Either String b
_ SExpr t
sx = String -> Either String (a, b)
forall a b. a -> Either a b
Left (String
"fromPair: expected two-element list; found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SExpr t -> String
forall a. SExpr a -> String
getShape SExpr t
sx)
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) = (:) (a -> [a] -> [a]) -> Either String a -> Either String ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr t -> Either String a
p SExpr t
s Either String ([a] -> [a])
-> Either String [a] -> Either String [a]
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
<*> (SExpr t -> Either String a) -> SExpr t -> Either String [a]
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 = [a] -> Either String [a]
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
fromList SExpr t -> Either String a
_ SExpr t
sx = String -> Either String [a]
forall a b. a -> Either a b
Left (String
"fromList: expected list; found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SExpr t -> String
forall a. SExpr a -> String
getShape SExpr t
sx)
fromAtom :: SExpr t -> Either String t
fromAtom :: forall t. SExpr t -> Either String t
fromAtom (A t
a) = t -> Either String t
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return t
a
fromAtom SExpr t
sx = String -> Either String t
forall a b. a -> Either a b
Left (String
"fromAtom: expected atom; found list" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SExpr t -> String
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) = (:) (SExpr t -> [SExpr t] -> [SExpr t])
-> Either String (SExpr t)
-> Either String ([SExpr t] -> [SExpr t])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr t -> Either String (SExpr t)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SExpr t
x Either String ([SExpr t] -> [SExpr t])
-> Either String [SExpr t] -> Either String [SExpr t]
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
<*> SExpr t -> Either String [SExpr t]
forall t. SExpr t -> Either String [SExpr t]
gatherList SExpr t
xs
gatherList SExpr t
Nil = [SExpr t] -> Either String [SExpr t]
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
gatherList SExpr t
sx = String -> Either String [SExpr t]
forall a b. a -> Either a b
Left (String
"gatherList: expected list; found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SExpr t -> String
forall a. SExpr a -> String
getShape SExpr t
sx)
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 = String -> Either String a
forall a b. a -> Either a b
Left (String
"asPair: expected two-element list; found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SExpr t -> String
forall a. SExpr a -> String
getShape SExpr t
sx)
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 = SExpr t -> Either String [SExpr t]
forall t. SExpr t -> Either String [SExpr t]
gatherList SExpr t
ls Either String [SExpr t]
-> ([SExpr 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
>>= [SExpr t] -> Either String a
f
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 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
_ SExpr t
sx = String -> Either String ()
forall a b. a -> Either a b
Left (String
"isAtom: expected atom; found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SExpr t -> String
forall a. SExpr a -> String
getShape SExpr t
sx)
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 = String -> Either String a
forall a b. a -> Either a b
Left (String
"asAtom: expected atom; found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SExpr t -> String
forall a. SExpr a -> String
getShape SExpr t
sx)
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 = SExpr t -> Either String [SExpr t]
forall t. SExpr t -> Either String [SExpr t]
gatherList SExpr t
ss Either String [SExpr t]
-> ([SExpr t] -> Either String [(SExpr t, SExpr t)])
-> Either String [(SExpr t, SExpr t)]
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
>>= (SExpr t -> Either String (SExpr t, SExpr t))
-> [SExpr t] -> Either String [(SExpr t, SExpr t)]
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 SExpr t -> Either String (SExpr t, SExpr t)
forall {a}. SExpr a -> Either String (SExpr a, SExpr a)
go Either String [(SExpr t, SExpr t)]
-> ([(SExpr t, SExpr 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
>>= [(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) = (SExpr a, SExpr a) -> Either String (SExpr a, SExpr a)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr a
a, SExpr a
b)
go SExpr a
sx = String -> Either String (SExpr a, SExpr a)
forall a b. a -> Either a b
Left (String
"asAssoc: expected pair; found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SExpr a -> String
forall a. SExpr a -> String
getShape SExpr a
sx)