From fe07a3f0620aa9ff341c9bfdf74b7819bf413d6d Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Mon, 30 Nov 2020 15:58:25 +0100 Subject: [PATCH] Refactor error reporting and add CARP_DIR check (#1033) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * compiler: refactor error reporting and add CARP_DIR check Co-authored-by: Tim Dévé * set CARP_DIR in tests Co-authored-by: Tim Dévé --- app/Main.hs | 47 +++++++++++++++++++++++++++++------------------ scripts/carp.sh | 1 + src/ColorText.hs | 21 +++++++++++++++++++++ src/Commands.hs | 11 ++++++++--- src/Eval.hs | 13 ++++++------- src/Interfaces.hs | 19 +++++++++++++------ src/Primitives.hs | 12 +++++------- 7 files changed, 83 insertions(+), 41 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 0af8adf4..0408f3cd 100644 --- a/app/Main.hs +++ b/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 - >>= load [carpProfile | hasProfile] - >>= execStrs "Preload" preloads - >>= loadOnce coreModulesToLoad - >>= load argFilesToLoad - >>= execStrs "Postload" postloads - >>= \ctx -> case execMode of - Repl -> do putStrLn "Welcome to Carp 0.4.2" - putStrLn "This is free software with ABSOLUTELY NO WARRANTY." - putStrLn "Evaluate (help) for more information." - snd <$> runRepl ctx - Build -> execStr "Compiler (Build)" "(build)" ctx - Install thing -> execStr "Installation" ("(load \"" ++ thing ++ "\")") ctx - BuildAndRun -> execStr "Compiler (Build & Run)" "(do (build) (run))" ctx - Check -> execStr "Check" "" ctx - -- TODO: Handle the return value from executeString and return that one to the shell + _ <- ifCarpDirSet + (pure startingContext + >>= load [carpProfile | hasProfile] + >>= execStrs "Preload" preloads + >>= loadOnce coreModulesToLoad + >>= load argFilesToLoad + >>= execStrs "Postload" postloads + >>= \ctx -> case execMode of + Repl -> do putStrLn "Welcome to Carp 0.4.2" + putStrLn "This is free software with ABSOLUTELY NO WARRANTY." + putStrLn "Evaluate (help) for more information." + snd <$> runRepl ctx + Build -> execStr "Compiler (Build)" "(build)" ctx + Install thing -> execStr "Installation" ("(load \"" ++ thing ++ "\")") ctx + BuildAndRun -> execStr "Compiler (Build & Run)" "(do (build) (run))" ctx + 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 diff --git a/scripts/carp.sh b/scripts/carp.sh index 446cfaa4..6e90cf4a 100755 --- a/scripts/carp.sh +++ b/scripts/carp.sh @@ -9,4 +9,5 @@ then fi CARP="$CARP $BUILD_OPTS --" fi +export CARP_DIR=`pwd` $CARP $CARP_OPTS "$@" diff --git a/src/ColorText.hs b/src/ColorText.hs index 457aec71..60ecd5e3 100644 --- a/src/ColorText.hs +++ b/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 diff --git a/src/Commands.hs b/src/Commands.hs index 59c61bf8..355ba754 100644 --- a/src/Commands.hs +++ b/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) diff --git a/src/Eval.hs b/src/Eval.hs index b0d8fae7..75e2f036 100644 --- a/src/Eval.hs +++ b/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 - fppl = projectFilePathPrintLength (contextProj ctx) + let fppl = projectFilePathPrintLength (contextProj ctx) case contextExecMode ctx of - Check -> putStrLn (machineReadableInfoFromXObj fppl xobj ++ " " ++ msg) - _ -> putStrLnWithColor Red msg + Check -> putStrLn (machineReadableInfoFromXObj fppl xobj ++ " " ++ e) + _ -> 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 diff --git a/src/Interfaces.hs b/src/Interfaces.hs index ae656278..a678921a 100644 --- a/src/Interfaces.hs +++ b/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 definitionSignature ++ " have kinds that do not match the kinds of the types in the interface signature " ++ - show interfaceSignature ++ "\n" ++ "Types of the form (f a) must be matched by constructor types such as (Maybe a)" - show (TypeMismatch path definitionSignature interfaceSignature) = "[INTERFACE ERROR] " ++ show path ++ " : " ++ show definitionSignature ++ - " doesn't match the interface signature " ++ show interfaceSignature - show (NonInterface path) = "[INTERFACE ERROR] " ++ show path ++ "Cant' implement the non-interface `" ++ show path ++ "`" + show (KindMismatch path definitionSignature interfaceSignature) = + labelStr "INTERFACE ERROR" + (show path ++ ":" ++ " One or more types in the interface implementation " ++ + show definitionSignature ++ " have kinds that do not match the kinds of the types in the interface signature " ++ + show interfaceSignature ++ "\n" ++ "Types of the form (f a) must be matched by constructor types such as (Maybe a)") + 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. diff --git a/src/Primitives.hs b/src/Primitives.hs index 589e1c70..26f7c8b8 100644 --- a/src/Primitives.hs +++ b/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 ++ - " at " ++ prettyInfoFromXObj xobj ++ " is not defined." ++ - " Did you define it using `definterface`?") - putStrLnWithColor White "" -- To restore color for sure. + checkInterface = let warn = do emitWarning ("The interface " ++ show interface ++ " implemented by " ++ show impl ++ + " at " ++ prettyInfoFromXObj xobj ++ " is not defined." ++ + " Did you define it using `definterface`?") 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) ++ - "' from " ++ show previousTypeUnwrapped ++ " to " ++ show (forceTy annXObj)) - putStrLnWithColor White "" -- To restore color for sure. + do emitWarning ("Definition at " ++ prettyInfoFromXObj annXObj ++ " changed type of '" ++ show (getPath annXObj) ++ + "' from " ++ show previousTypeUnwrapped ++ " to " ++ show (forceTy annXObj)) Nothing -> pure () case Meta.get "implements" previousMeta of Just (XObj (Lst interfaces) _ _) ->