Merge remote-tracking branch 'origin/master' into issue-32-better-coin-selection

Author: IAmPara0x

src/BotPlutusInterface/Effects.hs

@@ -44,11 +44,13 @@ import BotPlutusInterface.Types (
   ContractState (ContractState),
   LogContext (BpiLog, ContractLog),
   LogLevel (..),
+  LogLine (..),
   LogType (..),
   LogsList (LogsList),
   TxBudget,
   TxFile,
   addBudget,
+  sufficientLogLevel,
  )
 import Cardano.Api (AsType, FileError (FileIOError), HasTextEnvelope, TextEnvelopeDescr, TextEnvelopeError)
 import Cardano.Api qualified
@@ -65,7 +67,6 @@ import Data.Aeson qualified as JSON
 import Data.Bifunctor (second)
 import Data.ByteString qualified as ByteString
 import Data.Kind (Type)
-import Data.List (intersect)
 import Data.Maybe (catMaybes)
 import Data.String (IsString, fromString)
 import Data.Text (Text)
@@ -74,7 +75,7 @@ import Ledger qualified
 import Plutus.Contract.Effects (ChainIndexQuery, ChainIndexResponse)
 import Plutus.PAB.Core.ContractInstance.STM (Activity)
 import PlutusTx.Builtins.Internal (BuiltinByteString (BuiltinByteString))
-import Prettyprinter (Pretty (pretty), defaultLayoutOptions, layoutPretty, (<+>))
+import Prettyprinter (Pretty (pretty), defaultLayoutOptions, layoutPretty)
 import Prettyprinter qualified as PP
 import Prettyprinter.Render.String qualified as Render
 import System.Directory qualified as Directory
@@ -147,12 +148,11 @@ handlePABEffect contractEnv =
           case contractEnv.cePABConfig.pcCliLocation of
             Local -> Directory.createDirectoryIfMissing createParents filePath
             Remote ipAddr -> createDirectoryIfMissingRemote ipAddr createParents filePath
-        PrintLog logCtx logLevel txt ->
-          let logMsg = prettyLog logCtx logLevel txt
-           in do
-                printLog' contractEnv.cePABConfig.pcLogLevel logCtx logLevel logMsg
-                when contractEnv.cePABConfig.pcCollectLogs $
-                  collectLog contractEnv.ceContractLogs logCtx logLevel logMsg
+        PrintLog logCtx logLevel msg -> do
+          let logLine = LogLine logCtx logLevel msg
+          printLog' contractEnv.cePABConfig.pcLogLevel logLine
+          when contractEnv.cePABConfig.pcCollectLogs $
+            collectLog contractEnv.ceContractLogs logLine
         UpdateInstanceState s -> do
           atomically $
             modifyTVar contractEnv.ceContractState $
@@ -191,27 +191,19 @@ handlePABEffect contractEnv =
         SetInMemCollateral c -> Collateral.setInMemCollateral contractEnv c
     )
 
-printLog' :: LogLevel -> LogContext -> LogLevel -> PP.Doc () -> IO ()
-printLog' logLevelSetting msgCtx msgLogLvl msg =
+printLog' :: LogLevel -> LogLine -> IO ()
+printLog' logLevelSetting logLine =
   when
-    ( logLevelSetting {ltLogTypes = mempty} >= msgLogLvl {ltLogTypes = mempty}
-        && not (null intersectLogTypes)
-    )
+    (sufficientLogLevel logLevelSetting (logLineLevel logLine))
     $ putStrLn target
   where
     target =
-      Render.renderString . layoutPretty defaultLayoutOptions $
-        prettyLog msgCtx msgLogLvl msg
-
-    intersectLogTypes = ltLogTypes logLevelSetting `intersect` (ltLogTypes msgLogLvl <> [AnyLog])
-
-prettyLog :: LogContext -> LogLevel -> PP.Doc () -> PP.Doc ()
-prettyLog msgCtx msgLogLvl msg = pretty msgCtx <+> pretty msgLogLvl <+> msg
+      Render.renderString . layoutPretty defaultLayoutOptions . pretty $ logLine
 
-collectLog :: TVar LogsList -> LogContext -> LogLevel -> PP.Doc () -> IO ()
-collectLog logs logCtx logLvl msg = atomically $ modifyTVar' logs appendLog
+collectLog :: TVar LogsList -> LogLine -> IO ()
+collectLog logs logLine = atomically $ modifyTVar' logs appendLog
   where
