Skip to content

Hover links for Errors #700

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
TimWhiting wants to merge 1 commit into
base: dev
Choose a base branch
from
Open

Hover links for Errors #700

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion src/Backend/C/FromCore.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1229,7 +1229,7 @@ genLambda params eff body

platform <- getPlatform
env <- getEnv
let emitError doc = do let msg = show doc
let emitError code doc= do let msg = show doc
failure ("Backend.C.genLambda: " ++ msg)
nameDoc = text (show (cdefName env) ++ "@<lambda>")
getDataInfo name = do newtypes <- getNewtypes
Expand Down
95 changes: 80 additions & 15 deletions src/Common/Error.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -15,7 +15,7 @@ module Common.Error( -- error messages
, errorMessage, warningMessage, errorMessageKind, warningMessageKind, toWarning
, mergeErrors, errorsNil, errorsSingle, errorsAdd
-- monad: todo redesign
, Error, ok
, Error, ok, ErrorCode(..), InternalErrorCode(..), BuildErrorCode(..), GeneralErrorCode(..)
, warningMsg, errorMsg, warningMsgs, errorMsgs
, errorMsgPartial, errorMsgsPartial, addErrorMsg
, handleError, checkError, checkPartial, setPartial
Expand Down Expand Up @@ -44,7 +44,9 @@ data Errors = Errors{ errors :: ![ErrorMessage] }
type Warnings = Errors

data ErrorMessage = ErrorMsg{ errRange :: !Range
, errMessage :: !Doc
, errCode :: !Int -- Error code, more specific than the Kind (i.e. for type errors which type error)
, errShortMessage :: !Doc -- Short message for diagnostic panel, this should be short and explain the general error class, with no reference to the code that caused it
, errMessage :: !Doc -- Full message for error report in console or hover information
, errSeverity:: !ErrorSeverity
, errKind :: !ErrorKind
}
Expand All @@ -53,9 +55,72 @@ data ErrorMessage = ErrorMsg{ errRange :: !Range
data ErrorSeverity= SevInfo | SevWarning | SevError
deriving (Eq,Ord,Typeable)

data ErrorKind = ErrGeneral | ErrParse | ErrStatic | ErrKind | ErrType | ErrBuild | ErrInternal
data ErrorKind = ErrGeneral | ErrParse | ErrStatic | ErrKind | ErrType | ErrFip | ErrBuild | ErrInternal
deriving (Eq, Typeable)

errorKindCodeBase :: ErrorKind -> Int
errorKindCodeBase ekind
= case ekind of
ErrGeneral -> 0
ErrParse -> 1000
ErrStatic -> 2000
ErrKind -> 3000
ErrType -> 4000
ErrFip -> 5000
ErrBuild -> 6000
ErrInternal-> 7000

class ErrorCode a where
codeNum :: a -> Int
codeDoc :: a -> Doc

data GeneralErrorCode =
GeneralMonadFail
| GeneralException

instance ErrorCode GeneralErrorCode where
codeNum GeneralMonadFail = 0
codeNum GeneralException = 1
codeDoc GeneralMonadFail = text "internal compiler error in a monadic operation"
codeDoc GeneralException = text "general exception"

data InternalErrorCode =
InternalMonadFail
| InternalException
| InvalidCoreProduced

instance ErrorCode InternalErrorCode where
codeNum InternalMonadFail = 0
codeNum InternalException = 1
codeNum InvalidCoreProduced = 2

codeDoc InternalMonadFail = text "internal compiler error in a monadic operation"
codeDoc InternalException = text "internal exception"
codeDoc InvalidCoreProduced = text "core code produced is invalid"

data BuildErrorCode
= BuildException
| BuildErrorModuleNotFound
| BuildErrorFileNotFound
| BuildErrorInterfaceMissingSource
| BuildErrorModuleNameNotSuffixOfPath
| BuildErrorUnhandledEffects

instance ErrorCode BuildErrorCode where
codeNum BuildException = 0
codeNum BuildErrorModuleNotFound = 100
codeNum BuildErrorFileNotFound = 101
codeNum BuildErrorInterfaceMissingSource = 102
codeNum BuildErrorModuleNameNotSuffixOfPath = 103
codeNum BuildErrorUnhandledEffects = 200
codeDoc BuildException = text "build exception"
codeDoc BuildErrorModuleNotFound = text "module not found"
codeDoc BuildErrorFileNotFound = text "file not found"
codeDoc BuildErrorInterfaceMissingSource = text "interface file found, but source file not found"
codeDoc BuildErrorModuleNameNotSuffixOfPath = text "module name not suffix of path"
codeDoc BuildErrorUnhandledEffects = text "unhandled top level effects"


instance Exception ErrorMessage
instance Exception Errors

Expand All @@ -75,22 +140,21 @@ isWarning emsg
= errSeverity emsg <= SevWarning


infoMessageKind ekind range doc
= ErrorMsg range doc SevInfo ekind
infoMessageKind ekind range code longDoc
= ErrorMsg range (errorKindCodeBase ekind + codeNum code) (codeDoc code) longDoc SevInfo ekind

warningMessageKind ekind range doc
= ErrorMsg range doc SevWarning ekind
warningMessageKind ekind range code longDoc
= ErrorMsg range (errorKindCodeBase ekind + codeNum code) (codeDoc code) longDoc SevWarning ekind

errorMessageKind ekind range doc
= ErrorMsg range doc SevError ekind
errorMessageKind ekind range code longDoc
= ErrorMsg range (errorKindCodeBase ekind + codeNum code) (codeDoc code) longDoc SevError ekind

warningMessage range doc
= warningMessageKind ErrGeneral range doc

errorMessage range doc
= errorMessageKind ErrGeneral range doc


errorsNil :: Errors
errorsNil = Errors []

Expand Down Expand Up @@ -132,17 +196,17 @@ ppErrorSeverity cscheme ekind sev


ppErrorMessage :: FilePath -> Bool -> ColorScheme -> ErrorMessage -> Doc
ppErrorMessage cwd endToo {-show end of range as well?-} cscheme (ErrorMsg range doc esev ekind)
ppErrorMessage cwd endToo {-show end of range as well?-} cscheme (ErrorMsg range _ _ doc esev ekind)
= hang 2 $ ppRange cwd endToo cscheme range <.> colon <+> ppErrorSeverity cscheme ekind esev <+> doc

ppErrors :: FilePath -> Bool -> ColorScheme -> Errors -> Doc
ppErrors cwd endToo cscheme (Errors errs)
= vcat (map (ppErrorMessage cwd endToo cscheme) errs)


toWarning :: ErrorKind -> (Range,Doc) -> ErrorMessage
toWarning ekind (range,doc)
= warningMessageKind ekind range doc
toWarning :: ErrorCode a => ErrorKind -> a -> Range -> Doc -> ErrorMessage
toWarning ekind code range doc
= warningMessageKind ekind range code doc



Expand Down Expand Up @@ -253,7 +317,8 @@ instance Monad (Error b) where
Error msg m -> Error msg m

instance MonadFail (Error b) where
fail s = Error (errorsSingle (errorMessage rangeNull (text s))) Nothing
fail s = Error (errorsSingle (errorMessage rangeNull InternalMonadFail (text s))) Nothing


instance MonadPlus (Error b) where
mzero = Error errorsNil Nothing
Expand Down
8 changes: 7 additions & 1 deletion src/Common/Range.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,7 @@ module Common.Range
, bigLine
, after, rangeContains, rangeIsBefore, rangeStartsAt
, endOfRange, rangeJustBefore, rangeJustAfter
, showRange, showCompactRange
, showRange, showCompactRange, showFileUriRange
, BString, bstringToString, bstringToText, stringToBString
, bstringEmpty, bstringIsEmpty
, readInput
Expand Down Expand Up @@ -260,6 +260,12 @@ showCompactRange :: Range -> String
showCompactRange (Range p1 p2 _)
= "[" ++ showPos 0 p1 ++ "," ++ showPos 0 p2 ++ "]"

-- file:///some/file.js#L73,84-L83,52
-- https://github.com/microsoft/vscode/blob/b3ec8181fc49f5462b5128f38e0723ae85e295c2/src/vs/platform/opener/common/opener.ts#L151-L160
showFileUriRange :: Range -> String
showFileUriRange (Range (Pos (Source file _) _ line1 col1) (Pos _ _ line2 col2) _)
= "file://" ++ file ++ "#L" ++ show line1 ++ "," ++ show col1 ++ "-L" ++ show line2 ++ "," ++ show (col2 + 1)

showRange :: FilePath -> Bool -> Range -> String
showRange cwd endToo (Range p1 p2 _)
= (if (posLine p1 >= bigLine) then ""
Expand Down
24 changes: 12 additions & 12 deletions src/Compile/Build.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -516,7 +516,7 @@ moduleParse tparsedMap
Right (prog,warns)
-> do penv <- getPrettyEnv
let err = if not (reverse (show (programName prog)) `isPrefixOf` reverse (show (modName mod)))
then errorsSingle $ errorMessageKind ErrStatic (programNameRange prog) $
then errorsSingle $ errorMessageKind ErrBuild (programNameRange prog) BuildErrorModuleNameNotSuffixOfPath $
text "the module name" <+> TP.ppName penv (programName prog) <+>
text "is not a suffix of the expected name" <+> TP.ppName penv (modName mod)
else errorsNil
Expand Down Expand Up @@ -776,7 +776,7 @@ moduleFromModuleName relativeDir modName
-> do ifaceExist <- buildDoesFileExistAndNotEmpty ifacePath
if ifaceExist
then do cs <- getColorScheme
addWarningMessage (warningMessageKind ErrBuild rangeNull (text "interface" <+> color (colorModule cs) (pretty modName) <+> text "found but no corresponding source module"))
addWarningMessage (warningMessageKind ErrBuild rangeNull BuildErrorInterfaceMissingSource (text "interface" <+> color (colorModule cs) (pretty modName) <+> text "found but no corresponding source module"))
moduleValidate $ moduleCreateInitial modName "" ifacePath libIfacePath
else throwModuleNotFound rangeNull modName

Expand Down Expand Up @@ -880,12 +880,12 @@ coreReset core
throwModuleNotFound :: Range -> Name -> Build a
throwModuleNotFound range name
= do flags <- getFlags
throwError (\penv -> errorMessageKind ErrBuild range (errorNotFound flags colorModule "module" (pretty name)))
throwError (\penv -> errorMessageKind ErrBuild range BuildErrorModuleNotFound (errorNotFound flags colorModule "module" (pretty name)))

throwFileNotFound :: FilePath -> Build a
throwFileNotFound name
= do flags <- getFlags
throwError (\penv -> errorMessageKind ErrBuild rangeNull (errorNotFound flags colorSource "" (text name)))
throwError (\penv -> errorMessageKind ErrBuild rangeNull BuildErrorFileNotFound (errorNotFound flags colorSource "" (text name)))

errorNotFound flags clr kind namedoc
= text ("could not find" ++ (if null kind then "" else (" " ++ kind)) ++ ":") <+> color (clr cscheme) namedoc <->
Expand Down Expand Up @@ -1031,7 +1031,7 @@ forkTerminal term termProxyDone
= do mbf <- readChan ch
case mbf of
Nothing -> do return ()
Just io -> do io `catchAny` \err -> termError term (errorMessageKind ErrGeneral rangeNull (text (show err)))
Just io -> do io `catchAny` \err -> termError term (errorMessageKind ErrGeneral rangeNull GeneralException (text (show err)))
handleOutput ch


Expand All @@ -1049,18 +1049,18 @@ checked (Build cmp)
let env = env0{ envErrors = errsRef }
res <- do{ x <- cmp env; return (Right x) }
`catch` (\errs -> return (Left errs)) -- ErrorMessage's
`catchError` (\err -> makeErr env ErrInternal (show err)) -- error(...)
`catchIO` (\exn -> makeErr env ErrBuild (show exn)) -- IO errors
`catchError` (\err -> makeErr env ErrInternal InternalException (show err)) -- error(...)
`catchIO` (\exn -> makeErr env ErrBuild BuildException (show exn)) -- IO errors
errsw <- readIORef errsRef
writeIORef errsRef errorsNil
case res of
Right x -> return (Right (x,errsw))
Left errs -> return (Left (mergeErrors errsw errs))
)
where
makeErr env errKind msg
makeErr env errKind code msg
= do let rng = makeSourceRange (show (envModName env)) 1 1 1 1
return (Left (errorsSingle (errorMessageKind errKind rng (text msg))))
return (Left (errorsSingle (errorMessageKind errKind rng code (text msg))))

checkedDefault :: a -> Build a -> Build (a,Errors)
checkedDefault def action
Expand Down Expand Up @@ -1152,7 +1152,7 @@ instance Monad Build where
Build ie' -> ie' env)

instance F.MonadFail Build where
fail msg = throwError (\penv -> errorMessageKind ErrGeneral rangeNull (text msg))
fail msg = throwError (\penv -> errorMessageKind ErrGeneral rangeNull GeneralMonadFail (text msg))

onBuildException :: Build b -> Build a -> Build a
onBuildException (Build onExn) (Build b)
Expand All @@ -1170,7 +1170,7 @@ throwError msg
throwErrorKind :: ErrorKind -> (TP.Env -> Doc) -> Build a
throwErrorKind ekind doc
= do rng <- getCurrentRange
throwError (\penv -> errorMessageKind ekind rng (doc penv))
throwError (\penv -> errorMessageKind ekind rng BuildException (doc penv))

getEnv :: Build Env
getEnv
Expand Down Expand Up @@ -1252,7 +1252,7 @@ addErrorMessageKind :: ErrorKind -> (TP.Env -> Doc) -> Build ()
addErrorMessageKind ekind doc
= do rng <- getCurrentRange
penv <- getPrettyEnv
addErrorMessage (errorMessageKind ekind rng (doc penv))
addErrorMessage (errorMessageKind ekind rng BuildException (doc penv))

phaseTimed :: Int -> String -> (TP.Env -> Doc) -> Build a -> Build a
phaseTimed level p doc action
Expand Down
2 changes: 1 addition & 1 deletion src/Compile/BuildContext.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -467,7 +467,7 @@ completeMain addShow exprName tp buildc
return (handle body', imports' ++ imp)
else addDefaultHandlers range eff ls (imports ++ imp) (handle body)
infos
-> do throwError (\penv -> errorMessageKind ErrBuild range
-> do throwError (\penv -> errorMessageKind ErrBuild range BuildErrorUnhandledEffects
(text "there are unhandled effects for the main expression" <-->
text " inferred effect :" <+> TP.ppType penv eff <-->
text " unhandled effect:" <+> TP.ppType penv l <-->
Expand Down
2 changes: 1 addition & 1 deletion src/Compile/CodeGen.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -758,7 +758,7 @@ dquote s

compilerCatch comp term defValue io
= io `catchSystem` \msg ->
do (termError term) (errorMessageKind ErrBuild rangeNull
do (termError term) (errorMessageKind ErrBuild rangeNull BuildException
(hang 2 $ text ("failure during " ++ comp ++ ":")
<-> string msg)) -- (fillSep $ map string $ words msg)))
return defValue
Expand Down
7 changes: 6 additions & 1 deletion src/Compile/Options.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -70,6 +70,7 @@ prettyEnvFromFlags flags
, TP.verbose = verbose flags
, TP.coreShowTypes = showCoreTypes flags
, TP.showIds = showTypeIds flags
, TP.showFileLinks = showFileLinks flags
}


Expand Down Expand Up @@ -117,6 +118,7 @@ showTypeSigs flags = showHiddenTypeSigs flags || _showTypeSigs flags

data Flags
= Flags{ warnShadow :: !Bool
, showFileLinks :: !Bool
, showKinds :: !Bool
, showKindSigs :: !Bool
, showSynonyms :: !Bool
Expand Down Expand Up @@ -271,6 +273,7 @@ flagsNull :: Flags
flagsNull
= Flags -- warnings
True
False -- show file links
-- show
False False -- kinds kindsigs
False False False False -- synonyms core icore fcore
Expand Down Expand Up @@ -455,6 +458,8 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip

, flag [] ["showtime"] (\b f -> f{ showElapsed = b}) "show elapsed time and rss after evaluation"
, flag [] ["showspan"] (\b f -> f{ showSpan = b}) "show ending row/column too on errors"
, flag [] ["showfilelinks"] (\b f -> f{showFileLinks=b}) "show file links in error messages"

, flag [] ["showkindsigs"] (\b f -> f{showKindSigs=b}) "show kind signatures of type definitions"
, flag [] ["showtypesigs"] (\b f -> f{_showTypeSigs=b}) "show type signatures of definitions"
, flag [] ["showhiddentypesigs"] (\b f -> f{showHiddenTypeSigs=b})"(implies --showtypesigs) show hidden type signatures of definitions"
Expand Down Expand Up @@ -812,7 +817,7 @@ processInitialOptions flags0 opts
-> do arch <- if (null (targetArch flags1)) then getTargetArch else return hostArch
let flags = case mode of
ModeInteractive _ -> flags1{evaluate = True, targetArch = arch }
ModeLanguageServer _ -> flags1{genRangeMap = True, targetArch = arch }
ModeLanguageServer _ -> flags1{genRangeMap = True, targetArch = arch, showFileLinks = True }
_ -> flags1{targetArch = arch}
buildDir <- getKokaBuildDir (buildDir flags) (evaluate flags)
buildTag <- if (null (buildTag flags)) then getDefaultBuildTag else return (buildTag flags)
Expand Down
Loading