[refactor] Modified to use TH as classy-effects-th now supports dependent effect parameters.

This commit is contained in:
Yamada Ryo 2023-10-03 13:27:46 +09:00
parent d89d6968bc
commit 325b266047
No known key found for this signature in database
GPG Key ID: AAE3C7A542B02DBF
6 changed files with 8 additions and 34 deletions

View File

@ -5,7 +5,7 @@ packages:
source-repository-package source-repository-package
type: git type: git
location: https://github.com/sayo-hs/classy-effects location: https://github.com/sayo-hs/classy-effects
tag: 86dda61d2f4d5c66fd754a606775efb55dea0977 tag: fe8bcc5e5be492a021a464a887dd120f138c2d91
subdir: classy-effects-base subdir: classy-effects-base
subdir: classy-effects-th subdir: classy-effects-th
subdir: classy-effects subdir: classy-effects

View File

@ -14,8 +14,6 @@ The original of this example can be found at polysemy.
module Main where module Main where
import Control.Effect.Class ( import Control.Effect.Class (
EffectDataHandler,
EffectsVia (EffectsVia),
Taggable, Taggable,
getTag, getTag,
sendIns, sendIns,
@ -24,20 +22,11 @@ import Control.Effect.Class (
type (@#), type (@#),
type (~>), type (~>),
) )
import Control.Effect.Class.Machinery.DepParam ( import Control.Effect.Class.Machinery.DepParams (type (#-))
DepParams, import Control.Effect.Class.Machinery.TH (makeEffectF)
DepParamsFor,
DepParamsOf,
EffectClassIdentifierOf,
InsClassOf,
SendInsDep,
type (#-),
)
import Control.Effect.Freer (Fre, interpose, interpret, runFreerEffects, untag, type (<|-)) import Control.Effect.Freer (Fre, interpose, interpret, runFreerEffects, untag, type (<|-))
import Data.Effect.Class.TH (makeInstruction)
import Data.Free.Union (FindFirstDepParams, InsClassIn) import Data.Free.Union (FindFirstDepParams, InsClassIn)
import Data.Function ((&)) import Data.Function ((&))
import Data.Kind (Type)
import Data.String (IsString) import Data.String (IsString)
import Data.Tuple (Solo (Solo)) import Data.Tuple (Solo (Solo))
@ -45,22 +34,7 @@ class Teletype s f | f -> s where
readTTY :: f s readTTY :: f s
writeTTY :: s -> f () writeTTY :: s -> f ()
data I'Teletype makeEffectF ''Teletype
type instance DepParams I'Teletype = Solo Type
makeInstruction ''Teletype
type instance InsClassOf I'Teletype ('Solo s) = TeletypeI s
type instance EffectClassIdentifierOf (TeletypeI s) = I'Teletype
type instance DepParamsOf (TeletypeI s) = 'Solo s
instance
(SendInsDep I'Teletype f, 'Solo s ~ DepParamsFor I'Teletype f) =>
Teletype s (EffectsVia EffectDataHandler f)
where
readTTY = EffectsVia . sendIns $ ReadTTY
writeTTY = EffectsVia . sendIns . WriteTTY
teletypeToIO :: (IO <: Fre es m, Monad m) => Fre (TeletypeI String ': es) m ~> Fre es m teletypeToIO :: (IO <: Fre es m, Monad m) => Fre (TeletypeI String ': es) m ~> Fre es m
teletypeToIO = interpret \case teletypeToIO = interpret \case

View File

@ -35,7 +35,7 @@ import Control.Effect.Class (
type (~>), type (~>),
) )
import Control.Effect.Class.Fail (FailI (Fail)) import Control.Effect.Class.Fail (FailI (Fail))
import Control.Effect.Class.Machinery.DepParam (QueryDepParamsFor) import Control.Effect.Class.Machinery.DepParams (QueryDepParamsFor)
import Control.Freer.Trans ( import Control.Freer.Trans (
TransFreer, TransFreer,
hoistFreer, hoistFreer,

View File

@ -38,7 +38,7 @@ import Control.Effect.Class (
) )
import Control.Effect.Class.Fail (FailI (Fail)) import Control.Effect.Class.Fail (FailI (Fail))
import Control.Effect.Class.Fix (FixS (Mfix)) import Control.Effect.Class.Fix (FixS (Mfix))
import Control.Effect.Class.Machinery.DepParam (QueryDepParamsFor) import Control.Effect.Class.Machinery.DepParams (QueryDepParamsFor)
import Control.Effect.Class.Machinery.HFunctor (HFunctor, hfmap) import Control.Effect.Class.Machinery.HFunctor (HFunctor, hfmap)
import Control.Effect.Freer (FreerEffects, freerEffects, interpose, unFreerEffects) import Control.Effect.Freer (FreerEffects, freerEffects, interpose, unFreerEffects)
import Control.Freer.Trans (TransFreer, interpretFT, liftInsT, liftLowerFT) import Control.Freer.Trans (TransFreer, interpretFT, liftInsT, liftLowerFT)

View File

@ -16,7 +16,7 @@ implementation.
module Data.Free.Union where module Data.Free.Union where
import Control.Effect.Class (Instruction, type (~>)) import Control.Effect.Class (Instruction, type (~>))
import Control.Effect.Class.Machinery.DepParam ( import Control.Effect.Class.Machinery.DepParams (
DepParams, DepParams,
DepParamsOf, DepParamsOf,
EffectClassIdentifier, EffectClassIdentifier,

View File

@ -17,7 +17,7 @@ implementation.
module Data.Hefty.Union where module Data.Hefty.Union where
import Control.Effect.Class (Signature, type (~>)) import Control.Effect.Class (Signature, type (~>))
import Control.Effect.Class.Machinery.DepParam ( import Control.Effect.Class.Machinery.DepParams (
DepParams, DepParams,
DepParamsOfH, DepParamsOfH,
EffectClassIdentifier, EffectClassIdentifier,