{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
Module      :  Servant.Checked.Exceptions.Internal.EnvelopeT

Copyright   :  Dennis Gosnell 2019
License     :  BSD3

Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)
Stability   :  experimental
Portability :  unknown

This module defines the 'EnvelopeT' type and helper functions. 'EnvelopeT' is a
short-circuiting monad transformer.

'Envelope' is similar to 'Either' where multiple errors types are possible.
'EnvelopeT' is similar to 'ExceptT' in a similar manner.
-}

module Servant.Checked.Exceptions.Internal.EnvelopeT where

import Control.Monad.Except (ExceptT(ExceptT), MonadError(throwError, catchError))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Reader (MonadReader, ask, local, reader)
import Control.Monad.RWS (MonadRWS)
import Control.Monad.State (MonadState, get, put, state)
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.Writer (MonadWriter, listen, pass, tell, writer)
import Data.Functor.Classes
  ( Show1
  , liftShowList
  , liftShowsPrec
  , showsPrec1
  , showsUnaryWith
  )
import Data.Functor.Contravariant (Contravariant(contramap))
import Data.WorldPeace
  ( Contains
  , ElemRemove
  , IsMember
  , OpenUnion
  , Remove
  , ReturnX
  , ToOpenProduct
  , relaxOpenUnion
  )

import Servant.Checked.Exceptions.Internal.Envelope
  ( Envelope(ErrEnvelope, SuccEnvelope)
  , catchesEnvelope
  , liftA2Envelope
  , eitherToEnvelope
  , emptyEnvelope
  , envelope
  , envelopeRemove
  , envelopeToEither
  , errEnvelopeMatch
  , pureErrEnvelope
  , pureSuccEnvelope
  , relaxEnvelope
  )

-- $setup
-- >>> :set -XDataKinds
-- >>> :set -XTypeOperators
-- >>> import Data.Functor.Identity (Identity(Identity))

data EnvelopeT es m a = EnvelopeT
  { runEnvelopeT :: m (Envelope es a)
  } deriving Functor

instance (Show (OpenUnion es), Show1 m) => Show1 (EnvelopeT es m) where
  liftShowsPrec
    :: forall a
     . (Int -> a -> ShowS)
    -> ([a] -> ShowS)
    -> Int
    -> EnvelopeT es m a -> ShowS
  liftShowsPrec sp sl d (EnvelopeT m) =
    showsUnaryWith showInnerM "EnvelopeT" d m
    where
      showInnerM :: Int -> m (Envelope es a) -> ShowS
      showInnerM = liftShowsPrec sp' sl'

      sp' :: Int -> Envelope es a -> ShowS
      sp' = liftShowsPrec sp sl

      sl' :: [Envelope es a] -> ShowS
      sl' = liftShowList sp sl

instance (Show (OpenUnion e), Show1 m, Show a) => Show (EnvelopeT e m a) where
  showsPrec = showsPrec1

instance Monad m => Applicative (EnvelopeT es m) where
  pure :: a -> EnvelopeT es m a
  pure a = EnvelopeT $ pureSuccEnvelope a

  (<*>) :: EnvelopeT es m (a -> b) -> EnvelopeT es m a -> EnvelopeT es m b
  EnvelopeT a2b <*> EnvelopeT a = EnvelopeT $ go <$> a2b <*> a
    where
      go :: Envelope es (a -> b) -> Envelope es a -> Envelope es b
      go = (<*>)

instance Monad m => Monad (EnvelopeT es m) where
  (>>=) :: EnvelopeT es m a -> (a -> EnvelopeT es m b) -> EnvelopeT es m b
  (EnvelopeT m) >>= k = EnvelopeT $ do
    env <- m
    case env of
      SuccEnvelope a -> runEnvelopeT $ k a
      ErrEnvelope err -> pure $ ErrEnvelope err

instance MonadTrans (EnvelopeT es) where
  lift :: Monad m => m a -> EnvelopeT es m a
  lift m = EnvelopeT $ do
    val <- m
    pureSuccEnvelope val

instance MonadIO m => MonadIO (EnvelopeT es m) where
  liftIO :: IO a -> EnvelopeT es m a
  liftIO = lift . liftIO

instance Foldable m => Foldable (EnvelopeT es m) where
  foldMap f (EnvelopeT m) = foldMap (envelope (const mempty) f) m

instance (Traversable m) => Traversable (EnvelopeT es m) where
  traverse
    :: Applicative f => (a -> f b) -> EnvelopeT es m a -> f (EnvelopeT es m b)
  traverse f (EnvelopeT m) =
    fmap EnvelopeT $
      traverse (envelope (pure . ErrEnvelope) (fmap SuccEnvelope . f)) m

