diff --git a/heftia-effects/Example/Logging/Main.hs b/heftia-effects/Example/Logging/Main.hs index 3768164..3551b8f 100644 --- a/heftia-effects/Example/Logging/Main.hs +++ b/heftia-effects/Example/Logging/Main.hs @@ -10,15 +10,28 @@ module Main where import Control.Arrow ((>>>)) import Control.Effect (type (<:), type (<<:), type (~>)) -import Control.Effect.ExtensibleChurch (runEff, type (:!!)) +import Control.Effect.ExtensibleChurch (runEff, type (!!), type (:!!)) import Control.Effect.Handler.Heftia.Reader (runReader) import Control.Effect.Handler.Heftia.State (evalState) -import Control.Effect.Hefty (interposeRec, interposeRecH, interpretRec, interpretRecH, raise, raiseH) +import Control.Effect.Hefty ( + Elab, + copyEff, + interposeRec, + interposeRecH, + interpretRec, + interpretRecH, + raise, + raiseH, + raiseUnder, + reinterpretRecH, + subsume, + ) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Effect.Reader (ask, local) import Data.Effect.State (get, modify) import Data.Effect.TH (makeEffectF, makeEffectH) +import Data.Free.Sum (type (+)) import Data.Function ((&)) import Data.Hefty.Extensible (ForallHFunctor, type (<<|), type (<|)) import Data.Kind (Type) @@ -64,21 +77,28 @@ 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 n (LogChunk chunkName a) = - LogChunk chunkName . evalState @Int 0 $ - raise a & interposeRec \(Logging msg) -> do - count <- get - when (count <= n) do - if count == n - then logging "LOG OMITTED..." - else logging msg +limitLogChunk :: Log <| ef => Int -> '[LogChunk] :!! LLog ': ef ~> '[LogChunk] :!! LLog ': ef +limitLogChunk n = reinterpretRecH $ elabLimitLogChunk n - modify @Int (+ 1) +elabLimitLogChunk :: Log <| ef => Int -> Elab LogChunk ('[LogChunk] :!! LLog ': ef) +elabLimitLogChunk n (LogChunk name a) = + logChunk name do + raise . raiseH $ limitLog $ runLogChunk $ limitLogChunk n a + where + limitLog :: + forall ef. + Log <| ef => + '[] :!! LLog ': ef ~> '[] :!! ef + limitLog a' = + evalState @Int 0 $ + raiseUnder a' & interpretRec \(Logging msg) -> do + count <- get + when (count < n) do + logging msg + when (count == n - 1) do + logging "Subsequent logs are omitted..." + + modify @Int (+ 1) data FileSystem a where Mkdir :: FilePath -> FileSystem () @@ -96,11 +116,11 @@ runDummyFS = interpretRec \case -- | 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 + (LogChunk <<| eh, FileSystem <| ef, Time <| ef, ForallHFunctor eh) => + eh :!! (LLog ': ef) ~> eh :!! ef saveLogChunk = raise >>> raiseH - >>> ( interposeRecH \(LogChunk chunkName a) -> do + >>> ( interposeRecH \(LogChunk chunkName a) -> logChunk chunkName do chunkBeginAt <- currentTime let dirName = iso8601Show chunkBeginAt ++ "-" ++ T.unpack chunkName local @FilePath (++ dirName ++ "/") do @@ -108,71 +128,124 @@ saveLogChunk = mkdir logChunkPath a & interposeRec \(Logging msg) -> do logAt <- currentTime - logging msg writeToFile (logChunkPath ++ iso8601Show logAt ++ ".log") (show msg) ) >>> runReader @FilePath "./log/" + >>> discardLog + +discardLog :: ForallHFunctor eh => eh :!! LLog ': r ~> eh :!! r +discardLog = interpretRec \(Logging _) -> pure () logExample :: (LogChunk <<: m, Log <: m, MonadIO m) => m () -logExample = +logExample = do + logging "out of chunk scope 1" + logging "out of chunk scope 2" + logging "out of chunk scope 3" + logging "out of chunk scope 4" + + liftIO $ putStrLn "------" + logChunk "scope1" do - logging "foo" - logging "bar" - logging "baz" - logging "qux" + logging "in scope1 1" + logging "in scope1 2" + logging "in scope1 3" + logging "in scope1 4" liftIO $ putStrLn "------" logChunk "scope2" do - logging "hoge" - logging "piyo" - logging "fuga" - logging "hogera" + logging "in scope2 1" + logging "in scope2 2" + logging "in scope2 3" + logging "in scope2 4" liftIO $ putStrLn "------" - logging "quux" - logging "foobar" + logging "in scope1 5" + logging "in scope1 6" + +saveThenLimit :: IO () +saveThenLimit = + logExample + & copyEff + & saveLogChunk + & limitLogChunk 2 + & subsume + & runApp + +limitThenSave :: IO () +limitThenSave = + logExample + & limitLogChunk 2 + & subsume + & copyEff + & saveLogChunk + & runApp + +runApp :: LogChunk !! FileSystem + Time + Log + IO ~> IO +runApp = + runLogChunk + >>> runDummyFS + >>> logWithTime + >>> timeToIO + >>> logToIO + >>> runEff main :: IO () -main = - runEff - . logToIO - . timeToIO - . logWithTime - . runDummyFS - . runLogChunk - . saveLogChunk - $ do - logExample +main = do + putStrLn "# saveThenLimit" + saveThenLimit + putStrLn "" + putStrLn "# limitThenSave" + limitThenSave {- - mkdir ./log/2024-07-06T13:56:23.447829919Z-scope1/ -[2024-07-06 13:56:23.448628515 UTC] foo - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.448625419Z.log : "foo" -[2024-07-06 13:56:23.448932798 UTC] bar - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.448930113Z.log : "bar" -[2024-07-06 13:56:23.448989065 UTC] baz - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.448986289Z.log : "baz" -[2024-07-06 13:56:23.449036674 UTC] qux - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449035743Z.log : "qux" +# saveThenLimit +[2024-07-18 08:08:51.172881738 UTC] out of chunk scope 1 +[2024-07-18 08:08:51.172960947 UTC] out of chunk scope 2 +[2024-07-18 08:08:51.172977057 UTC] out of chunk scope 3 +[2024-07-18 08:08:51.172991414 UTC] out of chunk scope 4 ------ - mkdir ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449090566Z-scope2/ -[2024-07-06 13:56:23.44913009 UTC] hoge - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449127986Z.log : "hoge" - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449090566Z-scope2/2024-07-06T13:56:23.449125371Z.log : "hoge" -[2024-07-06 13:56:23.449215892 UTC] piyo - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449213508Z.log : "piyo" - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449090566Z-scope2/2024-07-06T13:56:23.449210612Z.log : "piyo" -[2024-07-06 13:56:23.449303087 UTC] fuga - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449300221Z.log : "fuga" - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449090566Z-scope2/2024-07-06T13:56:23.449298909Z.log : "fuga" -[2024-07-06 13:56:23.449383799 UTC] hogera - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449380502Z.log : "hogera" - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449090566Z-scope2/2024-07-06T13:56:23.44937926Z.log : "hogera" + mkdir ./log/2024-07-18T08:08:51.17303165Z-scope1/ + writeToFile ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173071515Z.log : "in scope1 1" +[2024-07-18 08:08:51.173099437 UTC] in scope1 1 + writeToFile ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173117962Z.log : "in scope1 2" +[2024-07-18 08:08:51.173143159 UTC] in scope1 2 +[2024-07-18 08:08:51.173157136 UTC] Subsequent logs are omitted... + writeToFile ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173174057Z.log : "in scope1 3" + writeToFile ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173208753Z.log : "in scope1 4" +------ + mkdir ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173252996Z-scope2/ + writeToFile ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173252996Z-scope2/2024-07-18T08:08:51.17328742Z.log : "in scope2 1" +[2024-07-18 08:08:51.173320152 UTC] in scope2 1 + writeToFile ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173252996Z-scope2/2024-07-18T08:08:51.173340811Z.log : "in scope2 2" +[2024-07-18 08:08:51.173380014 UTC] in scope2 2 +[2024-07-18 08:08:51.173395143 UTC] Subsequent logs are omitted... + writeToFile ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173252996Z-scope2/2024-07-18T08:08:51.173416954Z.log : "in scope2 3" + writeToFile ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173252996Z-scope2/2024-07-18T08:08:51.173453883Z.log : "in scope2 4" +------ + writeToFile ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173494499Z.log : "in scope1 5" + writeToFile ./log/2024-07-18T08:08:51.17303165Z-scope1/2024-07-18T08:08:51.173522993Z.log : "in scope1 6" + +# limitThenSave +[2024-07-18 08:08:51.173568508 UTC] out of chunk scope 1 +[2024-07-18 08:08:51.173584158 UTC] out of chunk scope 2 +[2024-07-18 08:08:51.173597743 UTC] out of chunk scope 3 +[2024-07-18 08:08:51.173611569 UTC] out of chunk scope 4 +------ + mkdir ./log/2024-07-18T08:08:51.173632088Z-scope1/ + writeToFile ./log/2024-07-18T08:08:51.173632088Z-scope1/2024-07-18T08:08:51.173661753Z.log : "in scope1 1" +[2024-07-18 08:08:51.173684326 UTC] in scope1 1 + writeToFile ./log/2024-07-18T08:08:51.173632088Z-scope1/2024-07-18T08:08:51.17370233Z.log : "in scope1 2" +[2024-07-18 08:08:51.173728749 UTC] in scope1 2 + writeToFile ./log/2024-07-18T08:08:51.173632088Z-scope1/2024-07-18T08:08:51.173743437Z.log : "Subsequent logs are omitted..." +[2024-07-18 08:08:51.173763865 UTC] Subsequent logs are omitted... +------ + writeToFile ./log/2024-07-18T08:08:51.173632088Z-scope1/2024-07-18T08:08:51.173799091Z.log : "in scope2 1" +[2024-07-18 08:08:51.173821103 UTC] in scope2 1 + writeToFile ./log/2024-07-18T08:08:51.173632088Z-scope1/2024-07-18T08:08:51.173841321Z.log : "in scope2 2" +[2024-07-18 08:08:51.173861538 UTC] in scope2 2 + writeToFile ./log/2024-07-18T08:08:51.173632088Z-scope1/2024-07-18T08:08:51.173878871Z.log : "Subsequent logs are omitted..." +[2024-07-18 08:08:51.173905952 UTC] Subsequent logs are omitted... ------ -[2024-07-06 13:56:23.449513012 UTC] quux - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449510688Z.log : "quux" -[2024-07-06 13:56:23.449560241 UTC] foobar - writeToFile ./log/2024-07-06T13:56:23.447829919Z-scope1/2024-07-06T13:56:23.449558087Z.log : "foobar" -} diff --git a/heftia/src/Control/Effect/Hefty.hs b/heftia/src/Control/Effect/Hefty.hs index ad7af51..48109c6 100644 --- a/heftia/src/Control/Effect/Hefty.hs +++ b/heftia/src/Control/Effect/Hefty.hs @@ -17,6 +17,7 @@ on [@data-effects@](https://hackage.haskell.org/package/data-effects). -} module Control.Effect.Hefty where +import Control.Arrow ((>>>)) import Control.Effect (type (~>)) import Control.Effect.Key (sendInsBy, sendSigBy) import Control.Freer (Freer, InjectIns, InjectInsBy, injectIns, injectInsBy, interpretFreer, liftIns, transformFreer) @@ -27,9 +28,9 @@ import Control.Monad.Identity (Identity (Identity), runIdentity) 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.HFunctor (HFunctor, caseH, hfmap, (:+:) (Inl, Inr)) import Data.Effect.Key (Key (Key), KeyH (KeyH), unKey, unKeyH, type (##>), type (#>)) -import Data.Effect.Tag (Tag (unTag), TagH (unTagH), type (#), type (##)) +import Data.Effect.Tag (Tag (Tag, unTag), TagH (TagH, unTagH), type (#), type (##)) import Data.Free.Sum (caseF, pattern L1, pattern R1, type (+)) import Data.Hefty.Union ( HFunctorUnion, @@ -983,6 +984,88 @@ subsumeH :: subsumeH = transformAllH $ injectRec |+: id {-# INLINE subsumeH #-} +copyEff :: + forall e r ehs fr u c. + ( Freer c fr + , Union u + , HFunctor (u ehs) + , Applicative (Eff u fr ehs (e ': r)) + , HeadIns e + , HasMembershipRec u e r + ) => + Eff u fr ehs (e ': r) ~> Eff u fr ehs (e ': r) +copyEff = reinterpretRec \e -> + send0 e *> liftEff (weaken $ injectRec $ liftInsIfSingle @_ @e e) + +copyEffH :: + forall e r ef fr u c. + ( Freer c fr + , Union u + , HFunctorUnion u + , HFunctor e + , ForallHFunctor u r + , Applicative (Eff u fr (e ': r) ef) + , HasMembershipRec u e r + ) => + Eff u fr (e ': r) ef ~> Eff u fr (e ': r) ef +copyEffH = reinterpretRecH \e -> send0H e *> liftEffH (weaken $ injectRec e) + +dupEff :: + forall e r ehs fr u c. + (Freer c fr, Union u, HFunctor (u ehs), Applicative (Eff u fr ehs (e ': e ': r)), HeadIns e) => + Eff u fr ehs (e ': r) ~> Eff u fr ehs (e ': e ': r) +dupEff = raiseUnder >>> reinterpretRec \e -> send0 e *> send1 e +{-# INLINE dupEff #-} + +dupEffH :: + forall e r ef fr u c. + ( Freer c fr + , Union u + , Applicative (Eff u fr (e ': e ': r) ef) + , HFunctorUnion u + , HFunctor e + , ForallHFunctor u r + ) => + Eff u fr (e ': r) ef ~> Eff u fr (e ': e ': r) ef +dupEffH = raiseUnderH >>> reinterpretRecH \e -> send0H e *> send1H e +{-# INLINE dupEffH #-} + +bundle :: + forall e r ehs fr u c. + (Freer c fr, Union u, HFunctor (u ehs)) => + Eff u fr ehs (e ': r) ~> Eff u fr ehs (u '[e] ': r) +bundle = transformAll $ inject0 . inject0 |+: weaken + +unbundle :: + forall e r ehs fr u c. + (Freer c fr, Union u, HFunctor (u ehs)) => + Eff u fr ehs (u '[e] ': r) ~> Eff u fr ehs (e ': r) +unbundle = transformAll $ inject0 . (id |+: end) |+: weaken + +pushBundle :: + forall e r1 r2 ehs fr u c. + (Freer c fr, Union u, HFunctor (u ehs)) => + Eff u fr ehs (u r1 ': e ': r2) ~> Eff u fr ehs (u (e ': r1) ': r2) +pushBundle = transformAll $ inject0 . weaken |+: inject0 . inject0 |+: weaken + +popBundle :: + forall e r1 r2 ehs fr u c. + (Freer c fr, Union u, HFunctor (u ehs)) => + Eff u fr ehs (u (e ': r1) ': r2) ~> Eff u fr ehs (u r1 ': e ': r2) +popBundle = transformAll $ (weaken . inject0 |+: inject0) |+: weaken2 + +enqueSum :: + forall e1 e2 r ehs fr u c. + (Freer c fr, Union u, HFunctor (u ehs)) => + Eff u fr ehs (e1 ': e2 ': r) ~> Eff u fr ehs (e1 :+: e2 ': r) +enqueSum = transformAll $ inject0 . Inl |+: inject0 . Inr |+: weaken + +dequeSum :: + forall e1 e2 r ehs fr u c. + (Freer c fr, Union u, HFunctor (u ehs)) => + Eff u fr ehs (e1 :+: e2 ': r) ~> Eff u fr ehs (e1 ': e2 ': r) +dequeSum = transformAll $ caseH inject0 (weaken . inject0) |+: weaken2 + liftInsEff :: forall e eh ef fr u c. (Freer c fr, Union u, HFunctor (u eh), HFunctor e) => @@ -1028,21 +1111,29 @@ mergeEffH = . unHefty send0 :: (Freer c fr, Union u, HeadIns e) => UnliftIfSingle e ~> Eff u fr eh (e ': r) -send0 = Hefty . liftIns . EffUnion . R1 . inject0 . liftInsIfSingle +send0 = liftEff . inject0 . liftInsIfSingle {-# INLINE send0 #-} send1 :: (Freer c fr, Union u, HeadIns e1) => UnliftIfSingle e1 ~> Eff u fr eh (e2 ': e1 ': r) -send1 = Hefty . liftIns . EffUnion . R1 . weaken . inject0 . liftInsIfSingle +send1 = liftEff . weaken . inject0 . liftInsIfSingle {-# INLINE send1 #-} send0H :: (Freer c fr, Union u) => e (Eff u fr (e ': r) ef) ~> Eff u fr (e ': r) ef -send0H = Hefty . liftIns . EffUnion . L1 . inject0 +send0H = liftEffH . inject0 {-# INLINE send0H #-} send1H :: (Freer c fr, Union u) => e1 (Eff u fr (e2 ': e1 ': r) ef) ~> Eff u fr (e2 ': e1 ': r) ef -send1H = Hefty . liftIns . EffUnion . L1 . weaken . inject0 +send1H = liftEffH . weaken . inject0 {-# INLINE send1H #-} +liftEff :: (Freer c fr, Union u) => u ef Nop ~> Eff u fr eh ef +liftEff = Hefty . liftIns . EffUnion . R1 +{-# INLINE liftEff #-} + +liftEffH :: (Freer c fr, Union u) => u eh (Eff u fr eh ef) ~> Eff u fr eh ef +liftEffH = Hefty . liftIns . EffUnion . L1 +{-# INLINE liftEffH #-} + runEff :: forall f fr u c. (Freer c fr, Union u, c f) => Eff u fr '[] '[LiftIns f] ~> f runEff = interpretAll $ id |+ exhaust {-# INLINE runEff #-} @@ -1051,6 +1142,20 @@ runPure :: forall a fr u c. (Freer c fr, Union u, c Identity) => Eff u fr '[] '[ runPure = runIdentity . interpretAll exhaust {-# INLINE runPure #-} +tagEff :: + forall tag e r ehs fr u c. + (Freer c fr, Union u, HFunctor (u ehs)) => + Eff u fr ehs (LiftIns e ': r) ~> Eff u fr ehs (LiftIns (e # tag) ': r) +tagEff = transform Tag +{-# INLINE tagEff #-} + +tagEffH :: + forall tag e r efs fr u c. + (Freer c fr, Union u, HFunctor (u (e ': r))) => + Eff u fr (e ': r) efs ~> Eff u fr (e ## tag ': r) efs +tagEffH = transformH TagH +{-# INLINE tagEffH #-} + untagEff :: forall tag e r ehs fr u c. (Freer c fr, Union u, HFunctor (u ehs)) =>