{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}

-- | Generic continuation-based parser

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

-- | Run a 'Parser' reporting to arbitrary 'Monad' with 'fail'.
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

-- | Run a 'Parser' reporting to an 'Either'.
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

-- | Helper to convert expected labels to a failure value.
unexpected
  :: (String -> a) -- ^ Smart-constructor for failure value
  -> Expected      -- ^ Accumulated expected labels
  -> String        -- ^ Failure message
  -> 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
    ]

-- | A continuation-based parser type.
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
  }

-- | Megaparsec-style collection of elements expected by combined parser alternatives.
type Expected = [Label]

-- | Single element expected by a parser. 'String' because 'Control.Monad.Fail.MonadFail' method.
type Label = String

-- | Failure continuation.
type Failure f r = Expected -> String -> f r

-- | Success continuation.
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 #-}