-- | Monad for partial results
module Generics.SOP.Util.PartialResult (
    Partial(..)
  , runPartial
  , partialResult
    -- * Re-exports
  , lift
  ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class

-- | Repeat f zero or more times
--
-- Note that this is a free monad construction, but the difference is in the
-- MonadPlus instead. We regard successive PSucc applications to indicate
-- "more success". This is very useful in parser construction: if all parsers
-- for all constructors fail immediately, we want to show an error message
-- for all the top-level parsers ("expected T1 or T2 .."). But if the parser
-- for T1, say, success in parsing the tag for T1, then we don't want to
-- try any more parsers for other constructors even if the parser for T1
-- now fails in parsing the arguments of T1. Instead, we want to give the
-- error message about attempting to parse T1.
data Partial (f :: * -> *) (a :: *) =
    Fail [String]
  | PZero a
  | PSucc (f (Partial f a))

partialResult :: Monad f => Partial f a -> Partial f a
partialResult :: Partial f a -> Partial f a
partialResult = f (Partial f a) -> Partial f a
forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc (f (Partial f a) -> Partial f a)
-> (Partial f a -> f (Partial f a)) -> Partial f a -> Partial f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Partial f a -> f (Partial f a)
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Functor f => Functor (Partial f) where
  fmap :: (a -> b) -> Partial f a -> Partial f b
fmap a -> b
_ (Fail [String]
e)   = [String] -> Partial f b
forall (f :: * -> *) a. [String] -> Partial f a
Fail [String]
e
  fmap a -> b
f (PZero a
a)  = b -> Partial f b
forall (f :: * -> *) a. a -> Partial f a
PZero (a -> b
f a
a)
  fmap a -> b
f (PSucc f (Partial f a)
pa) = f (Partial f b) -> Partial f b
forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc ((Partial f a -> Partial f b) -> f (Partial f a) -> f (Partial f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Partial f a -> Partial f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (Partial f a)
pa)

instance Functor f => Monad (Partial f) where
  return :: a -> Partial f a
return = a -> Partial f a
forall (f :: * -> *) a. a -> Partial f a
PZero
#if !MIN_VERSION_base(4,13,0)
  fail   = Fail . return
#endif

  Fail [String]
e   >>= :: Partial f a -> (a -> Partial f b) -> Partial f b
>>= a -> Partial f b
_ = [String] -> Partial f b
forall (f :: * -> *) a. [String] -> Partial f a
Fail [String]
e
  PZero a
a  >>= a -> Partial f b
f = a -> Partial f b
f a
a
  PSucc f (Partial f a)
fa >>= a -> Partial f b
f = f (Partial f b) -> Partial f b
forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc ((Partial f a -> Partial f b) -> f (Partial f a) -> f (Partial f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Partial f a -> (a -> Partial f b) -> Partial f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Partial f b
f) f (Partial f a)
fa)

#if MIN_VERSION_base(4,13,0)
instance Functor f => MonadFail (Partial f) where
  fail :: String -> Partial f a
fail = [String] -> Partial f a
forall (f :: * -> *) a. [String] -> Partial f a
Fail ([String] -> Partial f a)
-> (String -> [String]) -> String -> Partial f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall (m :: * -> *) a. Monad m => a -> m a
return
#endif

instance (MonadPlus f, Functor f) => MonadPlus (Partial f) where
  mzero :: Partial f a
mzero = [String] -> Partial f a
forall (f :: * -> *) a. [String] -> Partial f a
Fail []

  Fail  [String]
a mplus :: Partial f a -> Partial f a -> Partial f a
`mplus` Fail  [String]
b = [String] -> Partial f a
forall (f :: * -> *) a. [String] -> Partial f a
Fail ([String]
a [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
b)
  Fail  [String]
_ `mplus` Partial f a
b       = Partial f a
b
  Partial f a
a       `mplus` Fail  [String]
_ = Partial f a
a

  PZero a
a `mplus` PZero a
_ = a -> Partial f a
forall (f :: * -> *) a. a -> Partial f a
PZero a
a
  PZero a
_ `mplus` PSucc f (Partial f a)
b = f (Partial f a) -> Partial f a
forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc f (Partial f a)
b
  PSucc f (Partial f a)
a `mplus` PZero a
_ = f (Partial f a) -> Partial f a
forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc f (Partial f a)
a
  PSucc f (Partial f a)
a `mplus` PSucc f (Partial f a)
b = f (Partial f a) -> Partial f a
forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc (f (Partial f a)
a f (Partial f a) -> f (Partial f a) -> f (Partial f a)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` f (Partial f a)
b)

instance MonadTrans Partial where
  lift :: m a -> Partial m a
lift m a
ma = m (Partial m a) -> Partial m a
forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc (a -> Partial m a
forall (f :: * -> *) a. a -> Partial f a
PZero (a -> Partial m a) -> m a -> m (Partial m a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m a
ma)

instance Functor f => Applicative (Partial f) where
  pure :: a -> Partial f a
pure = a -> Partial f a
forall (m :: * -> *) a. Monad m => a -> m a
return
  Partial f (a -> b)
f <*> :: Partial f (a -> b) -> Partial f a -> Partial f b
<*> Partial f a
a = do a -> b
f' <- Partial f (a -> b)
f ; a
a' <- Partial f a
a ; b -> Partial f b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f' a
a')

instance (MonadPlus f, Functor f) => Alternative (Partial f) where
  empty :: Partial f a
empty = Partial f a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: Partial f a -> Partial f a -> Partial f a
(<|>) = Partial f a -> Partial f a -> Partial f a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

runPartial :: Monad m => ([String] -> m a) -> Partial m a -> m a
runPartial :: ([String] -> m a) -> Partial m a -> m a
runPartial [String] -> m a
failWith = Partial m a -> m a
go
  where
    go :: Partial m a -> m a
go (PZero a
a)  = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    go (PSucc m (Partial m a)
fa) = m (Partial m a)
fa m (Partial m a) -> (Partial m a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Partial m a -> m a
go
    go (Fail  [String]
es) = [String] -> m a
failWith [String]
es