Refactor error reporting and add CARP_DIR check (#1033)

* compiler: refactor error reporting and add CARP_DIR check

Co-authored-by: Tim Dévé <TimDeve@users.noreply.github.com>

* set CARP_DIR in tests

Co-authored-by: Tim Dévé <TimDeve@users.noreply.github.com>

app/Main.hs

@@ -2,7 +2,8 @@ module Main where
 
 import qualified System.Environment as SystemEnvironment
 import System.Console.Haskeline (runInputT)
-import Control.Monad (foldM)
+import System.Exit (exitFailure)
+import Control.Monad (foldM, when)
 import GHC.IO.Encoding
 import Data.Maybe
 
@@ -90,12 +91,21 @@ main = do setLocaleEncoding utf8
               optimize = otherOptimize otherOptions
               generateOnly = otherGenerateOnly otherOptions
               prompt = otherPrompt otherOptions
+              carpDir = lookup "CARP_DIR" sysEnv
+              ifCarpDirSet comp =
+                case carpDir of
+                  Just _ -> comp
+                  Nothing -> do
+                    emitWarning "The environment variable `CARP_DIR` is not set."
+                    if core
+                    then emitErrorAndExit "Cannot use core libraries without `CARP_DIR` being set (if you want to provide your own, use `--no-core`)."
+                    else comp
               applySettings p = p { projectCFlags = ["-D LOG_MEMORY" | logMemory] ++
                                                     ["-O3 -D NDEBUG" | optimize]
                                                     ++ projectCFlags p
                                   , projectCore = core
                                   , projectGenerateOnly = generateOnly
-                                  , projectCarpDir = fromMaybe (projectCarpDir p) $ lookup "CARP_DIR" sysEnv
+                                  , projectCarpDir = fromMaybe (projectCarpDir p) carpDir
                                   , projectPrompt = fromMaybe (projectPrompt p) prompt
                                   }
               project = applySettings defaultProject
@@ -120,22 +130,23 @@ main = do setLocaleEncoding utf8
               loadOnce = flip loadFilesOnce
           carpProfile <- configPath "profile.carp"
           hasProfile <- doesFileExist carpProfile
-          _ <- pure startingContext
+          _ <- ifCarpDirSet
-            >>= load [carpProfile | hasProfile]
+                (pure startingContext
-            >>= execStrs "Preload" preloads
+                >>= load [carpProfile | hasProfile]
-            >>= loadOnce coreModulesToLoad
+                >>= execStrs "Preload" preloads
-            >>= load argFilesToLoad
+                >>= loadOnce coreModulesToLoad
-            >>= execStrs "Postload" postloads
+                >>= load argFilesToLoad
-            >>= \ctx -> case execMode of
+                >>= execStrs "Postload" postloads
-                          Repl -> do putStrLn "Welcome to Carp 0.4.2"
+                >>= \ctx -> case execMode of
-                                     putStrLn "This is free software with ABSOLUTELY NO WARRANTY."
+                              Repl -> do putStrLn "Welcome to Carp 0.4.2"
-                                     putStrLn "Evaluate (help) for more information."
+                                         putStrLn "This is free software with ABSOLUTELY NO WARRANTY."
-                                     snd <$> runRepl ctx
+                                         putStrLn "Evaluate (help) for more information."
-                          Build -> execStr "Compiler (Build)" "(build)" ctx
+                                         snd <$> runRepl ctx
-                          Install thing -> execStr "Installation" ("(load \"" ++ thing ++ "\")") ctx
+                              Build -> execStr "Compiler (Build)" "(build)" ctx
-                          BuildAndRun -> execStr "Compiler (Build & Run)" "(do (build) (run))" ctx
+                              Install thing -> execStr "Installation" ("(load \"" ++ thing ++ "\")") ctx
-                          Check -> execStr "Check" "" ctx
+                              BuildAndRun -> execStr "Compiler (Build & Run)" "(do (build) (run))" ctx
-                          -- TODO: Handle the return value from executeString and return that one to the shell
+                              Check -> execStr "Check" "" ctx)
+                              -- TODO: Handle the return value from executeString and return that one to the shell
           pure ()
 -- | Options for how to run the compiler.
 data FullOptions = FullOptions

scripts/carp.sh

@@ -9,4 +9,5 @@ then
     fi
     CARP="$CARP $BUILD_OPTS --"
 fi
+export CARP_DIR=`pwd`
 $CARP $CARP_OPTS "$@"

src/ColorText.hs

@@ -1,6 +1,7 @@
 module ColorText where
 
 import System.Console.ANSI hiding (Blue, Red, Yellow, Green, White)
+import System.Exit (exitFailure)
 import System.IO
 
 import Util
@@ -28,3 +29,23 @@ putStrWithColor color str =
 
 putStrLnWithColor :: TextColor -> String -> IO ()
 putStrLnWithColor color str = putStrWithColor color (str ++ "\n")
+
+labelStr :: String -> String -> String
+labelStr label str = "[" ++ label ++ "] " ++ str
+
+emitWarning :: String -> IO ()
+emitWarning str = putStrLnWithColor Blue (labelStr "WARNING" str)
+
+emitErrorWithLabel :: String -> String -> IO ()
+emitErrorWithLabel label str = putStrLnWithColor Red (labelStr label str)
+
+emitError :: String -> IO ()
+emitError str = emitErrorWithLabel "ERROR" str
+
+emitErrorBare :: String -> IO ()
+emitErrorBare str = putStrLnWithColor Red str
+
+emitErrorAndExit :: String -> IO a
+emitErrorAndExit str = do
+  _ <- emitError str
+  exitFailure

src/Commands.hs

@@ -83,9 +83,14 @@ addCommandConfigurable path maybeArity callback doc example =
               in  XObj (Arr (map (tosym . intToArgName) [1..arity])) Nothing Nothing
             Nothing -> XObj (Arr [(XObj (Sym (SymPath [] "") Symbol) Nothing Nothing)]) Nothing Nothing
 
+presentErrorWithLabel :: MonadIO m => String -> String -> a -> m a
+presentErrorWithLabel label msg ret =
+  liftIO $ do emitErrorWithLabel label msg
+              pure ret
+
 presentError :: MonadIO m => String -> a -> m a
 presentError msg ret =
-  liftIO $ do putStrLnWithColor Red msg
+  liftIO $ do emitError msg
               pure ret
 
 -- | Command for changing various project settings.
@@ -146,7 +151,7 @@ commandProjectConfig ctx [xobj@(XObj (Str key) _ _), value] = do
                                        pure (proj { projectForceReload = forceReload })
                   _ -> Left ("Project.config can't understand the key '" ++ key ++ "' at " ++ prettyInfoFromXObj xobj ++ ".")
   case newProj of
-    Left errorMessage -> presentError ("[CONFIG ERROR] " ++ errorMessage) (ctx, dynamicNil)
+    Left errorMessage -> presentErrorWithLabel "CONFIG ERROR" errorMessage (ctx, dynamicNil)
     Right ok -> pure (ctx {contextProj=ok}, dynamicNil)
 commandProjectConfig ctx [faultyKey, _] =
   presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil)
