{-|
Module      : Network.Wai.RequestSpec.Internal.Parser
Description : Parser internals, instances, and Result type
Copyright   : Allele Dev 2015
License     : BSD-3
Maintainer  : allele.dev@gmail.com
Stability   : experimental
Portability : POSIX
-}
{-# LANGUAGE RankNTypes #-}
module Network.Wai.RequestSpec.Internal.Parser (
  Result(..),
  P(..)
) where

import Control.Applicative
import Control.Monad
import Data.Monoid

import Network.Wai.RequestSpec.Error

data Result a
  = Failure Error
  | Success a

instance Functor Result where
  fmap _ (Failure e) = Failure e
  fmap f (Success x) = Success (f x)
  {-# INLINE fmap #-}

instance Applicative Result where
  pure = Success
  (Failure e) <*> (Failure e') = Failure (e <> e')
  (Failure e) <*> _            = Failure e
  _           <*> (Failure e)  = Failure e
  (Success f) <*> (Success x)  = Success (f x)
  {-# INLINE pure #-}
  {-# INLINE (<*>) #-}

instance Monad Result where
  return = pure
  (Failure e) >>= _ = Failure e
  (Success x) >>= f = f x
  {-# INLINE return #-}
  {-# INLINE (>>=) #-}

instance Show a => Show (Result a) where
  show (Failure e) = show e
  show (Success a) = show a

newtype P a =
  P { runP :: forall r.
              (Error -> Result r)
           -> (a -> Error -> Result r)
           -> Result r
    }

instance Functor P where
  fmap f (P p) = P $ \kf ks -> p kf (ks . f)
  {-# INLINE fmap #-}

instance Monad P where
  return a = P $ \_ ks -> ks a mempty
  (P m) >>= k = P $ \kf ks ->
    m kf
      (\a e ->
        runP (k a) (\e'    -> kf (e <> e'))
                   ks
      )
  {-# INLINE return #-}
  {-# INLINE (>>=) #-}

instance Applicative P where
  pure = return
  (P f) <*> (P p) = P $ \kf ks ->
    p (\e   ->
          f (\e'    -> kf (e <> e'))
            (\_  e' -> kf (e <> e'))
      )
      (\a e ->
          f (\e'    -> kf (e <> e'))
            (\f' e' -> ks (f' a) e')
      )
  {-# INLINE pure #-}
  {-# INLINE (<*>) #-}

instance MonadPlus P where
  mzero = P $ \kf _ -> kf Clear
  mplus (P m) (P n) = P $ \kf ks ->
    m (\e ->
        n (kf . Or e)
          ks
      ) ks
  {-# INLINE mplus #-}
  {-# INLINE mzero #-}

instance Alternative P where
  empty = mzero
  (<|>) = mplus
  {-# INLINE empty #-}
  {-# INLINE (<|>) #-}

instance Monoid a => Monoid (P a) where
  mempty = P $ \_ ks -> ks mempty Clear
  mappend = mplus
  {-# INLINE mempty #-}
  {-# INLINE mappend #-}