Simplify logging - we can use laziness and filters instead of an expl…

…icit log level

dex.cabal

@@ -58,10 +58,10 @@ library
                      -- , JAX.Concrete
                      -- , JAX.Rename
                      -- , JAX.ToSimp
-                     , LLVM.Link
-                     , LLVM.Compile
+                     -- , LLVM.Link
+                     -- , LLVM.Compile
                      -- , LLVM.CUDA
-                     , LLVM.Shims
+                     -- , LLVM.Shims
                      , Lexing
                      -- , Linearize
                      , MonadUtil

src/dex.hs

@@ -43,7 +43,18 @@ runMode (CmdOpts evalMode cfg) = case evalMode of
 stdOutLogger :: Outputs -> IO ()
 stdOutLogger (Outputs outs) = do
   isatty <- queryTerminal stdOutput
-  forM_ outs \out -> putStr $ printOutput isatty out
+  forM_ outs \out -> do
+    when (outputPrintFilter out) do
+      putStr $ printOutput isatty out
+
+outputPrintFilter :: Output -> Bool
+outputPrintFilter = \case
+  TextOut _      -> True
+  HtmlOut _      -> False
+  SourceInfo _   -> False
+  PassResult _ _ -> True
+  MiscLog _      -> True
+  Error _        -> True
 
 simpleInfo :: Parser a -> ParserInfo a
 simpleInfo p = info (p <**> helper) mempty
@@ -91,7 +102,7 @@ parseEvalOpts = EvalConfig
 printOutput :: Bool -> Output -> String
 printOutput isatty out = case out of
   Error _ -> addColor isatty Red $ addPrefix ">" $ pprint out
-  _       -> addPrefix (addColor isatty Cyan ">") $ pprint $ out
+  _       -> addPrefix (addColor isatty Cyan ">") $ pprint out
 
 addPrefix :: String -> String -> String
 addPrefix prefix s = unlines $ map prefixLine $ lines s

src/lib/MonadUtil.hs

@@ -8,7 +8,7 @@
 
 module MonadUtil (
   DefuncState (..), LabelReader (..), SingletonLabel (..), FreshNames (..),
-  runFreshNameT, FreshNameT (..), Logger (..), LogLevel (..), getIOLogger, CanSetIOLogger (..),
+  runFreshNameT, FreshNameT (..), Logger (..), getIOLogger, CanSetIOLogger (..),
   IOLoggerT (..), runIOLoggerT, LoggerT (..), runLoggerT,
   IOLogger (..), HasIOLogger (..), captureIOLogs) where
 
@@ -58,13 +58,10 @@ runFreshNameT cont = evalStateT (runFreshNameT' cont) 0
 
 -- === Logging monad ===
 
-data IOLogger w = IOLogger { ioLogLevel  :: LogLevel
-                           , ioLogAction :: w -> IO () }
-data LogLevel = NormalLogLevel | DebugLogLevel
+data IOLogger w = IOLogger { ioLogAction :: w -> IO () }
 
 class (Monoid w, Monad m) => Logger w m | m -> w where
   emitLog :: w -> m ()
-  getLogLevel :: m LogLevel
 
 newtype IOLoggerT w m a = IOLoggerT { runIOLoggerT' :: ReaderT (IOLogger w) m a }
         deriving (Functor, Applicative, Monad, MonadIO, Fallible, MonadFail, Catchable)
@@ -86,20 +83,18 @@ instance (Monoid w, MonadIO m) => Logger w (IOLoggerT w m) where
   emitLog w = do
     logger <- getIOLogAction
     liftIO $ logger w
-  getLogLevel = IOLoggerT $ asks ioLogLevel
 
 getIOLogger :: (HasIOLogger w m, Logger w m) => m (IOLogger w)
-getIOLogger = IOLogger <$> getLogLevel <*> getIOLogAction
+getIOLogger = IOLogger <$> getIOLogAction
 
-runIOLoggerT :: (Monoid w, MonadIO m) => LogLevel -> (w -> IO ()) -> IOLoggerT w m a -> m a
-runIOLoggerT logLevel write cont = runReaderT (runIOLoggerT' cont) (IOLogger logLevel write)
+runIOLoggerT :: (Monoid w, MonadIO m) => (w -> IO ()) -> IOLoggerT w m a -> m a
+runIOLoggerT write cont = runReaderT (runIOLoggerT' cont) (IOLogger write)
 
 newtype LoggerT w m a = LoggerT { runLoggerT' :: WriterT w m a }
         deriving (Functor, Applicative, Monad, MonadIO)
 
 instance (Monoid w, Monad m) => Logger w (LoggerT w m) where
   emitLog w = LoggerT $ tell w
-  getLogLevel = return NormalLogLevel
 
 runLoggerT :: (Monoid w, Monad m) => LoggerT w m a -> m (a, w)
 runLoggerT cont = runWriterT (runLoggerT' cont)

src/lib/PPrint.hs

@@ -10,11 +10,12 @@ import Data.Int
 import Data.Word
 import Data.List (intersperse)
 import Data.String
+import Data.Text (Text, unpack)
 import Control.Monad.Reader
 import Control.Monad.State.Strict
 
 pprint :: Pretty a => a -> String
-pprint x = printDoc  $ pr x
+pprint x = printDoc $ pr x
 {-# SCC pprint #-}
 
 -- === printing doc ===
@@ -25,7 +26,7 @@ newtype PrinterM a = PrinterM { runPrinterM :: ReaderT Int (State [(Int, String)
 runPrinter :: PrinterM a -> String
 runPrinter cont = do
   let indentedLines = reverse $ execState (runReaderT (runPrinterM cont) 0) []
-  concat [replicate (2 * indents) ' ' <> s | (indents, s) <- indentedLines]
+  concat [replicate (2 * indents) ' ' <> s <> "\n"| (indents, s) <- indentedLines]
 
 printDoc :: Doc -> String
 printDoc d = runPrinter $ printDocM d
@@ -56,6 +57,7 @@ data Doc =
    DocLine   String
  | DocItems  [Doc]
  | DocIndent Doc
+   deriving (Show)
 
 vcat :: [Doc] -> Doc
 vcat = DocItems
@@ -107,3 +109,4 @@ instance Pretty Int64  where pr x = pr $ show x
 instance Pretty Float  where pr x = pr $ show x
 instance Pretty Double where pr x = pr $ show x
 instance Pretty Word64 where pr x = pr $ show x
+instance Pretty Text   where pr x = pr $ unpack x

src/lib/TopLevel2.hs

@@ -122,10 +122,7 @@ logTop :: TopLogger m => Output -> m ()
 logTop x = emitLog $ Outputs [x]
 
 logPass :: Pretty a => PassName -> a -> TopperM ()
-logPass passName result = do
-  getLogLevel >>= \case
-    NormalLogLevel -> logTop $ PassResult passName Nothing
-    DebugLogLevel  -> logTop $ PassResult passName  $ Just (pprint result)
+logPass passName result = logTop $ PassResult passName $ Just (pprint result)
 
 -- === helpers ===
 
@@ -144,7 +141,6 @@ instance Logger Outputs TopperM where
   emitLog x = do
     logger <- getIOLogAction
     liftIO $ logger x
-  getLogLevel = return DebugLogLevel
 
 instance HasIOLogger Outputs TopperM where
   getIOLogAction = TopperM $ asks topperLogAction

src/lib/Types/Complicated.hs

@@ -168,8 +168,7 @@ data DataConDefs n =
 
 data DataConDef n =
   -- Name for pretty printing, constructor elements, representation type,
-  -- list of projection indices that recovers elements from the representation.
-  DataConDef SourceName (EmptyAbs (Nest CBinder) n) (CType n) [[Projection]]
+  DataConDef SourceName (EmptyAbs (Nest CBinder) n) (CType n)
   deriving (Show, Generic)
 
 -- === type classes ===

src/lib/Types/Primitives.hs

@@ -19,8 +19,7 @@
 {-# LANGUAGE DefaultSignatures #-}
 
 module Types.Primitives (
-  module Types.Primitives, UnOp (..), BinOp (..),
-  CmpOp (..), Projection (..)) where
+  module Types.Primitives, UnOp (..), BinOp (..), CmpOp (..)) where
 
 import qualified Data.ByteString       as BS
 import Data.Int
@@ -60,13 +59,6 @@ data CmpOp = Less | Greater | Equal | LessEqual | GreaterEqual
 instance Hashable CmpOp
 instance Store    CmpOp
 
-data Projection =
-   UnwrapNewtype -- TODO: add `HasCore r` constraint
- | ProjectProduct Int
-   deriving (Show, Eq, Ord, Generic)
-instance Hashable Projection
-instance Store    Projection
-
 data PrimOp a =
    UnOp     UnOp   a
  | BinOp    BinOp a a
@@ -123,7 +115,6 @@ data RefOp a =
    MGet
  | MPut a
  | IndexRef a
- | ProjRef Projection
    deriving (Show, Eq, Ord, Generic, Functor, Foldable, Traversable)
 instance Hashable a => Hashable (RefOp a)
 instance Store    a => Store    (RefOp a)
@@ -392,16 +383,10 @@ instance Pretty a => Pretty (PrimOp a) where
       MGet        -> app "get" [pr ref]
       MPut x      -> app "(:=)" [pr ref, pr x]
       IndexRef i  -> app "(!)"  [pr ref, pr i]
-      ProjRef i   -> app "proj_ref" [pr ref, pr i]
     UnOp  op x   -> app (pr op) [pr x]
     BinOp op x y -> app (pr op) [pr x, pr y]
     MiscOp op -> undefined
 
-instance Pretty Projection where
-  pr = \case
-    UnwrapNewtype -> "u"
-    ProjectProduct i -> pr i
-
 instance Pretty a => Pretty (MemOp a) where
   pr = \case
     PtrOffset ptr idx -> app "(+>)" [pr idx]

src/lib/Types/Source.hs

@@ -953,8 +953,8 @@ instance Pretty Bin where
     CSEqual -> "="
 
 instance Pretty SourceBlock' where
-  pr (TopDecl decl) = pr decl
-  pr d = fromString $ show d
+  pr = \case
+    TopDecl decl -> pr decl
 
 instance Pretty CTopDecl where
   pr (CSDecl ann decl) = hcat [annDoc, pr decl]
@@ -1108,21 +1108,14 @@ instance Pretty (UExpr' n) where
 --       p = pretty
 
 instance Pretty SourceBlock where
-  pr block = pr $ sbContents block
-    -- pr $ ensureNewline (sbText block) where
-    -- -- Force the SourceBlock to end in a newline for echoing, even if
-    -- -- it was terminated with EOF in the original program.
-    -- ensureNewline t = case unsnoc t of
-    --   Nothing -> t
-    --   Just (_, '\n') -> t
-    --   _ -> t `snoc` '\n'
+  pr block = pr $ sbText block
 
 instance Pretty Output where
   pr = \case
     TextOut s -> pr s
     HtmlOut _ -> "<html output>"
-    SourceInfo _ -> ""
-    PassResult _ s -> pr s
+    SourceInfo _ -> "<source info>"
+    PassResult name s -> vcat [hcat [" === ", pr name, " ==="], pr s]
     MiscLog s -> pr s
     Error e -> pr e