mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
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>
This commit is contained in:
parent
892a972660
commit
fe07a3f062
47
app/Main.hs
47
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
|
||||
|
@ -9,4 +9,5 @@ then
|
||||
fi
|
||||
CARP="$CARP $BUILD_OPTS --"
|
||||
fi
|
||||
export CARP_DIR=`pwd`
|
||||
$CARP $CARP_OPTS "$@"
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
13
src/Eval.hs
13
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
|
||||
|
@ -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.
|
||||
|
@ -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) _ _) ->
|
||||
|
Loading…
Reference in New Issue
Block a user