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

[fix] for data-effects v0.2.

Browse Source
This commit is contained in:
Yamada Ryo 2024-10-03 09:40:50 +09:00
parent 3038caa017
commit 1a10842e34
No known key found for this signature in database
GPG Key ID: AAE3C7A542B02DBF
7 changed files with 47 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cabal.project
View File

@ -5,7 +5,7 @@ packages:
source-repository-package
type: git
location: https://github.com/sayo-hs/data-effects
tag: 9bec944466e19b1142a92922324d81804125fc2f
tag: d1c4acc93914ad40901950aa56c74a733e641e71
subdir: data-effects-core
subdir: data-effects-th
subdir: data-effects

4
heftia-effects/Example/KeyedEffects/Main.hs
View File

@ -8,7 +8,7 @@
module Main where
import Control.Effect (type (~>))
import Control.Effect.Key (SendInsBy)
import Control.Effect.Key (SendFOEBy)
import Control.Monad.Hefty.Interpret (interposeRec, interpretRec, runEff)
import Control.Monad.Hefty.Transform (unkey)
import Control.Monad.Hefty.Types (type (:!!))
@ -29,7 +29,7 @@ teletypeToIO = interpretRec \case
ReadTTY -> liftIO getLine
WriteTTY msg -> liftIO $ putStrLn msg
echo :: (SendInsBy "tty1" Teletype m, Monad m) => m ()
echo :: (SendFOEBy "tty1" Teletype m, Monad m) => m ()
echo = do
i <- readTTY'' @"tty1"
case i of

2
heftia-effects/heftia-effects.cabal
View File

@ -54,7 +54,7 @@ common common-base
build-depends:
base >= 4.16 && < 4.21,
data-effects ^>= 0.1.2,
data-effects ^>= 0.2,
heftia ^>= 0.4,
time,
unliftio,

21
heftia-effects/src/Control/Effect/Interpreter/Heftia/Concurrent/Timer.hs
View File

@ -3,12 +3,16 @@
module Control.Effect.Interpreter.Heftia.Concurrent.Timer where
import Control.Concurrent.Thread.Delay qualified as Thread
import Control.Effect (sendIns, type (~>))
import Control.Effect (type (~>))
import Control.Effect.Interpreter.Heftia.Coroutine (runCoroutine)
import Control.Effect.Interpreter.Heftia.State (evalState)
import Control.Monad.Hefty (HFunctors, interposeRec, interpret, interpretRec, raiseN, raiseNUnder, (:!!), type (<|))
import Control.Monad.Hefty.Interpret (interposeRec, interpret, interpretRec)
import Control.Monad.Hefty.Transform (raise, raiseUnder)
import Control.Monad.Hefty.Types (send, (:!!))
import Data.Effect.Concurrent.Timer (CyclicTimer (Wait), Timer (..), clock, cyclicTimer)
import Data.Effect.Coroutine (Status (Coroutine, Done))
import Data.Effect.Coroutine (Status (Continue, Done))
import Data.Effect.OpenUnion.Internal.FO (type (<|))
import Data.Effect.OpenUnion.Internal.HO (HFunctors)
import Data.Effect.State (get, put)
import Data.Function ((&))
import Data.Time (DiffTime)
@ -29,16 +33,19 @@ runTimerIO =
Sleep t ->
Thread.delay (diffTimeToPicoseconds t `quot` 1000_000) & liftIO
runCyclicTimer :: forall ef. (Timer <| ef) => '[] :!! CyclicTimer ': ef ~> '[] :!! ef
runCyclicTimer
:: forall ef
. (Timer <| ef)
=> '[] :!! CyclicTimer ': ef ~> '[] :!! ef
runCyclicTimer a = do
timer0 :: Status ('[] :!! ef) () DiffTime Void <- runCoroutine cyclicTimer
a
& raiseNUnder @1 @1
& raiseUnder
& interpret \case
Wait delta ->
get @(Status ('[] :!! ef) () DiffTime Void) >>= \case
Done x -> absurd x
Coroutine () k -> put =<< raiseN @1 (k delta)
Continue () k -> put =<< raise (k delta)
& evalState timer0
restartClock :: (Timer <| ef, HFunctors eh) => eh :!! ef ~> eh :!! ef
@ -48,4 +55,4 @@ restartClock a = do
Clock -> do
t <- clock
pure $ t - t0
other -> sendIns other
other -> send other

4
heftia-effects/src/Control/Effect/Interpreter/Heftia/Coroutine.hs
View File

@ -4,10 +4,10 @@ module Control.Effect.Interpreter.Heftia.Coroutine where
import Control.Monad.Hefty.Interpret (interpretBy)
import Control.Monad.Hefty.Types (Eff)
import Data.Effect.Coroutine (Status (Coroutine, Done), Yield (Yield))
import Data.Effect.Coroutine (Status (Continue, Done), Yield (Yield))
runCoroutine
:: forall a b ans r
. Eff '[] (Yield a b ': r) ans
-> Eff '[] r (Status (Eff '[] r) a b ans)
runCoroutine = interpretBy (pure . Done) (\(Yield a) k -> pure $ Coroutine a k)
runCoroutine = interpretBy (pure . Done) (\(Yield a) k -> pure $ Continue a k)