@@ -182,7 +187,7 @@ commandProjectGetConfig ctx [xobj@(XObj (Str key) _ _)] =
           _ -> Left key
   in pure $ case getVal ctx proj of
        Right val -> (ctx, Right $ xstr val)
-       Left key -> (evalError ctx ("[CONFIG ERROR] Project.get-config can't understand the key '" ++ key) (info xobj))
+       Left key -> (evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ key)) (info xobj))
 
 commandProjectGetConfig ctx [faultyKey] =
   presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil)

src/Eval.hs

@@ -396,11 +396,10 @@ executeString doCatch printResult ctx input fileName =
         interactiveFolder (_, context) xobj =
           executeCommand context xobj
         treatErr ctx e xobj = do
-          let msg =  "[PARSE ERROR] " ++ e
+          let fppl = projectFilePathPrintLength (contextProj ctx)
-              fppl = projectFilePathPrintLength (contextProj ctx)
           case contextExecMode ctx of
-            Check -> putStrLn (machineReadableInfoFromXObj fppl xobj ++ " " ++ msg)
+            Check -> putStrLn (machineReadableInfoFromXObj fppl xobj ++ " " ++ e)
-            _ -> putStrLnWithColor Red msg
+            _ -> emitErrorWithLabel "PARSE ERROR" e
           throw CancelEvaluationException
 
 -- | Used by functions that has a series of forms to evaluate and need to fold over them (producing a new Context in the end)
@@ -458,7 +457,7 @@ reportExecutionError ctx errorMessage =
   case contextExecMode ctx of
     Check -> putStrLn errorMessage
     _ ->
-      do putStrLnWithColor Red errorMessage
+      do emitErrorBare errorMessage
          throw CancelEvaluationException
 
 -- | Decides what to do when the evaluation fails for some reason.
@@ -466,12 +465,12 @@ catcher :: Context -> CarpException -> IO Context
 catcher ctx exception =
   case exception of
     (ShellOutException message returnCode) ->
