{-# LANGUAGE CPP        #-}
{-# LANGUAGE Rank2Types #-}
-- |
-- Module      :  Pinch.Internal.Pinchable.Parser
-- Copyright   :  (c) Abhinav Gupta 2015
-- License     :  BSD3
--
-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>
-- Stability   :  experimental
--
-- Implements a continuation based version of the @Either e@ monad.
--
module Pinch.Internal.Pinchable.Parser
    ( Parser
    , runParser
    , parserCatch
    ) where

import Control.Applicative
import Control.Monad
import qualified Control.Monad.Fail as Fail


-- | Failure continuation. Called with the failure message.
type Failure   r = String  -> r
type Success a r = a       -> r
-- ^ Success continuation. Called with the result.

-- | A simple continuation-based parser.
--
-- This is just @Either e a@ in continuation-passing style.
newtype Parser a = Parser
    { Parser a -> forall r. Failure r -> Success a r -> r
unParser :: forall r.
          Failure r    -- Failure continuation
       -> Success a r  -- Success continuation
       -> r
    } -- TODO can probably track position in the struct

instance Functor Parser where
    {-# INLINE fmap #-}
    fmap :: (a -> b) -> Parser a -> Parser b
fmap a -> b
f (Parser forall r. Failure r -> Success a r -> r
g) = (forall r. Failure r -> Success b r -> r) -> Parser b
forall a. (forall r. Failure r -> Success a r -> r) -> Parser a
Parser ((forall r. Failure r -> Success b r -> r) -> Parser b)
-> (forall r. Failure r -> Success b r -> r) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Failure r
kFail Success b r
kSucc -> Failure r -> Success a r -> r
forall r. Failure r -> Success a r -> r
g Failure r
kFail (Success b r
kSucc Success b r -> (a -> b) -> Success a r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative Parser where
    {-# INLINE pure #-}
    pure :: a -> Parser a
pure a
a = (forall r. Failure r -> Success a r -> r) -> Parser a
forall a. (forall r. Failure r -> Success a r -> r) -> Parser a
Parser ((forall r. Failure r -> Success a r -> r) -> Parser a)
-> (forall r. Failure r -> Success a r -> r) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure r
_ Success a r
kSucc -> Success a r
kSucc a
a

    {-# INLINE (<*>) #-}
    Parser forall r. Failure r -> Success (a -> b) r -> r
f' <*> :: Parser (a -> b) -> Parser a -> Parser b
<*> Parser forall r. Failure r -> Success a r -> r
a' =
        (forall r. Failure r -> Success b r -> r) -> Parser b
forall a. (forall r. Failure r -> Success a r -> r) -> Parser a
Parser ((forall r. Failure r -> Success b r -> r) -> Parser b)
-> (forall r. Failure r -> Success b r -> r) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Failure r
kFail Success b r
kSuccB ->
            Failure r -> Success (a -> b) r -> r
forall r. Failure r -> Success (a -> b) r -> r
f' Failure r
kFail (Success (a -> b) r -> r) -> Success (a -> b) r -> r
forall a b. (a -> b) -> a -> b
$ \a -> b
f ->
            Failure r -> Success a r -> r
forall r. Failure r -> Success a r -> r
a' Failure r
kFail (Success a r -> r) -> Success a r -> r
forall a b. (a -> b) -> a -> b
$ \a
a ->
                Success b r
kSuccB (a -> b
f a
a)

instance Alternative Parser where
    {-# INLINE empty #-}
    empty :: Parser a
empty = (forall r. Failure r -> Success a r -> r) -> Parser a
forall a. (forall r. Failure r -> Success a r -> r) -> Parser a
Parser ((forall r. Failure r -> Success a r -> r) -> Parser a)
-> (forall r. Failure r -> Success a r -> r) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure r
kFail Success a r
_ -> Failure r
kFail [Char]
"Alternative.empty"

    {-# INLINE (<|>) #-}
    Parser forall r. Failure r -> Success a r -> r
l' <|> :: Parser a -> Parser a -> Parser a
<|> Parser forall r. Failure r -> Success a r -> r
r' =
        (forall r. Failure r -> Success a r -> r) -> Parser a
forall a. (forall r. Failure r -> Success a r -> r) -> Parser a
Parser ((forall r. Failure r -> Success a r -> r) -> Parser a)
-> (forall r. Failure r -> Success a r -> r) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure r
kFail Success a r
kSucc ->
            Failure r -> Success a r -> r
forall r. Failure r -> Success a r -> r
l' (\[Char]
_ -> Failure r -> Success a r -> r
forall r. Failure r -> Success a r -> r
r' Failure r
kFail Success a r
kSucc) Success a r
kSucc

instance Monad Parser where
    {-# INLINE return #-}
    return :: a -> Parser a
return = a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    {-# INLINE (>>) #-}
    >> :: Parser a -> Parser b -> Parser b
(>>) = Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

    {-# INLINE (>>=) #-}
    Parser forall r. Failure r -> Success a r -> r
a' >>= :: Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
k =
        (forall r. Failure r -> Success b r -> r) -> Parser b
forall a. (forall r. Failure r -> Success a r -> r) -> Parser a
Parser ((forall r. Failure r -> Success b r -> r) -> Parser b)
-> (forall r. Failure r -> Success b r -> r) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Failure r
kFail Success b r
kSuccB ->
            Failure r -> Success a r -> r
forall r. Failure r -> Success a r -> r
a' Failure r
kFail (Success a r -> r) -> Success a r -> r
forall a b. (a -> b) -> a -> b
$ \a
a ->
            Parser b -> Failure r -> Success b r -> r
forall a. Parser a -> forall r. Failure r -> Success a r -> r
unParser (a -> Parser b
k a
a) Failure r
kFail Success b r
kSuccB

#if !MIN_VERSION_base(4,13,0)
    -- Monad(fail) was removed in GHC 8.8.1
    {-# INLINE fail #-}
    fail = Fail.fail
#endif

instance Fail.MonadFail Parser where
    {-# INLINE fail #-}
    fail :: [Char] -> Parser a
fail [Char]
msg = (forall r. Failure r -> Success a r -> r) -> Parser a
forall a. (forall r. Failure r -> Success a r -> r) -> Parser a
Parser ((forall r. Failure r -> Success a r -> r) -> Parser a)
-> (forall r. Failure r -> Success a r -> r) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Failure r
kFail Success a r
_ -> Failure r
kFail [Char]
msg


instance MonadPlus Parser where
    {-# INLINE mzero #-}
    mzero :: Parser a
mzero = Parser a
forall (f :: * -> *) a. Alternative f => f a
empty

    {-# INLINE mplus #-}
    mplus :: Parser a -> Parser a -> Parser a
mplus = Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

-- | Run a @Parser@ and return the result inside an @Either@.
runParser :: Parser a -> Either String a
runParser :: Parser a -> Either [Char] a
runParser Parser a
p = Parser a
-> Failure (Either [Char] a)
-> Success a (Either [Char] a)
-> Either [Char] a
forall a. Parser a -> forall r. Failure r -> Success a r -> r
unParser Parser a
p Failure (Either [Char] a)
forall a b. a -> Either a b
Left Success a (Either [Char] a)
forall a b. b -> Either a b
Right

-- | Allows handling parse errors.
parserCatch
    :: Parser a -> (String -> Parser b) -> (a -> Parser b) -> Parser b
parserCatch :: Parser a -> ([Char] -> Parser b) -> (a -> Parser b) -> Parser b
parserCatch Parser a
p [Char] -> Parser b
f a -> Parser b
g = Parser a -> ([Char] -> Parser b) -> (a -> Parser b) -> Parser b
forall a. Parser a -> forall r. Failure r -> Success a r -> r
unParser Parser a
p [Char] -> Parser b
f a -> Parser b
g
{-# INLINE parserCatch #-}