mirror of
https://github.com/sayo-hs/heftia.git
synced 2024-11-30 10:59:09 +03:00
[refactor] Modified to use TH as classy-effects-th now supports dependent effect parameters.
This commit is contained in:
parent
d89d6968bc
commit
325b266047
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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,
|
||||||
|
@ -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)
|
||||||
|
@ -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,
|
||||||
|
@ -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,
|
||||||
|
Loading…
Reference in New Issue
Block a user