-- |
-- Module      :  Data.SExpresso.Parse.Generic
-- Copyright   :  © 2019 Vincent Archambault
-- License     :  0BSD
--
-- Maintainer  :  Vincent Archambault <archambault.v@gmail.com>
-- Stability   :  experimental
--
-- This module includes everything you need to write a parser for
-- S-expression ('SExpr'). It is based on the "Text.Megaparsec"
-- library and parsers can be defined for any kind of ('MonadParsec' e
-- s m) instance. This is quite generic, if you are working with
-- streams of 'Char', we suggest you also import
-- "Data.SExpresso.Parse.Char" or simply "Data.SExpresso.Parse" which
-- re-exports everything.
--
-- You can customize your 'SExpr' parser by specifying the following:
--
--   * The parser for atoms
--
--   * The opening tag, the closing tag, and a possible dependency of
--     the closing tag on the opening one.
--
--   * If some space is required or optional between any pair of
--     atoms.
--
--   * How to parse space (ex: treat comments as whitespace)

{-# 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

-- | The 'SpacingRule' datatype is used to indicate if space is optional or mandatory between two consecutive @'SAtom' _@.
data SpacingRule =
  -- | Space is mandatory
  SMandatory
  -- | Space is optional
  | SOptional
   deriving (Int -> SpacingRule -> ShowS
[SpacingRule] -> ShowS
SpacingRule -> String
(Int -> SpacingRule -> ShowS)
-> (SpacingRule -> String)
-> ([SpacingRule] -> ShowS)
-> Show SpacingRule
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
(SpacingRule -> SpacingRule -> Bool)
-> (SpacingRule -> SpacingRule -> Bool) -> Eq SpacingRule
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)

-- | The @'SExprParser' m b a@ datatype defines how to parse an
-- @'SExpr' b a@. Most parsing functions require the underlying monad
-- @m@ to be an instance of ('MonadParsec' e s m).

data SExprParser m b a
  -- | The @c@ parameter in the first two arguments is the type of the
  -- relation between the opening tag and the closing one.
  = forall c. SExprParser
  (m c) -- ^ The parser for the opening tag. Returns an object of an
        -- arbitrary type @c@ that will be used to create the closing
        -- tag parser.
  (c -> m b) -- ^ A function that takes the object returned by the
             -- opening tag parser and provide a parser for the
             -- closing tag.
  (m a) -- ^ The parser for atoms
  (m ()) -- ^ A parser for space tokens which does not accept empty
         -- input (e.g. 'Text.Megaparsec.Char.space1')
  (a -> a -> SpacingRule) -- ^ A function to tell if two consecutive
                          -- atoms must be separated by space or
                          -- not. See also 'mkSpacingRule' and
                          -- 'setSpacingRule'

-- | The 'getSpace' function returns the parser for whitespace of an 'SExprParser' object.
getSpace :: SExprParser m b a -> m ()
getSpace :: SExprParser m b a -> m ()
getSpace (SExprParser m c
_ c -> m b
_ m a
_ m ()
sp a -> a -> SpacingRule
_) = m ()
sp

-- | The 'getSpacingRule' function returns spacing rule function of an 'SExprParser' object.
getSpacingRule :: SExprParser m b a -> (a -> a -> SpacingRule)
getSpacingRule :: 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

-- | The 'getAtom' function returns the parser for atoms of an 'SExprParser' object.
getAtom :: SExprParser m b a -> m a
getAtom :: SExprParser m b a -> m a
getAtom (SExprParser m c
_ c -> m b
_ m a
a m ()
_ a -> a -> SpacingRule
_) = m a
a

-- | The 'withLocation' function adds source location to a @'SExprParser'@. See also 'Location'.
withLocation :: (MonadParsec e s m, TraversableStream s) => SExprParser m b a -> SExprParser m (Located b) (Located a)
withLocation :: 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 <- m SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
        c
c <- m c
pSTag
        (SourcePos, c) -> m (SourcePos, c)
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 <- m SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
        Located b -> m (Located b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located b -> m (Located b)) -> Located b -> m (Located b)
forall a b. (a -> b) -> a -> b
$ Location -> b -> Located b
forall a. Location -> a -> Located a
At (SourcePos -> SourcePos -> Location
Span SourcePos
pos SourcePos
pos2) b
b
  in m (SourcePos, c)
-> ((SourcePos, c) -> m (Located b))
-> m (Located a)
-> m ()
-> (Located a -> Located a -> SpacingRule)
-> SExprParser m (Located b) (Located a)
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 (m a -> m (Located a)
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)

-- | The 'setAtom' function updates a parser with a new parser for atoms and and new spacing rule function.
setAtom :: m a -> (a -> a -> SpacingRule) -> SExprParser m b a' -> SExprParser m b a
setAtom :: 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
_) = m c
-> (c -> m b)
-> m a
-> m ()
-> (a -> a -> SpacingRule)
-> SExprParser m b a
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