instance Contravariant m => Contravariant (EnvelopeT es m) where
  contramap :: (b -> a) -> EnvelopeT es m a -> EnvelopeT es m b
  contramap f (EnvelopeT m) = EnvelopeT $ contramap (fmap f) m

instance MonadRWS r w s m => MonadRWS r w s (EnvelopeT es m)

instance MonadError error m => MonadError error (EnvelopeT es m) where
  throwError = EnvelopeT . throwError

  catchError
    :: forall a
     . EnvelopeT es m a
    -> (error -> EnvelopeT es m a)
    -> EnvelopeT es m a
  catchError (EnvelopeT m) handler = EnvelopeT $ catchError m innerRunner
    where
      innerRunner :: error -> m (Envelope es a)
      innerRunner = runEnvelopeT . handler

instance MonadReader r m => MonadReader r (EnvelopeT es m) where
  ask = lift ask
  local f (EnvelopeT m) = EnvelopeT (local f m)
  reader = lift . reader

instance MonadState s m => MonadState s (EnvelopeT es m) where
  get = lift get
  put = lift . put
  state = lift . state

instance MonadWriter w m => MonadWriter w (EnvelopeT es m) where
  writer = lift . writer
  tell = lift . tell
  listen (EnvelopeT m) =
    EnvelopeT $ do
      (envelopeA, w) <- listen m
      pure $ fmap (,w) envelopeA
  pass (EnvelopeT m) =
    EnvelopeT $ do
      envel <- m
      pass . pure $
        case envel of
          SuccEnvelope (a, f) -> (SuccEnvelope a, f)
          ErrEnvelope es -> (ErrEnvelope es, id)

-- | This is 'pure' for 'EnvelopeT'.
--
-- >>> pureSuccEnvT "hello" :: EnvelopeT '[] Identity String
-- EnvelopeT (Identity (SuccEnvelope "hello"))
pureSuccEnvT :: Applicative m => a -> EnvelopeT es m a
pureSuccEnvT = EnvelopeT . pureSuccEnvelope

-- | Throw an error in an 'ErrEnvelope'.
--
-- >>> let double = 3.5 :: Double
-- >>> throwErrEnvT double :: EnvelopeT '[String, Double, Int] Identity ()
-- EnvelopeT (Identity (ErrEnvelope (Identity 3.5)))
--
-- This is similar to 'throwError', but is specialized so you can throw just
-- one of the error types.
throwErrEnvT :: (Applicative m, IsMember e es) => e -> EnvelopeT es m a
throwErrEnvT = EnvelopeT . pureErrEnvelope

-- | Case analysis for 'EnvelopeT'.
--
-- ==== __Examples__
--
--  Here is an example of matching on a 'SuccEnvelope':
--
-- >>> let env = pure "hello" :: EnvelopeT '[Double, Int] Identity String
-- >>> envelopeT (\_ -> Identity "not a String") Identity env
-- Identity "hello"
--
-- Here is an example of matching on a 'ErrEnvelope':
--
-- >>> let double = 3.5 :: Double
-- >>> let env' = throwErrEnvT double :: EnvelopeT '[Double, Int] Identity String
-- >>> envelopeT (\_ -> Identity "not a String") Identity env'
-- Identity "not a String"
envelopeT :: Monad m => (OpenUnion es -> m c) -> (a -> m c) -> EnvelopeT es m a -> m c
envelopeT errHandler succHandler (EnvelopeT m) = do
  envel <- m
  envelope errHandler succHandler envel

-- | Slight simplification of 'envelopeT'.
--
-- ==== __Examples__
--
--  Here is an example of successfully matching:
--
-- >>> let env = pure "hello" :: EnvelopeT '[Double, Int] Identity String
-- >>> fromEnvT (\_ -> Identity "not a String") env
-- Identity "hello"
--
-- Here is an example of unsuccessfully matching:
--
-- >>> let double = 3.5 :: Double
-- >>> let env' = throwErrEnvT double :: EnvelopeT '[Double, Int] Identity String
-- >>> fromEnvT (\_ -> Identity "not a String") env'
-- Identity "not a String"
fromEnvT :: Monad m => (OpenUnion es -> m a) -> EnvelopeT es m a -> m a
fromEnvT f = envelopeT f pure

-- | Flipped version of 'fromEnvT'.
fromEnvTOr :: Monad m => EnvelopeT es m a -> (OpenUnion es -> m a) -> m a
fromEnvTOr = flip fromEnvT

