{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.SCargot.Parse
(
decode
, decodeOne
, SExprParser
, Reader
, Comment
, mkParser
, setCarrier
, addReader
, setComment
, asRich
, asWellFormed
, withQuote
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*), pure)
#endif
import Control.Monad ((>=>))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import Data.String (IsString)
import Text.Parsec ( (<|>)
, (<?>)
, char
, eof
, lookAhead
, many1
, runParser
, skipMany
)
import Text.Parsec.Char (anyChar, space)
import Text.Parsec.Text (Parser)
import Data.SCargot.Repr ( SExpr(..)
, RichSExpr
, WellFormedSExpr
, toRich
, toWellFormed
)
type ReaderMacroMap atom = Map Char (Reader atom)
type Reader atom = (Parser (SExpr atom) -> Parser (SExpr atom))
type = Parser ()
data SExprParser atom carrier = SExprParser
{ forall atom carrier. SExprParser atom carrier -> Parser atom
sesPAtom :: Parser atom
, forall atom carrier.
SExprParser atom carrier -> ReaderMacroMap atom
readerMap :: ReaderMacroMap atom
, :: Maybe Comment
, forall atom carrier.
SExprParser atom carrier -> SExpr atom -> Either String carrier
postparse :: SExpr atom -> Either String carrier
}
mkParser :: Parser atom -> SExprParser atom (SExpr atom)
mkParser :: forall atom. Parser atom -> SExprParser atom (SExpr atom)
mkParser Parser atom
parser = SExprParser
{ sesPAtom :: Parser atom
sesPAtom = Parser atom
parser
, readerMap :: ReaderMacroMap atom
readerMap = ReaderMacroMap atom
forall k a. Map k a
M.empty
, comment :: Maybe Comment
comment = Maybe Comment
forall a. Maybe a
Nothing
, postparse :: SExpr atom -> Either String (SExpr atom)
postparse = SExpr atom -> Either String (SExpr atom)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return
}
setCarrier :: (b -> Either String c) -> SExprParser a b -> SExprParser a c
setCarrier :: forall b c a.
(b -> Either String c) -> SExprParser a b -> SExprParser a c
setCarrier b -> Either String c
f SExprParser a b
spec = SExprParser a b
spec { postparse = postparse spec >=> f }
asRich :: SExprParser a (SExpr b) -> SExprParser a (RichSExpr b)
asRich :: forall a b. SExprParser a (SExpr b) -> SExprParser a (RichSExpr b)
asRich = (SExpr b -> Either String (RichSExpr b))
-> SExprParser a (SExpr b) -> SExprParser a (RichSExpr b)
forall b c a.
(b -> Either String c) -> SExprParser a b -> SExprParser a c
setCarrier (RichSExpr b -> Either String (RichSExpr b)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (RichSExpr b -> Either String (RichSExpr b))
-> (SExpr b -> RichSExpr b)
-> SExpr b
-> Either String (RichSExpr b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExpr b -> RichSExpr b
forall atom. SExpr atom -> RichSExpr atom
toRich)
asWellFormed :: SExprParser a (SExpr b) -> SExprParser a (WellFormedSExpr b)
asWellFormed :: forall a b.
SExprParser a (SExpr b) -> SExprParser a (WellFormedSExpr b)
asWellFormed = (SExpr b -> Either String (WellFormedSExpr b))
-> SExprParser a (SExpr b) -> SExprParser a (WellFormedSExpr b)
forall b c a.
(b -> Either String c) -> SExprParser a b -> SExprParser a c
setCarrier SExpr b -> Either String (WellFormedSExpr b)
forall atom. SExpr atom -> Either String (WellFormedSExpr atom)
toWellFormed
addReader :: Char -> Reader a -> SExprParser a c -> SExprParser a c
addReader :: forall a c. Char -> Reader a -> SExprParser a c -> SExprParser a c
addReader Char
c Reader a
reader SExprParser a c
spec = SExprParser a c
spec
{ readerMap = M.insert c reader (readerMap spec) }
setComment :: Comment -> SExprParser a c -> SExprParser a c
Comment
c SExprParser a c
spec = SExprParser a c
spec { comment = Just (c <?> "comment") }
withQuote :: IsString t => SExprParser t (SExpr t) -> SExprParser t (SExpr t)
withQuote :: forall t.
IsString t =>
SExprParser t (SExpr t) -> SExprParser t (SExpr t)
withQuote = Char
-> Reader t -> SExprParser t (SExpr t) -> SExprParser t (SExpr t)
forall a c. Char -> Reader a -> SExprParser a c -> SExprParser a c
addReader Char
'\'' ((SExpr t -> SExpr t) -> Reader t
forall a b.
(a -> b)
-> ParsecT Text () Identity a -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SExpr t -> SExpr t
forall {atom}. IsString atom => SExpr atom -> SExpr atom
go)
where go :: SExpr atom -> SExpr atom
go SExpr atom
s = SExpr atom -> SExpr atom -> SExpr atom
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr atom
"quote" (SExpr atom -> SExpr atom -> SExpr atom
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr atom
s SExpr atom
forall atom. SExpr atom
SNil)
peekChar :: Parser (Maybe Char)
peekChar :: Parser (Maybe Char)
peekChar = Char -> Maybe Char
forall a. a -> Maybe a
Just (Char -> Maybe Char)
-> ParsecT Text () Identity Char -> Parser (Maybe Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar Parser (Maybe Char) -> Parser (Maybe Char) -> Parser (Maybe Char)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Maybe Char -> Parser (Maybe Char)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Char
forall a. Maybe a
Nothing
parseGenericSExpr ::
Parser atom -> ReaderMacroMap atom -> Parser () -> Parser (SExpr atom)
parseGenericSExpr :: forall atom.
Parser atom
-> ReaderMacroMap atom -> Comment -> Parser (SExpr atom)
parseGenericSExpr Parser atom
atom ReaderMacroMap atom
reader Comment
skip = do
let sExpr :: Parser (SExpr atom)
sExpr = Parser atom
-> ReaderMacroMap atom -> Comment -> Parser (SExpr atom)
forall atom.
Parser atom
-> ReaderMacroMap atom -> Comment -> Parser (SExpr atom)
parseGenericSExpr Parser atom
atom ReaderMacroMap atom
reader Comment
skip Parser (SExpr atom) -> String -> Parser (SExpr atom)
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"s-expr"
Comment
skip
Maybe Char
c <- Parser (Maybe Char)
peekChar
SExpr atom
r <- case Maybe Char
c of
Maybe Char
Nothing -> String -> Parser (SExpr atom)
forall a. String -> ParsecT Text () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected end of input"
Just Char
'(' -> Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'(' ParsecT Text () Identity Char -> Comment -> Comment
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Comment
skip Comment -> Parser (SExpr atom) -> Parser (SExpr atom)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser (SExpr atom) -> Comment -> Parser (SExpr atom)
forall atom. Parser (SExpr atom) -> Comment -> Parser (SExpr atom)
parseList Parser (SExpr atom)
sExpr Comment
skip
Just ((Char
-> ReaderMacroMap atom
-> Maybe (Parser (SExpr atom) -> Parser (SExpr atom)))
-> ReaderMacroMap atom
-> Char
-> Maybe (Parser (SExpr atom) -> Parser (SExpr atom))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char
-> ReaderMacroMap atom
-> Maybe (Parser (SExpr atom) -> Parser (SExpr atom))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ReaderMacroMap atom
reader -> Just Parser (SExpr atom) -> Parser (SExpr atom)
r) -> ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT Text () Identity Char
-> Parser (SExpr atom) -> Parser (SExpr atom)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser (SExpr atom) -> Parser (SExpr atom)
r Parser (SExpr atom)
sExpr
Maybe Char
_ -> atom -> SExpr atom
forall atom. atom -> SExpr atom
SAtom (atom -> SExpr atom) -> Parser atom -> Parser (SExpr atom)
forall a b.
(a -> b)
-> ParsecT Text () Identity a -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser atom
atom
Comment
skip
SExpr atom -> Parser (SExpr atom)
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return SExpr atom
r
parseList :: Parser (SExpr atom) -> Parser () -> Parser (SExpr atom)
parseList :: forall atom. Parser (SExpr atom) -> Comment -> Parser (SExpr atom)
parseList Parser (SExpr atom)
sExpr Comment
skip = do
Maybe Char
i <- Parser (Maybe Char)
peekChar
case Maybe Char
i of
Maybe Char
Nothing -> String -> Parser (SExpr atom)
forall a. String -> ParsecT Text () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected end of input"
Just Char
')' -> Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')' ParsecT Text () Identity Char
-> Parser (SExpr atom) -> Parser (SExpr atom)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SExpr atom -> Parser (SExpr atom)
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return SExpr atom
forall atom. SExpr atom
SNil
Maybe Char
_ -> do
SExpr atom
car <- Parser (SExpr atom)
sExpr
Comment
skip
Maybe Char
c <- Parser (Maybe Char)
peekChar
case Maybe Char
c of
Just Char
'.' -> do
Char
_ <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
SExpr atom
cdr <- Parser (SExpr atom)
sExpr
Comment
skip
Char
_ <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')'
Comment
skip
SExpr atom -> Parser (SExpr atom)
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr atom -> SExpr atom -> SExpr atom
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr atom
car SExpr atom
cdr)
Just Char
')' -> do
Char
_ <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')'
Comment
skip
SExpr atom -> Parser (SExpr atom)
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr atom -> SExpr atom -> SExpr atom
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr atom
car SExpr atom
forall atom. SExpr atom
SNil)
Maybe Char
_ -> do
SExpr atom
cdr <- Parser (SExpr atom) -> Comment -> Parser (SExpr atom)
forall atom. Parser (SExpr atom) -> Comment -> Parser (SExpr atom)
parseList Parser (SExpr atom)
sExpr Comment
skip
SExpr atom -> Parser (SExpr atom)
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExpr atom -> SExpr atom -> SExpr atom
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr atom
car SExpr atom
cdr)
buildSkip :: Maybe (Parser ()) -> Parser ()
buildSkip :: Maybe Comment -> Comment
buildSkip Maybe Comment
Nothing = ParsecT Text () Identity Char -> Comment
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
buildSkip (Just Comment
c) = Comment
alternate
where alternate :: Comment
alternate = ParsecT Text () Identity Char -> Comment
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space Comment -> Comment -> Comment
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((Comment
c Comment -> Comment -> Comment
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Comment
alternate) Comment -> Comment -> Comment
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> () -> Comment
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
doParse :: Parser a -> Text -> Either String a
doParse :: forall a. Parser a -> Text -> Either String a
doParse Parser a
p Text
t = case Parser a -> () -> String -> Text -> Either ParseError a
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser Parser a
p () String
"" Text
t of
Left ParseError
err -> String -> Either String a
forall a b. a -> Either a b
Left (ParseError -> String
forall a. Show a => a -> String
show ParseError
err)
Right a
x -> a -> Either String a
forall a b. b -> Either a b
Right a
x
decodeOne :: SExprParser atom carrier -> Text -> Either String carrier
decodeOne :: forall atom carrier.
SExprParser atom carrier -> Text -> Either String carrier
decodeOne SExprParser atom carrier
spec = Parser (SExpr atom) -> Text -> Either String (SExpr atom)
forall a. Parser a -> Text -> Either String a
doParse (Parser (SExpr atom)
parser Parser (SExpr atom) -> Comment -> Parser (SExpr atom)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Comment
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) (Text -> Either String (SExpr atom))
-> (SExpr atom -> Either String carrier)
-> Text
-> Either String carrier
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (SExprParser atom carrier -> SExpr atom -> Either String carrier
forall atom carrier.
SExprParser atom carrier -> SExpr atom -> Either String carrier
postparse SExprParser atom carrier
spec)
where parser :: Parser (SExpr atom)
parser = Parser atom
-> ReaderMacroMap atom -> Comment -> Parser (SExpr atom)
forall atom.
Parser atom
-> ReaderMacroMap atom -> Comment -> Parser (SExpr atom)
parseGenericSExpr
(SExprParser atom carrier -> Parser atom
forall atom carrier. SExprParser atom carrier -> Parser atom
sesPAtom SExprParser atom carrier
spec)
(SExprParser atom carrier -> ReaderMacroMap atom
forall atom carrier.
SExprParser atom carrier -> ReaderMacroMap atom
readerMap SExprParser atom carrier
spec)
(Maybe Comment -> Comment
buildSkip (SExprParser atom carrier -> Maybe Comment
forall atom carrier. SExprParser atom carrier -> Maybe Comment
comment SExprParser atom carrier
spec))
decode :: SExprParser atom carrier -> Text -> Either String [carrier]
decode :: forall atom carrier.
SExprParser atom carrier -> Text -> Either String [carrier]
decode SExprParser atom carrier
spec =
Parser [SExpr atom] -> Text -> Either String [SExpr atom]
forall a. Parser a -> Text -> Either String a
doParse (ParsecT Text () Identity (SExpr atom) -> Parser [SExpr atom]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT Text () Identity (SExpr atom)
parser Parser [SExpr atom] -> Comment -> Parser [SExpr atom]
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Comment
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) (Text -> Either String [SExpr atom])
-> ([SExpr atom] -> Either String [carrier])
-> Text
-> Either String [carrier]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (SExpr atom -> Either String carrier)
-> [SExpr atom] -> Either String [carrier]
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 (SExprParser atom carrier -> SExpr atom -> Either String carrier
forall atom carrier.
SExprParser atom carrier -> SExpr atom -> Either String carrier
postparse SExprParser atom carrier
spec)
where parser :: ParsecT Text () Identity (SExpr atom)
parser = Parser atom
-> ReaderMacroMap atom
-> Comment
-> ParsecT Text () Identity (SExpr atom)
forall atom.
Parser atom
-> ReaderMacroMap atom -> Comment -> Parser (SExpr atom)
parseGenericSExpr
(SExprParser atom carrier -> Parser atom
forall atom carrier. SExprParser atom carrier -> Parser atom
sesPAtom SExprParser atom carrier
spec)
(SExprParser atom carrier -> ReaderMacroMap atom
forall atom carrier.
SExprParser atom carrier -> ReaderMacroMap atom
readerMap SExprParser atom carrier
spec)
(Maybe Comment -> Comment
buildSkip (SExprParser atom carrier -> Maybe Comment
forall atom carrier. SExprParser atom carrier -> Maybe Comment
comment SExprParser atom carrier
spec))