feat: init

spago.yaml

@@ -1,21 +1,36 @@
 package:
   dependencies:
-    - prelude
     - aff
+    - console
     - effect
     - either
-    - maybe
     - foldable-traversable
-    - console
+    - fork
+    - maybe
+    - mmorph
     - newtype
+    - node-buffer
+    - node-fs
+    - node-process
+    - prelude
+    - simple-json
     - strings
     - stringutils
+    - sync
     - transformers
     - tuples
     - typelevel-prelude
+    - unlift
   name: project
 workspace:
-  extra_packages: {}
+  extra_packages:
+    sync:
+      dependencies:
+        - aff
+        - arrays
+        - avar
+      git: https://git.orionkindel.com/orion/purescript-sync.git
+      ref: 'fe21a2e'
   package_set:
     url: https://raw.githubusercontent.com/purescript/package-sets/psc-0.15.10-20230930/packages.json
     hash: sha256-nTsd44o7/hrTdk0c6dh0wyBqhFFDJJIeKdQU6L1zv/A=

src/Control.Monad.Log.purs

@@ -0,0 +1,199 @@
+module Control.Monad.Log where
+
+import Prelude
+
+import Control.Alt ((<|>))
+import Control.Alternative (class Alt, class Alternative, class Plus)
+import Control.Monad.Cont (class MonadCont)
+import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, throwError)
+import Control.Monad.Except (runExcept)
+import Control.Monad.Fork.Class (class MonadBracket, class MonadFork, class MonadKill, bracket, kill, never, uninterruptible)
+import Control.Monad.Morph (class MFunctor, class MMonad, embed, hoist)
+import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT, ask, asks, local)
+import Control.Monad.Rec.Class (class MonadRec)
+import Control.Monad.State.Async (asyncGet, runWith)
+import Control.Monad.Trans.Class (class MonadTrans, lift)
+import Control.Monad.Writer (class MonadTell, class MonadWriter)
+import Control.MonadPlus (class MonadPlus)
+import Control.Parallel (class Parallel, parallel, sequential)
+import Data.Array.NonEmpty as Array.NonEmpty
+import Data.Array.NonEmpty.Internal (NonEmptyArray)
+import Data.Async.RwLock (RwLock)
+import Data.Either (either)
+import Data.List (List)
+import Data.Log (Log)
+import Data.Log as Log
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.Newtype (class Newtype, unwrap, wrap)
+import Data.Traversable (sequence_)
+import Effect.Aff (Aff, launchAff_)
+import Effect.Aff.Class (class MonadAff, liftAff)
+import Effect.Aff.Unlift (class MonadUnliftAff, UnliftAff(..), withUnliftAff)
+import Effect.Class (class MonadEffect, liftEffect)
+import Effect.Exception (Error, error)
+import Effect.Exception as Error
+import Effect.Unlift (class MonadUnliftEffect)
+import Foreign (readString, tagOf, unsafeReadTagged)
+import Node.EventEmitter as Event
+import Node.Process (uncaughtExceptionH, unhandledRejectionH)
+import Node.Process as Process
+
+type LogR =
+  { actor ::
+      { dev :: String
+      , thread :: Maybe String
+      }
+  , context ::
+      NonEmptyArray
+        { path :: String
+        , context :: Array String
+        }
+  , buffer :: RwLock (List Log)
+  , outputs :: Array (Log.Log -> Aff Unit)
+  }
+
+newtype LogT :: (Type -> Type) -> Type -> Type
+newtype LogT m a = LogT (ReaderT LogR m a)
+
+derive instance Newtype (LogT m a) _
+derive newtype instance Functor m => Functor (LogT m)
+derive newtype instance (Plus m) => Plus (LogT m)
+derive newtype instance (Plus m, Alternative m) => Alternative (LogT m)
+derive newtype instance Alt m => Alt (LogT m)
+derive newtype instance Apply m => Apply (LogT m)
+derive newtype instance Applicative m => Applicative (LogT m)
+derive newtype instance Bind m => Bind (LogT m)
+derive newtype instance Monad m => Monad (LogT m)
+derive newtype instance (Apply m, Semigroup a) => Semigroup (LogT m a)
+derive newtype instance (Applicative m, Monoid a) => Monoid (LogT m a)
+derive newtype instance (MonadPlus m) => MonadPlus (LogT m)
+derive newtype instance (MonadEffect m) => MonadEffect (LogT m)
+derive newtype instance (MonadAff m) => MonadAff (LogT m)
+derive newtype instance Monad m => MonadReader LogR (LogT m)
+derive newtype instance Monad m => MonadAsk LogR (LogT m)
+derive newtype instance MonadCont m => MonadCont (LogT m)
+derive newtype instance MonadTell w m => MonadTell w (LogT m)
+derive newtype instance MonadWriter w m => MonadWriter w (LogT m)
+derive newtype instance MonadRec m => MonadRec (LogT m)
+derive newtype instance MonadError e m => MonadError e (LogT m)
+derive newtype instance MonadThrow e m => MonadThrow e (LogT m)
+derive newtype instance MonadUnliftAff m => MonadUnliftAff (LogT m)
+derive newtype instance MonadUnliftEffect m => MonadUnliftEffect (LogT m)
+derive newtype instance MonadFork f m => MonadFork f (LogT m)
+
+instance MonadKill e f m => MonadKill e f (LogT m) where
+  kill e f = wrap $ kill e f
+
+instance (MonadKill e f (LogT m), MonadError e (LogT m), MonadKill e f m, MonadError e m, MonadBracket e f m) => MonadBracket e f (LogT m) where
+  bracket acq rel m = wrap $ bracket (unwrap acq) (\b r -> unwrap $ rel b r) (unwrap <<< m)
+  uninterruptible = wrap <<< uninterruptible <<< unwrap
+  never = wrap $ never
+
+instance (Parallel f m) => Parallel (LogT f) (LogT m) where
+  parallel = wrap <<< parallel <<< unwrap
+  sequential = wrap <<< sequential <<< unwrap
+
+instance MonadTrans LogT where
+  lift = wrap <<< lift
+
+instance MFunctor LogT where
+  hoist f = wrap <<< hoist f <<< unwrap
+
+instance MMonad LogT where
+  embed f = wrap <<< embed (unwrap <<< f) <<< unwrap
+
+-- | A monad which can perform logs
+-- |
+-- | #### Stores
+-- | - context - a stack trace of module paths and trace of "things being done" in those modules
+-- | - actor - device / thread ID pair
+-- | - outputs - actual renderers of log messages
+class (MonadAff m) <= MonadLog m where
+  log :: Log.Level -> String -> m Unit
+
+  logs :: m (List Log)
+
+  getOutputs :: m (Array (Log.Log -> Aff Unit))
+  getContext :: m (NonEmptyArray { path :: String, context :: Array String })
+  getActor :: m { dev :: String, thread :: Maybe String }
+
+  path :: forall a. String -> m a -> m a
+  context :: forall a. String -> m a -> m a
+  thread :: forall a. String -> m a -> m a
+
+instance (MonadAff m, MonadError e m) => MonadLog (LogT m) where
+  getOutputs = map _.outputs $ ask
+  getContext = map _.context $ ask
+  getActor = map _.actor $ ask
+  context c =
+    let
+      withContext r =
+        let
+          init = Array.NonEmpty.fromArray $ Array.NonEmpty.init r.context
+          last = Array.NonEmpty.last r.context
+          newLast = last { context = last.context <> [ c ] }
+        in
+          r { context = maybe (pure newLast) (_ <> pure newLast) init }
+    in
+      local withContext
+  path p =
+    let
+      withPath r = r { context = r.context <> pure { path: p, context: [] } }
+    in
+      local withPath
+  thread t =
+    let
+      withThread r = r { actor = r.actor { thread = Just t } }
+    in
+      local withThread
+  logs = do
+    buf <- asks _.buffer
+    runWith buf asyncGet
+  log level msg = do
+    outputs' <- getOutputs
+    actor <- getActor
+    context <- getContext
+    liftAff $ sequence_ $ outputs' <*> [ Log.Log { level, msg, actor: wrap actor, context } ]
+else instance (MonadAff (t l), MMonad t, MonadLog l) => MonadLog (t l) where
+  logs = lift logs
+  getOutputs = lift getOutputs
+  getActor = lift getActor
+  getContext = lift getContext
+  path = hoist <<< path
+  thread = hoist <<< thread
+  context = hoist <<< context
+  log l m = lift $ log l m
+
+runLog :: forall m a. { buffer :: RwLock (List Log), outputs :: Array (Log.Log -> Aff Unit), dev :: String } -> LogT m a -> m a
+runLog { buffer, outputs, dev } t = (unwrap $ unwrap t) { outputs, actor: { dev, thread: Nothing }, context: pure { path: "Main", context: [] }, buffer }
+
+logError :: forall m. MonadLog m => Error -> m Unit
+logError e =
+  let
+    msg = Error.message e
+    stack = fromMaybe "" $ Error.stack e
+  in
+    log Log.Error $ msg <> "\n" <> stack
+
+withLogError :: forall m a. MonadError Error m => MonadLog m => m a -> m a
+withLogError = flip catchError \e -> do
+  logError e
+  throwError e
+
+catchLog :: forall m. MonadError Error m => MonadLog m => m Unit -> m Unit
+catchLog = flip catchError \e -> do
+  logError e
+
+logUnhandled :: forall m. MonadUnliftAff m => MonadLog m => MonadAff m => m Unit
+logUnhandled =
+  let
+    tryError e = unsafeReadTagged "Error" e
+    tryString e = error <$> readString e
+    fallthrough e = error $ "unknown error type: " <> tagOf e
+    coerceError e = either (const $ fallthrough e) identity $ runExcept (tryError e <|> tryString e)
+  in
+    withUnliftAff \(UnliftAff mToAff) -> do
+      let
+        launchM = launchAff_ <<< mToAff
+      liftEffect $ Event.on_ uncaughtExceptionH (\e _ -> launchM $ logError e) Process.process
+      liftEffect $ Event.on_ unhandledRejectionH (\f _ -> launchM $ logError $ coerceError f) Process.process