-- | Try to pull out a specific @e@ from an 'ErrEnvelope'.
--
-- ==== __Examples__
--
-- Successfully pull out an @e@:
--
-- >>> let double = 3.5 :: Double
-- >>> let env = throwErrEnvT double :: EnvelopeT '[Double, Char] Identity ()
-- >>> errEnvTMatch env :: Identity (Maybe Double)
-- Identity (Just 3.5)
--
-- Unsuccessfully pull out an @e@:
--
-- >>> let env' = pure () :: EnvelopeT '[String, Double] Identity ()
-- >>> errEnvTMatch env' :: Identity (Maybe Double)
-- Identity Nothing
errEnvTMatch
  :: forall e es m a.
     (Functor m, IsMember e es)
  => EnvelopeT es m a
  -> m (Maybe e)
errEnvTMatch (EnvelopeT m) = fmap errEnvelopeMatch m

-- | An alternate case anaylsis for an 'EnvelopeT'.  This method uses a tuple
-- containing handlers for each potential value of the underlying 'Envelope'.
-- This is somewhat similar to the 'Control.Exception.catches' function.
--
-- When working with an 'Envelope' with a large number of possible error types,
-- it can be easier to use 'catchesEnvT' than 'envelopeT'.
--
-- ==== __Examples__
--
-- Here is an example of handling an 'SuccEnvelope' with two possible error values.
-- Notice that a normal tuple is used:
--
-- >>> let env = pure 2.0 :: EnvelopeT '[Int, String] IO Double
-- >>> let intHandler = (\int -> pure $ show int) :: Int -> IO String
-- >>> let strHandler = (\str -> pure str) :: String -> IO String
-- >>> let succHandler = (\dbl -> pure "got a double") :: Double -> IO String
-- >>> catchesEnvT (intHandler, strHandler) succHandler env :: IO String
-- "got a double"
--
-- Here is an example of handling an 'ErrEnvelope' with two possible error values.
-- Notice that a normal tuple is used to hold the handlers:
--
-- >>> let env = throwErrEnvT (3 :: Int) :: EnvelopeT '[Int, String] Identity Double
-- >>> let intHandler = (\int -> Identity $ show int) :: Int -> Identity String
-- >>> let strHandler = (\str -> Identity str) :: String -> Identity String
-- >>> let succHandler = (\dbl -> Identity "got a double") :: Double -> Identity String
-- >>> catchesEnvT (intHandler, strHandler) succHandler env :: Identity String
-- Identity "3"
--
-- Given an 'EnvelopeT' like @'EnvelopeT' \'['Int', 'String'] 'IO' 'Double'@,
-- the type of 'catchesEnvT' becomes the following:
--
-- @
--   'catchesEnvT'
--     :: ('Int' -> 'IO' x, 'String' -> 'IO' x)
--     -> ('Double' -> 'IO' x)
--     -> 'EnvelopeT' \'['Int', 'String'] 'IO' 'Double'
--     -> 'IO' x
-- @
--
-- Here is an example of handling an 'ErrEnvelope' with three possible values.
-- Notice how a 3-tuple is used to hold the handlers:
--
-- >>> let env = throwErrEnvT ("hi" :: String) :: EnvelopeT '[Int, String, Char] IO Double
-- >>> let intHandler = (\int -> pure $ show int) :: Int -> IO String
-- >>> let strHandler = (\str -> pure str) :: String -> IO String
-- >>> let chrHandler = (\chr -> pure [chr]) :: Char -> IO String
-- >>> let succHandler = (\dbl -> pure "got a double") :: Double -> IO String
-- >>> catchesEnvT (intHandler, strHandler, chrHandler) succHandler env :: IO String
-- "hi"
--
-- Given an 'Envelope' like @'EnvelopeT' \'['Int', 'String', 'Char'] 'IO' 'Double'@,
-- the type of 'catchesEnvT' becomes the following:
--
-- @
--   'catchesEnvT'
--     :: ('Int' -> 'IO' x, 'String' -> 'IO' x, 'Char' -> 'IO' x)
--     -> ('Double' -> 'IO' x)
--     -> 'EnvelopeT' \'['Int', 'String', 'Char'] 'IO' 'Double'
--     -> x
-- @
catchesEnvT
  :: forall tuple es m a x
   .  (Monad m, ToOpenProduct tuple (ReturnX (m x) es))
  => tuple -> (a -> m x) -> EnvelopeT es m a -> m x
catchesEnvT tuple a2mx (EnvelopeT m) = do
  envel <- m
  catchesEnvelope tuple a2mx envel

-- | Convert an 'EnvelopeT' to an 'ExceptT'.
envTToExceptT :: Functor m => EnvelopeT es m a -> ExceptT (OpenUnion es) m a
envTToExceptT (EnvelopeT m) = ExceptT $ fmap envelopeToEither m

