{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
module Data.SExpresso.Parse.Generic
(
SExprParser(..),
getAtom,
getSpace,
getSpacingRule,
setTags,
setTagsFromList,
setTagsFromMap,
setSpace,
setSpacingRule,
setAtom,
SpacingRule(..),
spaceIsMandatory,
spaceIsOptional,
mkSpacingRule,
withLocation,
parseSExprList,
parseSExpr,
decodeOne,
decode
)
where
import Data.Maybe
import qualified Data.Map as M
import Control.Applicative
import Control.Monad (mzero)
import Text.Megaparsec
import Data.SExpresso.SExpr
import Data.SExpresso.Parse.Location
data SpacingRule =
SMandatory
| SOptional
deriving (Int -> SpacingRule -> ShowS
[SpacingRule] -> ShowS
SpacingRule -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpacingRule] -> ShowS
$cshowList :: [SpacingRule] -> ShowS
show :: SpacingRule -> String
$cshow :: SpacingRule -> String
showsPrec :: Int -> SpacingRule -> ShowS
$cshowsPrec :: Int -> SpacingRule -> ShowS
Show, SpacingRule -> SpacingRule -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpacingRule -> SpacingRule -> Bool
$c/= :: SpacingRule -> SpacingRule -> Bool
== :: SpacingRule -> SpacingRule -> Bool
$c== :: SpacingRule -> SpacingRule -> Bool
Eq)
data SExprParser m b a
= forall c. SExprParser
(m c)
(c -> m b)
(m a)
(m ())
(a -> a -> SpacingRule)
getSpace :: SExprParser m b a -> m ()
getSpace :: forall (m :: * -> *) b a. SExprParser m b a -> m ()
getSpace (SExprParser m c
_ c -> m b
_ m a
_ m ()
sp a -> a -> SpacingRule
_) = m ()
sp
getSpacingRule :: SExprParser m b a -> (a -> a -> SpacingRule)
getSpacingRule :: forall (m :: * -> *) b a.
SExprParser m b a -> a -> a -> SpacingRule
getSpacingRule (SExprParser m c
_ c -> m b
_ m a
_ m ()
_ a -> a -> SpacingRule
sr) = a -> a -> SpacingRule
sr
getAtom :: SExprParser m b a -> m a
getAtom :: forall (m :: * -> *) b a. SExprParser m b a -> m a
getAtom (SExprParser m c
_ c -> m b
_ m a
a m ()
_ a -> a -> SpacingRule
_) = m a
a
withLocation :: (MonadParsec e s m, TraversableStream s) => SExprParser m b a -> SExprParser m (Located b) (Located a)
withLocation :: forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> SExprParser m (Located b) (Located a)
withLocation (SExprParser m c
pSTag c -> m b
pETag m a
atom m ()
sp a -> a -> SpacingRule
sr) =
let s :: m (SourcePos, c)
s = do
SourcePos
pos <- forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
c
c <- m c
pSTag
forall (m :: * -> *) a. Monad m => a -> m a
return (SourcePos
pos, c
c)
e :: (SourcePos, c) -> m (Located b)
e = \(SourcePos
pos, c
c) -> do
b
b <- c -> m b
pETag c
c
SourcePos
pos2 <- forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Location -> a -> Located a
At (SourcePos -> SourcePos -> Location
Span SourcePos
pos SourcePos
pos2) b
b
in forall (m :: * -> *) b a c.
m c
-> (c -> m b)
-> m a
-> m ()
-> (a -> a -> SpacingRule)
-> SExprParser m b a
SExprParser m (SourcePos, c)
s (SourcePos, c) -> m (Located b)
e (forall e s (m :: * -> *) a.
(MonadParsec e s m, TraversableStream s) =>
m a -> m (Located a)
located m a
atom) m ()
sp (\(At Location
_ a
a1) (At Location
_ a
a2) -> a -> a -> SpacingRule
sr a
a1 a
a2)
setAtom :: m a -> (a -> a -> SpacingRule) -> SExprParser m b a' -> SExprParser m b a
setAtom :: forall (m :: * -> *) a b a'.
m a
-> (a -> a -> SpacingRule)
-> SExprParser m b a'
-> SExprParser m b a
setAtom m a
a a -> a -> SpacingRule
sr (SExprParser m c
pSTag c -> m b
pETag m a'
_ m ()
sp a' -> a' -> SpacingRule
_) = forall (m :: * -> *) b a c.
m c
-> (c -> m b)
-> m a
-> m ()
-> (a -> a -> SpacingRule)
-> SExprParser m b a
SExprParser m c
pSTag c -> m b
pETag m a
a m ()
sp a -> a -> SpacingRule
sr
setTags :: m c -> (c -> m b) -> SExprParser m b' a -> SExprParser m b a
setTags :: forall (m :: * -> *) c b b' a.
m c -> (c -> m b) -> SExprParser m b' a -> SExprParser m b a
setTags m c
s c -> m b
e (SExprParser m c
_ c -> m b'
_ m a
a m ()
sp a -> a -> SpacingRule
sr) = forall (m :: * -> *) b a c.
m c
-> (c -> m b)
-> m a
-> m ()
-> (a -> a -> SpacingRule)
-> SExprParser m b a
SExprParser m c
s c -> m b
e m a
a m ()
sp a -> a -> SpacingRule
sr
setTagsFromList :: (MonadParsec e s m) =>
[(Tokens s, Tokens s, b)] -> SExprParser m b' a -> SExprParser m b a
setTagsFromList :: forall e s (m :: * -> *) b b' a.
MonadParsec e s m =>
[(Tokens s, Tokens s, b)]
-> SExprParser m b' a -> SExprParser m b a
setTagsFromList [(Tokens s, Tokens s, b)]
l SExprParser m b' a
p =
let m :: Map (Tokens s) [(Tokens s, b)]
m = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Tokens s
s,Tokens s
e,b
b) -> (Tokens s
s, [(Tokens s
e,b
b)])) [(Tokens s, Tokens s, b)]
l
in forall e s (m :: * -> *) b b' a.
MonadParsec e s m =>
Map (Tokens s) [(Tokens s, b)]
-> SExprParser m b' a -> SExprParser m b a
setTagsFromMap Map (Tokens s) [(Tokens s, b)]
m SExprParser m b' a
p
setTagsFromMap :: (MonadParsec e s m) =>
M.Map (Tokens s) [(Tokens s, b)] -> SExprParser m b' a -> SExprParser m b a
setTagsFromMap :: forall e s (m :: * -> *) b b' a.
MonadParsec e s m =>
Map (Tokens s) [(Tokens s, b)]
-> SExprParser m b' a -> SExprParser m b a
setTagsFromMap Map (Tokens s) [(Tokens s, b)]
m SExprParser m b' a
p =
let l :: [(Tokens s, [(Tokens s, b)])]
l = forall k a. Map k a -> [(k, a)]
M.toList Map (Tokens s) [(Tokens s, b)]
m
choose :: [(Tokens s, a)] -> f a
choose [] = forall (f :: * -> *) a. Alternative f => f a
empty
choose ((Tokens s
s, a
eb) : [(Tokens s, a)]
ts) = (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
eb) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(Tokens s, a)] -> f a
choose [(Tokens s, a)]
ts
stag :: m [(Tokens s, b)]
stag = forall {f :: * -> *} {e} {s} {a}.
MonadParsec e s f =>
[(Tokens s, a)] -> f a
choose [(Tokens s, [(Tokens s, b)])]
l
etag :: [(Tokens s, a)] -> m a
etag = \[(Tokens s, a)]
xs -> forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Tokens s
e, a
b) -> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
b) [(Tokens s, a)]
xs
in forall (m :: * -> *) c b b' a.
m c -> (c -> m b) -> SExprParser m b' a -> SExprParser m b a
setTags m [(Tokens s, b)]
stag forall {a}. [(Tokens s, a)] -> m a
etag SExprParser m b' a
p
spaceIsMandatory :: a -> a -> SpacingRule
spaceIsMandatory :: forall a. a -> a -> SpacingRule
spaceIsMandatory = \a
_ a
_ -> SpacingRule
SMandatory
spaceIsOptional :: a -> a -> SpacingRule
spaceIsOptional :: forall a. a -> a -> SpacingRule
spaceIsOptional = \a
_ a
_ -> SpacingRule
SOptional
setSpacingRule :: (a -> a -> SpacingRule) -> SExprParser m b a -> SExprParser m b a
setSpacingRule :: forall a (m :: * -> *) b.
(a -> a -> SpacingRule) -> SExprParser m b a -> SExprParser m b a
setSpacingRule a -> a -> SpacingRule
r p :: SExprParser m b a
p@(SExprParser m c
pSTag c -> m b
pETag m a
_ m ()
_ a -> a -> SpacingRule
_) = forall (m :: * -> *) b a c.
m c
-> (c -> m b)
-> m a
-> m ()
-> (a -> a -> SpacingRule)
-> SExprParser m b a
SExprParser m c
pSTag c -> m b
pETag (forall (m :: * -> *) b a. SExprParser m b a -> m a
getAtom SExprParser m b a
p) (forall (m :: * -> *) b a. SExprParser m b a -> m ()
getSpace SExprParser m b a
p) a -> a -> SpacingRule
r
mkSpacingRule :: (a -> SpacingRule) -> (a -> a -> SpacingRule)
mkSpacingRule :: forall a. (a -> SpacingRule) -> a -> a -> SpacingRule
mkSpacingRule a -> SpacingRule
f = \a
a1 a
a2 -> case a -> SpacingRule
f a
a1 of
SpacingRule
SOptional -> SpacingRule
SOptional
SpacingRule
SMandatory -> a -> SpacingRule
f a
a2
setSpace :: m () -> SExprParser m b a -> SExprParser m b a
setSpace :: forall (m :: * -> *) b a.
m () -> SExprParser m b a -> SExprParser m b a
setSpace m ()
sp (SExprParser m c
s c -> m b
e m a
a m ()
_ a -> a -> SpacingRule
sr) = forall (m :: * -> *) b a c.
m c
-> (c -> m b)
-> m a
-> m ()
-> (a -> a -> SpacingRule)
-> SExprParser m b a
SExprParser m c
s c -> m b
e m a
a m ()
sp a -> a -> SpacingRule
sr
spaceIsOK :: (a -> a -> SpacingRule) -> (SExpr b a) -> (SExpr b a) -> Bool -> Bool
spaceIsOK :: forall a b.
(a -> a -> SpacingRule) -> SExpr b a -> SExpr b a -> Bool -> Bool
spaceIsOK a -> a -> SpacingRule
getSpacingRule' SExpr b a
sexp1 SExpr b a
sexp2 Bool
spaceInBetween =
case (SExpr b a
sexp1, SExpr b a
sexp2, Bool
spaceInBetween) of
(SExpr b a
_, SExpr b a
_, Bool
True) -> Bool
True
(SList b
_ [SExpr b a]
_, SExpr b a
_, Bool
_) -> Bool
True
(SExpr b a
_, SList b
_ [SExpr b a]
_, Bool
_) -> Bool
True
(SAtom a
a1, SAtom a
a2, Bool
_) -> a -> a -> SpacingRule
getSpacingRule' a
a1 a
a2 forall a. Eq a => a -> a -> Bool
== SpacingRule
SOptional
sepEndBy' :: (MonadParsec e s m, TraversableStream s) => m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
sepEndBy' :: forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
sepEndBy' m (SExpr b a)
p m ()
sep a -> a -> SpacingRule
f = forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
sepEndBy1' m (SExpr b a)
p m ()
sep a -> a -> SpacingRule
f forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
sepEndBy1' :: (MonadParsec e s m, TraversableStream s) => m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
sepEndBy1' :: forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
sepEndBy1' m (SExpr b a)
p m ()
sep a -> a -> SpacingRule
f = do
SExpr b a
x <- m (SExpr b a)
p
[SExpr b a]
xs <- forall {e} {s}.
(MonadParsec e s m, TraversableStream s) =>
SExpr b a -> m [SExpr b a]
parseContent SExpr b a
x
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SExpr b a
x forall a. a -> [a] -> [a]
: [SExpr b a]
xs
where parseContent :: SExpr b a -> m [SExpr b a]
parseContent SExpr b a
a1 = do
Bool
s <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a b. a -> b -> a
const Bool
True) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
sep
Maybe SourcePos
mpos <- if Bool -> Bool
not Bool
s then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Maybe (SExpr b a)
mx <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m (SExpr b a)
p
case Maybe (SExpr b a)
mx of
Maybe (SExpr b a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just SExpr b a
a2 ->
if forall a b.
(a -> a -> SpacingRule) -> SExpr b a -> SExpr b a -> Bool -> Bool
spaceIsOK a -> a -> SpacingRule
f SExpr b a
a1 SExpr b a
a2 Bool
s
then do
[SExpr b a]
xs <- SExpr b a -> m [SExpr b a]
parseContent SExpr b a
a2
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SExpr b a
a2 forall a. a -> [a] -> [a]
: [SExpr b a]
xs
else forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label (String
"The previous two atoms are not separated by space.\n" forall a. Semigroup a => a -> a -> a
<>
String
"A space was expected at " forall a. Semigroup a => a -> a -> a
<> SourcePos -> String
sourcePosPretty (forall a. HasCallStack => Maybe a -> a
fromJust Maybe SourcePos
mpos)) forall (m :: * -> *) a. MonadPlus m => m a
mzero
parseSExprList :: (MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> m (SExpr b a)
parseSExprList :: forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> m (SExpr b a)
parseSExprList def :: SExprParser m b a
def@(SExprParser m c
pSTag c -> m b
pETag m a
_ m ()
sp a -> a -> SpacingRule
sr) = do
c
c <- m c
pSTag
Maybe ()
_ <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
sp
[SExpr b a]
xs <- forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
sepEndBy' (forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> m (SExpr b a)
parseSExpr SExprParser m b a
def) m ()
sp a -> a -> SpacingRule
sr
b
b <- c -> m b
pETag c
c
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> [SExpr b a] -> SExpr b a
SList b
b [SExpr b a]
xs
parseSExpr :: (MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> m (SExpr b a)
parseSExpr :: forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> m (SExpr b a)
parseSExpr SExprParser m b a
def = (forall (m :: * -> *) b a. SExprParser m b a -> m a
getAtom SExprParser m b a
def forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. a -> SExpr b a
SAtom) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> m (SExpr b a)
parseSExprList SExprParser m b a
def)
decodeOne :: (MonadParsec e s m, TraversableStream s) => SExprParser m b a -> m (SExpr b a)
decodeOne :: forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> m (SExpr b a)
decodeOne SExprParser m b a
def =
let ws :: m ()
ws = forall (m :: * -> *) b a. SExprParser m b a -> m ()
getSpace SExprParser m b a
def
in forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
ws forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> m (SExpr b a)
parseSExpr SExprParser m b a
def forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)
decode :: (MonadParsec e s m, TraversableStream s) => SExprParser m b a -> m [SExpr b a]
decode :: forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> m [SExpr b a]
decode SExprParser m b a
def =
let ws :: m ()
ws = forall (m :: * -> *) b a. SExprParser m b a -> m ()
getSpace SExprParser m b a
def
in forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
ws forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
sepEndBy' (forall e s (m :: * -> *) b a.
(MonadParsec e s m, TraversableStream s) =>
SExprParser m b a -> m (SExpr b a)
parseSExpr SExprParser m b a
def) m ()
ws (forall (m :: * -> *) b a.
SExprParser m b a -> a -> a -> SpacingRule
getSpacingRule SExprParser m b a
def) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof