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

[refactor] Formatting.

Browse Source
This commit is contained in:
Yamada Ryo 2024-07-08 20:03:47 +09:00
parent d306f22d29
commit b298e9a4c2
No known key found for this signature in database
GPG Key ID: AAE3C7A542B02DBF
20 changed files with 228 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
fourmolu.yaml Normal file
View File

@ -0,0 +1,10 @@
indentation: 4
comma-style: leading
import-export-style: diff-friendly
indent-wheres: false
record-brace-space: true
respectful: true
haddock-style: multi-line
newlines-between-decls: 1
fixities: []
function-arrows: leading

16
heftia-effects/Example/Continuation/Main.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
@ -7,12 +7,12 @@
module Main where
import Data.Effect.TH (makeEffectF, makeEffectH)
import Control.Effect.ExtensibleChurch (runEff, type (:!!))
import Control.Effect (SendIns (sendIns), type (~>))
import Control.Effect.Hefty (interpretRec, interposeK, interpretH)
import Data.Hefty.Extensible (ForallHFunctor, type (<|))
import Control.Effect.ExtensibleChurch (runEff, type (:!!))
import Control.Effect.Hefty (interposeK, interpretH, interpretRec)
import Data.Effect.TH (makeEffectF, makeEffectH)
import Data.Function ((&))
import Data.Hefty.Extensible (ForallHFunctor, type (<|))
type ForkID = Int
@ -36,9 +36,9 @@ applyResetFork numberOfFork (ResetFork m) =
main :: IO ()
main =
runEff
. runForkSingle
. interpretH (applyResetFork 4)
$ do
. runForkSingle
. interpretH (applyResetFork 4)
$ do
sendIns . putStrLn . (("[out of scope] " ++) . show) =<< fork
s <- resetFork do
fid1 <- fork

2
heftia-effects/Example/Continuation2/Main.hs
View File

@ -6,8 +6,8 @@ module Main where
import Control.Effect (sendIns)
import Control.Effect.ExtensibleChurch (runEff, type (!!))
import Control.Effect.Handler.Heftia.ShiftReset (Shift, Shift_, getCC, getCC_, runShift, runShift_)
import Control.Effect.Handler.Heftia.Reader (elaborateLocal, interpretAsk)
import Control.Effect.Handler.Heftia.ShiftReset (Shift, Shift_, getCC, getCC_, runShift, runShift_)
import Control.Effect.Handler.Heftia.State (evalState)
import Control.Effect.Hefty (interpretH, send1, type ($))
import Control.Monad.Extra (whenM)

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