-- | Convert an 'ExceptT' to an 'EnvelopeT'.
exceptTToEnvT :: Functor m => ExceptT (OpenUnion es) m a -> EnvelopeT es m a
exceptTToEnvT (ExceptT m) = EnvelopeT $ fmap eitherToEnvelope m

-- | Safely unwrap an 'EnvelopeT'.
--
-- >>> let myenvT = pure "hello" :: EnvelopeT '[] IO String
-- >>> emptyEnvT myenvT :: IO String
-- "hello"
emptyEnvT :: Functor m => EnvelopeT '[] m a -> m a
emptyEnvT (EnvelopeT m) = fmap emptyEnvelope m

-- | Change the errors type in an 'EnvelopeT' to a larger set.
--
-- ==== __Examples__
--
-- >>> let double = 3.5 :: Double
-- >>> let envT1 = throwErrEnvT double :: EnvelopeT '[Int, Double] Identity Float
-- >>> relaxEnvT envT1 :: EnvelopeT '[Char, Int, String, Double] Identity Float
-- EnvelopeT (Identity (ErrEnvelope (Identity 3.5)))
--
-- >>> let envT2 = pure double :: EnvelopeT '[Char, Int] Identity Double
-- >>> relaxEnvT envT2 :: EnvelopeT '[(), Char, String, Int] Identity Double
-- EnvelopeT (Identity (SuccEnvelope 3.5))
relaxEnvT :: (Functor m, Contains es1 es2) => EnvelopeT es1 m a -> EnvelopeT es2 m a
relaxEnvT (EnvelopeT m) = EnvelopeT $ fmap relaxEnvelope m

-- | Combine two 'EnvelopeT's.  Generalize the set of errors to include the errors
-- from both 'EnvelopeT's. Similar to 'liftA2' but more general.
--
-- ==== __Examples__
--
-- >>> let env1 = pure "hello" :: EnvelopeT '[Double, Int] Identity String
-- >>> let env2 = pure " world" :: EnvelopeT '[Char]  Identity String
-- >>> liftA2EnvT (<>) env1 env2 :: EnvelopeT '[Double, Int, Char] Identity String
-- EnvelopeT (Identity (SuccEnvelope "hello world"))
--
-- If either of the 'Envelope's is an 'ErrEnvelope', then return the 'ErrEnvelope'.
--
-- >>> let env3 = throwErrEnvT "some err" :: EnvelopeT '[String, Double] Identity Int
-- >>> let env4 = pure 1 :: EnvelopeT '[Char]  Identity Int
-- >>> liftA2EnvT (+) env3 env4 :: EnvelopeT '[String, Double, Char] Identity Int
-- EnvelopeT (Identity (ErrEnvelope (Identity "some err")))
--
-- >>> let env5 = pure "hello" :: EnvelopeT '[Char] Identity String
-- >>> let env6 = throwErrEnvT 3.5 :: EnvelopeT '[(), Double] Identity String
-- >>> liftA2EnvT (<>) env5 env6 :: EnvelopeT '[Char, (), Double] Identity String
-- EnvelopeT (Identity (ErrEnvelope (Identity 3.5)))
--
-- If both of the 'EnvelopeT's is an 'ErrEnvelope', then short-circuit and only
-- return the first 'ErrEnvelope'.
--
-- >>> let env7 = throwErrEnvT 4.5 :: EnvelopeT '[(), Double] Identity String
-- >>> let env8 = throwErrEnvT 'x' :: EnvelopeT '[Int, Char] Identity String
-- >>> liftA2EnvT (<>) env7 env8 :: EnvelopeT '[(), Double, Int, Char] Identity String
-- EnvelopeT (Identity (ErrEnvelope (Identity 4.5)))
liftA2EnvT
  :: (Contains es1 fullEs, Contains es2 fullEs, Applicative m)
  => (a -> b -> c)
  -> EnvelopeT es1 m a
  -> EnvelopeT es2 m b
  -> EnvelopeT fullEs m c
liftA2EnvT f (EnvelopeT m) (EnvelopeT n) =
  EnvelopeT $ liftA2Envelope f <$> m <*> n