2
heftia/heftia.cabal
View File

@ -89,7 +89,7 @@ library
-- other-extensions:
build-depends:
base >= 4.16 && < 4.21,
data-effects ^>= 0.1.2,
data-effects ^>= 0.2,
freer-simple ^>= 1.2.1.2,
mtl,
unliftio

52
heftia/src/Control/Monad/Hefty/Types.hs
View File

@ -5,8 +5,8 @@
module Control.Monad.Hefty.Types where
import Control.Applicative (Alternative, empty, (<|>))
import Control.Effect (SendIns, SendSig, sendIns, sendSig, type (~>))
import Control.Effect.Key (ByKey (ByKey), SendInsBy, SendSigBy, key, sendInsBy, sendSigBy)
import Control.Effect (SendFOE, SendHOE, sendFOE, sendHOE, type (~>))
import Control.Effect.Key (ByKey (ByKey), SendFOEBy, SendHOEBy, key, sendFOEBy, sendHOEBy)
import Control.Monad (MonadPlus)
import Control.Monad.Error.Class (MonadError, catchError, throwError)
import Control.Monad.Fix (MonadFix, mfix)
@ -76,25 +76,25 @@ instance Monad (Eff eh ef) where
Op e q -> Op e (q |> k)
{-# INLINE (>>=) #-}
instance (e <| ef) => SendIns e (Eff eh ef) where
sendIns = send
{-# INLINE sendIns #-}
instance (e <| ef) => SendFOE e (Eff eh ef) where
sendFOE = send
{-# INLINE sendFOE #-}
instance (e <<| eh) => SendSig e (Eff eh ef) where
sendSig = sendH
{-# INLINE sendSig #-}
instance (e <<| eh) => SendHOE e (Eff eh ef) where
sendHOE = sendH
{-# INLINE sendHOE #-}
instance (MemberBy key e ef) => SendInsBy key e (Eff eh ef) where
sendInsBy = send . Key @key
{-# INLINE sendInsBy #-}
instance (MemberBy key e ef) => SendFOEBy key e (Eff eh ef) where
sendFOEBy = send . Key @key
{-# INLINE sendFOEBy #-}
instance (MemberHBy key e eh) => SendSigBy key e (Eff eh ef) where
sendSigBy = sendH . KeyH @key
{-# INLINE sendSigBy #-}
instance (MemberHBy key e eh) => SendHOEBy key e (Eff eh ef) where
sendHOEBy = sendH . KeyH @key
{-# INLINE sendHOEBy #-}
instance
( SendInsBy ReaderKey (Ask r) (Eff eh ef)
, SendSigBy ReaderKey (Local r) (Eff eh ef)
( SendFOEBy ReaderKey (Ask r) (Eff eh ef)
, SendHOEBy ReaderKey (Local r) (Eff eh ef)
)
=> MonadReader r (Eff eh ef)
where
@ -106,8 +106,8 @@ instance
data ReaderKey
instance
( SendInsBy WriterKey (Tell w) (Eff eh ef)
, SendSigBy WriterKey (WriterH w) (Eff eh ef)
( SendFOEBy WriterKey (Tell w) (Eff eh ef)
, SendHOEBy WriterKey (WriterH w) (Eff eh ef)
, Monoid w
)
=> MonadWriter w (Eff eh ef)
@ -121,7 +121,7 @@ instance
data WriterKey
instance
(SendInsBy StateKey (State s) (Eff eh ef))
(SendFOEBy StateKey (State s) (Eff eh ef))
=> MonadState s (Eff eh ef)
where
get = get'' @StateKey
@ -132,8 +132,8 @@ instance
data StateKey
instance
( SendInsBy ErrorKey (Throw e) (Eff eh ef)
, SendSigBy ErrorKey (Catch e) (Eff eh ef)
( SendFOEBy ErrorKey (Throw e) (Eff eh ef)
, SendHOEBy ErrorKey (Catch e) (Eff eh ef)
)
=> MonadError e (Eff eh ef)
where
@ -145,11 +145,11 @@ instance
data ErrorKey
instance
( SendInsBy ReaderKey (Ask r) (Eff eh ef)
, SendSigBy ReaderKey (Local r) (Eff eh ef)
, SendInsBy WriterKey (Tell w) (Eff eh ef)
, SendSigBy WriterKey (WriterH w) (Eff eh ef)
, SendInsBy StateKey (State s) (Eff eh ef)
( SendFOEBy ReaderKey (Ask r) (Eff eh ef)
, SendHOEBy ReaderKey (Local r) (Eff eh ef)
, SendFOEBy WriterKey (Tell w) (Eff eh ef)
, SendHOEBy WriterKey (WriterH w) (Eff eh ef)
, SendFOEBy StateKey (State s) (Eff eh ef)
, Monoid w
)
=> MonadRWS r w s (Eff eh ef)