-      do putStrLnWithColor Red ("[RUNTIME ERROR] " ++ message)
+      do emitErrorWithLabel "RUNTIME ERROR" message
          stop returnCode
     CancelEvaluationException ->
       stop 1
     EvalException evalError ->
-      do putStrLnWithColor Red (show evalError)
+      do emitError (show evalError)
          stop 1
   where stop returnCode =
           case contextExecMode ctx of

src/Interfaces.hs

@@ -8,6 +8,7 @@ module Interfaces (registerInInterfaceIfNeeded,
 
 import Data.Either (isRight)
 
+import ColorText
 import Obj
 import Lookup
 import Types
@@ -20,12 +21,18 @@ data InterfaceError = KindMismatch SymPath Ty Ty
                     | NonInterface SymPath
 
 instance Show InterfaceError where
-  show (KindMismatch path definitionSignature interfaceSignature) = "[INTERFACE ERROR] " ++ show path ++ ":" ++ " One or more types in the interface implementation " ++
+  show (KindMismatch path definitionSignature interfaceSignature) =
-                                                                    show definitionSignature ++ " have kinds that do not match the kinds of the types in the interface signature " ++
+    labelStr "INTERFACE ERROR"
-                                                                    show interfaceSignature ++ "\n" ++ "Types of the form (f a) must be matched by constructor types such as (Maybe a)"
+      (show path ++ ":" ++ " One or more types in the interface implementation " ++
-  show (TypeMismatch path definitionSignature interfaceSignature) = "[INTERFACE ERROR] " ++ show path ++ " : " ++ show definitionSignature ++
+       show definitionSignature ++ " have kinds that do not match the kinds of the types in the interface signature " ++
-                                                                  " doesn't match the interface signature " ++ show interfaceSignature
+       show interfaceSignature ++ "\n" ++ "Types of the form (f a) must be matched by constructor types such as (Maybe a)")
-  show (NonInterface path) = "[INTERFACE ERROR] " ++ show path ++ "Cant' implement the non-interface `" ++ show path ++ "`"
+  show (TypeMismatch path definitionSignature interfaceSignature) =
+    labelStr "INTERFACE ERROR"
+      (show path ++ " : " ++ show definitionSignature ++
+       " doesn't match the interface signature " ++ show interfaceSignature)
+  show (NonInterface path) =
+    labelStr "INTERFACE ERROR"
+      (show path ++ "Cant' implement the non-interface `" ++ show path ++ "`")
 
 -- TODO: This is currently called once outside of this module--try to remove that call and make this internal.
 -- Checks whether a given form's type matches an interface, and if so, registers the form with the interface.

src/Primitives.hs

@@ -124,10 +124,9 @@ primitiveImplements xobj ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), inne
       def = lookupInEnv impl global
   in  maybe notFound found def
   where (SymPath modules _) = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
-        checkInterface = let warn = do putStrWithColor Blue ("[WARNING] The interface " ++ show interface ++ " implemented by " ++ show impl ++
+        checkInterface = let warn = do emitWarning ("The interface " ++ show interface ++ " implemented by " ++ show impl ++
-                                                              " at " ++ prettyInfoFromXObj xobj ++ " is not defined." ++
+                                                    " at " ++ prettyInfoFromXObj xobj ++ " is not defined." ++
-                                                              " Did you define it using `definterface`?")
+                                                    " Did you define it using `definterface`?")
-                                       putStrLnWithColor White "" -- To restore color for sure.
                              tyEnv = getTypeEnv . contextTypeEnv $ ctx
                          in maybe warn (\_ -> pure ()) (lookupInEnv interface tyEnv)
         -- If the implementation binding doesn't exist yet, set the implements
@@ -191,9 +190,8 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
             case previousType of
               Just previousTypeUnwrapped ->
                 unless (areUnifiable (forceTy annXObj) previousTypeUnwrapped) $
-                  do putStrWithColor Blue ("[WARNING] Definition at " ++ prettyInfoFromXObj annXObj ++ " changed type of '" ++ show (getPath annXObj) ++
+                  do emitWarning ("Definition at " ++ prettyInfoFromXObj annXObj ++ " changed type of '" ++ show (getPath annXObj) ++
-                                           "' from " ++ show previousTypeUnwrapped ++ " to " ++ show (forceTy annXObj))
+                                  "' from " ++ show previousTypeUnwrapped ++ " to " ++ show (forceTy annXObj))
-                     putStrLnWithColor White "" -- To restore color for sure.
               Nothing -> pure ()
             case Meta.get "implements" previousMeta of
               Just (XObj (Lst interfaces) _ _) ->