@ -10,10 +10,10 @@ module Main where
import Control.Effect (SendIns (sendIns), type (~>))
import Control.Effect.ExtensibleChurch (runEff, type (:!!))
import Control.Effect.Hefty (interposeRec, interpretRec, unkeyEff)
import Data.Effect.TH (makeEffectF)
import Data.Hefty.Extensible (type (<|), MemberBy, ForallHFunctor)
import Data.Effect.Key (type (#>), unKey)
import Control.Effect.Key (SendInsBy)
import Data.Effect.Key (unKey, type (#>))
import Data.Effect.TH (makeEffectF)
import Data.Hefty.Extensible (ForallHFunctor, MemberBy, type (<|))
data Teletype a where
ReadTTY :: Teletype String

76
heftia-effects/Example/Logging/Main.hs
View File

@ -1,30 +1,31 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.
module Main where
import Data.Text (Text)
import Data.Kind (Type)
import Data.Effect.TH (makeEffectF, makeEffectH)
import Data.Hefty.Extensible (type (<|), type (<<|), ForallHFunctor)
import Control.Effect.ExtensibleChurch (runEff, type (:!!))
import Control.Effect (type (~>), sendIns, type (<:), type (<<:))
import Control.Effect.Hefty (interpretRec, interposeRec, interpretRecH, interposeRec, raise, raiseH, interposeRecH)
import qualified Data.Text.IO as T
import Data.Time (UTCTime, getCurrentTime)
import qualified Data.Text as T
import Data.Effect.State (get, modify)
import Control.Effect.Handler.Heftia.State (evalState)
import Data.Function ((&))
import Control.Monad (when)
import Control.Effect.Handler.Heftia.Reader (interpretReader)
import Data.Effect.Reader (local, ask)
import Data.Time.Format.ISO8601 (iso8601Show)
import Control.Arrow ((>>>))
import Control.Effect (sendIns, type (<:), type (<<:), type (~>))
import Control.Effect.ExtensibleChurch (runEff, type (:!!))
import Control.Effect.Handler.Heftia.Reader (interpretReader)
import Control.Effect.Handler.Heftia.State (evalState)
import Control.Effect.Hefty (interposeRec, interposeRecH, interpretRec, interpretRecH, raise, raiseH)
import Control.Monad (when)
import Data.Effect.Reader (ask, local)
import Data.Effect.State (get, modify)
import Data.Effect.TH (makeEffectF, makeEffectH)
import Data.Function ((&))
import Data.Hefty.Extensible (ForallHFunctor, type (<<|), type (<|))
import Data.Kind (Type)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Time (UTCTime, getCurrentTime)
import Data.Time.Format.ISO8601 (iso8601Show)
data Log a where
Logging :: Text -> Log ()
@ -62,9 +63,11 @@ runLogChunk :: ForallHFunctor eh => LogChunk ': eh :!! ef ~> eh :!! ef
runLogChunk = interpretRecH \(LogChunk _ m) -> m
-- | Limit the number of logs in a log chunk to the first @n@ logs.
limitLogChunk
:: forall eh ef. (LogChunk <<| eh, Log <| ef) =>
Int -> LogChunk ('[] :!! ef) ~> LogChunk ('[] :!! ef)
limitLogChunk ::
forall eh ef.
(LogChunk <<| eh, Log <| ef) =>
Int ->
LogChunk ('[] :!! ef) ~> LogChunk ('[] :!! ef)
limitLogChunk n (LogChunk chunkName a) =
LogChunk chunkName . evalState @Int 0 $
raise a & interposeRec \(Logging msg) -> do
@ -90,12 +93,13 @@ runDummyFS = interpretRec \case
sendIns $ putStrLn $ "<runDummyFS> writeToFile " <> path <> " : " <> content
-- | Create directories according to the log-chunk structure and save one log in one file.
saveLogChunk
:: forall eh ef. (LogChunk <<| eh, Log <| ef, FileSystem <| ef, Time <| ef, ForallHFunctor eh) =>
eh :!! ef ~> eh :!! ef
saveLogChunk ::
forall eh ef.
(LogChunk <<| eh, Log <| ef, FileSystem <| ef, Time <| ef, ForallHFunctor eh) =>
eh :!! ef ~> eh :!! ef
saveLogChunk =
raise >>> raiseH
>>> ( interposeRecH \(LogChunk chunkName a) -> do
raise >>> raiseH
>>> ( interposeRecH \(LogChunk chunkName a) -> do
chunkBeginAt <- currentTime
let dirName = iso8601Show chunkBeginAt ++ "-" ++ T.unpack chunkName
local @FilePath (++ dirName ++ "/") do
@ -105,8 +109,8 @@ saveLogChunk =
logAt <- currentTime
logging msg
writeToFile (logChunkPath ++ iso8601Show logAt ++ ".log") (show msg)
)
>>> interpretReader @FilePath "./log/"
)
>>> interpretReader @FilePath "./log/"
logExample :: (LogChunk <<: m, Log <: m, IO <: m, Monad m) => m ()
logExample =
@ -132,14 +136,14 @@ logExample =
main :: IO ()
main =
runEff
. logToIO
. timeToIO
. logWithTime
. runDummyFS
. runLogChunk
. saveLogChunk
$ do
logExample
. logToIO
. timeToIO
. logWithTime
. runDummyFS
. runLogChunk
. saveLogChunk
$ do
logExample
{-
<runDummyFS> mkdir ./log/2024-07-06T13:56:23.447829919Z-scope1/

2
heftia-effects/Example/Teletype/Main.hs
View File

@ -16,7 +16,7 @@ import Control.Effect.ExtensibleChurch (runEff, type (:!!))
import Control.Effect.Hefty (interposeRec, interpretRec, untagEff)
import Data.Effect.TH (makeEffectF)
import Data.Effect.Tag (Tag (unTag), type (#))
import Data.Hefty.Extensible (type (<|), ForallHFunctor)
import Data.Hefty.Extensible (ForallHFunctor, type (<|))
data Teletype a where
ReadTTY :: Teletype String

12
heftia-effects/Example/Writer/Main.hs
View File

@ -19,12 +19,12 @@ censorHello :: (Tell String <: m, WriterH String <<: m, Monad m) => m ()
censorHello =
censor
( \s ->
if s == "Hello" then
"Goodbye"
else if s == "Hello world!" then
"Hello world!!"
else
s
if s == "Hello"
then "Goodbye"
else
if s == "Hello world!"
then "Hello world!!"
else s
)
hello

8
heftia-effects/src/Control/Effect/Handler/Heftia/Coroutine.hs
View File

@ -4,21 +4,23 @@
module Control.Effect.Handler.Heftia.Coroutine where
import Data.Effect.Coroutine (continueStatus, replyCoroutine, LYield, Status (Done, Coroutine), YieldH (YieldH))
import Control.Effect.Hefty (Eff, interpretK, interpretKH_)
import Control.Monad.Freer (MonadFreer)
import Data.Effect.Coroutine (LYield, Status (Coroutine, Done), YieldH (YieldH), continueStatus, replyCoroutine)
import Data.Hefty.Union (Union)
runCoroutine ::
forall a b r er fr u c.
(MonadFreer c fr, Union u, c (Eff u fr '[] er)) =>
Eff u fr '[] (LYield a b ': er) r -> Eff u fr '[] er (Status (Eff u fr '[] er) a b r)
Eff u fr '[] (LYield a b ': er) r ->
Eff u fr '[] er (Status (Eff u fr '[] er) a b r)
runCoroutine = interpretK (pure . Done) (\kk y -> pure $ replyCoroutine y kk)
runCoroutineH ::
forall a b r ef fr u c.
(MonadFreer c fr, Union u, c (Eff u fr '[] ef)) =>
Eff u fr '[YieldH a b] ef r -> Eff u fr '[] ef (Status (Eff u fr '[] ef) a b r)
Eff u fr '[YieldH a b] ef r ->
Eff u fr '[] ef (Status (Eff u fr '[] ef) a b r)
runCoroutineH =
interpretKH_ (pure . Done) \kk (YieldH a k) ->
pure $ Coroutine a \b ->

2
heftia-effects/src/Control/Effect/Handler/Heftia/Except.hs
View File

@ -27,7 +27,7 @@ import Control.Monad.Freer (MonadFreer)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Data.Effect.Except (Catch (Catch), LThrow, Throw (Throw))
import Data.Function ((&))
import Data.Hefty.Union (Union, Member)
import Data.Hefty.Union (Member, Union)
-- | Elaborate the t'Catch' effect using the 'ExceptT' monad transformer.
elaborateCatch ::

45
heftia-effects/src/Control/Effect/Handler/Heftia/Input.hs
View File

@ -10,46 +10,53 @@ Stability : experimental
Portability : portable
-}
module Control.Effect.Handler.Heftia.Input where
import Control.Freer (Freer)
import Data.Hefty.Union (Union (HasMembership))
import Control.Effect.Hefty (Eff, interpret, interpretRec, raiseUnder)
import Data.Effect.HFunctor (HFunctor)
import Data.Effect.Input (Input(Input), LInput)
import Control.Effect (type (~>))
import Control.Arrow ((>>>))
import Control.Effect (type (~>))
import Control.Effect.Handler.Heftia.State (evalState)
import Control.Effect.Hefty (Eff, interpret, interpretRec, raiseUnder)
import Control.Freer (Freer)
import Control.Monad.State (StateT)
import Data.Effect.HFunctor (HFunctor)
import Data.Effect.Input (Input (Input), LInput)
import Data.Effect.State (LState, gets, put)
import Data.Hefty.Union (Union (HasMembership))
import Data.List (uncons)
runInputEff ::
forall i r eh fr u c.
(Freer c fr, Union u, Applicative (Eff u fr eh r), HFunctor (u eh)) =>
Eff u fr eh r i -> Eff u fr eh (LInput i ': r) ~> Eff u fr eh r
Eff u fr eh r i ->
Eff u fr eh (LInput i ': r) ~> Eff u fr eh r
runInputEff a = interpretRec \Input -> a
{-# INLINE runInputEff #-}
runInputConst ::
forall i r eh fr u c.
(Freer c fr, Union u, Applicative (Eff u fr eh r), HFunctor (u eh)) =>
i -> Eff u fr eh (LInput i ': r) ~> Eff u fr eh r
i ->
Eff u fr eh (LInput i ': r) ~> Eff u fr eh r
runInputConst i = interpretRec \Input -> pure i
{-# INLINE runInputConst #-}
runInputList ::
forall i r fr u c.
( Freer c fr, Union u
, Applicative (Eff u fr '[] r), Monad (Eff u fr '[] (LState [i] ': r))
, c (Eff u fr '[] r), c (StateT [i] (Eff u fr '[] r))
( Freer c fr
, Union u
, Applicative (Eff u fr '[] r)
, Monad (Eff u fr '[] (LState [i] ': r))
, c (Eff u fr '[] r)
, c (StateT [i] (Eff u fr '[] r))
, HasMembership u (LState [i]) (LState [i] ': r)
, HFunctor (u '[])
) =>
[i] -> Eff u fr '[] (LInput (Maybe i) ': r) ~> Eff u fr '[] r
[i] ->
Eff u fr '[] (LInput (Maybe i) ': r) ~> Eff u fr '[] r
runInputList is =
raiseUnder
>>> ( interpret \Input -> do
is' <- gets @[i] uncons
mapM_ (put . snd) is'
pure $ fst <$> is'
)
>>> evalState is
raiseUnder
>>> ( interpret \Input -> do
is' <- gets @[i] uncons
mapM_ (put . snd) is'
pure $ fst <$> is'
)
>>> evalState is

2
heftia-effects/src/Control/Effect/Handler/Heftia/Reader.hs
View File

@ -27,7 +27,7 @@ import Control.Freer (Freer)
import Data.Effect.HFunctor (HFunctor)
import Data.Effect.Reader (Ask (..), LAsk, Local (..), ask)
import Data.Function ((&))
import Data.Hefty.Union (ForallHFunctor, HFunctorUnion, Union, Member)
import Data.Hefty.Union (ForallHFunctor, HFunctorUnion, Member, Union)
interpretReader ::
forall r rh rf fr u c.

6
heftia-effects/src/Control/Effect/Handler/Heftia/State.hs
View File

@ -18,7 +18,8 @@ module Control.Effect.Handler.Heftia.State where
import Control.Arrow ((>>>))
import Control.Effect (type (~>))
import Control.Effect.Handler.Heftia.Reader (interpretAsk)
import Control.Effect.Hefty (Eff, interpose, interpretK, raiseUnder, interposeT, interpretFin, injectF)
import Control.Effect.Hefty (Eff, injectF, interpose, interposeT, interpretFin, interpretK, raiseUnder)
import Control.Freer (Freer)
import Control.Monad.Freer (MonadFreer)
import Control.Monad.State (StateT)
import Control.Monad.Trans.State (runStateT)
@ -28,9 +29,8 @@ import Data.Effect.Reader (Ask (Ask), LAsk, ask)
import Data.Effect.State (LState, State (Get, Put), get, put)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Hefty.Union (Union, Member)
import Data.Hefty.Union (Member, Union)
import Data.Tuple (swap)
import Control.Freer (Freer)
-- | Interpret the 'Get'/'Put' effects using the 'StateT' monad transformer.
interpretState ::

8
heftia-effects/src/Control/Effect/Handler/Heftia/Unlift.hs
View File

@ -11,12 +11,12 @@ Portability : portable
-}
module Control.Effect.Handler.Heftia.Unlift where
import Control.Freer (Freer)
import Data.Hefty.Union (Union)
import Control.Effect.Hefty (Eff, interpretH_, send0, runEff)
import Data.Effect.Unlift (UnliftBase (WithRunInBase), UnliftIO)
import Control.Effect (type (~>))
import Control.Effect.Hefty (Eff, interpretH_, runEff, send0)
import Control.Freer (Freer)
import Data.Effect (LiftIns)
import Data.Effect.Unlift (UnliftBase (WithRunInBase), UnliftIO)
import Data.Hefty.Union (Union)
runUnliftBase ::
forall b fr u c.

22
heftia-effects/src/Control/Effect/Handler/Heftia/Writer.hs
View File

@ -17,17 +17,17 @@ See [README.md](https://github.com/sayo-hs/heftia/blob/master/README.md).
module Control.Effect.Handler.Heftia.Writer where
import Control.Effect (type (~>))
import Control.Effect.Hefty (Eff, Elab, interposeT, interpretK, interpretT, rewrite, interpretFin, interposeFin, injectF)
import Control.Effect.Hefty (Eff, Elab, injectF, interposeFin, interposeT, interpretFin, interpretK, interpretT, rewrite)
import Control.Freer (Freer)
import Control.Monad.Freer (MonadFreer)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Writer.CPS qualified as CPS
import Control.Monad.Trans.Writer.Strict qualified as Strict
import Data.Effect.HFunctor (HFunctor)
import Data.Effect.Writer (LTell, Tell (Tell), WriterH (Censor, Listen), tell)
import Data.Function ((&))
import Data.Hefty.Union (Union, Member)
import Data.Hefty.Union (Member, Union)
import Data.Tuple (swap)
import Control.Monad.Trans (lift)
import Control.Freer (Freer)
elaborateWriterPost ::
forall w ef fr u c.
@ -54,13 +54,13 @@ postCensor ::
, Monad (Eff u fr '[] es)
, c (CPS.WriterT w (Eff u fr '[] es))
) =>
(w -> w) -> Eff u fr '[] es ~> Eff u fr '[] es
(w -> w) ->
Eff u fr '[] es ~> Eff u fr '[] es
postCensor f m = do
(a, w) <- CPS.runWriterT $ confiscateT m
tell $ f w
pure a
elaborateWriterPre ::
forall w ef fr u c.
( Monoid w
@ -92,11 +92,12 @@ elaborateWriterPre' = \case
Censor f m -> preCensor f m
preCensor ::
forall w es fr u c. (Freer c fr, Member u (Tell w) es, Union u, HFunctor (u '[])) =>
(w -> w) -> Eff u fr '[] es ~> Eff u fr '[] es
forall w es fr u c.
(Freer c fr, Member u (Tell w) es, Union u, HFunctor (u '[])) =>
(w -> w) ->
Eff u fr '[] es ~> Eff u fr '[] es
preCensor f = rewrite @(Tell w) \(Tell w) -> Tell $ f w
listenT ::
forall w es a fr u c.
( Monoid w
@ -130,7 +131,6 @@ listenT' m =
m & interposeFin @(Tell w) (liftStrictWriterT . injectF) \(Tell w) -> do
liftStrictWriterT (tell w) *> tellStrictWriterT w
interpretTell ::
(Monoid w, Freer c fr, Union u, Monad (Eff u fr '[] r), c (CPS.WriterT w (Eff u fr '[] r))) =>
Eff u fr '[] (LTell w ': r) a ->
@ -166,7 +166,6 @@ interpretTellK =
(w', r) <- k ()
pure (w <> w', r)
liftStrictWriterT :: forall w f. (Monoid w, Functor f) => f ~> Strict.WriterT w f
liftStrictWriterT = Strict.WriterT . ((,mempty) <$>)
{-# INLINE liftStrictWriterT #-}
@ -175,7 +174,6 @@ tellStrictWriterT :: forall w f. Applicative f => w -> Strict.WriterT w f ()
tellStrictWriterT = Strict.WriterT . pure . ((),)
{-# INLINE tellStrictWriterT #-}
transactWriter ::
forall w es a fr u c.
( Monoid w

2
heftia/src/Control/Effect/Free.hs
View File

@ -23,7 +23,7 @@ import Control.Freer (Freer, InjectIns, ViaFreer (ViaFreer), injectIns, transfor
import Control.Hefty (Hefty (Hefty), unHefty)
import Data.Effect (LiftIns (LiftIns), Nop, SigClass)
import Data.Free.Sum (pattern R1)
import Data.Hefty.Union (U, Union, exhaust, injectRec, Member)
import Data.Hefty.Union (Member, U, Union, exhaust, injectRec)
{- |
A common type for representing first-order extensible effectful programs that can issue effects

20
heftia/src/Control/Effect/Hefty.hs
View File

@ -17,8 +17,8 @@ on [@classy-effects@](https://hackage.haskell.org/package/classy-effects).
module Control.Effect.Hefty where
import Control.Effect (type (~>))
import Control.Freer (Freer, InjectIns, injectIns, interpretFreer, liftIns, transformFreer, InjectInsBy, injectInsBy)
import Control.Hefty (Hefty (Hefty), InjectSig, injectSig, overHefty, unHefty, InjectSigBy, injectSigBy)
import Control.Freer (Freer, InjectIns, InjectInsBy, injectIns, injectInsBy, interpretFreer, liftIns, transformFreer)
import Control.Hefty (Hefty (Hefty), InjectSig, InjectSigBy, injectSig, injectSigBy, overHefty, unHefty)
import Control.Monad.Cont (Cont, ContT (ContT), lift, runContT)
import Control.Monad.Freer (MonadFreer, interpretFreerK)
import Control.Monad.Identity (Identity (Identity))
@ -26,6 +26,7 @@ import Control.Monad.Trans (MonadTrans)
import Data.Coerce (coerce)
import Data.Effect (LiftIns (LiftIns), Nop, SigClass, unliftIns)
import Data.Effect.HFunctor (HFunctor, caseH, hfmap, (:+:))
import Data.Effect.Key (Key (Key), unKey, unKeyH, type (##>), type (#>))
import Data.Effect.Tag (Tag (unTag), TagH (unTagH), type (#), type (##))
import Data.Free.Sum (caseF, pattern L1, pattern R1, type (+))
import Data.Hefty.Union (
@ -33,6 +34,9 @@ import Data.Hefty.Union (
HFunctorUnion_ (ForallHFunctor),
HeadIns,
LiftInsIfSingle (liftInsIfSingle, unliftInsIfSingle),
Lookup,
Member,
MemberH,
MemberRec,
U,
UH,
@ -42,11 +46,10 @@ import Data.Hefty.Union (
injectRec,
projectRec,
weaken2,
(|+), Lookup, Member, MemberH
(|+),
)
import Data.Kind (Type)
import Data.Maybe.Singletons (FromJust)
import Data.Effect.Key (type (#>), type (##>), unKey, unKeyH, Key (Key))
{- |
A common type for representing first-order and higher-order extensible effectful programs that can
@ -223,7 +226,7 @@ interpretContTH_ i = interpretContTAllH_ $ i |+: exhaust
-- | Interpret the leading first-order effect class into the carrier @f@.
interpretFin ::
forall e r f fr u c.
(Freer c fr , Union u, HeadIns e, c f) =>
(Freer c fr, Union u, HeadIns e, c f) =>
(u r Nop ~> f) ->
UnliftIfSingle e ~> f ->
Eff u fr '[] (e ': r) ~> f
@ -970,18 +973,19 @@ untagEffH ::
untagEffH = transformH unTagH
{-# INLINE untagEffH #-}
-- keyed effects
instance
(MemberRec u (LiftIns (key #> e)) efs, LiftIns (key #> e) ~ FromJust (Lookup key efs)) =>
InjectInsBy key e (EffUnion u ehs efs f) where
InjectInsBy key e (EffUnion u ehs efs f)
where
injectInsBy = EffUnion . R1 . injectRec . LiftIns . Key @key
{-# INLINE injectInsBy #-}
instance
(MemberRec u e ehs, e ~ FromJust (Lookup key ehs)) =>
InjectSigBy key e (EffUnion u ehs efs) where
InjectSigBy key e (EffUnion u ehs efs)
where
injectSigBy = EffUnion . L1 . injectRec
{-# INLINE injectSigBy #-}

14
heftia/src/Control/Freer.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
@ -21,16 +21,16 @@ import Control.Applicative (Alternative)
import Control.Applicative.Free (Ap, liftAp, runAp)
import Control.Applicative.Free.Fast qualified as Fast
import Control.Effect (SendIns, sendIns, type (~>))
import Control.Effect.Key (SendInsBy, sendInsBy)
import Control.Monad (MonadPlus)
import Control.Monad.Base (MonadBase)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Class (MonadState, get, put)
import Data.Effect (InsClass)
import Data.Functor.Coyoneda (Coyoneda, hoistCoyoneda, liftCoyoneda, lowerCoyoneda)
import Data.Kind (Type)
import Control.Effect.Key (SendInsBy, sendInsBy)
import Data.Effect.Fail (Fail (Fail))
import Data.Effect.State (State, get'', put'')
import Control.Monad.State.Class (MonadState, get, put)
import Data.Functor.Coyoneda (Coyoneda, hoistCoyoneda, liftCoyoneda, lowerCoyoneda)
import Data.Kind (Type)
-- | A type class to abstract away the encoding details of the Freer carrier.
class (forall e. c (f e)) => Freer c f | f -> c where
@ -122,9 +122,7 @@ reencodeFreer :: (Freer c fr, Freer c' fr', c (fr' f)) => fr f ~> fr' f
reencodeFreer = interpretFreer liftIns
{-# INLINE reencodeFreer #-}
instance
(Freer c fr, InjectInsBy StateKey (State s) e, Monad (fr e)) => MonadState s (ViaFreer fr e) where
instance (Freer c fr, InjectInsBy StateKey (State s) e, Monad (fr e)) => MonadState s (ViaFreer fr e) where
get = get'' @StateKey
put = put'' @StateKey
{-# INLINE get #-}

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

@ -1,6 +1,6 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
@ -10,29 +10,29 @@ module Control.Hefty where
import Control.Applicative (Alternative)
import Control.Effect (SendIns (..), SendSig (..), type (~>))
import Control.Freer (Freer (liftIns), InjectIns, injectIns, InjectInsBy, injectInsBy, StateKey)
import Control.Effect.Key (ByKey (ByKey), SendInsBy, SendSigBy, key, sendInsBy, sendSigBy)
import Control.Freer (Freer (liftIns), InjectIns, InjectInsBy, StateKey, injectIns, injectInsBy)
import Control.Monad (MonadPlus)
import Control.Monad.Base (MonadBase)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Effect (InsClass, SigClass)
import Data.Kind (Type)
import Control.Effect.Key (SendInsBy, sendInsBy, SendSigBy, sendSigBy, key, ByKey (ByKey))
import Data.Effect.Fail (Fail)
import Control.Monad.Fix (MonadFix, mfix)
import Data.Effect.Fix (Fix)
import UnliftIO (MonadUnliftIO, withRunInIO)
import Data.Effect.Unlift (UnliftIO, pattern WithRunInIO)
import Data.Effect.Reader (Ask, Local, ask'', local'')
import Control.Monad.Reader.Class (MonadReader, ask, local)
import qualified Data.Effect.Fail as E
import qualified Data.Effect.Fix as E
import Control.Monad.Writer.Class (MonadWriter, tell, listen, pass)
import Data.Effect.Writer (tell'', Tell, WriterH, listen'')
import Data.Tuple (swap)
import Data.Function ((&))
import Data.Effect.State (State, get'', put'')
import Control.Monad.State.Class (MonadState, get, put)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.RWS.Class (MonadRWS)
import Control.Monad.Reader.Class (MonadReader, ask, local)
import Control.Monad.State.Class (MonadState, get, put)
import Control.Monad.Writer.Class (MonadWriter, listen, pass, tell)
import Data.Effect (InsClass, SigClass)
import Data.Effect.Fail (Fail)
import Data.Effect.Fail qualified as E
import Data.Effect.Fix (Fix)
import Data.Effect.Fix qualified as E
import Data.Effect.Reader (Ask, Local, ask'', local'')
import Data.Effect.State (State, get'', put'')
import Data.Effect.Unlift (UnliftIO, pattern WithRunInIO)
import Data.Effect.Writer (Tell, WriterH, listen'', tell'')
import Data.Function ((&))
import Data.Kind (Type)
import Data.Tuple (swap)
import UnliftIO (MonadUnliftIO, withRunInIO)
newtype
Hefty
@ -84,13 +84,14 @@ instance (Freer c fr, InjectSigBy key e e') => SendSigBy key e (Hefty fr e') whe
class InjectSigBy key e (e' :: SigClass) | key e' -> e where
injectSigBy :: e f ~> e' f
instance
( Freer c fr
, InjectInsBy ReaderKey (Ask r) (e (Hefty fr e))
, InjectSigBy ReaderKey (Local r) e
, Monad (fr (e (Hefty fr e)))
) => MonadReader r (Hefty fr e) where
) =>
MonadReader r (Hefty fr e)
where
ask = ask'' @ReaderKey
local = local'' @ReaderKey
{-# INLINE ask #-}
@ -104,7 +105,9 @@ instance
, InjectSigBy WriterKey (WriterH w) e
, Monoid w
, Monad (fr (e (Hefty fr e)))
) => MonadWriter w (Hefty fr e) where
) =>
MonadWriter w (Hefty fr e)
where
tell = tell'' @WriterKey
listen = fmap swap . listen'' @WriterKey
pass m = pass (ByKey m) & key @WriterKey
@ -115,7 +118,8 @@ data WriterKey
instance
(Freer c fr, InjectInsBy StateKey (State s) (e (Hefty fr e)), Monad (fr (e (Hefty fr e)))) =>
MonadState s (Hefty fr e) where
MonadState s (Hefty fr e)
where
get = get'' @StateKey
put = put'' @StateKey
{-# INLINE get #-}
@ -130,8 +134,8 @@ instance
, InjectInsBy StateKey (State s) (e (Hefty fr e))
, Monoid w
, Monad (fr (e (Hefty fr e)))
) => MonadRWS r w s (Hefty fr e)
) =>
MonadRWS r w s (Hefty fr e)
instance (Freer c fr, InjectIns IO (e (Hefty fr e)), Monad (fr (e (Hefty fr e)))) => MonadIO (Hefty fr e) where
liftIO = sendIns
@ -150,6 +154,8 @@ instance
, InjectIns IO (e (Hefty fr e))
, InjectSig UnliftIO e
, Monad (fr (e (Hefty fr e)))
) => MonadUnliftIO (Hefty fr e) where
) =>
MonadUnliftIO (Hefty fr e)
where
withRunInIO f = Hefty . liftIns . injectSig $ WithRunInIO f
{-# INLINE withRunInIO #-}

14
heftia/src/Data/Hefty/Extensible.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE UndecidableInstances #-}
-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
@ -18,8 +18,7 @@ the [extensible](https://hackage.haskell.org/package/extensible) package as a ba
module Data.Hefty.Extensible (
module Data.Hefty.Extensible,
Forall,
)
where
) where
import Data.Effect (SigClass)
import Data.Effect.HFunctor (HFunctor, hfmap)
@ -27,6 +26,7 @@ import Data.Extensible (Forall, Match (Match), htabulateFor, match)
import Data.Extensible.Sum (strikeAt, (<:|), type (:/) (EmbedAt))
import Data.Extensible.Sum qualified as E
import Data.Hefty.Union (
ClassIndex,
HFunctorUnion_ (ForallHFunctor),
Union (
HasMembership,
@ -36,8 +36,10 @@ import Data.Hefty.Union (
project,
weaken,
(|+:)
), ClassIndex,
),
)
import Data.Hefty.Union qualified as U
import Data.Hefty.Union qualified as Union
import Data.Proxy (Proxy (Proxy))
import Data.Type.Equality ((:~:) (Refl))
import GHC.TypeNats (KnownNat)
@ -45,14 +47,12 @@ import Type.Membership.Internal (
Elaborate,
Elaborated (Expecting),
FindType,
membership,
Membership,
leadership,
membership,
nextMembership,
)
import Unsafe.Coerce (unsafeCoerce)
import qualified Data.Hefty.Union as Union
import qualified Data.Hefty.Union as U
{- |
An implementation of an open union for higher-order effects using

89
heftia/src/Data/Hefty/Union.hs
View File

@ -1,9 +1,9 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
@ -25,15 +25,15 @@ import Control.Effect (type (~>))
import Control.Monad ((<=<))
import Data.Effect (LNop, LiftIns (LiftIns), Nop, SigClass, unliftIns)
import Data.Effect.HFunctor (HFunctor, caseH, (:+:) (Inl, Inr))
import Data.Effect.Key (type (##>), type (#>))
import Data.Free.Sum (type (+))
import Data.Kind (Constraint)
import Data.Singletons (SingI, sing)
import Data.Singletons.TH (singletons)
import Data.Type.Bool (If)
import Data.Type.Equality ((:~:) (Refl))
import GHC.TypeLits (ErrorMessage (ShowType, Text, (:$$:), (:<>:)), TypeError, Nat)
import qualified GHC.TypeNats as N
import Data.Effect.Key (type (#>), type (##>))
import GHC.TypeLits (ErrorMessage (ShowType, Text, (:$$:), (:<>:)), Nat, TypeError)
import GHC.TypeNats qualified as N
{- |
A type class representing a general open union for higher-order effects, independent of the internal
@ -176,14 +176,16 @@ class
where
type ForallHFunctor u :: [SigClass] -> Constraint
$( singletons
[d|
data SearchResult = FoundIn FoundLevel | NotFound
$(singletons [d|
data SearchResult = FoundIn FoundLevel | NotFound
data FoundLevel = CurrentLevel | LowerLevel
|])
data FoundLevel = CurrentLevel | LowerLevel
|]
)
type family FoundLevelOf found :: FoundLevel where
FoundLevelOf ('FoundIn l) = l
FoundLevelOf ( 'FoundIn l) = l
type MemberH u e ehs = HasMembershipRec u e ehs
type Member u e efs = MemberH u (LiftIns e) efs
@ -210,7 +212,8 @@ type HasMembershipRec3_ u e es found lvl =
)
instance
( SearchMemberRec es u e es, MemberFound e es (CurrentLevelSearchResult searchResult)
( SearchMemberRec es u e es
, MemberFound e es (CurrentLevelSearchResult searchResult)
, searchResult ~ Search u es e
, SingI (HeadLowerSearchResult searchResult)
, found ~ CurrentLevelSearchResult searchResult
@ -225,7 +228,7 @@ instance
class MemberFound e es found where
withFound :: (forall lvl. (found ~ 'FoundIn lvl, SingI lvl) => a) -> a
instance SingI lvl => MemberFound e es ('FoundIn lvl) where
instance SingI lvl => MemberFound e es ( 'FoundIn lvl) where
withFound a = a
{-# INLINE withFound #-}
@ -251,21 +254,22 @@ class
(e :: SigClass)
(es :: [SigClass])
where
type family Search_ act u rest e :: SearchResults
type Search_ act u rest e :: SearchResults
injectSMR_ ::
searchResult ~ Search_ act u rest e =>
CurrentLevelSearchResult searchResult :~: 'FoundIn lvl
-> SSearchResult ('FoundIn lvl)
-> SSearchResult (HeadLowerSearchResult searchResult)
-> e f ~> u es f
CurrentLevelSearchResult searchResult :~: 'FoundIn lvl ->
SSearchResult ( 'FoundIn lvl) ->
SSearchResult (HeadLowerSearchResult searchResult) ->
e f ~> u es f
projectSMR_ ::
searchResult ~ Search_ act u rest e =>
CurrentLevelSearchResult searchResult :~: 'FoundIn lvl
-> SSearchResult ('FoundIn lvl)
-> SSearchResult (HeadLowerSearchResult searchResult)
-> u es f a -> Maybe (e f a)
CurrentLevelSearchResult searchResult :~: 'FoundIn lvl ->
SSearchResult ( 'FoundIn lvl) ->
SSearchResult (HeadLowerSearchResult searchResult) ->
u es f a ->
Maybe (e f a)
type Search u rest e = Search_ (NextSearchMemberRecAction rest u e) u rest e
@ -273,7 +277,7 @@ injectSMR ::
forall rest u e es searchResult lvl f.
(SearchMemberRec rest u e es, searchResult ~ Search u rest e) =>
CurrentLevelSearchResult searchResult :~: 'FoundIn lvl ->
SSearchResult ('FoundIn lvl) ->
SSearchResult ( 'FoundIn lvl) ->
SSearchResult (HeadLowerSearchResult searchResult) ->
e f ~> u es f
injectSMR = injectSMR_ @(NextSearchMemberRecAction rest u e) @rest
@ -283,7 +287,7 @@ projectSMR ::
forall rest u e es searchResult lvl f a.
(SearchMemberRec rest u e es, searchResult ~ Search u rest e) =>
CurrentLevelSearchResult searchResult :~: 'FoundIn lvl ->
SSearchResult ('FoundIn lvl) ->
SSearchResult ( 'FoundIn lvl) ->
SSearchResult (HeadLowerSearchResult searchResult) ->
u es f a ->
Maybe (e f a)
@ -291,8 +295,11 @@ projectSMR = projectSMR_ @(NextSearchMemberRecAction rest u e) @rest
{-# INLINE projectSMR #-}
data SearchResults = SearchResults SearchResult SearchResult
type family CurrentLevelSearchResult a where CurrentLevelSearchResult ('SearchResults a _) = a
type family HeadLowerSearchResult a where HeadLowerSearchResult ('SearchResults _ a) = a
type family CurrentLevelSearchResult a where
CurrentLevelSearchResult ( 'SearchResults a _) = a
type family HeadLowerSearchResult a where
HeadLowerSearchResult ( 'SearchResults _ a) = a
data SearchMemberRecAction = SmrStop | SmrRight | SmrDown
@ -305,7 +312,7 @@ instance
(HasMembership u e es, Union u) =>
SearchMemberRec_ 'SmrStop (e ': _tail) u e es
where
type Search_ _ _ (e ': _tail) e = 'SearchResults ('FoundIn 'CurrentLevel) 'NotFound
type Search_ _ _ (e ': _tail) e = 'SearchResults ( 'FoundIn 'CurrentLevel) 'NotFound
injectSMR_ _ _ _ = inject
projectSMR_ _ _ _ = project
@ -313,7 +320,7 @@ instance
{-# INLINE projectSMR_ #-}
type family IsFound found where
IsFound ('FoundIn _) = 'True
IsFound ( 'FoundIn _) = 'True
IsFound 'NotFound = 'False
instance
@ -329,10 +336,15 @@ instance
) =>
SearchMemberRec_ 'SmrDown (u es' ': tail) u e es
where
type Search_ _ _ (u es' ': tail) e =
SearchResultsOnSmrDown u es' tail e
(CurrentLevelSearchResult (Search u es' e))
(CurrentLevelSearchResult (Search u tail e))
type
Search_ _ _ (u es' ': tail) e =
SearchResultsOnSmrDown
u
es'
tail
e
(CurrentLevelSearchResult (Search u es' e))
(CurrentLevelSearchResult (Search u tail e))
injectSMR_ Refl found = \case
SFoundIn lvl -> inject . injectSMR @es' @u @_ @es' Refl (SFoundIn lvl) sing
@ -347,7 +359,7 @@ instance
type SearchResultsOnSmrDown u es' tail e foundInHead foundInTail =
'SearchResults
( If (IsFound foundInHead) ('FoundIn 'LowerLevel) foundInTail )
(If (IsFound foundInHead) ( 'FoundIn 'LowerLevel) foundInTail)
foundInHead
instance
@ -380,14 +392,14 @@ instance SearchMemberRec_ act '[] u e es where
{-# INLINE injectSMR_ #-}
{-# INLINE projectSMR_ #-}
-- A hack to avoid the "Quantified predicate must have a class or type variable head" error.
type HasMembershipWhenCurrentLevel lvl u e es =
HasMembershipWhenCurrentLevel_ (HasMembership u e es) lvl u e es
class
(lvl ~ 'CurrentLevel => c, c ~ HasMembership u e es) =>
HasMembershipWhenCurrentLevel_ c lvl u e es | u e es -> c
HasMembershipWhenCurrentLevel_ c lvl u e es
| u e es -> c
instance
(lvl ~ 'CurrentLevel => c, c ~ HasMembership u e es) =>
HasMembershipWhenCurrentLevel_ c lvl u e es
@ -396,12 +408,12 @@ type SearchMemberRecWhenLowerLevel lvl rest u e =
SearchMemberRecWhenLowerLevel_ (SearchMemberRec rest u e rest) lvl rest u e
class
(lvl ~ 'LowerLevel => c, c ~ SearchMemberRec rest u e rest) =>
SearchMemberRecWhenLowerLevel_ c lvl rest u e | rest u e -> c
SearchMemberRecWhenLowerLevel_ c lvl rest u e
| rest u e -> c
instance
(lvl ~ 'LowerLevel => c, c ~ SearchMemberRec rest u e rest) =>
SearchMemberRecWhenLowerLevel_ c lvl rest u e
infixr 5 |+
(|+) :: Union u => (e a -> r) -> (u es f a -> r) -> u (LiftIns e ': es) f a -> r
f |+ g = f . unliftIns |+: g
@ -500,8 +512,7 @@ type family ClassIndex (es :: [SigClass]) (e :: SigClass) :: Nat where
ClassIndex (_ ': es) e = 1 N.+ ClassIndex es e
ClassIndex '[] e =
TypeError
('Text "The effect class ‘" ':<>: 'ShowType e ':<>: 'Text "’ was not found in the list.")
( 'Text "The effect class ‘" ':<>: 'ShowType e ':<>: 'Text "’ was not found in the list.")
-- keyed effects
@ -516,5 +527,5 @@ type family Lookup (key :: k) es :: Maybe SigClass where
Lookup key '[] = 'Nothing
type family OrElse (a :: Maybe k) (b :: Maybe k) :: Maybe k where
OrElse ('Just a) _ = 'Just a
OrElse ( 'Just a) _ = 'Just a
OrElse 'Nothing a = a