{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
module Data.EDN.Class.Parser
( parseEither
, parseM
, Parser(..)
, Success
, Failure
, Expected
, Label
, parserError
) where
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
#if MIN_VERSION_base(4,13,0)
#else
import Data.Semigroup (Semigroup(..))
#endif
import qualified Control.Monad.Fail as Fail
import qualified Data.List as List
parseM :: Fail.MonadFail m => (a -> Parser b) -> a -> m b
parseM :: (a -> Parser b) -> a -> m b
parseM a -> Parser b
p a
v = Parser b -> Failure m b -> Success b m b -> m b
forall a.
Parser a
-> forall (f :: * -> *) r. Failure f r -> Success a f r -> f r
runParser (a -> Parser b
p a
v) ((String -> m b) -> Failure m b
forall a. (String -> a) -> Expected -> String -> a
unexpected String -> m b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail) Success b m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
parseEither :: (a -> Parser b) -> a -> Either String b
parseEither :: (a -> Parser b) -> a -> Either String b
parseEither a -> Parser b
p a
v = Parser b
-> Failure (Either String) b
-> Success b (Either String) b
-> Either String b
forall a.
Parser a
-> forall (f :: * -> *) r. Failure f r -> Success a f r -> f r
runParser (a -> Parser b
p a
v) ((String -> Either String b) -> Failure (Either String) b
forall a. (String -> a) -> Expected -> String -> a
unexpected String -> Either String b
forall a b. a -> Either a b
Left) Success b (Either String) b
forall a b. b -> Either a b
Right
unexpected
:: (String -> a)
-> Expected
-> String
-> a
unexpected :: (String -> a) -> Expected -> String -> a
unexpected String -> a
failWith [] String
err =
String -> a
failWith String
err
unexpected String -> a
failWith Expected
es String
err =
String -> a
failWith (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ Expected -> String
unlines
[ String
err
, String
"expected"
, String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> Expected -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " Expected
es
]
newtype Parser a = Parser
{ Parser a
-> forall (f :: * -> *) r. Failure f r -> Success a f r -> f r
runParser
:: forall f r.
Failure f r
-> Success a f r
-> f r
}
type Expected = [Label]
type Label = String
type Failure f r = Expected -> String -> f r
type Success a f r = a -> f r
instance Functor Parser where
fmap :: (a -> b) -> Parser a -> Parser b
fmap a -> b
f Parser a
p =
(forall (f :: * -> *) r. Failure f r -> Success b f r -> f r)
-> Parser b
forall a.
(forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
Parser ((forall (f :: * -> *) r. Failure f r -> Success b f r -> f r)
-> Parser b)
-> (forall (f :: * -> *) r. Failure f r -> Success b f r -> f r)
-> Parser b
forall a b. (a -> b) -> a -> b
$ \Failure f r
kf Success b f r
ks ->
Parser a -> Failure f r -> Success a f r -> f r
forall a.
Parser a
-> forall (f :: * -> *) r. Failure f r -> Success a f r -> f r
runParser Parser a
p Failure f r
kf (Success a f r -> f r) -> Success a f r -> f r
forall a b. (a -> b) -> a -> b
$ \a
a ->
Success b f r
ks (a -> b
f a
a)
{-# INLINE fmap #-}
instance Applicative Parser where
pure :: a -> Parser a
pure a
a =
(forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
forall a.
(forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
Parser ((forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a)
-> (forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure f r
_kf Success a f r
ks ->
Success a f r
ks a
a
{-# INLINE pure #-}
Parser (a -> b)
d <*> :: Parser (a -> b) -> Parser a -> Parser b
<*> Parser a
e =
Parser (a -> b)
d Parser (a -> b) -> ((a -> b) -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a -> b
b -> (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
b Parser a
e
{-# INLINE (<*>) #-}
instance Alternative Parser where
empty :: Parser a
empty =
(forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
forall a.
(forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
Parser ((forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a)
-> (forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure f r
kf Success a f r
_ks ->
Failure f r
kf Expected
forall a. Monoid a => a
mempty String
"empty"
{-# INLINE empty #-}
Parser a
a <|> :: Parser a -> Parser a -> Parser a
<|> Parser a
b =
(forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
forall a.
(forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
Parser ((forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a)
-> (forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure f r
kf Success a f r
ks ->
let
kf' :: Expected -> p -> f r
kf' Expected
expected p
_ = Parser a -> Failure f r -> Success a f r -> f r
forall a.
Parser a
-> forall (f :: * -> *) r. Failure f r -> Success a f r -> f r
runParser Parser a
b (Failure f r
kf Failure f r -> (Expected -> Expected) -> Failure f r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expected -> Expected -> Expected
forall a. Monoid a => a -> a -> a
mappend Expected
expected) Success a f r
ks
in
Parser a -> Failure f r -> Success a f r -> f r
forall a.
Parser a
-> forall (f :: * -> *) r. Failure f r -> Success a f r -> f r
runParser Parser a
a Failure f r
forall p. Expected -> p -> f r
kf' Success a f r
ks
{-# INLINE (<|>) #-}
instance Fail.MonadFail Parser where
fail :: String -> Parser a
fail = String -> Parser a
forall a. String -> Parser a
parserError
{-# INLINE fail #-}
instance Monad Parser where
Parser a
m >>= :: Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
g =
(forall (f :: * -> *) r. Failure f r -> Success b f r -> f r)
-> Parser b
forall a.
(forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
Parser ((forall (f :: * -> *) r. Failure f r -> Success b f r -> f r)
-> Parser b)
-> (forall (f :: * -> *) r. Failure f r -> Success b f r -> f r)
-> Parser b
forall a b. (a -> b) -> a -> b
$ \Failure f r
kf Success b f r
ks ->
let
ks' :: a -> f r
ks' a
a = Parser b -> Failure f r -> Success b f r -> f r
forall a.
Parser a
-> forall (f :: * -> *) r. Failure f r -> Success a f r -> f r
runParser (a -> Parser b
g a
a) Failure f r
kf Success b f r
ks
in
Parser a -> Failure f r -> (a -> f r) -> f r
forall a.
Parser a
-> forall (f :: * -> *) r. Failure f r -> Success a f r -> f r
runParser Parser a
m Failure f r
kf a -> f r
ks'
{-# INLINE (>>=) #-}
return :: a -> Parser a
return = a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE return #-}
#if MIN_VERSION_base(4,12,0)
#else
fail = Fail.fail
{-# INLINE fail #-}
#endif
instance MonadPlus Parser where
mzero :: Parser a
mzero = String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mzero"
{-# INLINE mzero #-}
mplus :: Parser a -> Parser a -> Parser a
mplus Parser a
a Parser a
b = Parser a
a Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser a
b
{-# INLINE mplus #-}
instance Semigroup (Parser a) where
<> :: Parser a -> Parser a -> Parser a
(<>) = Parser a -> Parser a -> Parser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance Monoid (Parser a) where
mempty :: Parser a
mempty = String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mempty"
{-# INLINE mempty #-}
mappend :: Parser a -> Parser a -> Parser a
mappend = Parser a -> Parser a -> Parser a
forall a. Semigroup a => a -> a -> a
(<>)
{-# INLINE mappend #-}
parserError :: String -> Parser a
parserError :: String -> Parser a
parserError String
msg = (forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
forall a.
(forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
Parser ((forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a)
-> (forall (f :: * -> *) r. Failure f r -> Success a f r -> f r)
-> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure f r
kf Success a f r
_ks ->
Failure f r
kf Expected
forall a. Monoid a => a
mempty String
msg
{-# INLINE parserError #-}