sayo-hs/heftia
1
1
Fork 0
mirror of https://github.com/sayo-hs/heftia.git synced 2024-11-27 15:45:19 +03:00
Code Issues Actions Packages Projects Releases Wiki Activity

[add] Alternative/MonadPlus instances to the wrapper data type.

Browse Source
This commit is contained in:
Yamada Ryo 2024-07-16 01:22:40 +09:00
parent 9aa4fdcf3a
commit 554ac38173
No known key found for this signature in database
GPG Key ID: AAE3C7A542B02DBF
1 changed files with 24 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
heftia/src/Control/Hefty.hs
View File

@ -8,7 +8,7 @@
module Control.Hefty where module Control.Hefty where
import Control.Applicative (Alternative) import Control.Applicative (Alternative, empty, (<|>))
import Control.Effect (SendIns (..), SendSig (..), type (~>)) import Control.Effect (SendIns (..), SendSig (..), type (~>))
import Control.Effect.Key (ByKey (ByKey), SendInsBy, SendSigBy, key, sendInsBy, sendSigBy) import Control.Effect.Key (ByKey (ByKey), SendInsBy, SendSigBy, key, sendInsBy, sendSigBy)
import Control.Freer (Freer (liftIns), InjectIns, InjectInsBy, StateKey, injectIns, injectInsBy) import Control.Freer (Freer (liftIns), InjectIns, InjectInsBy, StateKey, injectIns, injectInsBy)
@ -25,6 +25,8 @@ import Data.Effect.Fail (Fail)
import Data.Effect.Fail qualified as E import Data.Effect.Fail qualified as E
import Data.Effect.Fix (Fix) import Data.Effect.Fix (Fix)
import Data.Effect.Fix qualified as E import Data.Effect.Fix qualified as E
import Data.Effect.NonDet (Choose, Empty, choose)
import Data.Effect.NonDet qualified as NonDet
import Data.Effect.Reader (Ask, Local, ask'', local'') import Data.Effect.Reader (Ask, Local, ask'', local'')
import Data.Effect.State (State, get'', put'') import Data.Effect.State (State, get'', put'')
import Data.Effect.Unlift (UnliftIO, pattern WithRunInIO) import Data.Effect.Unlift (UnliftIO, pattern WithRunInIO)
@ -43,9 +45,7 @@ newtype
deriving newtype instance Functor (f (e (Hefty f e))) => Functor (Hefty f e) deriving newtype instance Functor (f (e (Hefty f e))) => Functor (Hefty f e)
deriving newtype instance Applicative (f (e (Hefty f e))) => Applicative (Hefty f e) deriving newtype instance Applicative (f (e (Hefty f e))) => Applicative (Hefty f e)
deriving newtype instance Alternative (f (e (Hefty f e))) => Alternative (Hefty f e)
deriving newtype instance Monad (f (e (Hefty f e))) => Monad (Hefty f e) deriving newtype instance Monad (f (e (Hefty f e))) => Monad (Hefty f e)
deriving newtype instance MonadPlus (f (e (Hefty f e))) => MonadPlus (Hefty f e)
deriving newtype instance (MonadBase b (f (e (Hefty f e))), Monad b) => MonadBase b (Hefty f e) deriving newtype instance (MonadBase b (f (e (Hefty f e))), Monad b) => MonadBase b (Hefty f e)
deriving newtype instance Foldable (f (e (Hefty f e))) => Foldable (Hefty f e) deriving newtype instance Foldable (f (e (Hefty f e))) => Foldable (Hefty f e)
@ -137,6 +137,27 @@ instance
) => ) =>
MonadRWS r w s (Hefty fr e) MonadRWS r w s (Hefty fr e)
instance
( Freer c fr
, InjectIns Empty (e (Hefty fr e))
, InjectSig Choose e
, Applicative (fr (e (Hefty fr e)))
) =>
Alternative (Hefty fr e)
where
empty = NonDet.empty
a <|> b = choose a b
{-# INLINE empty #-}
{-# INLINE (<|>) #-}
instance
( Freer c fr
, InjectIns Empty (e (Hefty fr e))
, InjectSig Choose e
, Monad (fr (e (Hefty fr e)))
) =>
MonadPlus (Hefty fr e)
instance (Freer c fr, InjectIns IO (e (Hefty fr e)), Monad (fr (e (Hefty fr e)))) => MonadIO (Hefty fr e) where instance (Freer c fr, InjectIns IO (e (Hefty fr e)), Monad (fr (e (Hefty fr e)))) => MonadIO (Hefty fr e) where
liftIO = sendIns liftIO = sendIns
{-# INLINE liftIO #-} {-# INLINE liftIO #-}