]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Lib/Strict.hs
Add Sym.Balance.
[comptalang.git] / 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