{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Data.SCargot.Repr.Rich
(
R.RichSExpr(..)
, R.toRich
, R.fromRich
, cons
, uncons
, pattern (:::)
, pattern A
, pattern L
, pattern DL
, pattern Nil
, _car
, _cdr
, 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
_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 -> forall a. [RichSExpr a] -> RichSExpr a
L (RichSExpr a
yforall a. a -> [a] -> [a]
:[RichSExpr a]
xs)) 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 -> forall a. [RichSExpr a] -> a -> RichSExpr a
DL (RichSExpr a
yforall a. a -> [a] -> [a]
:[RichSExpr a]
xs) a
a) 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> RichSExpr a
A a
a)
_car RichSExpr a -> f (RichSExpr a)
_ (RSList []) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. RichSExpr a
Nil
_car RichSExpr a -> f (RichSExpr a)
_ (RSDotted [] a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> RichSExpr a
A a
a)
_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 []) = forall a. [RichSExpr a] -> RichSExpr a
L [RichSExpr a
x]
go (RSAtom a
a) = forall a. [RichSExpr a] -> a -> RichSExpr a
DL [RichSExpr a
x] a
a
go (RSList [RichSExpr a]
xs') = forall a. [RichSExpr a] -> RichSExpr a
L (RichSExpr a
xforall a. a -> [a] -> [a]
:[RichSExpr a]
xs')
go (RSDotted [RichSExpr a]
ys a
a') = forall a. [RichSExpr a] -> a -> RichSExpr a
DL (RichSExpr a
xforall a. a -> [a] -> [a]
:[RichSExpr a]
ys) a
a'
in RichSExpr a -> RichSExpr a
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RichSExpr a -> f (RichSExpr a)
f (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 []) = forall a. [RichSExpr a] -> RichSExpr a
L [RichSExpr a
x]
go (RSAtom a
a') = forall a. [RichSExpr a] -> a -> RichSExpr a
DL [RichSExpr a
x] a
a'
go (RSList [RichSExpr a]
xs) = forall a. [RichSExpr a] -> RichSExpr a
L (RichSExpr a
xforall a. a -> [a] -> [a]
:[RichSExpr a]
xs)
go (RSDotted [RichSExpr a]
ys a
a') = forall a. [RichSExpr a] -> a -> RichSExpr a
DL (RichSExpr a
xforall a. a -> [a] -> [a]
:[RichSExpr a]
ys) a
a'
in RichSExpr a -> RichSExpr a
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RichSExpr a -> f (RichSExpr a)
f (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 []) = forall a. [RichSExpr a] -> RichSExpr a
L [RichSExpr a
x]
go (RSAtom a
a') = forall a. [RichSExpr a] -> a -> RichSExpr a
DL [RichSExpr a
x] a
a'
go (RSList [RichSExpr a]
ys) = forall a. [RichSExpr a] -> RichSExpr a
L (RichSExpr a
xforall a. a -> [a] -> [a]
:[RichSExpr a]
ys)
go (RSDotted [RichSExpr a]
ys a
a') = forall a. [RichSExpr a] -> a -> RichSExpr a
DL (RichSExpr a
xforall a. a -> [a] -> [a]
:[RichSExpr a]
ys) a
a'
in RichSExpr a -> RichSExpr a
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RichSExpr a -> f (RichSExpr a)
f (forall a. [RichSExpr a] -> a -> RichSExpr a
DL [RichSExpr a]
xs a
a)
_cdr RichSExpr a -> f (RichSExpr a)
_ (RSAtom a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> RichSExpr a
A a
a)
_cdr RichSExpr a -> f (RichSExpr a)
_ (RSList []) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. RichSExpr a
Nil
_cdr RichSExpr a -> f (RichSExpr a)
_ (RSDotted [] a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> RichSExpr a
A a
a)
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)) = forall a. a -> Maybe a
Just (RichSExpr a
x, forall a. [RichSExpr a] -> RichSExpr a
R.RSList [RichSExpr a]
xs)
uncons (R.RSDotted (RichSExpr a
x:[RichSExpr a]
xs) a
a) = forall a. a -> Maybe a
Just (RichSExpr a
x, forall a. [RichSExpr a] -> a -> RichSExpr a
R.RSDotted [RichSExpr a]
xs a
a)
uncons RichSExpr a
_ = forall a. Maybe a
Nothing
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) = forall a. [RichSExpr a] -> RichSExpr a
R.RSList (RichSExpr a
xforall a. a -> [a] -> [a]
:[RichSExpr a]
xs)
cons RichSExpr a
x (R.RSDotted [RichSExpr a]
xs a
a) = forall a. [RichSExpr a] -> a -> RichSExpr a
R.RSDotted (RichSExpr a
xforall a. a -> [a] -> [a]
:[RichSExpr a]
xs) a
a
cons RichSExpr a
x (R.RSAtom a
a) = forall a. [RichSExpr a] -> a -> RichSExpr a
R.RSDotted [RichSExpr a
x] a
a
#if MIN_VERSION_base(4,8,0)
pattern (:::) :: RichSExpr a -> RichSExpr a -> RichSExpr a
#endif
pattern x $b::: :: forall a. RichSExpr a -> RichSExpr a -> RichSExpr a
$m::: :: forall {r} {a}.
RichSExpr a
-> (RichSExpr a -> RichSExpr a -> r) -> ((# #) -> r) -> r
::: xs <- (uncons -> Just (x, xs))
#if MIN_VERSION_base(4,8,0)
where RichSExpr a
x ::: RichSExpr a
xs = forall a. RichSExpr a -> RichSExpr a -> RichSExpr a
cons RichSExpr a
x RichSExpr a
xs
#endif
#if MIN_VERSION_base(4,8,0)
pattern A :: a -> RichSExpr a
#endif
pattern $bA :: forall a. a -> RichSExpr a
$mA :: forall {r} {a}. RichSExpr a -> (a -> r) -> ((# #) -> r) -> r
A a = R.RSAtom a
#if MIN_VERSION_base(4,8,0)
pattern L :: [RichSExpr a] -> RichSExpr a
#endif
pattern $bL :: forall a. [RichSExpr a] -> RichSExpr a
$mL :: forall {r} {a}.
RichSExpr a -> ([RichSExpr a] -> r) -> ((# #) -> r) -> r
L xs = R.RSList xs
#if MIN_VERSION_base(4,8,0)
pattern DL :: [RichSExpr a] -> a -> RichSExpr a
#endif
pattern $bDL :: forall a. [RichSExpr a] -> a -> RichSExpr a
$mDL :: forall {r} {a}.
RichSExpr a -> ([RichSExpr a] -> a -> r) -> ((# #) -> r) -> r
DL xs x = R.RSDotted xs x
#if MIN_VERSION_base(4,8,0)
pattern Nil :: RichSExpr a
#endif
pattern $bNil :: forall a. RichSExpr a
$mNil :: forall {r} {a}. RichSExpr a -> ((# #) -> r) -> ((# #) -> r) -> r
Nil = R.RSList []
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 = forall t a.
((RichSExpr t, RichSExpr t) -> Either String a)
-> RichSExpr t -> Either String a
asPair forall a b. (a -> b) -> a -> b
$ \(RichSExpr t
l,RichSExpr t
r) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RichSExpr t -> Either String a
pl RichSExpr t
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RichSExpr t -> Either String b
pr RichSExpr t
r
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 = forall t a.
([RichSExpr t] -> Either String a)
-> RichSExpr t -> Either String a
asList forall a b. (a -> b) -> a -> b
$ \[RichSExpr t]
ss -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RichSExpr t -> Either String a
p [RichSExpr t]
ss
fromAtom :: RichSExpr t -> Either String t
fromAtom :: forall t. RichSExpr t -> Either String t
fromAtom (RSList [RichSExpr t]
_) = forall a b. a -> Either a b
Left String
"fromAtom: expected atom; found list"
fromAtom (RSDotted [RichSExpr t]
_ t
_) = forall a b. a -> Either a b
Left String
"fromAtom: expected atom; found dotted list"
fromAtom (RSAtom t
a) = forall (m :: * -> *) a. Monad m => a -> m a
return t
a
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) = forall a b. a -> Either a b
Left (String
"asPair: expected two-element list; found list of lenght " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [RichSExpr t]
ls))
asPair (RichSExpr t, RichSExpr t) -> Either String a
_ RSDotted {} = 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 {} = forall a b. a -> Either a b
Left (String
"asPair: expected two-element list; found atom")
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 {} = forall a b. a -> Either a b
Left (String
"asList: expected list; found dotted list")
asList [RichSExpr t] -> Either String a
_ RSAtom { } = forall a b. a -> Either a b
Left (String
"asList: expected list; found dotted 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 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
_ RSList {} = forall a b. a -> Either a b
Left String
"isAtom: expected atom; found list"
isAtom t
_ RSDotted {} = forall a b. a -> Either a b
Left String
"isAtom: expected atom; found dotted list"
isNil :: RichSExpr t -> Either String ()
isNil :: forall t. RichSExpr t -> Either String ()
isNil (RSList []) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
isNil RSList {} = forall a b. a -> Either a b
Left String
"isNil: expected nil; found non-nil list"
isNil RSDotted {} = forall a b. a -> Either a b
Left String
"isNil: expected nil; found dotted list"
isNil RSAtom {} = forall a b. a -> Either a b
Left String
"isNil: expected nil; found atom"
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 {} = forall a b. a -> Either a b
Left (String
"asAtom: expected atom; found list")
asAtom t -> Either String a
_ RSDotted {} = forall a b. a -> Either a b
Left (String
"asAtom: expected atom; found dotted list")
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) = forall {atom}.
[RichSExpr atom]
-> Either String [(RichSExpr atom, RichSExpr atom)]
gatherPairs [RichSExpr t]
ss 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) = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RichSExpr atom
a, RichSExpr atom
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 [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
gatherPairs (RSAtom {} : [RichSExpr atom]
_) = forall a b. a -> Either a b
Left (String
"asAssoc: expected pair; found atom")
gatherPairs (RSDotted {} : [RichSExpr atom]
_) = forall a b. a -> Either a b
Left (String
"asAssoc: expected pair; found dotted list")
gatherPairs (RSList [RichSExpr atom]
ls : [RichSExpr atom]
_) = forall a b. a -> Either a b
Left (String
"asAssoc: expected pair; found list of length " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [RichSExpr atom]
ls))
asAssoc [(RichSExpr t, RichSExpr t)] -> Either String a
_ RSDotted {} = 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 {} = 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'
_ [] = 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'
_ [] = forall a b. a -> Either a b
Left String
"cdr: Taking cdr of zero-element list"