heftia-effects-0.4.0.1: Example/Logging/Main.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
-- 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 Control.Arrow ((>>>))
import Control.Monad (when)
import Control.Monad.Hefty (
Type,
interpose,
interposeH,
interpret,
interpretH,
liftIO,
makeEffectF,
makeEffectH,
raise,
raiseH,
raiseUnder,
reinterpretH,
runEff,
subsume,
(&),
type (!!),
type (+),
type (:!!),
type (<:),
type (<<:),
type (<<|),
type (<|),
type (~>),
type (~~>),
)
import Control.Monad.Hefty.Reader (runReader)
import Control.Monad.Hefty.State (evalState)
import Control.Monad.IO.Class (MonadIO)
import Data.Effect.Reader (Ask, Local, ask, local)
import Data.Effect.State (get, modify)
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 (defaultTimeLocale, formatTime)
data Log a where
Logging :: Text -> Log ()
makeEffectF [''Log]
logToIO :: (IO <| r) => eh :!! Log ': r ~> eh :!! r
logToIO = interpret \(Logging msg) -> liftIO $ T.putStrLn msg
data Time a where
CurrentTime :: Time UTCTime
makeEffectF [''Time]
timeToIO :: (IO <| r) => eh :!! Time ': r ~> eh :!! r
timeToIO = interpret \CurrentTime -> liftIO getCurrentTime
logWithTime :: (Log <| ef, Time <| ef) => eh :!! ef ~> eh :!! ef
logWithTime = interpose \(Logging msg) -> do
t <- currentTime
logging $ "[" <> iso8601 t <> "] " <> msg
iso8601 :: UTCTime -> Text
iso8601 t = T.take 23 (T.pack $ formatTime defaultTimeLocale "%FT%T.%q" t) <> "Z"
-- | An effect that introduces a scope that represents a chunk of logs.
data LogChunk f (a :: Type) where
LogChunk
:: Text
-- ^ chunk name
-> f a
-> LogChunk f a
makeEffectH [''LogChunk]
-- | Ignore chunk names and output logs in log chunks as they are.
runLogChunk :: LogChunk ': eh :!! ef ~> eh :!! ef
runLogChunk = interpretH \(LogChunk _ m) -> m
data FileSystem a where
Mkdir :: FilePath -> FileSystem ()
WriteToFile :: FilePath -> Text -> FileSystem ()
makeEffectF [''FileSystem]
runDummyFS :: (IO <| r) => eh :!! FileSystem ': r ~> eh :!! r
runDummyFS = interpret \case
Mkdir path ->
liftIO $ putStrLn $ "<runDummyFS> mkdir " <> path
WriteToFile path content ->
liftIO $ putStrLn $ "<runDummyFS> writeToFile " <> path <> " : " <> T.unpack 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)
=> eh :!! ef ~> eh :!! ef
saveLogChunk =
raise
>>> raiseH
>>> hookCreateDirectory
>>> hookWriteFile
>>> runReader @FilePath "./log/"
where
hookCreateDirectory
, hookWriteFile
:: (Local FilePath ': eh :!! Ask FilePath ': ef)
~> (Local FilePath ': eh :!! Ask FilePath ': ef)
hookCreateDirectory =
interposeH \(LogChunk chunkName a) -> logChunk chunkName do
chunkBeginAt <- currentTime
let dirName = T.unpack $ iso8601 chunkBeginAt <> "-" <> chunkName
local @FilePath (++ dirName ++ "/") do
logChunkPath <- ask
mkdir logChunkPath
a
hookWriteFile =
interpose \(Logging msg) -> do
logChunkPath <- ask
logAt <- currentTime
writeToFile (T.unpack $ T.pack logChunkPath <> iso8601 logAt <> ".log") msg
logging msg
-- | Limit the number of logs in a log chunk to the first @n@ logs.
limitLogChunk :: (Log <| ef) => Int -> '[LogChunk] :!! Log ': ef ~> '[LogChunk] :!! Log ': ef
limitLogChunk n = reinterpretH $ elabLimitLogChunk n
elabLimitLogChunk :: (Log <| ef) => Int -> LogChunk ~~> '[LogChunk] :!! Log ': ef
elabLimitLogChunk n (LogChunk name a) =
logChunk name do
raise . raiseH $ limitLog $ runLogChunk $ limitLogChunk n a
where
limitLog :: (Log <| ef) => '[] :!! Log ': ef ~> '[] :!! ef
limitLog a' =
evalState @Int 0 $
raiseUnder a' & interpret \(Logging msg) -> do
count <- get
when (count < n) do
logging msg
when (count == n - 1) do
logging "Subsequent logs are omitted..."
modify @Int (+ 1)
logExample :: (LogChunk <<: m, Log <: m, MonadIO m) => m ()
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 "in scope1 1"
logging "in scope1 2"
logging "in scope1 3"
logging "in scope1 4"
liftIO $ putStrLn "------"
logChunk "scope2" do
logging "in scope2 1"
logging "in scope2 2"
logging "in scope2 3"
logging "in scope2 4"
liftIO $ putStrLn "------"
logging "in scope1 5"
logging "in scope1 6"
saveThenLimit :: IO ()
saveThenLimit =
logExample
& saveLogChunk
& limitLogChunk 2
& subsume @Log
& runApp
limitThenSave :: IO ()
limitThenSave =
logExample
& limitLogChunk 2
& subsume @Log
& saveLogChunk
& runApp
runApp :: LogChunk !! FileSystem + Time + Log + IO ~> IO
runApp =
runLogChunk
>>> runDummyFS
>>> logWithTime
>>> timeToIO
>>> logToIO
>>> runEff
main :: IO ()
main = do
putStrLn "# saveThenLimit"
saveThenLimit
putStrLn ""
putStrLn "# limitThenSave"
limitThenSave
{-
# saveThenLimit
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z.log : out of chunk scope 1
[2024-08-31T17:25:38.063Z] out of chunk scope 1
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z.log : out of chunk scope 2
[2024-08-31T17:25:38.063Z] out of chunk scope 2
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z.log : out of chunk scope 3
[2024-08-31T17:25:38.063Z] out of chunk scope 3
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z.log : out of chunk scope 4
[2024-08-31T17:25:38.063Z] out of chunk scope 4
------
<runDummyFS> mkdir ./log/2024-08-31T17:25:38.063Z-scope1/
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.063Z.log : in scope1 1
[2024-08-31T17:25:38.063Z] in scope1 1
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.063Z.log : in scope1 2
[2024-08-31T17:25:38.063Z] in scope1 2
[2024-08-31T17:25:38.064Z] Subsequent logs are omitted...
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z.log : in scope1 3
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z.log : in scope1 4
------
<runDummyFS> mkdir ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z-scope2/
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z-scope2/2024-08-31T17:25:38.064Z.log : in scope2 1
[2024-08-31T17:25:38.064Z] in scope2 1
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z-scope2/2024-08-31T17:25:38.064Z.log : in scope2 2
[2024-08-31T17:25:38.064Z] in scope2 2
[2024-08-31T17:25:38.064Z] Subsequent logs are omitted...
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z-scope2/2024-08-31T17:25:38.064Z.log : in scope2 3
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z-scope2/2024-08-31T17:25:38.064Z.log : in scope2 4
------
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z.log : in scope1 5
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.063Z-scope1/2024-08-31T17:25:38.064Z.log : in scope1 6
# limitThenSave
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.064Z.log : out of chunk scope 1
[2024-08-31T17:25:38.065Z] out of chunk scope 1
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z.log : out of chunk scope 2
[2024-08-31T17:25:38.065Z] out of chunk scope 2
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z.log : out of chunk scope 3
[2024-08-31T17:25:38.065Z] out of chunk scope 3
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z.log : out of chunk scope 4
[2024-08-31T17:25:38.065Z] out of chunk scope 4
------
<runDummyFS> mkdir ./log/2024-08-31T17:25:38.065Z-scope1/
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : in scope1 1
[2024-08-31T17:25:38.065Z] in scope1 1
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : in scope1 2
[2024-08-31T17:25:38.065Z] in scope1 2
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : Subsequent logs are omitted...
[2024-08-31T17:25:38.065Z] Subsequent logs are omitted...
------
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : in scope2 1
[2024-08-31T17:25:38.065Z] in scope2 1
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : in scope2 2
[2024-08-31T17:25:38.065Z] in scope2 2
<runDummyFS> writeToFile ./log/2024-08-31T17:25:38.065Z-scope1/2024-08-31T17:25:38.065Z.log : Subsequent logs are omitted...
[2024-08-31T17:25:38.065Z] Subsequent logs are omitted...
------
-}