lcc/Hcompta/LCC/Lib/Strict.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Hcompta.LCC.Lib.Strict where
   5
   6 -- import Data.Bool
   7 -- import qualified Control.Monad.Classes as MC
   8 import Control.Applicative (Applicative(..))
   9 import Control.Monad (Monad(..))
  10 import Control.Monad.IO.Class (MonadIO(..))
  11 import Control.Monad.Trans.Class (MonadTrans(..))
  12 import Data.Foldable (Foldable(..))
  13 import Data.Function (($), (.), id, flip)
  14 import Data.Functor (Functor)
  15 import Data.Semigroup (Semigroup(..))
  16 import Data.Strict
  17 import qualified Control.Monad.Trans.Reader as R
  18 import qualified Control.Monad.Trans.State.Strict as SS
  19
  20 -- * Type 'Maybe'
  21
  22 instance Applicative Maybe where
  23         pure = Just
  24         Nothing <*> _       = Nothing
  25         _       <*> Nothing = Nothing
  26         Just f  <*> Just a  = Just (f a)
  27 instance Monad Maybe where
  28         return = Just
  29         Nothing >>= _ = Nothing
  30         Just a  >>= f = f a
  31
  32 -- * Type 'Either'
  33 left :: (l -> a) -> Either l r -> Either a r
  34 left f = either (Left . f) Right
  35
  36 rights :: [Either l r] -> [r]
  37 rights = foldr (\case Right r -> (r :); _ -> id) []
  38
  39 accumLeftsAndFoldlRights
  40  :: (Foldable t, Semigroup l)
  41  => (ra -> r -> ra) -> ra
  42  -> t (Either l r)
  43  -> Either l ra
  44 accumLeftsAndFoldlRights f rempty =
  45         foldl' (flip $ either el er) (Right rempty)
  46         where
  47                 el l (Left ls)  = Left (l <> ls)
  48                 el l _          = Left l
  49                 er _ (Left ls)  = Left ls
  50                 er r (Right ra) = Right (f ra r)
  51
  52 instance Applicative (Either l) where
  53         pure = Right
  54         Left l  <*> _       = Left l
  55         _       <*> Left l  = Left l
  56         Right f <*> Right r = Right (f r)
  57 instance Monad (Either l) where
  58         return = Right
  59         Left  l >>= _ = Left l
  60         Right r >>= f = f r
  61
  62 -- * Type 'StateT'
  63 newtype StateT s m a = StateT (SS.StateT s m a)
  64  deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)
  65
  66 runState :: Monad m => s -> StateT s m a -> m (a, s)
  67 runState s (StateT t) = SS.runStateT t s
  68 evalState :: Monad m => s -> StateT s m a -> m a
  69 evalState s (StateT t) = SS.evalStateT t s
  70
  71 {- NOTE: commented out to be able to have eff being a sub-state of s.
  72 type instance MC.CanDo (StateT s m) eff = StateCanDo s eff
  73 type family StateCanDo s eff where
  74         StateCanDo s (MC.EffState  s) = 'True
  75         StateCanDo s (MC.EffReader s) = 'True
  76         StateCanDo s (MC.EffLocal  s) = 'True
  77         StateCanDo s (MC.EffWriter s) = 'True
  78         StateCanDo s eff              = 'False
  79 -}
  80
  81 -- * Type 'ReaderT'
  82 newtype ReaderT s m a = ReaderT (R.ReaderT s m a)
  83  deriving (Functor, Applicative, Monad, MonadIO)
  84
  85 runReader :: Monad m => r -> ReaderT r m a -> m a
  86 runReader r (ReaderT t) = R.runReaderT t r