carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-11 05:25:28 +03:00
Code Issues Projects Releases Wiki Activity

Refactor error reporting and add CARP_DIR check (#1033)

Browse Source 
* 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:
Veit Heller 2020-11-30 15:58:25 +01:00 committed by GitHub
parent 892a972660
commit fe07a3f062
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 83 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
app/Main.hs
View File

@ -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

1
scripts/carp.sh
View File

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

21
src/ColorText.hs
View File

@ -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

11
src/Commands.hs
View File

@ -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
View File

@ -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

19
src/Interfaces.hs
View File

@ -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.

12
src/Primitives.hs
View File

@ -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) _ _) ->