-- | 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 :: forall (f :: * -> *) a. Monad f => Partial f a -> Partial f a
partialResult = forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return

instance Functor f => Functor (Partial f) where
  fmap :: forall a b. (a -> b) -> Partial f a -> Partial f b
fmap a -> b
_ (Fail [String]
e)   = forall (f :: * -> *) a. [String] -> Partial f a
Fail [String]
e
  fmap a -> b
f (PZero a
a)  = forall (f :: * -> *) a. a -> Partial f a
PZero (a -> b
f a
a)
  fmap a -> b
f (PSucc f (Partial f a)
pa) = forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 :: forall a. a -> Partial f a
return = forall (f :: * -> *) a. a -> Partial f a
PZero
#if !MIN_VERSION_base(4,13,0)
  fail   = Fail . return
#endif

  Fail [String]
e   >>= :: forall a b. Partial f a -> (a -> Partial f b) -> Partial f b
>>= a -> 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 = forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 :: forall a. String -> Partial f a
fail = forall (f :: * -> *) a. [String] -> Partial f a
Fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
#endif

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

  Fail  [String]
a mplus :: forall a. Partial f a -> Partial f a -> Partial f a
`mplus` Fail  [String]
b = forall (f :: * -> *) a. [String] -> Partial f a
Fail ([String]
a 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
_ = forall (f :: * -> *) a. a -> Partial f a
PZero a
a
  PZero a
_ `mplus` PSucc f (Partial f a)
b = 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
_ = 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 = forall (f :: * -> *) a. f (Partial f a) -> Partial f a
PSucc (f (Partial f a)
a forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` f (Partial f a)
b)

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

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

instance (MonadPlus f, Functor f) => Alternative (Partial f) where
  empty :: forall a. Partial f a
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: forall 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 :: forall (m :: * -> *) a.
Monad m =>
([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)  = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    go (PSucc m (Partial m a)
fa) = m (Partial m a)
fa 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