Add Logger

Makefile

@@ -1,4 +1,4 @@
-.PHONY: all bench build check clean configure golden fast haddock hlint main repl report run stan stylish test update
+.PHONY: all bench build check clean configure golden fast haddock hlint main output repl report run stan stylish test update
 
 all: update fast bench
 
@@ -36,6 +36,9 @@ hlint:
 main:
 	make stylish configure check build test
 
+output:
+	if test -d .output; then rm -r .output; fi
+
 repl:
 	cabal new-repl lib:helma
 

docs/ARCHITECTURE.md

@@ -32,6 +32,7 @@ Tools and libraries:
   * [x] [slist](https://kowainik.github.io/projects/slist) for sized list
   * [x] [ListLike](https://hackage.haskell.org/package/ListLike) for list abstraction
   * [ ] [mono-traversable](https://github.com/snoyberg/mono-traversable#readme) for list abstraction
+  * [ ] [lens](https://github.com/ekmett/lens#lens-lenses-folds-and-traversals) for for modification
 * For production code:
   * [x] [mtl](https://github.com/haskell/mtl) for IoC
   * [X] [polysemy](https://github.com/polysemy-research/polysemy#readme) for IoC

docs/CHANGELOG.md

@@ -1,5 +1,12 @@
 # 📅 Revision history for HelMA
 
+## 0.6.12.0 -- 2022-01-07
+
+* Add `Logger` based on Writer
+* Refactor `Safe`
+* Replace `CartesianProduct` to `ZipA`
+* Use local `hlint`
+
 ## 0.6.11.2 -- 2021-12-14
 
 * Fix version in cabal

helma.cabal

@@ -1,7 +1,7 @@
 cabal-version:       2.4
 
 name:                helma
-version:             0.6.11.2
+version:             0.6.12.0
 
 synopsis:            HELMA - Heavenly Esoteric Little Minimal Automaton for Esoteric Languages
 description:         Please see the README on GitHub at <https://github.com/helvm/helma#readme>
@@ -113,16 +113,21 @@ library
     HelVM.Common.Containers.MTInsertDef
     HelVM.Common.Containers.Util
 
+    HelVM.Common.Control.Control
+    HelVM.Common.Control.Message
+    HelVM.Common.Control.Logger
+    HelVM.Common.Control.Safe
+
     HelVM.Common.Digit.Digitable
     HelVM.Common.Digit.Digits
     HelVM.Common.Digit.ToDigit
 
     HelVM.Common.ListLikeUtil
     HelVM.Common.NamedValue
     HelVM.Common.ReadText
-    HelVM.Common.Safe
     HelVM.Common.SequencesUtil
     HelVM.Common.Util
+    HelVM.Common.ZipA
 
     HelVM.HelMA.Automata.BrainFuck.Evaluator.TEvaluator
     HelVM.HelMA.Automata.BrainFuck.Evaluator.IEvaluator
@@ -215,12 +220,13 @@ test-suite helma-test
   other-modules:
     Spec
 
-    HelVM.CartesianProduct
     HelVM.Expectations
     HelVM.GoldenExpectations
     HelVM.MonadErrorSpec
 
     HelVM.Common.Collections.MapListSpec
+    HelVM.Common.Control.LoggerSpec
+
     HelVM.Common.ListLikeUtilSpec
 
     HelVM.HelMA.Automata.BrainFuck.Evaluator.IEvaluatorSpec
@@ -262,6 +268,7 @@ test-suite helma-test
 
     , helma
 
+    , dlist
     , filepath
     , ListLike
     , mtl
@@ -280,7 +287,6 @@ benchmark helma-benchmark
   hs-source-dirs:      hs/benchmark
   main-is:             Main.hs
   other-modules:
-    HelVM.CartesianProduct
 
     HelVM.HelMA.Automata.BrainFuck.Evaluator.IEvaluatorBenchMark
     HelVM.HelMA.Automata.BrainFuck.Evaluator.TEvaluatorBenchMark

hlint.sh

@@ -1,3 +1,6 @@
 #!/usr/bin/env bash
 
-curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .
+#curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .
+hlint . --report=hlint.html --timing
+
+mv hlint.html docs/reports

hs/app/Main.hs

@@ -8,7 +8,7 @@ import           HelVM.HelMA.Automaton.API.TypeOptions
 
 import           HelVM.HelMA.Automaton.IO.BusinessIO
 
-import           HelVM.Common.Safe
+import           HelVM.Common.Control.Control
 
 import           HelVM.HelMA.Automaton.Types.CellType
 import           HelVM.HelMA.Automaton.Types.IntCellType
@@ -83,7 +83,7 @@ parse WS   a = pPrintNoColor . flip (WS.parse WhiteTokenType) a
 parse lang _ = tokenize lang
 
 eval :: TypeOptions -> AsciiLabels -> Lang -> Source -> IO ()
-eval options a lang s = (exceptTToIO . evalParams lang) params
+eval options a lang s = (controlTToIO . evalParams lang) params
   where params = EvalParams {asciiLabel = a , source = s , typeOptions = options}
 
 evalParams :: BIO m => Lang -> EvalParams -> m ()

hs/benchmark/HelVM/HelMA/Automata/BrainFuck/Evaluator/IEvaluatorBenchMark.hs

@@ -4,6 +4,7 @@ import           HelVM.HelMA.Automata.BrainFuck.Evaluator.IEvaluator
 import           HelVM.HelMA.Automata.BrainFuck.FileUtil
 
 import           HelVM.HelMA.Automaton.IO.MockIO
+
 import           HelVM.HelMA.Automaton.Types.CellType
 
 import qualified Data.ListLike                                       as LL

hs/benchmark/HelVM/HelMA/Automata/WhiteSpace/EvaluatorBenchMark.hs

@@ -8,7 +8,7 @@ import           HelVM.HelMA.Automaton.IO.MockIO
 import           HelVM.HelMA.Automaton.Types.RAMType
 import           HelVM.HelMA.Automaton.Types.StackType
 
-import           HelVM.CartesianProduct
+import           HelVM.Common.ZipA
 
 import           System.FilePath.Posix
 

hs/src/HelVM/Common/Collections/MapList.hs

@@ -2,7 +2,7 @@ module HelVM.Common.Collections.MapList where
 
 import           HelVM.Common.Containers.LLIndexSafe
 import           HelVM.Common.Containers.LLInsertDef
-import           HelVM.Common.Safe
+import           HelVM.Common.Control.Safe
 
 import           Data.Default
 
@@ -79,7 +79,7 @@ instance {-# OVERLAPPING #-} IndexSafe (MapList a) a where
   findMaybe    = mapListFindMaybe
   indexMaybe   = mapListIndexMaybe
   findSafe   i = liftMaybeOrError "MapList.findSafe: index is not correct" . mapListFindMaybe i
-  indexSafe  l = liftMaybeOrError "MapList.indexSafe: index is not correct" . mapListIndexMaybe l
+  indexSafe  l = liftMaybeOrError "MapList.LLIndexSafe: index is not correct" . mapListIndexMaybe l
 
 instance InsertDef (MapList a) a where
   insertDef i e = fromIntMap . IntMap.insert i e . unMapList

hs/src/HelVM/Common/Containers/LLIndexSafe.hs

@@ -1,23 +1,23 @@
 {-# LANGUAGE UndecidableInstances #-}
 module HelVM.Common.Containers.LLIndexSafe where
 
-import           HelVM.Common.Safe
+import           HelVM.Common.Control.Safe
 
 import           Data.ListLike
 
-import           Prelude           hiding (break, divMod, drop, fromList, length, splitAt, swap, uncons)
+import           Prelude                   hiding (break, divMod, drop, fromList, length, splitAt, swap, uncons)
 
 -- | Index
-naturalIndexSafe :: (MonadSafeError m , IndexSafe full item) => full -> Natural -> m item
+naturalIndexSafe :: (MonadSafe m , IndexSafe full item) => full -> Natural -> m item
 naturalIndexSafe l =  indexSafe l . fromIntegral
 
 -- | Type Class
 class IndexSafe full item | full -> item where
   findWithDefault :: item -> Int -> full -> item
   findMaybe  :: Int -> full -> Maybe item
   indexMaybe :: full -> Int -> Maybe item
-  findSafe   :: MonadSafeError m => Int -> full -> m item
-  indexSafe  :: MonadSafeError m => full -> Int -> m item
+  findSafe   :: MonadSafe m => Int -> full -> m item
+  indexSafe  :: MonadSafe m => full -> Int -> m item
 
 instance ListLike full item => IndexSafe full item where
   findWithDefault e i = fromMaybe e . findMaybe i
@@ -27,7 +27,7 @@ instance ListLike full item => IndexSafe full item where
   indexSafe           = indexSafeLL
 
 -- | Internal functions
-indexSafeLL :: (MonadSafeError m , ListLike full item) => full -> Int -> m item
+indexSafeLL :: (MonadSafe m , ListLike full item) => full -> Int -> m item
 indexSafeLL l i
   | i < 0         = liftError "LLIndexSafe.indexSafeLL: index must be >= 0"
   | length l <= i = liftError "LLIndexSafe.indexSafeLL: index must not found"

hs/src/HelVM/Common/Containers/MTIndexSafe.hs

@@ -1,25 +1,25 @@
 {-# LANGUAGE UndecidableInstances #-}
 module HelVM.Common.Containers.MTIndexSafe where
 
-import           HelVM.Common.Safe
+import           HelVM.Common.Control.Safe
 
 import           Control.Type.Operator
 import           Data.MonoTraversable
 import           Data.Sequences
 
-import           Prelude               hiding (break, divMod, drop, fromList, length, splitAt, swap, uncons)
+import           Prelude                   hiding (break, divMod, drop, fromList, length, splitAt, swap, uncons)
 
 -- | Index
-naturalIndexSafe :: (MonadSafeError m , IndexSafe seq , Num $ Index seq) => seq -> Natural -> m $ Element seq
+naturalIndexSafe :: (MonadSafe m , IndexSafe seq , Num $ Index seq) => seq -> Natural -> m $ Element seq
 naturalIndexSafe l =  indexSafe l . fromIntegral
 
 -- | Type Class
 class IndexSafe seq where
   findWithDefault :: Element seq -> Index seq -> seq -> Element seq
   findMaybe  :: Index seq -> seq -> Maybe $ Element seq
   indexMaybe :: seq -> Index seq -> Maybe $ Element seq
-  findSafe   :: MonadSafeError m => Index seq -> seq -> m $ Element seq
-  indexSafe  :: MonadSafeError m => seq -> Index seq -> m $ Element seq
+  findSafe   :: MonadSafe m => Index seq -> seq -> m $ Element seq
+  indexSafe  :: MonadSafe m => seq -> Index seq -> m $ Element seq
 
 instance IsSequence seq => IndexSafe seq where
   findWithDefault e i = fromMaybe e . findMaybe i

hs/src/HelVM/Common/Containers/Util.hs

@@ -1,11 +1,11 @@
 module HelVM.Common.Containers.Util where
 
-import           HelVM.Common.Safe
+import           HelVM.Common.Control.Safe
 
 import           Relude.Extra
 
-indexSafeByKey :: (MonadSafeError m , Show k , Ord k , Show v) => k -> Map k v -> m v
-indexSafeByKey k mapKV = liftMaybeOrErrorTupleList [( "key" , show k) , ("map" , show mapKV)] $ lookup k mapKV
+indexSafeByKey :: (MonadSafe m , Show k , Ord k , Show v) => k -> Map k v -> m v
+indexSafeByKey k mapKV = liftMaybeOrErrorTupleList [("key" , show k) , ("mapKV" , show mapKV)] $ lookup k mapKV
 
 showFoldable ::  (Foldable c , Functor c , Show e) => c e -> Text
 showFoldable f = fmconcat $ show <$> f

hs/src/HelVM/Common/Control/Control.hs

@@ -0,0 +1,68 @@
+module HelVM.Common.Control.Control (
+  controlTToIO,
+  controlToIO,
+
+  runControlT,
+  runControl,
+
+  safeWithMessagesToText,
+
+  controlT,
+  control,
+
+  safeWithMessages,
+
+  MonadControl,
+  ControlT,
+  Control,
+
+  UnitSafeWithMessages,
+  SafeWithMessages
+) where
+
+import           HelVM.Common.Control.Logger
+import           HelVM.Common.Control.Message
+import           HelVM.Common.Control.Safe
+
+import           Control.Type.Operator
+
+controlTToIO :: ControlT IO a -> IO a
+controlTToIO a = safeWithMessagesToIO =<< runControlT a
+
+controlToIO :: Control a -> IO a
+controlToIO = safeToIO . removeLogger
+
+runControlT :: ControlT m a -> m $ SafeWithMessages a
+runControlT = runLoggerT . runSafeT
+
+runControl :: Control a -> SafeWithMessages a
+runControl a = runLogger $ runSafe <$> a
+
+safeWithMessagesToIO :: SafeWithMessages a -> IO a
+safeWithMessagesToIO (safe , _) = safeToIO safe
+
+safeWithMessagesToText :: SafeWithMessages a -> Text
+safeWithMessagesToText (safe , messages) = errorsToText messages <> safeToText safe
+
+-- | Constructors
+
+controlT :: Monad m => m a -> ControlT m a
+controlT = safeT . loggerT
+
+control :: a -> Control a
+control = logger . pure
+
+safeWithMessages :: a -> SafeWithMessages a
+safeWithMessages = withMessages . pure
+
+-- | Types
+
+type MonadControl m = (MonadLogger m, MonadSafe m)
+
+type ControlT m = SafeT (LoggerT m)
+
+type Control a = Logger $ Safe a
+
+type UnitSafeWithMessages = SafeWithMessages ()
+
+type SafeWithMessages a = WithMessages (Safe a)