{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.LCC.Lib.Strict where

-- import Data.Bool
-- import qualified Control.Monad.Classes as MC
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), id, flip)
import Data.Functor (Functor)
import Data.Semigroup (Semigroup(..))
import Data.Strict
import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.State.Strict as SS

-- * Type 'Maybe'

instance Applicative Maybe where
	pure = Just
	Nothing <*> _       = Nothing
	_       <*> Nothing = Nothing
	Just f  <*> Just a  = Just (f a)
instance Monad Maybe where
	return = Just
	Nothing >>= _ = Nothing
	Just a  >>= f = f a

-- * Type 'Either'
left :: (l -> a) -> Either l r -> Either a r
left f = either (Left . f) Right

rights :: [Either l r] -> [r]
rights = foldr (\case Right r -> (r :); _ -> id) []

accumLeftsAndFoldlRights
 :: (Foldable t, Semigroup l)
 => (ra -> r -> ra) -> ra
 -> t (Either l r)
 -> Either l ra
accumLeftsAndFoldlRights f rempty =
	foldl' (flip $ either el er) (Right rempty)
	where
		el l (Left ls)  = Left (l <> ls)
		el l _          = Left l
		er _ (Left ls)  = Left ls
		er r (Right ra) = Right (f ra r)

instance Applicative (Either l) where
	pure = Right
	Left l  <*> _       = Left l
	_       <*> Left l  = Left l
	Right f <*> Right r = Right (f r)
instance Monad (Either l) where
	return = Right
	Left  l >>= _ = Left l
	Right r >>= f = f r

-- * Type 'StateT'
newtype StateT s m a = StateT (SS.StateT s m a)
 deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)

runState :: Monad m => s -> StateT s m a -> m (a, s)
runState s (StateT t) = SS.runStateT t s
evalState :: Monad m => s -> StateT s m a -> m a
evalState s (StateT t) = SS.evalStateT t s

{- NOTE: commented out to be able to have eff being a sub-state of s.
type instance MC.CanDo (StateT s m) eff = StateCanDo s eff
type family StateCanDo s eff where
	StateCanDo s (MC.EffState  s) = 'True
	StateCanDo s (MC.EffReader s) = 'True
	StateCanDo s (MC.EffLocal  s) = 'True
	StateCanDo s (MC.EffWriter s) = 'True
	StateCanDo s eff              = 'False
-}

-- * Type 'ReaderT'
newtype ReaderT s m a = ReaderT (R.ReaderT s m a)
 deriving (Functor, Applicative, Monad, MonadIO)

runReader :: Monad m => r -> ReaderT r m a -> m a
runReader r (ReaderT t) = R.runReaderT t r