-    appendLog (LogsList ls) = LogsList $ (logCtx, logLvl, msg) : ls
+    appendLog (LogsList ls) = LogsList $ logLine : ls
 
 -- | Reinterpret contract logs to be handled by PABEffect later down the line.
 handleContractLog :: forall w a effs. Member (PABEffect w) effs => Pretty a => Eff (LogMsg a ': effs) ~> Eff effs

src/BotPlutusInterface/Types.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -9,6 +10,7 @@ module BotPlutusInterface.Types (
   LogContext (..),
   LogLevel (..),
   LogType (..),
+  LogLine (..),
   ContractEnvironment (..),
   Tip (Tip, epoch, hash, slot, block, era, syncProgress),
   ContractState (..),
@@ -30,6 +32,7 @@ module BotPlutusInterface.Types (
   addBudget,
   readCollateralUtxo,
   collateralValue,
+  sufficientLogLevel,
 ) where
 
 import Cardano.Api (NetworkId (Testnet), NetworkMagic (..), ScriptExecutionError, ScriptWitnessIndex)
@@ -38,8 +41,10 @@ import Control.Concurrent.STM (TVar, readTVarIO)
 import Data.Aeson (ToJSON)
 import Data.Aeson qualified as JSON
 import Data.Aeson.TH (Options (..), defaultOptions, deriveJSON)
+import Data.Data (Data (toConstr), constrIndex, dataTypeOf, eqT, fromConstrB, indexConstr, type (:~:) (Refl))
 import Data.Default (Default (def))
 import Data.Kind (Type)
+import Data.List (intersect)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Text (Text)
@@ -177,13 +182,29 @@ newtype ContractStats = ContractStats
 instance Show (TVar ContractStats) where
   show _ = "<ContractStats>"
 
--- | List of string logs.
+{- | Single log message
+ Defined for pretty instance.
+-}
+data LogLine = LogLine
+  { logLineContext :: LogContext
+  , logLineLevel :: LogLevel
+  , logLineMsg :: PP.Doc ()
+  }
+  deriving stock (Show)
+
+instance Pretty LogLine where
+  pretty (LogLine msgCtx msgLogLvl msg) = pretty msgCtx <+> pretty msgLogLvl <+> PP.unAnnotate msg
+
+-- | List of logs.
 newtype LogsList = LogsList
-  { getLogsList :: [(LogContext, LogLevel, PP.Doc ())]
+  { getLogsList :: [LogLine]
   }
   deriving stock (Show)
   deriving newtype (Semigroup, Monoid)
 
+instance Pretty LogsList where
+  pretty = PP.vcat . map pretty . getLogsList
+
 instance Show (TVar LogsList) where
   show _ = "<ContractLogs>"
 
@@ -252,7 +273,7 @@ data LogType
   | CollateralLog
   | PABLog
   | AnyLog
-  deriving stock (Eq, Ord, Show)
+  deriving stock (Eq, Ord, Show, Data)
 
 instance Pretty LogType where
   pretty CoinSelectionLog = "CoinSelection"
@@ -267,7 +288,16 @@ data LogLevel
   | Notice {ltLogTypes :: [LogType]}
   | Info {ltLogTypes :: [LogType]}
   | Debug {ltLogTypes :: [LogType]}
-  deriving stock (Eq, Ord, Show)
+  deriving stock (Eq, Show, Data)
+
+instance Enum LogLevel where
+  fromEnum = (\a -> a - 1) . constrIndex . toConstr
+  toEnum = fromConstrB field . indexConstr (dataTypeOf $ Notice []) . (+ 1)
+    where
+      field :: forall a. Data a => a
+      field = case eqT :: Maybe (a :~: [LogType]) of
+        Just Refl -> [AnyLog]
+        Nothing -> error "Expected a value of type LogType."
 
 instance Pretty LogLevel where
   pretty = \case
@@ -277,6 +307,18 @@ instance Pretty LogLevel where
     Warn a -> "[WARNING " <> pretty a <> "]"
     Error a -> "[ERROR " <> pretty a <> "]"
 
+{- | if sufficientLogLevel settingLogLevel msgLogLvl
+ then message should be displayed with this log level setting.
+-}
+sufficientLogLevel :: LogLevel -> LogLevel -> Bool
+sufficientLogLevel logLevelSetting msgLogLvl =
+  msgLogLvl `constrLEq` logLevelSetting -- the log is important enough
+    && not (null intersectLogTypes) -- log is of type we're interested in
+  where
+    intersectLogTypes = ltLogTypes logLevelSetting `intersect` (ltLogTypes msgLogLvl <> [AnyLog])
+
+    constrLEq a b = fromEnum a <= fromEnum b
+
 data LogContext = BpiLog | ContractLog
   deriving stock (Bounded, Enum, Eq, Ord, Show)