-- | This is like 'liftA2EnvT' but for monadic bind ('>>=').
--
-- This allows you to bind on 'EnvelopeT's that contain different errors.
--
-- The resulting 'EnvelopeT' must have a superset of the errors in two input
-- 'EnvelopeT's.
--
-- ==== __Examples__
--
-- >>> let env1 = pure "hello" :: EnvelopeT '[Double, Int] Identity String
-- >>> let f1 str = pure (length str) :: EnvelopeT '[Char] Identity Int
-- >>> bindEnvT env1 f1 :: EnvelopeT '[Double, Int, Char] Identity Int
-- EnvelopeT (Identity (SuccEnvelope 5))
--
-- If either of the 'EnvelopeT's holds an 'ErrEnvelope', then return the 'ErrEnvelope'.
--
-- >>> let env2 = throwErrEnvT "some err" :: EnvelopeT '[String, Double] Identity Int
-- >>> let f2 i = pureSuccEnvT (i + 1) :: EnvelopeT '[Char] Identity Int
-- >>> bindEnvT env2 f2 :: EnvelopeT '[String, Double, Char] Identity Int
-- EnvelopeT (Identity (ErrEnvelope (Identity "some err")))
--
-- >>> let env3 = pureSuccEnvT "hello" :: EnvelopeT '[Char] Identity String
-- >>> let f3 _ = throwErrEnvT 3.5 :: EnvelopeT '[(), Double] Identity Int
-- >>> bindEnvT env3 f3 :: EnvelopeT '[Char, (), Double] Identity Int
-- EnvelopeT (Identity (ErrEnvelope (Identity 3.5)))
--
-- If both of the 'Envelope's is an 'ErrEnvelope', then short-circuit and only
-- return the first 'ErrEnvelope'.
--
-- >>> let env4 = throwErrEnvT 3.5 :: EnvelopeT '[(), Double] Maybe String
-- >>> let f4 _ = throwErrEnvT 'x' :: EnvelopeT '[Int, Char] Maybe String
-- >>> bindEnvT env4 f4 :: EnvelopeT '[Char, (), Double, Int] Maybe String
-- EnvelopeT (Just (ErrEnvelope (Identity 3.5)))
bindEnvT
  :: (Contains es1 fullEs, Contains es2 fullEs, Monad m)
  => EnvelopeT es1 m a
  -> (a -> EnvelopeT es2 m b)
  -> EnvelopeT fullEs m b
bindEnvT (EnvelopeT m) f =
  EnvelopeT $ do
    envel1 <- m
    case envel1 of
      SuccEnvelope a ->
        let x = f a
        in runEnvelopeT $ relaxEnvT x
      ErrEnvelope u ->
        let fullEs = relaxOpenUnion u
        in pure $ ErrEnvelope fullEs

-- | This function allows you to try to remove individual error types from an
-- 'EnvelopeT'.
--
-- This can be used to handle only certain error types in an 'Envelope',
-- instead of having to handle all of them at the same time.  This can be more
-- convenient than a function like 'catchesEnvT'.
--
-- ==== __Examples__
--
-- Pulling out an error in an 'EnvelopeT':
--
-- >>> let env1 = throwErrEnvT "hello" :: EnvelopeT '[String, Double] Identity Float
-- >>> envTRemove env1 :: EnvelopeT '[Double] Identity (Either Float String)
-- EnvelopeT (Identity (SuccEnvelope (Right "hello")))
--
-- Failing to pull out an error in an 'EnvelopeT':
--
-- >>> let env2 = throwErrEnvT (3.5 :: Double) :: EnvelopeT '[String, Double] Identity Float
-- >>> envTRemove env2 :: EnvelopeT '[Double] Identity (Either Float String)
-- EnvelopeT (Identity (ErrEnvelope (Identity 3.5)))
--
-- Note that if you have an 'EnvelopeT' with multiple errors of the same type,
-- they will all be handled at the same time:
--
-- >>> let env3 = throwErrEnvT (3.5 :: Double) :: EnvelopeT '[String, Double, Char, Double] Identity Float
-- >>> envTRemove env3 :: EnvelopeT '[String, Char] Identity (Either Float Double)
-- EnvelopeT (Identity (SuccEnvelope (Right 3.5)))
--
-- 'SuccEnvelope' gets passed through as expected:
--
-- >>> let env4 = pureSuccEnvT 3.5 :: EnvelopeT '[String, Double] Identity Float
-- >>> envTRemove env4 :: EnvelopeT '[Double] Identity (Either Float String)
-- EnvelopeT (Identity (SuccEnvelope (Left 3.5)))
envTRemove
  :: forall e es m a
   . (ElemRemove e es, Functor m)
  => EnvelopeT es m a
  -> EnvelopeT (Remove e es) m (Either a e)
envTRemove (EnvelopeT m) = EnvelopeT $ fmap go m
  where
  go :: Envelope es a -> Envelope (Remove e es) (Either a e)
  go envel =
    case envelopeRemove envel of
      Right e -> SuccEnvelope (Right e)
      Left envel -> fmap Left envel