add log effects to FromParser

exe/CompileMonad.idr

@@ -138,6 +138,7 @@ liftFromParser act =
      handleStateIORef !(asksAt STATE defs),
      handleStateIORef !(asksAt STATE ns),
      handleStateIORef !(asksAt STATE suf),
+     \g => send g,
      \g => send g]
 
 export %inline

lib/Quox/Parser/FromParser.idr

@@ -32,41 +32,44 @@ data StateTag = NS | SEEN
 
 public export
 FromParserPure : List (Type -> Type)
-FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen]
+FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
 
 public export
 FromParserIO : List (Type -> Type)
 FromParserIO = FromParserPure ++ [LoadFile]
 
 
+public export
+record PureParserResult a where
+  constructor MkPureParserResult
+  val       : a
+  suf       : NameSuf
+  defs      : Definitions
+  log       : SnocList LogDoc
+  logLevels : LevelStack
+
 export
 fromParserPure : {default [<] ns : Mods} ->
-                 NameSuf -> Definitions ->
+                 NameSuf -> Definitions -> LevelStack ->
-                 Eff FromParserPure a ->
+                 Eff FromParserPure a -> Either Error (PureParserResult a)
-                 Either Error (a, NameSuf, Definitions)
+fromParserPure suf defs lvls act = runSTErr $ do
-fromParserPure suf defs act = runSTErr $ do
+  suf  <- newSTRef' suf
-  suf  <- liftST $ newSTRef suf
+  defs <- newSTRef' defs
-  defs <- liftST $ newSTRef defs
+  log  <- newSTRef' [<]
+  lvls <- newSTRef' lvls
   res  <- runEff act $ with Union.(::)
-    [handleExcept (\e => stLeft e),
+    [handleExcept $ \e => stLeft e,
      handleStateSTRef defs,
-     handleStateSTRef !(liftST $ newSTRef ns),
+     handleStateSTRef !(newSTRef' ns),
-     handleStateSTRef suf]
+     handleStateSTRef suf,
-  pure (res, !(liftST $ readSTRef suf), !(liftST $ readSTRef defs))
+     handleLogST log lvls]
-
+  pure $ MkPureParserResult {
-
+    val       = res,
-export covering
+    suf       = !(readSTRef' suf),
-fromParserIO : (MonadRec io, HasIO io) =>
+    defs      = !(readSTRef' defs),
-               IncludePath -> IORef SeenSet ->
+    log       = !(readSTRef' log),
-               IORef NameSuf -> IORef Definitions ->
+    logLevels = !(readSTRef' lvls)
-               Eff FromParserIO a -> io (Either Error a)
+  }
-fromParserIO inc seen suf defs act =
-  liftIO $ fromIOErr $ runEff act $ with Union.(::)
-    [handleExcept (\e => ioLeft e),
-     handleStateIORef defs,
-     handleStateIORef !(newIORef [<]),
-     handleStateIORef suf,
-     handleLoadFileIOE LoadError WrapParseError seen inc]
 
 
 parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
@@ -370,8 +373,9 @@ data HasFail = NoFail | AnyFail | FailWith String
 
 export covering
 expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error
-expectFail loc act =
+expectFail loc act = do
-  case fromParserPure !(getAt GEN) !(getAt DEFS) {ns = !(getAt NS)} act of
+  gen <- getAt GEN; defs <- getAt DEFS; ns <- getAt NS; lvl <- curLevels
+  case fromParserPure {ns} gen defs (singleton lvl) act of
     Left  err => pure err
     Right _   => throw $ ExpectedFail loc
 

tests/Tests/FromPTerm.idr

@@ -68,7 +68,7 @@ parameters {c : Bool} {auto _ : Show b}
 
 runFromParser : {default empty defs : Definitions} ->
                 Eff FromParserPure a -> Either FromParser.Error a
-runFromParser = map fst . fromParserPure 0 defs
+runFromParser = map val . fromParserPure 0 defs initStack
 
 export
 tests : Test