src/Data.Log.Backend.js

@@ -0,0 +1,2 @@
+/** @type {<T>(a: T) => string} */
+export const _prettyJson = a => JSON.stringify(a, null, 2)

src/Data.Log.Backend.purs

@@ -0,0 +1,92 @@
+module Data.Log.Backend where
+
+import Prelude
+
+import Control.Monad.State.Async as AsyncState
+import Data.Array.NonEmpty as Array.NonEmpty
+import Data.Async.RwLock (RwLock)
+import Data.DateTime.Instant (Instant)
+import Data.DateTime.Instant as Instant
+import Data.Foldable (intercalate)
+import Data.JSDate as Date
+import Data.List (List)
+import Data.List as List
+import Data.Log.Types (Actor(..), Level(..), Log, actor, context, level, message)
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Newtype (unwrap)
+import Effect (Effect)
+import Effect.Aff (Aff)
+import Effect.Class (liftEffect)
+import Effect.Console as Console
+import Effect.Now as Now
+import Effect.Unsafe (unsafePerformEffect)
+import Node.Buffer as Buffer
+import Node.Encoding (Encoding(..))
+import Node.FS.Aff as FS
+import Simple.JSON (class WriteForeign, writeImpl)
+
+foreign import _prettyJson :: forall a. a -> String
+
+pretty :: Log -> String
+pretty log =
+  let
+    level' = case level log of
+      Debug -> "[DEBUG]"
+      Trace -> "[TRACE]"
+      Info -> "[INFO ]"
+      Warn -> "[WARN ]"
+      Error -> "[ERROR]"
+    actor' = case actor log of Actor { thread } -> fromMaybe "" thread
+    context' = (\{ path: p, context: cs } -> show p <> " " <> (intercalate " > " cs)) $ Array.NonEmpty.last $ context log
+  in
+    intercalate "" [ level', actor', context', message log ]
+
+json :: Instant -> Log -> String
+json now log = do
+  prettyJson
+    { level: show $ level log
+    , context: context log
+    , message: message log
+    , ts: unwrap $ Instant.unInstant now
+    , time: unsafePerformEffect $ Date.toISOString $ Date.fromInstant now
+    , actor: unwrap $ actor log
+    }
+
+prettyJson :: forall a. WriteForeign a => a -> String
+prettyJson = _prettyJson <<< writeImpl
+
+consoleMethod :: Level -> String -> Effect Unit
+consoleMethod lv = case lv of
+  Debug -> Console.debug
+  Trace -> Console.debug
+  Info -> Console.log
+  Warn -> Console.warn
+  Error -> Console.error
+
+backendFromString :: Level -> String -> Maybe (Log -> Aff Unit)
+backendFromString filter "console_pretty" = Just $ backendConsolePretty filter
+backendFromString filter "console_json" = Just $ backendConsoleJSON filter
+backendFromString _ "json_file" = Just $ backendJSONFile ".log"
+backendFromString _ _ = Nothing
+
+backendBuffer :: RwLock (List Log) -> Log -> Aff Unit
+backendBuffer rwlock log =
+  AsyncState.runWith rwlock
+    $ AsyncState.asyncModify
+    $ pure <<< List.Cons log
+
+backendConsolePretty :: Level -> Log -> Aff Unit
+backendConsolePretty filter log = when (level log >= filter) $ liftEffect $ consoleMethod (level log) $ pretty log
+
+backendConsoleJSON :: Level -> Log -> Aff Unit
+backendConsoleJSON filter log = do
+  now <- liftEffect Now.now
+  when (level log >= filter) $ liftEffect $ consoleMethod (level log) (json now log <> "\n")
+
+backendJSONFile :: String -> Log -> Aff Unit
+backendJSONFile path log = do
+  now <- liftEffect Now.now
+  let
+    line = json now log <> "\n"
+  lineBuf <- liftEffect $ Buffer.fromString line UTF8
+  FS.appendFile path lineBuf

src/Data.Log.Types.purs

@@ -0,0 +1,105 @@
+module Data.Log.Types where
+
+import Prelude
+
+import Data.Array.NonEmpty (NonEmptyArray)
+import Data.Bounded.Generic (genericBottom, genericTop)
+import Data.Enum (class BoundedEnum, class Enum)
+import Data.Enum.Generic (genericCardinality, genericFromEnum, genericPred, genericSucc, genericToEnum)
+import Data.Generic.Rep (class Generic)
+import Data.Maybe (Maybe(..))
+import Data.Newtype (class Newtype, unwrap)
+import Data.Show.Generic (genericShow)
+import Data.String as String
+import Simple.JSON (class WriteForeign, writeImpl)
+
+-- | An identifier describing a combination of device (computer) and thread
+newtype Actor = Actor
+  { dev :: String
+  , thread :: Maybe String
+  }
+
+derive instance Newtype Actor _
+derive instance Generic Actor _
+instance Show Actor where
+  show = genericShow
+
+instance WriteForeign Actor where
+  writeImpl = writeImpl <<< unwrap
+
+data Level
+  = Debug
+  | Trace
+  | Info
+  | Warn
+  | Error
+
+derive instance Generic Level _
+derive instance Eq Level
+derive instance Ord Level
+instance Enum Level where
+  succ = genericSucc
+  pred = genericPred
+
+instance Bounded Level where
+  top = genericTop
+  bottom = genericBottom
+
+instance BoundedEnum Level where
+  cardinality = genericCardinality
+  toEnum = genericToEnum
+  fromEnum = genericFromEnum
+
+instance Show Level where
+  show = genericShow
+
+instance WriteForeign Level where
+  writeImpl = writeImpl <<< String.toLower <<< show
+
+levelFromString :: String -> Maybe Level
+levelFromString =
+  let
+    impl "default" = Just Info
+    impl "info" = Just Info
+    impl "trace" = Just Trace
+    impl "verbose" = Just Trace
+    impl "v" = Just Trace
+    impl "vv" = Just Debug
+    impl "vverbose" = Just Debug
+    impl "veryverbose" = Just Debug
+    impl "very-verbose" = Just Debug
+    impl "debug" = Just Debug
+    impl "warn" = Just Warn
+    impl "warning" = Just Warn
+    impl "warnings" = Just Warn
+    impl "err" = Just Error
+    impl "quiet" = Just Error
+    impl "error" = Just Error
+    impl "errors" = Just Error
+    impl _ = Nothing
+  in
+    impl <<< String.toLower
+
+newtype Log = Log
+  { context :: NonEmptyArray { path :: String, context :: Array String }
+  , actor :: Actor
+  , msg :: String
+  , level :: Level
+  }
+
+derive instance Newtype Log _
+
+instance WriteForeign Log where
+  writeImpl = writeImpl <<< unwrap
+
+level :: Log -> Level
+level (Log r) = r.level
+
+actor :: Log -> Actor
+actor (Log r) = r.actor
+
+message :: Log -> String
+message (Log r) = r.msg
+
+context :: Log -> NonEmptyArray { path :: String, context :: Array String }
+context (Log r) = r.context

src/Data.Log.purs

@@ -0,0 +1,5 @@
+module Data.Log
+  ( module X
+  ) where
+
+import Data.Log.Types (Actor(..), Level(..), Log(..), actor, context, level, levelFromString, message) as X

src/Main.purs

@@ -1,7 +0,0 @@
-module Main where
-
-import Prelude
-import Effect (Effect)
-
-main :: Effect Unit
-main = pure unit