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