-- | The 'setTags' function updates a parser with a new parser for the opening and closing tags.
setTags :: m c -> (c -> m b) -> SExprParser m b' a -> SExprParser m b a
setTags :: 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) = m c
-> (c -> m b)
-> m a
-> m ()
-> (a -> a -> SpacingRule)
-> SExprParser m b a
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

-- | The 'setTagsFromList' function helps you build the opening and
-- closing parsers from a list of triplets. Each triplet specifies a
-- stream of tokens to parse as the opening tag, a stream of tokens to
-- parse at the closing tag and what to return when this pair is
-- encountered. The 'setTagsFromList' can handle multiple triplets
-- with the same opening tags. See also 'setTagsFromMap'.
--
-- The example e1 parses "()" as @'SList' () []@.
--
-- > e1 = setTagsFromList [("(", ")", ()] p
--
-- The example e2 parses both "()" and "[]" as @'SList' () []@ but does
-- not parse "(]" or "[)"
--
-- > e2 = setTagsFromList [("(", ")", ()), ("[", "]", ())] p 
--
-- The example e3 parses "()" as @'SList' List []@ and "#()" as
-- @'SList' Vector []@, but does not parse "(]" or "[)"
--
-- > e3 = setTagsFromList [("(", ")", List), ("#(",")",Vector)] p
--
-- The example e4 parses "()" as @'SList' ')' []@ and "(]" as
-- @'SList' ']' []@, but does not parse "])"
--
-- > e4 = setTagsFromList [("(", ")", ')'), ("(", "]", ']')] p 
setTagsFromList ::  (MonadParsec e s m) =>
                    [(Tokens s, Tokens s, b)] -> SExprParser m b' a -> SExprParser m b a
setTagsFromList :: [(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 = ([(Tokens s, b)] -> [(Tokens s, b)] -> [(Tokens s, b)])
-> [(Tokens s, [(Tokens s, b)])] -> Map (Tokens s) [(Tokens s, b)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [(Tokens s, b)] -> [(Tokens s, b)] -> [(Tokens s, b)]
forall a. [a] -> [a] -> [a]
(++) ([(Tokens s, [(Tokens s, b)])] -> Map (Tokens s) [(Tokens s, b)])
-> [(Tokens s, [(Tokens s, b)])] -> Map (Tokens s) [(Tokens s, b)]
forall a b. (a -> b) -> a -> b
$ ((Tokens s, Tokens s, b) -> (Tokens s, [(Tokens s, b)]))
-> [(Tokens s, Tokens s, b)] -> [(Tokens s, [(Tokens s, 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 Map (Tokens s) [(Tokens s, b)]
-> SExprParser m b' a -> SExprParser m b a
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

-- | The 'setTagsFromMap' function helps you build the opening and
-- closing parsers from a map. Each key specifies a stream of tokens to
-- parse as the opening tag and the value of the map specifies one or
-- more streams of tokens to parse at the closing tag and what to
-- return when this pair is encountered. See also 'setTagsFromList'.
--
-- The example e1 parses "()" as @'SList' () []@.
--
-- > e1 = setTagsFromList $ M.fromList [("(", [")", ()]] p
--
-- The example e2 parses both "()" and "[]" as @'SList' () []@ but does
-- not parse "(]" or "[)"
--
-- > e2 = setTagsFromList $ M.fromList [("(", [")", ()]), ("[", ["]", ()])] p 
--
-- The example e3 parses "()" as @'SList' List []@ and "#()" as
-- @'SList' Vector []@, but does not parse "(]" or "[)"
--
-- > e3 = setTagsFromList $ M.fromList [("(", [")", List]), ("#(", [")",Vector])] p
--
-- The example e4 parses "()" as @'SList' ')' []@ and "(]" as
-- @'SList' ']' []@, but does not parse "])"
--
-- > e4 = setTagsFromList $ M.fromList [("(", [(")", ')'), ("]", ']')])] p 
setTagsFromMap :: (MonadParsec e s m) =>
                  M.Map (Tokens s) [(Tokens s, b)] -> SExprParser m b' a -> SExprParser m b a
setTagsFromMap :: 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 = Map (Tokens s) [(Tokens s, b)] -> [(Tokens s, [(Tokens s, b)])]
forall k a. Map k a -> [(k, a)]
M.toList Map (Tokens s) [(Tokens s, b)]
m

      choose :: [(Tokens s, a)] -> f a
choose [] = f a
forall (f :: * -> *) a. Alternative f => f a
empty
      choose ((Tokens s
s, a
eb) : [(Tokens s, a)]
ts) = (Tokens s -> f (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
s f (Tokens s) -> f a -> f a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return a
eb) f a -> f a -> f a
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 = [(Tokens s, [(Tokens s, b)])] -> m [(Tokens s, b)]
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 -> [m a] -> m a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([m a] -> m a) -> [m a] -> m a
forall a b. (a -> b) -> a -> b
$ ((Tokens s, a) -> m a) -> [(Tokens s, a)] -> [m a]
forall a b. (a -> b) -> [a] -> [b]
map (\(Tokens s
e, a
b) -> Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
e m (Tokens s) -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b) [(Tokens s, a)]
xs
  in m [(Tokens s, b)]
-> ([(Tokens s, b)] -> m b)
-> SExprParser m b' a
-> SExprParser m b a
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 [(Tokens s, b)] -> m b
forall a. [(Tokens s, a)] -> m a
etag SExprParser m b' a
p

-- | The 'spaceIsMandatory' function is a spacing rule where space is always mandatory. See also 'getSpacingRule'.
spaceIsMandatory :: a -> a -> SpacingRule
spaceIsMandatory :: a -> a -> SpacingRule
spaceIsMandatory = \a
_ a
_ -> SpacingRule
SMandatory

-- | The 'spaceIsOptional' function is a spacing rule where space is always optional. See also 'getSpacingRule'.
spaceIsOptional :: a -> a -> SpacingRule
spaceIsOptional :: a -> a -> SpacingRule
spaceIsOptional = \a
_ a
_ -> SpacingRule
SOptional

-- | The 'setSpacingRule' function modifies a 'SExprParser' by setting
-- the function to tell if two consecutive atoms must be separated by
-- space or not. See also 'mkSpacingRule'.
setSpacingRule :: (a -> a -> SpacingRule) -> SExprParser m b a -> SExprParser m b a
setSpacingRule :: (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
_) = m c
-> (c -> m b)
-> m a
-> m ()
-> (a -> a -> SpacingRule)
-> SExprParser m b a
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 (SExprParser m b a -> m a
forall (m :: * -> *) b a. SExprParser m b a -> m a
getAtom SExprParser m b a
p) (SExprParser m b a -> m ()
forall (m :: * -> *) b a. SExprParser m b a -> m ()
getSpace SExprParser m b a
p) a -> a -> SpacingRule
r

-- | The 'mkSpacingRule' function is a helper to create a valid
-- spacing rule function for 'SExprParser' when some atoms have the
-- same 'SpacingRule' both before and after no matter what the other
-- atom is. It takes as argument a function @f@ that takes a single
-- atom and returns the 'SpacingRule' that applies both before and
-- after this atom.
--
-- For example, to create a spacing rule where space is optional both
-- before and after the fictitious @MyString@ token:
--
-- > s (MyString _) = SOptional
-- > s _ = Mandatory
-- > spacingRule = mkSpacingRule s
--
-- The above is equivalent to :
--
-- > spacingRule (MyString _) _ = SOptional
-- > spacingRule _ (MyString _) = SOptional
-- > spacingRule _ _ = SMandatory

mkSpacingRule :: (a -> SpacingRule) -> (a -> a -> SpacingRule)
mkSpacingRule :: (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

-- | The 'setSpace' function modifies a 'SExprParser' by setting the
-- parser to parse whitespace. The parser for whitespace must not
-- accept the empty input (e.g. 'Text.Megaparsec.Char.space1')
setSpace :: m () -> SExprParser m b a -> SExprParser m b a
setSpace :: 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) = m c
-> (c -> m b)
-> m a
-> m ()
-> (a -> a -> SpacingRule)
-> SExprParser m b a
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

-- Tells if the space (or absence of) between two atoms is valid or not 
spaceIsOK :: (a -> a -> SpacingRule) -> (SExpr b a) -> (SExpr b a) -> Bool -> Bool
spaceIsOK :: (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 SpacingRule -> SpacingRule -> Bool
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' :: m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
sepEndBy' m (SExpr b a)
p m ()
sep a -> a -> SpacingRule
f = m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
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 m [SExpr b a] -> m [SExpr b a] -> m [SExpr b a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [SExpr b a] -> m [SExpr b 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' :: 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 <- SExpr b a -> m [SExpr b a]
forall e s.
(MonadParsec e s m, TraversableStream s) =>
SExpr b a -> m [SExpr b a]
parseContent SExpr b a
x
  [SExpr b a] -> m [SExpr b a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([SExpr b a] -> m [SExpr b a]) -> [SExpr b a] -> m [SExpr b a]
forall a b. (a -> b) -> a -> b
$ SExpr b a
x SExpr b a -> [SExpr b a] -> [SExpr b a]
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 <- Bool -> (() -> Bool) -> Maybe () -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> () -> Bool
forall a b. a -> b -> a
const Bool
True) (Maybe () -> Bool) -> m (Maybe ()) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m () -> m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
sep
          Maybe SourcePos
mpos <- if Bool -> Bool
not Bool
s then SourcePos -> Maybe SourcePos
forall a. a -> Maybe a
Just (SourcePos -> Maybe SourcePos)
-> m SourcePos -> m (Maybe SourcePos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos else Maybe SourcePos -> m (Maybe SourcePos)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SourcePos
forall a. Maybe a
Nothing 
          Maybe (SExpr b a)
mx <- m (SExpr b a) -> m (Maybe (SExpr b a))
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 -> [SExpr b a] -> m [SExpr b a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Just SExpr b a
a2 ->
              if (a -> a -> SpacingRule) -> SExpr b a -> SExpr b a -> Bool -> Bool
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
                [SExpr b a] -> m [SExpr b a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([SExpr b a] -> m [SExpr b a]) -> [SExpr b a] -> m [SExpr b a]
forall a b. (a -> b) -> a -> b
$ SExpr b a
a2 SExpr b a -> [SExpr b a] -> [SExpr b a]
forall a. a -> [a] -> [a]
: [SExpr b a]
xs
              else String -> m [SExpr b a] -> m [SExpr b a]
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" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                         String
"A space was expected at " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SourcePos -> String
sourcePosPretty (Maybe SourcePos -> SourcePos
forall a. HasCallStack => Maybe a -> a
fromJust Maybe SourcePos
mpos)) m [SExpr b a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | The 'parseSExprList' function return a parser for parsing S-expression of the form @'SList' _ _@.
parseSExprList :: (MonadParsec e s m, TraversableStream s) =>
                SExprParser m b a -> m (SExpr b a)
parseSExprList :: 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 ()
_ <- m () -> m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
sp
          [SExpr b a]
xs <- m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
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' (SExprParser m b a -> m (SExpr b a)
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
          SExpr b a -> m (SExpr b a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr b a -> m (SExpr b a)) -> SExpr b a -> m (SExpr b a)
forall a b. (a -> b) -> a -> b
$ b -> [SExpr b a] -> SExpr b a
forall b a. b -> [SExpr b a] -> SExpr b a
SList b
b [SExpr b a]
xs

-- | The 'parseSExpr' function return a parser for parsing
-- S-expression ('SExpr'), that is either an atom (@'SAtom' _@) or a
-- list @'SList' _ _@. See also 'decodeOne' and 'decode'.
parseSExpr :: (MonadParsec e s m, TraversableStream s) =>
              SExprParser m b a -> m (SExpr b a)
parseSExpr :: SExprParser m b a -> m (SExpr b a)
parseSExpr SExprParser m b a
def = (SExprParser m b a -> m a
forall (m :: * -> *) b a. SExprParser m b a -> m a
getAtom SExprParser m b a
def m a -> (a -> m (SExpr b a)) -> m (SExpr b a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SExpr b a -> m (SExpr b a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr b a -> m (SExpr b a))
-> (a -> SExpr b a) -> a -> m (SExpr b a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SExpr b a
forall b a. a -> SExpr b a
SAtom) m (SExpr b a) -> m (SExpr b a) -> m (SExpr b a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (SExprParser m b a -> m (SExpr b 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)

-- | The 'decodeOne' function return a parser for parsing a file
-- containing only one S-expression ('SExpr'). It can parse extra
-- whitespace at the beginning and at the end of the file. See also
-- 'parseSExpr' and 'decode'.
decodeOne :: (MonadParsec e s m, TraversableStream s) => SExprParser m b a -> m (SExpr b a)
decodeOne :: SExprParser m b a -> m (SExpr b a)
decodeOne SExprParser m b a
def =
  let ws :: m ()
ws = SExprParser m b a -> m ()
forall (m :: * -> *) b a. SExprParser m b a -> m ()
getSpace SExprParser m b a
def
  in m () -> m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
ws m (Maybe ()) -> m (SExpr b a) -> m (SExpr b a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SExprParser m b a -> m (SExpr b a)
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 (SExpr b a) -> m () -> m (SExpr b a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (m () -> m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
ws m (Maybe ()) -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)

-- | The 'decode' function return a parser for parsing a file
-- containing many S-expression ('SExpr'). It can parse extra
-- whitespace at the beginning and at the end of the file. See also
-- 'parseSExpr' and 'decodeOne'.
decode :: (MonadParsec e s m, TraversableStream s) => SExprParser m b a -> m [SExpr b a]
decode :: SExprParser m b a -> m [SExpr b a]
decode SExprParser m b a
def =
  let ws :: m ()
ws = SExprParser m b a -> m ()
forall (m :: * -> *) b a. SExprParser m b a -> m ()
getSpace SExprParser m b a
def
  in m () -> m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m ()
ws m (Maybe ()) -> m [SExpr b a] -> m [SExpr b a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m (SExpr b a) -> m () -> (a -> a -> SpacingRule) -> m [SExpr b a]
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' (SExprParser m b a -> m (SExpr b a)
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 (SExprParser m b a -> a -> a -> SpacingRule
forall (m :: * -> *) b a.
SExprParser m b a -> a -> a -> SpacingRule
getSpacingRule SExprParser m b a
def) m [SExpr b a] -> m () -> m [SExpr b a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof