Explicit error reporting

ivory-backend-c/ivory-backend-c.cabal

@@ -34,19 +34,21 @@ library
 
   build-depends:        base >= 4.7 && < 5,
                         base-compat,
-                        language-c-quote >= 0.11.0.0,
-                        srcloc,
-                        mainland-pretty >= 0.2.5,
-                        monadLib >= 3.7,
-                        template-haskell >= 2.8,
                         bytestring >= 0.10,
+                        containers,
                         directory,
                         filepath,
+                        language-c-quote >= 0.11.0.0,
+                        mainland-pretty >= 0.2.5,
+                        monadLib >= 3.7,
+                        pretty,
                         process,
-                        containers,
+                        srcloc,
+                        template-haskell >= 2.8,
+                        -- project
                         ivory,
-                        ivory-opts,
-                        ivory-artifact
+                        ivory-artifact,
+                        ivory-opts
   hs-source-dirs:       src
   default-language:     Haskell2010
 

ivory-backend-c/src/Ivory/Compile/C/CmdlineFrontend.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Ivory.Compile.C.CmdlineFrontend
   ( compile
   , compileWith
@@ -9,11 +11,9 @@ module Ivory.Compile.C.CmdlineFrontend
   , outputCompiler
   ) where
 
-import           Data.List                               (intercalate, nub,
-                                                          (\\))
-import qualified Ivory.Compile.C                         as C
 import qualified Paths_ivory_backend_c                   as P
 
+import qualified Ivory.Compile.C                         as C
 import           Ivory.Compile.C.CmdlineFrontend.Options
 
 import           Ivory.Artifact
@@ -31,11 +31,16 @@ import qualified Ivory.Opts.TypeCheck                    as T
 
 
 import           Control.Monad                           (when)
-import           Data.List                               (foldl')
+import           Data.List                               (foldl', intercalate,
+                                                          nub, (\\))
 import           Data.Maybe                              (catMaybes, mapMaybe)
+import           MonadLib                                (WriterM, put,
+                                                          runWriterT)
 import           System.Directory                        (createDirectoryIfMissing)
 import           System.Environment                      (getArgs)
 import           System.FilePath                         (addExtension, (</>))
+import           System.IO                               (hPutStrLn, stderr)
+import           Text.PrettyPrint                        (Doc, render, vcat)
 
 -- Code Generation Front End ---------------------------------------------------
 
@@ -54,7 +59,8 @@ runCompiler ms as os = runCompilerWith ms as os
 -- | Main compile function.
 runCompilerWith :: [Module] -> [Located Artifact] -> Opts -> IO ()
 runCompilerWith modules artifacts opts = do
-  cmodules <- compileUnits modules opts
+  (cmodules, errors) <- runWriterT $ compileUnits modules opts
+  hPutStrLn stderr $ render $ vcat errors
   if outProcSyms opts
     then C.outputProcSyms modules
     else outputCompiler cmodules artifacts opts
@@ -101,7 +107,7 @@ outputmodules opts cmodules user_artifacts = do
   output :: FilePath -> FilePath -> (C.CompileUnits -> String)
          -> C.CompileUnits
          -> IO ()
-  output dir ext render m = outputHelper fout (render m)
+  output dir ext renderUnits m = outputHelper fout (renderUnits m)
     where fout = addExtension (dir </> (C.unitName m)) ext
 
   renderHeader cu = C.renderHdr (C.headers cu) (C.unitName cu)
@@ -118,21 +124,21 @@ outputmodules opts cmodules user_artifacts = do
     out = writeFile fname contents
 
 -- | Compile, type-check, and optimize modules, but don't generate C files.
-compileUnits ::[Module] -> Opts -> IO [C.CompileUnits]
+compileUnits :: WriterM m [Doc] => [Module] -> Opts -> m [C.CompileUnits]
 compileUnits modules opts = do
 
   when (tcErrors opts) $ do
     let ts = map T.typeCheck modules
     let anyTs = or (map T.existErrors ts)
     let b = tcWarnings opts
-    mapM_ (T.showTyChkModule b) ts
+    mapM_ (\t -> put [T.showTyChkModule b t]) ts
     when anyTs (error "Type-checking failed!")
 
   when (scErrors opts) $ do
     let ds = S.dupDefs modules
-    S.showDupDefs ds
+    put [S.showDupDefs ds]
     let ss = S.sanityCheck modules
-    mapM_ S.showSanityChkModule ss
+    mapM_ (\s -> put [S.showSanityChkModule s]) ss
     let anySs = or (map S.existErrors ss)
     when anySs (error "Sanity-check failed!")
 

ivory-opts/src/Ivory/Opts/SanityCheck.hs

@@ -26,8 +26,6 @@ module Ivory.Opts.SanityCheck
 import           Prelude                                 ()
 import           Prelude.Compat
 
-import           System.IO                               (hPutStrLn, stderr)
-
 import           Control.Monad                           (unless)
 import qualified Data.List                               as L
 import qualified Data.Map                                as M
@@ -73,7 +71,7 @@ showError err = case err of
       $$ text "but is used with type:"
       $$ nest 4 (quotes (pretty expected))
 
-showSanityChkModule :: ModResult Result -> IO ()
+showSanityChkModule :: ModResult Result -> Doc
 showSanityChkModule res = showModErrs go res
   where
   go :: Result -> Doc
@@ -173,10 +171,11 @@ sanityCheck ms = map goMod ms
                     | m <- ms
                     ]
 
-showDupDefs :: [String] -> IO ()
+showDupDefs :: [String] -> Doc
 showDupDefs dups =
-  if null dups then return ()
-    else hPutStrLn stderr $ render (vcat (map docDups dups) $$ empty)
+  case dups of
+    [] -> empty
+    _  -> vcat (map docDups dups)
   where
   docDups x = text "*** WARNING"
            <> colon

ivory-opts/src/Ivory/Opts/TypeCheck.hs

@@ -110,8 +110,10 @@ showWarning w =
                 -> "Array contains unused initializers."
            )
 
--- Boolean says whether to show warnings (True) or not.
-showTyChkModule :: Bool -> ModResult Result -> IO ()
+showTyChkModule
+  :: Bool -- ^ show warnings
+  -> ModResult Result
+  -> Doc
 showTyChkModule b res = showModErrs go res
   where
   go :: Result -> Doc

ivory-opts/src/Ivory/Opts/Utils.hs

@@ -13,8 +13,6 @@ import           Ivory.Language.Syntax.Concrete.Location
 import           Ivory.Language.Syntax.Concrete.Pretty   (pretty, prettyPrint)
 import qualified Ivory.Language.Syntax.Type              as I
 
-import           System.IO                               (hPutStrLn, stderr)
-
 --------------------------------------------------------------------------------
 
 -- | Type of the expression's arguments.
@@ -40,16 +38,13 @@ data ModResult a = ModResult String [SymResult a]
   deriving (Show, Read, Eq)
 
 -- Show the errors for a module.
-showModErrs :: Show a => (a -> Doc) -> ModResult a -> IO ()
+showModErrs :: Show a => (a -> Doc) -> ModResult a -> Doc
 showModErrs doc (ModResult m errs) =
   case errs of
-    [] -> return ()
+    [] -> empty
     _  ->
-         hPutStrLn stderr
-       $ render
-       $ text "***" <+> text "Module" <+> text m <> colon
+         text "***" <+> text "Module" <+> text m <> colon
       $$ nest 2 (vcat (map (showSymErrs doc) errs))
-      $$ empty
 
 -- Show the errors for a symbol (area or procedure).
 showSymErrs :: (a -> Doc) -> SymResult a -> Doc
@@ -59,7 +54,6 @@ showSymErrs doc (SymResult sym errs) =
     _  ->
          text "***" <+> text "Symbol" <+> text sym <> colon
       $$ nest 2 (vcat (map doc errs))
-      $$ empty
 
 showWithLoc :: (a -> Doc) -> Located a -> Doc
 showWithLoc sh (Located loc a) =