diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index a10545fee..0605c3e7f 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -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) ++ "@") getDataInfo name = do newtypes <- getNewtypes diff --git a/src/Common/Error.hs b/src/Common/Error.hs index aed9e52bd..20ab26c78 100644 --- a/src/Common/Error.hs +++ b/src/Common/Error.hs @@ -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 @@ -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 } @@ -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 @@ -75,14 +140,14 @@ 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 @@ -90,7 +155,6 @@ warningMessage range doc errorMessage range doc = errorMessageKind ErrGeneral range doc - errorsNil :: Errors errorsNil = Errors [] @@ -132,7 +196,7 @@ 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 @@ -140,9 +204,9 @@ 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 @@ -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 diff --git a/src/Common/Range.hs b/src/Common/Range.hs index b56449abf..97c66c439 100644 --- a/src/Common/Range.hs +++ b/src/Common/Range.hs @@ -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 @@ -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 "" diff --git a/src/Compile/Build.hs b/src/Compile/Build.hs index f55371752..1fce79de1 100644 --- a/src/Compile/Build.hs +++ b/src/Compile/Build.hs @@ -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 @@ -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 @@ -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 <-> @@ -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 @@ -1049,8 +1049,8 @@ 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 @@ -1058,9 +1058,9 @@ checked (Build cmp) 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 @@ -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) @@ -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 @@ -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 diff --git a/src/Compile/BuildContext.hs b/src/Compile/BuildContext.hs index d78a276d9..8587f6f72 100644 --- a/src/Compile/BuildContext.hs +++ b/src/Compile/BuildContext.hs @@ -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 <--> diff --git a/src/Compile/CodeGen.hs b/src/Compile/CodeGen.hs index 424af343a..b4c63ba67 100644 --- a/src/Compile/CodeGen.hs +++ b/src/Compile/CodeGen.hs @@ -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 diff --git a/src/Compile/Options.hs b/src/Compile/Options.hs index d443b3203..f2b5f0445 100644 --- a/src/Compile/Options.hs +++ b/src/Compile/Options.hs @@ -70,6 +70,7 @@ prettyEnvFromFlags flags , TP.verbose = verbose flags , TP.coreShowTypes = showCoreTypes flags , TP.showIds = showTypeIds flags + , TP.showFileLinks = showFileLinks flags } @@ -117,6 +118,7 @@ showTypeSigs flags = showHiddenTypeSigs flags || _showTypeSigs flags data Flags = Flags{ warnShadow :: !Bool + , showFileLinks :: !Bool , showKinds :: !Bool , showKindSigs :: !Bool , showSynonyms :: !Bool @@ -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 @@ -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" @@ -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) diff --git a/src/Core/AnalysisCCtx.hs b/src/Core/AnalysisCCtx.hs index f7fa581ac..8252f7a7b 100644 --- a/src/Core/AnalysisCCtx.hs +++ b/src/Core/AnalysisCCtx.hs @@ -38,16 +38,17 @@ import Kind.Kind import Type.Type import Type.Pretty as Pretty import Type.TypeVar +import Type.InferMonad(TypeInferErrorCode(..)) import Core.Core import Core.Pretty -- take a context and check if it is well-formed and return a well-typed context expression -analyzeCCtx :: Range -> Newtypes -> Expr -> (Int -> ((Expr,[(Range,Doc)]),Int)) +analyzeCCtx :: Range -> Newtypes -> Expr -> (Int -> ((Expr,[(TypeInferErrorCode,Range,Doc)]),Int)) analyzeCCtx rng newtypes expr uniq = let (res,uniq') = runCCtx rng newtypes uniq (cctxCreate expr) in case res of Right e -> ((e,[]),uniq') - Left errs -> let errs' = if null errs then [(rng,text "ill-formed context")] + Left errs -> let errs' = if null errs then [(TypeErrorCCtxIllFormed,rng,text "ill-formed context")] else errs in ((makeCCtxEmpty (typeOf expr),errs'),uniq) @@ -131,7 +132,7 @@ cctxCheckNoHole expr return () -cctxFind :: [(Range,Doc)] -> [Expr] -> [Expr] -> CCtx ([Expr],Ctx,[Expr]) +cctxFind :: [(TypeInferErrorCode,Range,Doc)] -> [Expr] -> [Expr] -> CCtx ([Expr],Ctx,[Expr]) -- no args cctxFind errs acc [] = emitErrors errs @@ -211,7 +212,7 @@ makeCCtxSetContextPath obj conName fieldName newtype CCtx a = CCtx (Int -> CCtxEnv -> Result a) -runCCtx :: Range -> Newtypes -> Int -> CCtx a -> (Either [(Range,Doc)] a,Int) +runCCtx :: Range -> Newtypes -> Int -> CCtx a -> (Either [(TypeInferErrorCode,Range,Doc)] a,Int) runCCtx rng nt uniq (CCtx c) = case (c uniq (CCtxEnv rng nt)) of Ok x u' -> (Right x,u') @@ -221,7 +222,7 @@ runCCtx rng nt uniq (CCtx c) data CCtxEnv = CCtxEnv{ rng :: Range, newtypes :: Newtypes } -data Result a = Err [(Range,Doc)] +data Result a = Err [(TypeInferErrorCode,Range,Doc)] | Ok a Int instance Functor CCtx where @@ -256,18 +257,18 @@ updateEnv :: (CCtxEnv -> CCtxEnv) -> CCtx a -> CCtx a updateEnv f (CCtx c) = CCtx (\u env -> c u (f env)) -emitError :: Doc -> CCtx a -emitError doc +emitError :: TypeInferErrorCode -> Doc -> CCtx a +emitError code doc = do env <- getEnv - emitErrors [(rng env,doc)] + emitErrors [(code,rng env,doc)] -emitErrors :: [(Range,Doc)] -> CCtx a +emitErrors :: [(TypeInferErrorCode,Range,Doc)] -> CCtx a emitErrors errs = do -- mtrace ("emit errors: " ++ show errs) (CCtx (\u env -> Err errs)) -try :: CCtx a -> CCtx (Either [(Range,Doc)] a) +try :: CCtx a -> CCtx (Either [(TypeInferErrorCode,Range,Doc)] a) try (CCtx c) = CCtx (\u env -> case c u env of Ok x u' -> Ok (Right x) u' @@ -291,13 +292,13 @@ ensureValidHoleType :: Type -> CCtx () ensureValidHoleType tp = do env <- getEnv case dataTypeNameOf tp of - Left (TVar{}) -> emitError (text "the hole in the constructor context has an unresolved or polymorphic type") - Left _ -> emitError (text "the hole in the constructor context has an invalid data type") + Left (TVar{}) -> emitError TypeErrorCCtxHolePolymorphicType (text "the hole in the constructor context has an unresolved or polymorphic type") + Left _ -> emitError TypeErrorCCtxHoleInvalidType (text "the hole in the constructor context has an invalid data type") Right name -> case newtypesLookupAny name (newtypes env) of Just dataInfo -> do let (dataRepr,_) = getDataRepr dataInfo when (dataDefIsValue (dataInfoDef dataInfo) || dataReprIsValue dataRepr) $ - emitError (text "the hole in a constructor context cannot be a value type") + emitError TypeErrorCCtxHoleValueType (text "the hole in a constructor context cannot be a value type") return () dataTypeNameOf :: Type -> Either Type Name diff --git a/src/Core/AnalysisMatch.hs b/src/Core/AnalysisMatch.hs index 895fdc677..97070a87f 100644 --- a/src/Core/AnalysisMatch.hs +++ b/src/Core/AnalysisMatch.hs @@ -26,10 +26,11 @@ import Type.Type import Type.Pretty import Type.TypeVar import Type.Unify( runUnifyEx, unify ) +import Type.InferMonad(TypeInferErrorCode(..)) import Core.Core import Core.Pretty -analyzeBranches :: Newtypes -> Name -> Range -> [Branch] -> [Type] -> [DataInfo] -> Bool -> (Bool,[(Range,Doc)],[Branch]) +analyzeBranches :: Newtypes -> Name -> Range -> [Branch] -> [Type] -> [DataInfo] -> Bool -> (Bool,[(TypeInferErrorCode,Range,Doc)],[Branch]) analyzeBranches newtypes defName range branches types infos isLazyMatch = let (exhaustive,branches',warnings) = matchBranches newtypes defName range branches types infos isLazyMatch @@ -61,7 +62,7 @@ instance Pretty Match where | (cinfo,ms) <- cmatches]) pretty (MatchComplete _) = text "" -type Warnings = [(Range,Doc)] +type Warnings = [(TypeInferErrorCode,Range,Doc)] dataInfoGetConInfos :: Bool -> DataInfo -> [ConInfo] @@ -101,16 +102,16 @@ matchBranch newtypes defName range matches patTps branch@(Branch patterns guards analyzeGuards :: Range -> [Guard] -> Warnings analyzeGuards range (Guard test expr : guards) | isExprTrue test && not (null guards) - = [(range, text "Some guards in the branches will never be reached")] + = [(TypeInferGuardUnreachable, range, text "Some guards in the branches will never be reached")] analyzeGuards range (Guard test expr : guards) | isExprFalse test - = [(range, text "Some guard condition in the branches is never true")] ++ analyzeGuards range guards + = [(TypeInferGuardAlwaysFalse, range, text "Some guard condition in the branches is never true")] ++ analyzeGuards range guards analyzeGuards range (g:gs) = analyzeGuards range gs analyzeGuards range [] = [] matchPattern :: Newtypes -> Name -> Range -> Bool -> (Match,Type,Pattern) -> (Match,Pattern,Warnings) matchPattern newtypes defName range top (m@(MatchComplete _), tp, pat) = -- already full matched - let warnings = if top then [(range,text "Some branches in the match will never be reached:" <+> text (show pat))] else [] + let warnings = if top then [(TypeInferBranchUnreachable, range,text "Some branches in the match will never be reached:" <+> text (show pat))] else [] in (m, pat, warnings) matchPattern newtypes defName range top (match@(Match cinfos cmatches), tp, pat) = case pat of diff --git a/src/Core/Check.hs b/src/Core/Check.hs index 34e9833d1..9d2f234d2 100644 --- a/src/Core/Check.hs +++ b/src/Core/Check.hs @@ -49,7 +49,7 @@ checkCore liberalEffects allowPartialApps prettyEnv gamma case checkDefGroups defGroups (return ()) of Check c -> case c uniq (CEnv liberalEffects allowPartialApps gamma prettyEnv []) of Ok x _ -> return x - Err doc -> liftError (warningMsg (warningMessageKind ErrStatic rangeNull doc)) + Err doc -> liftError (warningMsg (warningMessageKind ErrInternal rangeNull InvalidCoreProduced doc)) diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs index 12197aeab..ce482bd4a 100644 --- a/src/Core/CheckFBIP.hs +++ b/src/Core/CheckFBIP.hs @@ -59,7 +59,7 @@ checkFBIP penv platform newtypes borrowed gamma = do uniq <- unique defGroups <- getCoreDefs let (_,warns) = runChk penv uniq platform newtypes borrowed gamma (chkDefGroups defGroups) - liftError (warningMsgs [warningMessageKind ErrStatic range doc | (range,doc) <- warns]) + liftError (warningMsgs [warningMessageKind ErrFip range code doc | (code,range,doc) <- warns]) {-------------------------------------------------------------------------- @@ -111,7 +111,7 @@ chkExpr expr TypeApp body _ -> chkExpr body Lam pars eff body -> do chkEffect eff - requireCapability mayAlloc $ \ppenv -> Just $ + requireCapability FipWarningLambdaAllocation mayAlloc $ \ppenv -> Just $ text "allocating a lambda expression" out <- extractOutput $ chkExpr body writeOutput =<< foldM (\out nm -> bindName nm NotReusable out) out pars @@ -132,7 +132,7 @@ chkExpr expr withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ withTailMod [Let dgs body] $ chkExpr $ defExpr def Let _ _ - -> emitWarning $ \penv -> text "internal: currently the fip analysis cannot handle nested function bindings" + -> emitWarning FipWarningUnsupportedNestedBinding $ \penv -> text "internal: currently the fip analysis cannot handle nested function bindings" Case scrutinees branches -> chkBranches scrutinees branches @@ -203,7 +203,7 @@ bindPattern (PatLit _, _) out = pure out bindPattern (PatWild, tp) out = do ndd <- needsDupDropTp tp when ndd $ - requireCapability mayDealloc $ \ppenv -> Just $ + requireCapability FipWarningDroppedPatternBinder mayDealloc $ \ppenv -> Just $ vcat [text "binding a wildcard pattern of type" <+> pretty tp <+> text "causes deallocation"] pure out @@ -222,7 +222,7 @@ chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function chkFunCallable (getName tname) input <- getInput unless (isTailContext input || getName tname `notElem` defGroupNames input) $ - requireCapability mayRecurse $ \ppenv -> Just $ + requireCapability FipWarningNonTailRecursive mayRecurse $ \ppenv -> Just $ cat [text "non-tail call to a (mutually) recursive function: ", ppName ppenv (getName tname)] chkApp fn args -- local function = do withNonTail $ mapM_ chkExpr args @@ -230,7 +230,7 @@ chkApp fn args -- local function Var tname _ -> isBorrowed tname _ -> pure False unless isBapp $ do - requireCapability mayDealloc $ \ppenv -> Just $ + requireCapability FipWarningOwnedCall mayDealloc $ \ppenv -> Just $ vcat [text "owned calls to functions require deallocation: ", source ppenv (prettyExpr ppenv fn) ] chkExpr fn @@ -247,7 +247,7 @@ chkArg (Borrow, expr) _ -> do chkExpr expr ndd <- needsDupDropTp (typeOf expr) when ndd $ - requireCapability mayDealloc $ \ppenv -> Just $ + requireCapability FipWarningOwnedAsBorrowed mayDealloc $ \ppenv -> Just $ vcat [text "passing owned expressions as borrowed causes deallocation:", source ppenv (prettyExpr ppenv expr)] @@ -265,12 +265,12 @@ chkWrap :: TName -> VarInfo -> Chk () chkWrap tname info = do bs <- getParamInfos (getName tname) unless (Borrow `notElem` bs) $ - emitWarning $ \penv -> text "a function with borrowed parameters is passed as an argument and implicitly wrapped (causing allocation)" + emitWarning FipWarningFunctionWrapped $ \penv -> text "a function with borrowed parameters is passed as an argument and implicitly wrapped (causing allocation)" chkAllocation :: TName -> ConRepr -> Chk () chkAllocation cname repr | isConAsJust repr = pure () chkAllocation cname repr | "_noreuse" `isSuffixOf` nameLocal (conTypeName repr) - = requireCapability mayAlloc $ \ppenv -> Just $ + = requireCapability FipWarningExplicitNoReuse mayAlloc $ \ppenv -> Just $ cat [text "types suffixed with _noreuse are not reused: ", ppName ppenv $ conTypeName repr] chkAllocation cname crepr = do size <- getConstructorAllocSize crepr @@ -281,7 +281,7 @@ chkAllocation cname crepr chkEffect :: Tau -> Chk () chkEffect tp = if isFBIPExtend tp then pure () else - emitWarning $ \penv -> text "algebraic effects other than" <+> ppType penv typePure <+> text "may cause allocation." + emitWarning FipWarningEffectsAllocate $ \penv -> text "algebraic effects other than" <+> ppType penv typePure <+> text "may cause allocation." where isFBIPExtend tp = case extractEffectExtend tp of (taus, tau) -> all isFBIP taus @@ -293,7 +293,7 @@ chkEffect tp {-------------------------------------------------------------------------- Chk monad --------------------------------------------------------------------------} -type Chk a = ReaderT (Env, Input) (WriterT (Output, [(Range,Doc)]) Unique) a +type Chk a = ReaderT (Env, Input) (WriterT (Output, [(FipErrorCode,Range,Doc)]) Unique) a data Env = Env{ currentDef :: [Def], prettyEnv :: Pretty.Env, @@ -330,6 +330,65 @@ instance Semigroup Output where instance Monoid Output where mempty = Output M.empty M.empty Leaf +data FipErrorCode + = FipWarningLambdaAllocation + | FipWarningFunctionWrapped + | FipWarningDroppedPatternBinder + | FipWarningNameUnbound + | FipWarningOwnedCall + | FipWarningOwnedAsBorrowed + | FipWarningNonFipCall + | FipWarningEffectsAllocate + | FipWarningNonTailRecursive + | FipWarningNonLazy + | FipWarningMatchConstructorDropped + | FipWarningBranchUsageDiffers + | FipWarningLastUseBorrowed + | FipWarningVariableShared + | FipWarningVariableDropped + | FipWarningFipDeclarationMismatch + | FipWarningExplicitNoReuse + | FipWarningFipInformationNotFound + | FipWarningUnsupportedNestedBinding +instance ErrorCode FipErrorCode where + codeNum FipWarningLambdaAllocation = 0 + codeNum FipWarningFunctionWrapped = 1 + codeNum FipWarningDroppedPatternBinder = 2 + codeNum FipWarningNameUnbound = 3 + codeNum FipWarningOwnedCall = 4 + codeNum FipWarningOwnedAsBorrowed = 5 + codeNum FipWarningNonFipCall = 6 + codeNum FipWarningEffectsAllocate = 7 + codeNum FipWarningNonTailRecursive = 8 + codeNum FipWarningNonLazy = 9 + codeNum FipWarningMatchConstructorDropped = 10 + codeNum FipWarningBranchUsageDiffers = 11 + codeNum FipWarningLastUseBorrowed = 12 + codeNum FipWarningVariableShared = 13 + codeNum FipWarningVariableDropped = 14 + codeNum FipWarningFipDeclarationMismatch = 15 + codeNum FipWarningExplicitNoReuse = 100 + codeNum FipWarningFipInformationNotFound = 101 + codeNum FipWarningUnsupportedNestedBinding = 200 + codeDoc FipWarningLambdaAllocation = text "lambda allocation is not fip" + codeDoc FipWarningFunctionWrapped = text "function is wrapped and causes allocation" + codeDoc FipWarningDroppedPatternBinder = text "wildcard pattern binder causes deallocation" + codeDoc FipWarningNameUnbound = text "borrowed name may have been used" + codeDoc FipWarningOwnedCall = text "owned call requires deallocation" + codeDoc FipWarningOwnedAsBorrowed = text "passing owned expression as borrowed causes deallocation" + codeDoc FipWarningNonFipCall = text "non-fip function call" + codeDoc FipWarningEffectsAllocate = text "effects other than pure may cause allocation" + codeDoc FipWarningNonTailRecursive = text "non-tail (mutually) recursive function causes allocation" + codeDoc FipWarningNonLazy = text "non-lazy constructor causes allocation" + codeDoc FipWarningMatchConstructorDropped = text "match constructor is not reused" + codeDoc FipWarningBranchUsageDiffers = text "branch usage differs from the function definition" + codeDoc FipWarningLastUseBorrowed = text "last use of variable is borrowed (causing deallocation)" + codeDoc FipWarningVariableShared = text "variable is shared (causing deallocation)" + codeDoc FipWarningVariableDropped = text "variable is dropped (causing deallocation)" + codeDoc FipWarningExplicitNoReuse = text "explicit _no_reuse causes allocation" + codeDoc FipWarningFipDeclarationMismatch = text "fip declaration mismatch" + codeDoc FipWarningUnsupportedNestedBinding = text "nested function bindings not supported currently" + prettyGammaNm :: Pretty.Env -> Output -> Doc prettyGammaNm ppenv (Output nm dia _) = tupled $ map @@ -346,7 +405,7 @@ prettyGammaDia ppenv (Output nm dia _) (\(sz, cs) -> map (\(_, (c,_):_) -> prettyCon ppenv c sz) cs) (M.toList dia) -runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Gamma -> Chk a -> (a,[(Range,Doc)]) +runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Gamma -> Chk a -> (a,[(FipErrorCode,Range,Doc)]) runChk penv u platform newtypes borrowed gamma c = fst $ runUnique 0 $ fmap (fmap snd) $ runWriterT $ @@ -400,10 +459,10 @@ chkFunCallable fn Nothing | fn `elem` [nameCCtxSetCtxPath,nameFieldAddrOf] -> writeCallAllocation fn (Fip (AllocAtMost 0)) Nothing - -> emitWarning $ \penv -> text "internal: fip analysis could not find fip information for function:" <+> ppName penv fn + -> emitWarning FipWarningFipInformationNotFound $ \penv -> text "internal: fip analysis could not find fip information for function:" <+> ppName penv fn Just fip' -> if fip' `isCallableFrom` fip then writeCallAllocation fn fip' - else emitWarning $ \penv -> text "calling a non-fip function:" <+> ppName penv fn + else emitWarning FipWarningNonFipCall $ \penv -> text "calling a non-fip function:" <+> ppName penv fn where isCallableFrom (Fip _) _ = True isCallableFrom (Fbip _ _) (Fbip _ _) = True @@ -434,11 +493,11 @@ chkLazyCon (TName cname _) repr let fip' = conInfoLazyFip conInfo if not (conInfoIsLazy conInfo) || fip' `isCallableFrom` fip then writeCallAllocation cname fip' - else emitWarning $ \penv -> text "allocating a non-fip lazy constructor:" <+> ppName penv cname + else emitWarning FipWarningNonLazy $ \penv -> text "allocating a non-fip lazy constructor:" <+> ppName penv cname _ -> warn Nothing -> warn where - warn = emitWarning $ \penv -> text "internal: fip analysis could not find fip information for constructor:" <+> ppName penv cname + warn = emitWarning FipWarningFipInformationNotFound $ \penv -> text "internal: fip analysis could not find fip information for constructor:" <+> ppName penv cname -- you can use an fbip lazy constructor in a fip function isCallableFrom (NoFip _) (Fip _) = False @@ -463,13 +522,13 @@ extractOutput f -- | Perform a test if the capability is not present -- and emit a warning if the test is unsuccessful. -requireCapability :: Chk Bool -> (Pretty.Env -> Maybe Doc) -> Chk () -requireCapability mayUseCap test +requireCapability :: FipErrorCode -> Chk Bool -> (Pretty.Env -> Maybe Doc) -> Chk () +requireCapability code mayUseCap test = do hasCap <- mayUseCap unless hasCap $ do env <- getEnv case test (prettyEnv env) of - Just warning -> emitWarning (\_ -> warning) + Just warning -> emitWarning code (\_ -> warning) Nothing -> pure () withNonTail :: Chk a -> Chk a @@ -535,7 +594,7 @@ markBorrowed nm info markSeen nm info isHeapValue <- needsDupDrop nm when (isHeapValue && infoIsRefCounted info) $ - requireCapability mayDealloc $ \ppenv -> Just $ + requireCapability FipWarningLastUseBorrowed mayDealloc $ \ppenv -> Just $ text "the last use of" <+> ppName ppenv (getName nm) <+> text "is borrowed (causing deallocation)" getAllocation :: TName -> Reusable -> Chk () @@ -547,7 +606,7 @@ getAllocation nm (ReusableWithSize size) provideToken :: TName -> Reusable -> Output -> Chk Output provideToken _ NotReusable out = pure out provideToken debugName (ReusableWithSize size) out - = do requireCapability mayDealloc $ \ppenv -> + = do requireCapability FipWarningMatchConstructorDropped mayDealloc $ \ppenv -> let fittingAllocs = M.findWithDefault [] size (gammaDia out) in case fittingAllocs of [] -> Just $ text "the matched constructor" <+> prettyCon ppenv debugName size <+> text "is not reused" @@ -565,7 +624,7 @@ joinContexts pats cs (allReusable, c') <- foldM tryReuse (True, c) (map fst $ M.toList unused) pure (allReusable, c') unless (and noDealloc) $ do - requireCapability mayDealloc $ \ppenv -> Just $ + requireCapability FipWarningBranchUsageDiffers mayDealloc $ \ppenv -> Just $ vcat $ text "not all branches use the same variables:" : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaNm ppenv out]) pats cs let unionDia = foldl1' (M.unionWith zipTokens) $ map (M.map (adjustProb (length cs')) . gammaDia) cs' @@ -618,7 +677,7 @@ bindName nm msize out Just n -- variable is used 'n' times -> do isHeapVal <- needsDupDrop nm when (n > 1 && isHeapVal) $ - requireCapability mayAlloc $ \ppenv -> Just $ + requireCapability FipWarningVariableShared mayAlloc $ \ppenv -> Just $ text "the variable" <+> ppName ppenv (getName nm) <+> text "is used multiple times (causing sharing and preventing reuse)" pure $ out { gammaNm = M.delete nm (gammaNm out) } @@ -628,7 +687,7 @@ chkDrop isTopLevelReused nm isFlat <- isFlatType nm unless ((isTopLevelReused && isFlat) || not isHeapValue) $ -- non-reused heap values are dropped - requireCapability mayDealloc $ \ppenv -> Just $ + requireCapability FipWarningVariableDropped mayDealloc $ \ppenv -> Just $ text "the variable" <+> ppName ppenv (getName nm) <+> text "is unused (causing deallocation)" -- | We record if the program has both an allocation @@ -677,7 +736,7 @@ checkOutputEmpty out = do case M.maxViewWithKey $ gammaNm out of Nothing -> pure () Just ((nm, _), _) - -> emitWarning $ \penv -> text "unbound name (which may have been used despite being borrowed):" <+> ppName penv (getName nm) + -> emitWarning FipWarningNameUnbound $ \penv -> text "unbound name (which may have been used despite being borrowed):" <+> ppName penv (getName nm) let notReused = S.fromList $ map snd $ concatMap snd $ concatMap snd $ M.toList $ gammaDia out (allocations, allocInLoop) = getAllocCredits notReused (allocTree out) allocations' = if hasBothInSequence allocInLoop then AllocUnlimited else allocations @@ -685,7 +744,7 @@ checkOutputEmpty out -- chkTrace $ show $ simplifyAllocTree (allocTree out) permission <- fipAlloc <$> getFip unless (allocations' <= permission) $ - emitWarning $ \penv -> text "function allocates" + emitWarning FipWarningFipDeclarationMismatch $ \penv -> text "function allocates" <+> text (prettyFipAlloc allocations') <+> text "but was declared as allocating" <+> text (prettyFipAlloc permission) @@ -776,11 +835,11 @@ chkTrace msg = do env <- getEnv trace ("chk: " ++ show (map defName (currentDef env)) ++ ": " ++ msg) $ return () -emitDoc :: Range -> Doc -> Chk () -emitDoc rng doc = tell (mempty, [(rng,doc)]) +emitDoc :: FipErrorCode -> Range -> Doc -> Chk () +emitDoc code rng doc = tell (mempty, [(code,rng,doc)]) -emitWarning :: (Pretty.Env -> Doc) -> Chk () -emitWarning makedoc +emitWarning :: FipErrorCode -> (Pretty.Env -> Doc) -> Chk () +emitWarning code makedoc = do env <- getEnv let (rng,name) = case currentDef env of (def:_) -> (defNameRange def, defName def) @@ -788,7 +847,7 @@ emitWarning makedoc penv = prettyEnv env fdoc = text "fip fun" <+> ppName penv name <.> colon <+> makedoc penv when (qualifier name /= nameCoreDebug) $ - emitDoc rng fdoc + emitDoc code rng fdoc getConstructorAllocSize :: ConRepr -> Chk Reusable getConstructorAllocSize conRepr diff --git a/src/Interpreter/Interpret.hs b/src/Interpreter/Interpret.hs index ac3295015..770b2eddf 100644 --- a/src/Interpreter/Interpret.hs +++ b/src/Interpreter/Interpret.hs @@ -302,7 +302,7 @@ buildTypeExpr st buildc expr errorFileNotFound :: Flags -> FilePath -> ErrorMessage errorFileNotFound flags name - = errorMessageKind ErrBuild rangeNull (docNotFound (colorSchemeFromFlags flags) (includePath flags) name) + = errorMessageKind ErrBuild rangeNull BuildErrorFileNotFound (docNotFound (colorSchemeFromFlags flags) (includePath flags) name) docNotFound cscheme path name = text "could not find:" <+> ppPath name <-> diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index aa3a7c5db..e692a198c 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -109,8 +109,8 @@ inferKinds isValue colors platform mbRangeMap imports kgamma0 syns0 data0 cons1 = constructorsFromList conInfos gamma1 = constructorGamma isValue dataInfos errs5 = constructorCheckDuplicates colors conInfos - warns = [warningMessageKind ErrKind rng doc | (rng,doc) <- warns1 ++ warns2 ++ warns3 ++ warns4] - errs = [errorMessageKind ErrKind rng doc | (rng,doc) <- errs1 ++ errs2 ++ errs3 ++ errs4 ++ errs5] + warns = [warningMessageKind ErrKind rng code doc | (code,rng,doc) <- warns1 ++ warns2 ++ warns3 ++ warns4] + errs = [errorMessageKind ErrKind rng code doc | (code,rng,doc) <- errs1 ++ errs2 ++ errs3 ++ errs4 ++ errs5] -- now order and group definitions including newly synthesized definitions for type definitions dgroups = groupBindings modName (synDefs ++ defs1) @@ -653,7 +653,7 @@ lazyConDefCall info conInfo parNames recurseArg memoTarget topExpr memoizeWarning rng fdoc = do cs <- getColorScheme let showConName name = color (colorCons cs) (pretty (unqualify name)) - addWarning rng $ text "Cannot update the lazy constructor" <+> showConName (conInfoName conInfo) <+> fdoc showConName + addWarning KindErrorLazyConstructorUpdate rng $ text "Cannot update the lazy constructor" <+> showConName (conInfoName conInfo) <+> fdoc showConName memoizeCon cname con nargs range @@ -772,7 +772,7 @@ lazyAddUpdate info conInfo evalName arg topExpr updateWarning rng fdoc = do cs <- getColorScheme let showConName name = color (colorCons cs) (pretty (unqualify name)) - addWarning rng $ text "Cannot update the lazy constructor" <+> showConName (conInfoName conInfo) <+> fdoc showConName + addWarning KindErrorLazyConstructorUpdate rng $ text "Cannot update the lazy constructor" <+> showConName (conInfoName conInfo) <+> fdoc showConName lazyUpdateCon cname expr @@ -826,7 +826,7 @@ constructorGamma isValue dataInfos conInfoGamma conInfos = gammaNew [(conInfoName conInfo,InfoCon (conInfoVis conInfo) (conInfoType conInfo) conRepr conInfo (conInfoRange conInfo) (conInfoDoc conInfo)) | (conInfo,conRepr) <- conInfos] -constructorCheckDuplicates :: ColorScheme -> [ConInfo] -> [(Range,Doc)] +constructorCheckDuplicates :: ColorScheme -> [ConInfo] -> [(KindInferErrorCode,Range,Doc)] constructorCheckDuplicates cscheme conInfos = concatMap duplicate $ groupBy sameName conInfos where @@ -834,7 +834,7 @@ constructorCheckDuplicates cscheme conInfos = conInfoName ci1 == conInfoName ci2 duplicate (ci1:ci2:_) - = [(conInfoRange ci2 + = [(KindErrorDuplicateConstructorName, conInfoRange ci2 ,text "Constructor" <+> color (colorSource cscheme) (pretty (conInfoName ci2)) <+> text "is already defined at" <+> text (show (conInfoRange ci1)))] duplicate _ @@ -903,7 +903,7 @@ checkRecursion :: [TypeDef UserType UserType UserKind] -> KInfer () checkRecursion tdefs = if (length tdefs <= 1 || any isDataType tdefs) then return () - else do addError (getRange tdefs) (text "Type synonyms cannot be recursive") + else do addError KindErrorTypeSynonymRecursive (getRange tdefs) (text "Type synonyms cannot be recursive") return () where isDataType (DataType{}) = True @@ -1381,7 +1381,7 @@ addLazyIndirect (DataType newtp targs constructors range vis sort ddef dataEff d _ -> False when (not validDdef) $ - addError rng $ text "Cannot add lazy constructors to a" <+> text (show ddef) <+> text "type" + addError KindErrorLazyConstructorOnInvalidType rng $ text "Cannot add lazy constructors to a" <+> text (show ddef) <+> text "type" -- get fip annotation of the data defintion let userConFip con = case userConLazy con of @@ -1393,7 +1393,7 @@ addLazyIndirect (DataType newtp targs constructors range vis sort ddef dataEff d DataDefLazy fip -> -- trace ("fip check: " ++ show (fip,defaultFip) ++ ", gt? " ++ show (fip > defaultFip)) $ if (fip < defaultFip) -- annotated - then do addError rng $ text "The datatype" <+> text (show fip) <+> text "annotation cannot be more restrictive than the fip annotations of the lazy constructors" + then do addError KindErrorTypeMoreRestrictiveFipThanConstructor rng $ text "The datatype" <+> text (show fip) <+> text "annotation cannot be more restrictive than the fip annotations of the lazy constructors" return defaultFip else return fip _ -> return defaultFip @@ -1485,13 +1485,13 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort else let effNames = concatMap fromOpsName recNames fromOpsName nm = if (isOperationsName nm) then [fromOperationsName nm] else [] in if (any (occursNegativeCon (recNames ++ effNames)) (conInfos0)) - then do addError range (text "Type" <+> nameDoc <+> text "is declared as being" <-> text " (co)inductive but it occurs recursively in a negative position." <-> + then do addError KindErrorInductiveTypeRecursive range (text "Type" <+> nameDoc <+> text "is declared as being" <-> text " (co)inductive but it occurs recursively in a negative position." <-> text " hint: declare it as a divergent (or retractive) type using 'div type' (or 'div effect') to allow negative occurrences") else return () -- create datadef and conInfos with correct ValueRepr and ordered fields - let emitError d = addError range (text "Type" <+> nameDoc <+> d) - emitWarning d = addWarning range (text "Type" <+> nameDoc <+> d) + let emitError code d = addError code range (text "Type" <+> nameDoc <+> d) + emitWarning code d = addWarning code range (text "Type" <+> nameDoc <+> d) resultHasKindStar = hasKindStarResult (getKind typeResult) maxMembers = maximum ([0] ++ map (length . conInfoParams) conInfos0) conCount = length conInfos0 @@ -1721,7 +1721,7 @@ resolveApp idmap partialSyn (TpVar name r,args) rng = do (tp',kind) <- case M.lookup name idmap of Nothing -> do cs <- getColorScheme -- failure ("Kind.Infer.ResolveApp: cannot find: " ++ show name ++ " at " ++ show rng) - addError rng (text "Type variable" <+> color (colorType cs) (pretty name) <+> text "is undefined" <-> + addError KindErrorTypeVariableNotDefined rng (text "Type variable" <+> color (colorType cs) (pretty name) <+> text "is undefined" <-> text " hint: bind the variable using" <+> color (colorType cs) (text "forall<" <.> pretty name <.> text ">")) id <- uniqueId (show name) return (TVar (TypeVar id kindStar Bound), kindStar) @@ -1739,7 +1739,7 @@ resolveApp idmap partialSyn (TpCon name r,[fixed,ext]) rng | name == nameEffect let (ls,tl) = extractOrderedEffect fixed' if isEffectEmpty tl then return () - else addError rng (text "Effects can only have one extension point (use a `|` instead of a comma in the effect type ?)") + else addError KindErrorEffectMultipleVariables rng (text "Effects can only have one extension point (use a `|` instead of a comma in the effect type ?)") return (shallowEffectExtend fixed' ext') resolveApp idmap partialSyn (TpCon name r,args) rng @@ -1753,10 +1753,10 @@ resolveApp idmap partialSyn (TpCon name r,args) rng -> do -- check over/under application if (not partialSyn && length args < length params) then do cs <- getColorScheme - addError rng (text "Type alias" <+> color (colorType cs) (pretty name) <+> text "has too few arguments") + addError KindErrorTypeSynonymTooFewArguments rng (text "Type alias" <+> color (colorType cs) (pretty name) <+> text "has too few arguments") else if (length args > length params) then do cs <- getColorScheme - addError rng (text "Type alias" <+> color (colorType cs) (pretty name) <+> text "has too many arguments") + addError KindErrorTypeSynonymTooManyArguments rng (text "Type alias" <+> color (colorType cs) (pretty name) <+> text "has too many arguments") else return () args' <- mapM (resolveType idmap True) args -- partially applied synonyms are allowed in synonym applications let tsyn = (TSyn (TypeSyn name kind rank (Just syn)) args' (subNew (zip params args') |-> tp)) diff --git a/src/Kind/InferMonad.hs b/src/Kind/InferMonad.hs index 60c4e25c7..76041df50 100644 --- a/src/Kind/InferMonad.hs +++ b/src/Kind/InferMonad.hs @@ -23,6 +23,7 @@ module Kind.InferMonad( KInfer , infQualifiedName , checkExternal , withDataEffects, lookupDataEffect + , KindInferErrorCode(..), ) where @@ -55,6 +56,7 @@ import Type.Type import Syntax.RangeMap import qualified Core.Core as Core +import Common.Error (ErrorCode(..)) {--------------------------------------------------------------- Inference monad @@ -68,9 +70,9 @@ data KEnv = KEnv{ cscheme :: !ColorScheme, platform :: !Platform, currentM , newtypesImported :: !Newtypes, newtypesExtended :: !Newtypes , dataEffects :: M.NameMap DataEffect } -data KResult a = KResult{ result:: !a, errors:: ![(Range,Doc)], warnings :: ![(Range,Doc)], st :: !KSt } +data KResult a = KResult{ result:: !a, errors:: ![(KindInferErrorCode,Range,Doc)], warnings :: ![(KindInferErrorCode,Range,Doc)], st :: !KSt } -runKindInfer :: ColorScheme -> Platform -> Maybe RangeMap -> Name -> ImportMap -> KGamma -> Synonyms -> Newtypes -> Int -> KInfer a -> ([(Range,Doc)],[(Range,Doc)],Maybe RangeMap,Int,a) +runKindInfer :: ColorScheme -> Platform -> Maybe RangeMap -> Name -> ImportMap -> KGamma -> Synonyms -> Newtypes -> Int -> KInfer a -> ([(KindInferErrorCode,Range,Doc)],[(KindInferErrorCode,Range,Doc)],Maybe RangeMap,Int,a) runKindInfer cscheme platform mbRangeMap moduleName imports kgamma syns datas unique (KInfer ki) = let imports' = case importsExtend ({-toShortModuleName-} moduleName) moduleName imports of Just imp -> imp @@ -107,15 +109,15 @@ getKindEnv :: KInfer KEnv getKindEnv = KInfer (\env -> \st -> KResult env [] [] st) -addError :: Range -> Doc -> KInfer () -addError range doc +addError :: KindInferErrorCode -> Range -> Doc -> KInfer () +addError code range doc = do addRangeInfo range (Error doc) - KInfer (\env -> \st -> KResult () [(range,doc)] [] st) + KInfer (\env -> \st -> KResult () [(code,range,doc)] [] st) -addWarning :: Range -> Doc -> KInfer () -addWarning range doc +addWarning :: KindInferErrorCode -> Range -> Doc -> KInfer () +addWarning code range doc = do addRangeInfo range (Warning doc) - KInfer (\env -> \st -> KResult () [] [(range,doc)] st) + KInfer (\env -> \st -> KResult () [] [(code,range,doc)] st) getKSub :: KInfer KSub getKSub @@ -207,7 +209,7 @@ extendInfGamma tbinders ki Nothing -> return (M.insert name infkind infgamma) Just _ -> do env <- getKindEnv let cs = cscheme env - addError nameRange $ text "Type" <+> ppType cs name <+> text "is already defined" + addError KindErrorTypeNameAlreadyDefined nameRange $ text "Type" <+> ppType cs name <+> text "is already defined" return (M.insert name infkind infgamma) -- replace @@ -239,7 +241,7 @@ extendKGamma ranges (Core.TypeDefGroup (tdefs)) ki case kgammaLookupQ name kgamma of Nothing -> return (kgammaExtend name kind doc kgamma,tdef:tdefs) Just _ -> do env <- getKindEnv - addError range $ text "Type" <+> ppType (cscheme env) name <+> + addError KindErrorTypeNameAlreadyDefined range $ text "Type" <+> ppType (cscheme env) name <+> text "is already defined" return (kgamma,tdefs) where @@ -286,7 +288,7 @@ checkExternal name range case mbRes of Just range0 -> do env <- getKindEnv let cs = cscheme env - addError range (text "external" <+> prettyName cs name <+> text "is already defined at" <+> text (show (rangeStart range0)) + addError KindErrorExternNameAlreadyDefined range (text "external" <+> prettyName cs name <+> text "is already defined at" <+> text (show (rangeStart range0)) <-> text "hint: use a local qualifier?") return () Nothing -> addExternal name range @@ -302,18 +304,18 @@ infQualifiedName name range Right (name',alias) -> if (not (nameCaseEqualPrefixOf alias (qualifier name))) then do let cs = cscheme env - addError range (text "module" <+> ppModule cs name <+> text "should be cased as" <+> color (colorModule cs) (pretty alias) + addError KindErrorModuleNameInvalidCase range (text "module" <+> ppModule cs name <+> text "should be cased as" <+> color (colorModule cs) (pretty alias) -- <+> text (showPlain name ++ ", " ++ showPlain alias) ) return name' else return name' Left [] -> do let cs = cscheme env - addError range (text "module" <+> ppModule cs name <+> text "is undefined") + addError KindErrorModuleNameNotDefined range (text "module" <+> ppModule cs name <+> text "is undefined") return name Left aliases -> do let cs = cscheme env - addError range (text "module" <+> ppModule cs name <+> ambiguous cs aliases) + addError KindErrorModuleNameAmbiguous range (text "module" <+> ppModule cs name <+> ambiguous cs aliases) return name ppModule cs name @@ -342,12 +344,12 @@ findInfKind name0 range if (-- trace ("compare: " ++ show (qname,name,name0)) $ not (nameCaseEqual name' name)) then do let cs = cscheme env - addError range (text "type" <+> (ppType cs (unqualify name0)) <+> text "should be cased as" <+> ppType cs (unqualify name')) + addError KindErrorTypeNameInvalidCase range (text "type" <+> (ppType cs (unqualify name0)) <+> text "should be cased as" <+> ppType cs (unqualify name')) else return () case mbAlias of Just alias | nameModule name0 /= nameModule alias -> do let cs = cscheme env - addError range (text "module" <+> color (colorModule cs) (text (nameModule name0)) <+> text "should be cased as" <+> color (colorModule cs) (pretty alias) + addError KindErrorModuleNameInvalidCase range (text "module" <+> color (colorModule cs) (text (nameModule name0)) <+> text "should be cased as" <+> color (colorModule cs) (pretty alias) -- <+> text (show (name,qname,mbAlias,name0)) -- <+> text ( nameModule name0 ++ ", " ++ showPlain alias) ) @@ -355,12 +357,12 @@ findInfKind name0 range return (qname,KICon kind, doc) NotFound -> do let cs = cscheme env -- trace ("cannot find type: " ++ show name ++ ", " ++ show (currentModule env) ++ ", " ++ show (kgamma env)) $ - addError range (text "Type" <+> (ppType cs name) <+> text "is not defined" <-> + addError KindErrorTypeNameNotDefined range (text "Type" <+> (ppType cs name) <+> text "is not defined" <-> text " hint: bind the variable using" <+> color (colorType cs) (text "forall<" <.> ppType cs name <.> text ">") <+> text "?") k <- freshKind return (name,k,"") Ambiguous names -> do let cs = cscheme env - addError range (text "Type" <+> ppType cs name <+> ambiguous cs names) + addError KindErrorTypeNameAmbiguous range (text "Type" <+> ppType cs name <+> ambiguous cs names) k <- freshKind return (name,k,"") @@ -419,3 +421,103 @@ lookupDataEffect name case mbDataInfo of Just di -> return (dataInfoEffect di) Nothing -> return DataNoEffect + +data KindInferErrorCode = + -- Module Names + KindErrorModuleNameNotDefined + | KindErrorModuleNameAmbiguous + | KindErrorModuleNameInvalidCase + -- Types Names + | KindErrorTypeNameNotDefined + | KindErrorTypeNameAmbiguous + | KindErrorTypeNameInvalidCase + | KindErrorTypeNameAlreadyDefined + -- External Names + | KindErrorExternNameAlreadyDefined + -- Type Declarations + | KindErrorTypeMoreRestrictiveFipThanConstructor + | KindErrorInductiveTypeRecursive + | KindErrorDuplicateConstructorName + | KindErrorValueTypeRecursive + | KindErrorValueTypeNotInductive + | KindErrorValueTypeMismatch + | KindWarningValueTypeUnknownSize + | KindWarningValueTypeLarge + | KindErrorValueTypeMixedFields + | KindWarningValueTypeAnnotationRedundant + -- Type Aliases + | KindErrorTypeSynonymRecursive + | KindErrorTypeSynonymTooFewArguments + | KindErrorTypeSynonymTooManyArguments + -- Lazy Constructors + | KindErrorLazyConstructorUpdate + | KindErrorLazyConstructorOnInvalidType + -- Annotations + | KindErrorEffectMultipleVariables + | KindErrorTypeVariableNotDefined + -- Unification Errors + | KindErrorKindMismatch + + +instance ErrorCode KindInferErrorCode where + -- Module Names + codeNum KindErrorModuleNameNotDefined = 0 + codeNum KindErrorModuleNameAmbiguous = 1 + codeNum KindErrorModuleNameInvalidCase = 2 + -- Types Names + codeNum KindErrorTypeNameNotDefined = 100 + codeNum KindErrorTypeNameAmbiguous = 101 + codeNum KindErrorTypeNameInvalidCase = 102 + codeNum KindErrorTypeNameAlreadyDefined = 103 + -- External Names + codeNum KindErrorExternNameAlreadyDefined = 200 + -- Type Declarations + codeNum KindErrorTypeMoreRestrictiveFipThanConstructor = 300 + codeNum KindErrorInductiveTypeRecursive = 301 + codeNum KindErrorDuplicateConstructorName = 302 + codeNum KindErrorValueTypeRecursive = 303 + codeNum KindErrorValueTypeNotInductive = 304 + codeNum KindErrorValueTypeMismatch = 305 + codeNum KindWarningValueTypeUnknownSize = 306 + codeNum KindWarningValueTypeLarge = 307 + codeNum KindErrorValueTypeMixedFields = 308 + codeNum KindWarningValueTypeAnnotationRedundant = 309 + -- Type Aliases + codeNum KindErrorTypeSynonymRecursive = 400 + codeNum KindErrorTypeSynonymTooFewArguments = 401 + codeNum KindErrorTypeSynonymTooManyArguments = 402 + -- Lazy Constructors + codeNum KindErrorLazyConstructorUpdate = 500 + codeNum KindErrorLazyConstructorOnInvalidType = 501 + -- Annotations + codeNum KindErrorEffectMultipleVariables = 600 + codeNum KindErrorTypeVariableNotDefined = 601 + -- Unification Errors + codeNum KindErrorKindMismatch = 700 + + codeDoc KindErrorModuleNameNotDefined = text "module name not defined" + codeDoc KindErrorModuleNameAmbiguous = text "module name ambiguous" + codeDoc KindErrorModuleNameInvalidCase = text "module name invalid case" + codeDoc KindErrorTypeNameNotDefined = text "type name not defined" + codeDoc KindErrorTypeNameAmbiguous = text "type name ambiguous" + codeDoc KindErrorTypeNameInvalidCase = text "type name invalid case" + codeDoc KindErrorTypeNameAlreadyDefined = text "type name already defined" + codeDoc KindErrorExternNameAlreadyDefined = text "extern name already defined" + codeDoc KindErrorTypeMoreRestrictiveFipThanConstructor = text "type's fip annotation is more restrictive than a constructor's" + codeDoc KindErrorInductiveTypeRecursive = text "inductive type cannot be recursive" + codeDoc KindErrorValueTypeRecursive = text "value type cannot be recursive" + codeDoc KindErrorValueTypeNotInductive = text "value type cannot be inductive" + codeDoc KindErrorValueTypeMismatch = text "value type mismatch" + codeDoc KindWarningValueTypeUnknownSize = text "value type has unknown size" + codeDoc KindWarningValueTypeLarge = text "value type is large" + codeDoc KindErrorValueTypeMixedFields = text "value type has mixed fields" + codeDoc KindWarningValueTypeAnnotationRedundant = text "value type annotation is redundant for an enumerated type" + codeDoc KindErrorDuplicateConstructorName = text "duplicate constructor name" + codeDoc KindErrorTypeSynonymRecursive = text "type synonym cannot be recursive" + codeDoc KindErrorTypeSynonymTooFewArguments = text "type synonym has too few arguments" + codeDoc KindErrorTypeSynonymTooManyArguments = text "type synonym has too many arguments" + codeDoc KindErrorLazyConstructorUpdate = text "lazy constructor cannot be updated in place" + codeDoc KindErrorLazyConstructorOnInvalidType = text "lazy constructor on invalid type" + codeDoc KindErrorEffectMultipleVariables = text "effect annotation has multiple variables" + codeDoc KindErrorTypeVariableNotDefined = text "type variable not defined" + codeDoc KindErrorKindMismatch = text "kind mismatch" \ No newline at end of file diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs index b29dae1e9..f501ce387 100644 --- a/src/Kind/Repr.hs +++ b/src/Kind/Repr.hs @@ -18,6 +18,7 @@ import Common.NamePrim import Common.Syntax import Common.Failure import Type.Type +import Kind.InferMonad --------------------------------------------------------- -- Create a datadef and elaborate conInfo's with a ValueRepr @@ -26,7 +27,7 @@ import Type.Type --------------------------------------------------------- -- value types -createDataDef :: Monad m => (Doc-> m ()) -> (Doc-> m ()) -> (Name -> m (Maybe DataInfo)) +createDataDef :: Monad m => (KindInferErrorCode -> Doc-> m ()) -> (KindInferErrorCode -> Doc-> m ()) -> (Name -> m (Maybe DataInfo)) -> Platform -> Name -> Bool -> Bool -> DataKind -> Int -> DataDef -> [ConInfo] -> m (DataDef,[ConInfo]) createDataDef emitError emitWarning lookupDataInfo @@ -74,13 +75,13 @@ createDataDef emitError emitWarning lookupDataInfo _ -> return DataDefNormal DataDefValue{} | isRec - -> do emitError $ text "cannot be declared as a value type since it is recursive." + -> do emitError KindErrorValueTypeRecursive $ text "cannot be declared as a value type since it is recursive." return DataDefNormal DataDefValue{} | not resultHasKindStar - -> do emitError $ text "is declared as a value type but does not have a value kind ('V')." -- should never happen? + -> do emitError KindErrorValueTypeMismatch $ text "is declared as a value type but does not have a value kind ('V')." -- should never happen? return DataDefNormal DataDefValue{} | sort /= Inductive - -> do emitError $ text "is declared as a value type but is not inductive." + -> do emitError KindErrorValueTypeNotInductive $ text "is declared as a value type but is not inductive." return DataDefNormal DataDefValue{} -> do dd <- createMaxDataDef conInfos @@ -88,13 +89,13 @@ createDataDef emitError emitWarning lookupDataInfo DataDefValue vr -> do let size = valueReprSize platform vr when (size > 4*sizePtr platform) $ - emitWarning (text "requires" <+> pretty size <+> text "bytes which is rather large for a value type") + emitWarning KindWarningValueTypeLarge (text "requires" <+> pretty size <+> text "bytes which is rather large for a value type") when isEnum $ - emitWarning (text "is an enumeration -- there is no need to declare it as a value type") + emitWarning KindWarningValueTypeAnnotationRedundant (text "is an enumeration -- there is no need to declare it as a value type") -- when isIso $ -- emitWarning (text "is a isomorphic type -- there is no need to declare it as a value type") return dd - _ -> do emitError $ text "cannot be used as a value type." -- should never happen? + _ -> do emitError KindErrorValueTypeMismatch $ text "cannot be used as a value type." -- should never happen? return DataDefNormal return (ddef,conInfos) where @@ -139,7 +140,7 @@ createDataDef emitError emitWarning lookupDataInfo then (sizeSize platform) else 0 m <- if (size <= 0) - then do emitWarning $ text "is declared as a primitive value type but has no known compilation size, assuming size" <+> pretty (sizePtr platform) + then do emitWarning KindWarningValueTypeUnknownSize $ text "is declared as a primitive value type but has no known compilation size, assuming size" <+> pretty (sizePtr platform) return (sizePtr platform) else return size return (DataDefValue (valueReprNew m 0 m)) @@ -160,7 +161,7 @@ createDataDef emitError emitWarning lookupDataInfo -- non-equal scan fields | otherwise -> do when isVal $ - emitError (text "is declared as a value type but has" <+> text "multiple constructors with a different number of regular types overlapping with value types." <-> + emitError KindErrorValueTypeMixedFields (text "is declared as a value type but has" <+> text "multiple constructors with a different number of regular types overlapping with value types." <-> text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") -- else emitWarning (text "cannot be defaulted to a value type as it has" <+> text "multiple constructors with a different number of regular types overlapping with value types.") -- trace ("warning: cannot default to a value type due to mixed raw/regular fields: " ++ show nameDoc) $ @@ -175,7 +176,7 @@ createDataDef emitError emitWarning lookupDataInfo -- order constructor fields of constructors with raw field so the regular fields come first to be scanned. -- return the ordered fields, and a ValueRepr (raw size part, the scan count (including tags), align, and full size) -- The size is used for reuse and should include all needed fields including the tag field for "open" datatypes -orderConFields :: Monad m => (Doc -> m ()) -> Doc -> (Name -> m (Maybe DataInfo)) -> Platform +orderConFields :: Monad m => (KindInferErrorCode -> Doc -> m ()) -> Doc -> (Name -> m (Maybe DataInfo)) -> Platform -> Int -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) orderConFields emitError nameDoc getDataInfo platform extraPreScan fields = do visit ([], [], [], extraPreScan, 0) fields @@ -183,7 +184,7 @@ orderConFields emitError nameDoc getDataInfo platform extraPreScan fields -- visit :: ([((Name,Type),ValueRepr)],[((Name,Type),ValueRepr)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) visit (rraw, rmixed, rscan, scanCount0, alignment0) [] = do when (length rmixed > 1) $ - do emitError (nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> + do emitError KindErrorValueTypeMixedFields (nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> text ("hint: use 'box' on either field to make it a non-value type.")) let -- scancount and size before any mixed and raw fields preSize = (sizeHeader platform) + (scanCount0 * sizeField platform) diff --git a/src/Kind/Unify.hs b/src/Kind/Unify.hs index 41beaa02b..cfb82d149 100644 --- a/src/Kind/Unify.hs +++ b/src/Kind/Unify.hs @@ -33,10 +33,10 @@ unify context range kind1 kind2 case mgu skind1 skind2 of Ok sub' -> extendKSub sub' err -> do cscheme <- getColorScheme - kindError cscheme context range err skind1 skind2 + kindError KindErrorKindMismatch cscheme context range err skind1 skind2 -kindError colors context range err kind1 kind2 - = addError range $ +kindError code colors context range err kind1 kind2 + = addError code range $ text message <-> table ([(text "type context", docFromRange colors rangeContext) ,(text "type", docFromRange colors range) diff --git a/src/Main/langserver/LanguageServer/Conversions.hs b/src/Main/langserver/LanguageServer/Conversions.hs index a3e396598..9a0a66c50 100644 --- a/src/Main/langserver/LanguageServer/Conversions.hs +++ b/src/Main/langserver/LanguageServer/Conversions.hs @@ -82,7 +82,7 @@ toLspDiagnostics uri src err = errorMessageToDiagnostic :: Maybe T.Text -> J.NormalizedUri -> E.ErrorMessage -> (J.NormalizedUri, [J.Diagnostic]) errorMessageToDiagnostic errSource defaultUri e = (uriFromRange (E.errRange e) defaultUri, - [makeDiagnostic (toSeverity (E.errSeverity e)) errSource (E.errRange e) (E.errMessage e)] ) + [makeDiagnostic (toSeverity (E.errSeverity e)) errSource (E.errCode e) (E.errRange e) (E.errShortMessage e)] ) where toSeverity sev = case sev of @@ -93,7 +93,7 @@ errorMessageToDiagnostic errSource defaultUri e toLspErrorDiagnostics :: J.NormalizedUri -> Maybe T.Text -> E.ErrorMessage -> M.Map J.NormalizedUri [J.Diagnostic] toLspErrorDiagnostics uri src e = M.singleton (uriFromRange (E.errRange e) uri) - [makeDiagnostic (toSeverity (E.errSeverity e)) src (E.errRange e) (E.errMessage e)] + [makeDiagnostic (toSeverity (E.errSeverity e)) src (E.errCode e) (E.errRange e) (E.errShortMessage e)] where toSeverity sev = case sev of @@ -105,18 +105,17 @@ uriFromRange :: R.Range -> J.NormalizedUri -> J.NormalizedUri uriFromRange r uri = if R.rangeSource r == sourceNull then uri else J.toNormalizedUri $ J.filePathToUri $ sourceName (R.rangeSource r) -toLspWarningDiagnostic :: Maybe T.Text -> R.Range -> Doc -> J.Diagnostic -toLspWarningDiagnostic diagsrc range doc - = makeDiagnostic J.DiagnosticSeverity_Warning diagsrc range doc +toLspWarningDiagnostic :: Maybe T.Text -> Int -> R.Range -> Doc -> J.Diagnostic +toLspWarningDiagnostic diagsrc code range doc + = makeDiagnostic J.DiagnosticSeverity_Warning diagsrc code range doc -makeDiagnostic :: J.DiagnosticSeverity -> Maybe T.Text -> R.Range -> Doc -> J.Diagnostic -makeDiagnostic s diagsrc r doc = - J.Diagnostic range severity code codeDescription diagsrc message tags related dataX +makeDiagnostic :: J.DiagnosticSeverity -> Maybe T.Text -> Int -> R.Range -> Doc -> J.Diagnostic +makeDiagnostic s diagsrc code r doc = + J.Diagnostic range severity (Just (J.InL $ fromIntegral code)) codeDescription diagsrc message tags related dataX where range = toLspRange r severity = Just s - code = Nothing - codeDescription = Nothing + codeDescription = Nothing -- Just (show doc) message = T.pack $ show doc tags | "is unused" `T.isInfixOf` message = Just [J.DiagnosticTag_Unnecessary] diff --git a/src/Main/langserver/LanguageServer/Handler/Hover.hs b/src/Main/langserver/LanguageServer/Handler/Hover.hs index 004230eac..77327458e 100644 --- a/src/Main/langserver/LanguageServer/Handler/Hover.hs +++ b/src/Main/langserver/LanguageServer/Handler/Hover.hs @@ -29,7 +29,7 @@ import Kind.Pretty (prettyKind) import Type.Pretty (ppScheme, defaultEnv, Env(..), ppName, keyword) import Syntax.RangeMap (NameInfo (..), RangeInfo (..), rangeMapFindAt) import Syntax.Colorize( removeComment ) - +import Common.Error (Errors(..), ErrorMessage (..)) import qualified Language.LSP.Protocol.Types as J import qualified Language.LSP.Protocol.Lens as J import qualified Language.LSP.Protocol.Message as J @@ -47,16 +47,27 @@ hoverHandler do let J.HoverParams doc pos0 _ = req ^. J.params uri = J.toNormalizedUri (doc ^. J.uri) - done :: LSM () - done = responder $ Right $ J.InR J.Null + errs <- getErrors + + pos <- liftIO $ fromLspPos uri pos0 + let filteredErrs = filter (\e -> errRange e `R.rangeContains` pos) (errors errs) + errDoc = + case filteredErrs of + [] -> empty + _ -> color Red (text "Errors:") <--> hang 2 (vcat (map (\e -> errMessage e <.> linebreak) filteredErrs)) + let done :: LSM () + done = do + case filteredErrs of + [] -> responder $ Right $ J.InR J.Null + _ -> do + markdown <- prettyMarkdown errDoc + responder $ Right $ J.InL $ J.Hover (J.InL (J.mkMarkdown markdown)) (Just (toLspRange (makeRange pos pos))) liftMaybe :: LSM (Maybe a) -> (a -> LSM ()) -> LSM () liftMaybe action next = do res <- action case res of Nothing -> done Just x -> next x - - pos <- liftIO $ fromLspPos uri pos0 -- trace ("hover: lookup: " ++ show uri) $ liftMaybe (lookupModuleName uri) $ \(fpath,modname) -> -- trace ("hover: found: " ++ show modname) $ @@ -67,7 +78,7 @@ hoverHandler do penv <- getPrettyEnvFor modname mods <- lookupModulePaths let doc = formatRangeInfoHover penv mods rngInfo - markdown <- prettyMarkdown doc + markdown <- prettyMarkdown (doc <.> text "\n\n" <.> errDoc) let rsp = J.Hover (J.InL (J.mkMarkdown markdown)) (Just (toLspRange rng)) -- trace ("hover markdown:\n" ++ show markdown) $ responder $ Right $ J.InL rsp diff --git a/src/Main/langserver/LanguageServer/Handler/TextDocument.hs b/src/Main/langserver/LanguageServer/Handler/TextDocument.hs index d3a9930ae..e30a21371 100644 --- a/src/Main/langserver/LanguageServer/Handler/TextDocument.hs +++ b/src/Main/langserver/LanguageServer/Handler/TextDocument.hs @@ -190,9 +190,11 @@ liftBuildDiag mbflags defaultUri build flushDiagnosticsBySource (maxErrors flags) diagSourceKoka res <- liftBuildWith mbflags build case res of - Right (x,errs) -> do diagnoseErrors defaultUri (errors errs) + Right (x,errs) -> do setErrors errs + diagnoseErrors defaultUri (errors errs) return (Just x) - Left errs -> do diagnoseErrors defaultUri (errors errs) + Left errs -> do setErrors errs + diagnoseErrors defaultUri (errors errs) return Nothing -- A build retains all errors over all loaded modules, so we can always publish all diff --git a/src/Main/langserver/LanguageServer/Monad.hs b/src/Main/langserver/LanguageServer/Monad.hs index 98a450e95..97c29f371 100644 --- a/src/Main/langserver/LanguageServer/Monad.hs +++ b/src/Main/langserver/LanguageServer/Monad.hs @@ -21,6 +21,7 @@ module LanguageServer.Monad LSM, getTerminal, getFlags, getHtmlPrinter, getLSState,modifyLSState, + getErrors, setErrors, updateConfig, getInlayHintOptions, runLSM, @@ -92,6 +93,7 @@ data LSState = LSState { terminal :: !Terminal, progressReport :: !(Maybe (J.ProgressAmount -> LSM ())), htmlPrinter :: !(Doc -> IO T.Text), + errs :: !Errors, pendingRequests :: !(TVar (Set.Set J.SomeLspId)), cancelledRequests :: !(TVar (Set.Set J.SomeLspId)), @@ -179,6 +181,7 @@ defaultLSState flags = do terminal = term, htmlPrinter = htmlTextColorPrinter, flags = flags, documentInfos = M.empty, documentVersions = fileVersions, signatureContext = Nothing, progressReport = Nothing, + errs = Errors [], config = Config{ langServerOpts = LanguageServerOptions{ inlayHintOpts=InlayHintOptions{ @@ -190,6 +193,15 @@ defaultLSState flags = do } } +setErrors :: Errors -> LSM () +setErrors errs + = do modifyLSState (\s -> s{errs=errs}) + +getErrors :: LSM Errors +getErrors + = do s <- getLSState + return (errs s) + -- Prints a message to html spans htmlTextColorPrinter :: Doc -> IO T.Text htmlTextColorPrinter doc @@ -383,13 +395,23 @@ lookupProgram mname getPrettyEnv :: LSM TP.Env getPrettyEnv = do flags <- getFlags - return (prettyEnvFromFlags flags) + caps <- J.getClientCapabilities + return (prettyEnvFromFlagsAndCaps flags caps) + +-- Gate some features behind client capabilities +-- (e.g. markdown in diagnostics are only supported by some clients) +-- TODO: The getPrettyEnv functions are not used in building files, which is where diagnostics come from. +prettyEnvFromFlagsAndCaps :: Flags -> J.ClientCapabilities -> TP.Env +prettyEnvFromFlagsAndCaps flags caps = + let env = prettyEnvFromFlags flags + in env{TP.showFileLinks = True} -- J.markupMessageSupport $ J.DiagnosticClientCapabilities caps} -- Pretty environment getPrettyEnvFor :: ModuleName -> LSM TP.Env getPrettyEnvFor modname = do flags <- getFlags - return (prettyEnvFromFlags flags){ TP.context = modname } + caps <- J.getClientCapabilities + return (prettyEnvFromFlagsAndCaps flags caps){ TP.context = modname } -- Format as markdown diff --git a/src/Static/FixityResolve.hs b/src/Static/FixityResolve.hs index 245f85165..2b7e45ae6 100644 --- a/src/Static/FixityResolve.hs +++ b/src/Static/FixityResolve.hs @@ -190,14 +190,27 @@ fixitiesNew :: [(Name,Fixity)] -> Fixities fixitiesNew fs = M.fromList [(name,f) | (name,f@(FixInfix _ _)) <- fs] +data StaticErrorCode = + StaticErrorInfixOperatorAmbiguousAssociativity + | StaticErrorInfixOperatorTooFewArguments + | StaticErrorUnaryOperatorTooFewArguments + +instance ErrorCode StaticErrorCode where + codeNum StaticErrorInfixOperatorAmbiguousAssociativity = 0 + codeNum StaticErrorInfixOperatorTooFewArguments = 1 + codeNum StaticErrorUnaryOperatorTooFewArguments = 101 + codeDoc StaticErrorInfixOperatorTooFewArguments = text "infix operator has not enough arguments" + codeDoc StaticErrorInfixOperatorAmbiguousAssociativity = text "infix operator ambiguous associativity" + codeDoc StaticErrorUnaryOperatorTooFewArguments = text "unary operator has not enough arguments" + -- The fixity monad collects error messages and passes a fixity map data FixM a = FixM (Fixities -> Res a) -data Res a = Res !a ![(Range,Doc)] +data Res a = Res !a ![(StaticErrorCode,Range,Doc)] runFixM :: Fixities -> FixM a -> Error b a runFixM fixities (FixM f) = case f fixities of - Res x errors -> if null errors then return x else errorMsgs [errorMessageKind ErrStatic rng doc | (rng,doc) <- errors] + Res x errors -> if null errors then return x else errorMsgs [errorMessageKind ErrStatic rng code doc | (code,rng,doc) <- errors] instance Functor FixM where fmap = liftM @@ -216,9 +229,9 @@ getFixities :: FixM Fixities getFixities = FixM (\fm -> Res fm []) -emitError :: Range -> Doc -> FixM () -emitError range doc - = FixM (\fm -> Res () [(range,doc)]) +emitError :: StaticErrorCode -> Range -> Doc -> FixM () +emitError code range doc + = FixM (\fm -> Res () [(code,range,doc)]) {-------------------------------------------------------------------------- Resolve fixities: @@ -310,8 +323,8 @@ checkAmbigious ops t ambigious :: Fixity -> Fixity -> UserExpr -> FixM () ambigious fixCtx fix op - = emitError (getRange op) - (text "Ambigious" <+> ppFixity fix <+> text "operator" <+> opText <.> text "in a" + = emitError StaticErrorInfixOperatorAmbiguousAssociativity (getRange op) + (text "Ambiguous" <+> ppFixity fix <+> text "operator" <+> opText <.> text "in a" <+> ppFixity fixCtx <+> text "context" <-> text " hint: add parenthesis around the sub-expression to disambiguate") where @@ -356,7 +369,7 @@ applyUnaryOp op (t:ts) = return ((App op [(Nothing, t)] (combineRanged op t)):ts) applyUnaryOp op ts - = do{ emitError (getRange op) + = do{ emitError StaticErrorUnaryOperatorTooFewArguments (getRange op) (text "Unary operator has not enough arguments") ; return ts } @@ -364,7 +377,7 @@ applyUnaryOp op ts applyInfixOp op (t1:t2:ts) = return ((makeApp op t2 t1 (combineRanged t1 t2)):ts) applyInfixOp op ts - = do{ emitError (getRange op) + = do{ emitError StaticErrorInfixOperatorTooFewArguments (getRange op) (text "Infix operator has not enough arguments") ; return ts } diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index e1b01f1c8..cc1fb576c 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -70,7 +70,25 @@ import Common.ColorScheme (defaultColorScheme) -- Parser on token stream ----------------------------------------------------------- -type LexParser a = Parsec [Lexeme] [(String, Range)] a -- GenParser Lexeme () a +type LexParser a = Parsec [Lexeme] [(ParseErrorCode, String, Range)] a -- GenParser Lexeme () a + +data ParseErrorCode + = ParseErrorParsec + | ParseWarningDeprecatedKeyword + | ParseWarningDeprecatedSyntax + | ParseWarningRedundantSyntax + +instance ErrorCode ParseErrorCode where + codeNum ParseErrorParsec = 0 + codeNum ParseWarningDeprecatedKeyword = 100 + codeNum ParseWarningDeprecatedSyntax = 101 + codeNum ParseWarningRedundantSyntax = 102 + codeDoc ParseErrorParsec = text "parse error" + codeDoc ParseWarningDeprecatedKeyword = text "deprecated keyword" + codeDoc ParseWarningDeprecatedSyntax = text "deprecated syntax" + codeDoc ParseWarningRedundantSyntax = text "redundant syntax" + + parseLex :: Lex -> LexParser Lexeme parseLex lex @@ -105,7 +123,7 @@ logSyntaxWarnings warnings parseProgramFromString :: Bool -> Bool -> BString -> FilePath -> Error a UserProgram parseProgramFromString allowAt semiInsert input fname = do ((prog,lexemes), syntaxWarnings) <- lexParse allowAt semiInsert id program fname 1 input - addWarnings (map (\(s, r) -> warningMessageKind ErrParse r (text s)) syntaxWarnings) $ + addWarnings (map (\(c, s, r) -> warningMessageKind ErrParse r c (text s)) syntaxWarnings) $ return prog parseValueDef :: Bool -> FilePath -> Int -> String -> Error () UserDef @@ -124,7 +142,7 @@ parseExpression :: Bool -> FilePath -> Int -> Name -> String -> Error () UserDef parseExpression semiInsert sourceName line name input = lexParseS semiInsert (const (expression name)) sourceName line input -ignoreSyntaxWarnings :: Error b (a, [(String, Range)]) -> Error b a +ignoreSyntaxWarnings :: Error b (a, [(ParseErrorCode, String, Range)]) -> Error b a ignoreSyntaxWarnings result = do (x, syntaxWarnings) <- result return x @@ -133,9 +151,9 @@ lexParseS :: Bool -> (Source -> LexParser b) -> FilePath -> Int -> String -> Err lexParseS semiInsert p sourceName line str = do ((result,lexemes), syntaxWarnings) <- (lexParse False semiInsert id p sourceName line (stringToBString str)) - return $ trace (concat (intersperse "\n" (map fst syntaxWarnings))) $ result + return $ trace (concat (intersperse "\n" (map (\(_,w,_) -> w) syntaxWarnings))) $ result -runStateParser :: LexParser a -> SourceName -> [Lexeme] -> Either ParseError (a, [(String, Range)]) +runStateParser :: LexParser a -> SourceName -> [Lexeme] -> Either ParseError (a, [(ParseErrorCode, String, Range)]) runStateParser p sourceName lex = runParser (pp p) [] sourceName lex where @@ -144,7 +162,7 @@ runStateParser p sourceName lex = s <- getState return (r, s) -lexParse :: Bool -> Bool -> ([Lexeme]-> [Lexeme]) -> (Source -> LexParser a) -> FilePath -> Int -> BString -> Error b ((a,[Lexeme]), [(String, Range)]) +lexParse :: Bool -> Bool -> ([Lexeme]-> [Lexeme]) -> (Source -> LexParser a) -> FilePath -> Int -> BString -> Error b ((a,[Lexeme]), [(ParseErrorCode, String, Range)]) lexParse allowAt semiInsert preprocess p sourceName line rawinput = let source = Source sourceName rawinput lexemes = lexSource allowAt semiInsert preprocess line source @@ -157,7 +175,7 @@ lexParse allowAt semiInsert preprocess p sourceName line rawinput parseProgramFromLexemes :: Source -> [Lexeme] -> Error () UserProgram parseProgramFromLexemes source lexemes = do (prog, syntaxWarnings) <- parseLexemes (program source) source lexemes - addWarnings (map (\(s, r) -> warningMessageKind ErrParse r (text s)) syntaxWarnings) $ + addWarnings (map (\(c, s, r) -> warningMessageKind ErrParse r c (text s)) syntaxWarnings) $ return prog @@ -170,7 +188,7 @@ parseDependencies source lexemes -- trace ("dependencies: " ++ show x) $ return x -parseLexemes :: LexParser a -> Source -> [Lexeme] -> Error () (a, [(String, Range)]) +parseLexemes :: LexParser a -> Source -> [Lexeme] -> Error () (a, [(ParseErrorCode, String, Range)]) parseLexemes p source@(Source sourceName _) lexemes = case (runStateParser p sourceName lexemes) of Left err -> makeParseError (errorRangeLexeme lexemes source) err @@ -179,7 +197,7 @@ parseLexemes p source@(Source sourceName _) lexemes makeParseError :: (ParseError -> Range) -> ParseError -> Error b a makeParseError toRange perr - = errorMsg (errorMessageKind ErrParse (toRange perr) errorDoc) + = errorMsg (errorMessageKind ErrParse (toRange perr) ParseErrorParsec errorDoc) where errorDoc = PP.string ("invalid syntax" ++ (drop 1 $ dropWhile (/=':') $ show perr)) @@ -384,7 +402,7 @@ visibility vis = do rng <- keywordOr "pub" ["public"] return (Public,rng) <|> do rng <- keyword "private" - pwarningMessage "using 'private' is deprecated, only use 'pub' to make declarations public" rng + pwarningMessage ParseWarningDeprecatedKeyword "using 'private' is deprecated, only use 'pub' to make declarations public" rng return (Private,rng) <|> return (vis,rangeNull) @@ -1362,7 +1380,7 @@ parseFipEx :: Range -> Bool -> LexParser (Fip,Range) parseFipEx rng0 isTail = do rng1 <- specialId "fip" (alloc,rng2) <- parseFipAlloc - when isTail $ pwarningMessage "a 'fip' function implies already 'tail'" rng1 + when isTail $ pwarningMessage ParseWarningRedundantSyntax "a 'fip' function implies already 'tail'" rng1 return (Fip alloc, combineRanges [rng0,rng1,rng2]) <|> do rng1 <- specialId "fbip" @@ -1769,7 +1787,7 @@ ifexpr <|> do pos <- getPosition expr <- blockexpr - pwarning ("warning " ++ show pos ++ ": using an 'if' without 'then' is deprecated.\n hint: add the 'then' keyword.") rng + pwarning ParseWarningDeprecatedSyntax ("warning " ++ show pos ++ ": using an 'if' without 'then' is deprecated.\n hint: add the 'then' keyword.") rng return expr returnexpr @@ -1936,7 +1954,7 @@ handlerOp :: LexParser (Clause, Maybe (UserExpr -> UserExpr)) handlerOp = do rng <- keyword "return" (name,prng,tp) <- do (name,prng) <- paramid - pwarningMessage "'return x' is deprecated; use 'return(x)' instead." prng + pwarningMessage ParseWarningDeprecatedSyntax "'return x' is deprecated; use 'return(x)' instead." prng tp <- optionMaybe typeAnnotPar return (name,prng,tp) <|> @@ -1981,7 +1999,7 @@ handlerOp return OpControlErr (name, nameRng) <- qidentifier if opSort == OpControlErr then - pwarningMessage "using a bare operation is deprecated.\n hint: start with 'val', 'fun', 'brk', or 'ctl' instead." nameRng + pwarningMessage ParseWarningDeprecatedSyntax "using a bare operation is deprecated.\n hint: start with 'val', 'fun', 'brk', or 'ctl' instead." nameRng else return () (oppars,prng) <- opParams expr <- bodyexpr @@ -2032,7 +2050,7 @@ guards return [Guard guardTrue exp] <|> do exp <- block - pwarningMessage "use '->' for pattern matches" (getRange exp) + pwarningMessage ParseWarningDeprecatedSyntax "use '->' for pattern matches" (getRange exp) return [Guard guardTrue exp] guardBar @@ -3144,15 +3162,15 @@ docconid warnDeprecated dep new rng = do pos <- getPosition - pwarning ("warning " ++ show pos ++ ": keyword \"" ++ dep ++ "\" is deprecated. Consider using \"" ++ new ++ "\" instead.") rng + pwarning ParseWarningDeprecatedKeyword ("warning " ++ show pos ++ ": keyword \"" ++ dep ++ "\" is deprecated. Consider using \"" ++ new ++ "\" instead.") rng -pwarningMessage msg rng +pwarningMessage code msg rng = do pos <- getPosition - pwarning ("warning " ++ show pos ++ ": " ++ msg) rng + pwarning code ("warning " ++ show pos ++ ": " ++ msg) rng -pwarning :: String -> Range -> LexParser () -pwarning msg rng = modifyState (\prev -> prev ++ [(msg, rng)]) +pwarning :: ParseErrorCode -> String -> Range -> LexParser () +pwarning code msg rng = modifyState (\prev -> prev ++ [(code, msg, rng)]) uniqueRngHiddenName :: Range -> String -> Name diff --git a/src/Type/Infer.hs b/src/Type/Infer.hs index b70cc157f..0bfb81984 100644 --- a/src/Type/Infer.hs +++ b/src/Type/Infer.hs @@ -77,6 +77,7 @@ import Core.BindingGroups( regroup ) import qualified Syntax.RangeMap as RM import Common.File (seqqList) import Type.Operations (hasOptionalOrImplicits) +import Kind.InferMonad (lookupDataEffect) {-------------------------------------------------------------------------- @@ -228,9 +229,9 @@ inferDefGroup topLevel (DefRec defs0) cont (Just _) -> do env <- getPrettyEnv if topLevel - then infError nameRng (text "recursive functions with the same overloaded name must all have a full type signature" <+> parens (ppName env name) <-> + then infError TypeErrorOverloadedNameRecursionRequireTypes nameRng (text "recursive functions with the same overloaded name must all have a full type signature" <+> parens (ppNameLink env name nameRng ) <-> text " hint: give a type annotation for each function (including the effect type).") - else infError nameRng (text "recursive functions with the same overloaded name cannot be defined as local definitions" <+> parens (ppName env name) <-> + else infError TypeErrorOverloadedNameRecursionNotTopLevel nameRng (text "recursive functions with the same overloaded name cannot be defined as local definitions" <+> parens (ppNameLink env name nameRng) <-> text " hint: use different names for each function.") Nothing @@ -243,7 +244,7 @@ inferDefGroup topLevel (DefRec defs0) cont _ -> case lookup name gamma of Just _ -> do env <- getPrettyEnv - infError nameRng (text "recursive functions with the same overloaded name must have a full type signature" <+> parens (ppName env name)) + infError TypeErrorOverloadedNameRecursionRequireTypes nameRng (text "recursive functions with the same overloaded name must have a full type signature" <+> parens (ppNameLink env name nameRng)) Nothing -> do qname <- if (topLevel) then qualifyName name else return name case expr of @@ -272,11 +273,13 @@ inferDefGroup topLevel (DefRec defs0) cont checkRecVal :: Core.DefGroup -> Inf () checkRecVal (Core.DefNonRec def) = return () checkRecVal (Core.DefRec defs) - = mapM_ checkDef defs + = do + env <- getPrettyEnv + mapM_ (checkDef env) defs where - checkDef def + checkDef env def = if (not (Core.defIsVal def)) then return () else - do infError (Core.defNameRange def) (text ("value definition is recursive.\n recursive group: " ++ show (map Core.defName defs))) + do infError TypeErrorRecursiveValueDefinitions (Core.defNameRange def) (text "Value definition(s) are recursive.\n recursive group: " <.> hsep (map (\d -> ppNameLink env (Core.defName d) (Core.defNameRange d)) defs)) fixCanonicalName :: Bool -> Core.Def -> Inf Core.Def fixCanonicalName isRec def @@ -524,7 +527,7 @@ inferBindDef def@(Def (ValueBinder name () expr nameRng vrng) rng vis sort inl d checkValue = Check "Values cannot have an effect" checkPolyValue = Check "Polymorphic values cannot have an effect" -unusedWarning rng = infWarning rng (text "expression has no effect and is unused" <--> +unusedWarning rng = infWarning TypeWarningUnusedExpression rng (text "expression has no effect and is unused" <--> text " hint: did you forget an operator? or used \"fun\" instead of \"fn\"?" ) {-------------------------------------------------------------------------- Expression @@ -543,7 +546,7 @@ inferIsolated contextRange range body inf Just vrng -> do seff <- subst ieff let (ls,tl) = extractOrderedEffect seff case filter (\l -> labelName l == nameTpLocal) ls of - (_:_) -> typeError contextRange vrng + (_:_) -> typeError TypeErrorLocalEscape contextRange vrng (text "reference to a local variable escapes its lexical scope") seff [] _ -> return () return (itp,seff,icore) @@ -586,11 +589,11 @@ inferExpr propagated expect (Bind def body rng) inferExpr propagated expect (App (Var name _ nameRng) [(_,expr)] rng) | name == nameReturn = do allowed <- isReturnAllowed if (False && not allowed) - then infError rng (text "illegal expression context for a return statement") + then infError TypeErrorIllegalReturnContext rng (text "illegal expression context for a return statement") else do mbTp <- lookupInfName nameReturn -- (unqualify nameReturn) case mbTp of Nothing - -> do infError rng (text "illegal context for a return statement") + -> do infError TypeErrorIllegalReturnContext rng (text "illegal context for a return statement") inferExpr propagated expect expr Just (_,retTp) -> do (tp,eff,core) <- inferExpr (Just (retTp,nameRng)) expect expr @@ -629,7 +632,7 @@ inferExpr propagated expect (App assign@(Var name _ arng) [lhs@(_,lval),rhs@(_,r _ -> errorAssignable where errorAssignable - = do contextError rng (getRange lval) (text "not an assignable expression") [(text "because",text "an assignable expression must be an application, index expression, or variable")] + = do contextError TypeErrorNotAssignable rng (getRange lval) (text "not an assignable expression") [(text "because",text "an assignable expression must be an application, index expression, or variable")] return (typeUnit,typeTotal,Core.Con (Core.TName (nameTuple 0) typeUnit) (Core.ConEnum nameTpUnit Core.DataEnum valueReprZero 0)) checkAssign @@ -669,7 +672,7 @@ inferExpr propagated expect (App (Var byref _ _) [(_,Var name _ rng)] _) | byre inferExpr propagated expect (App fun@(Var hname _ nameRng) [] rng) | hname == nameCCtxHoleCreate = do ok <- useHole when (not ok) $ - contextError rng rng (text "ill-formed constructor context") + contextError TypeErrorCCtxMultipleHoles rng rng (text "ill-formed constructor context") [(text "because",text "there can be only one hole, and it must occur under a constructor context 'ctx'")] (tp,eff,core) <- inferApp propagated expect fun [] rng addRangeInfo nameRng (RM.Id (newName "hole") (RM.NIValue "expr" tp "" False) [] False) @@ -688,11 +691,11 @@ inferExpr propagated expect (App (Var ctxname _ nameRng) [(_,expr)] rng) | ctxn ((tp,eff,core),hole) <- allowHole $ inferExpr prop Instantiated expr inferUnify (Infer rng) nameRng tp tpv when (not hole) $ - contextError rng rng (text "ill-formed constructor context") [(text "because",text "the context has no 'hole'")] + contextError TypeErrorCCtxHoleNotFound rng rng (text "ill-formed constructor context") [(text "because",text "the context has no 'hole'")] newtypes <- getNewtypes score <- subst core (ccore,errs) <- withUnique (analyzeCCtx rng newtypes score) - mapM_ (\(rng,err) -> infError rng err) errs + mapM_ (\(code,rng,err) -> infError code rng err) errs let ctp = Core.typeOf ccore addRangeInfo nameRng (RM.Id (newName "ctx") (RM.NIValue "expr" ctp "" False) [] False) return (Core.typeOf ccore,eff,ccore) @@ -885,7 +888,7 @@ inferHandler :: Maybe (Type,Range) -> Expect -> HandlerSort -> HandlerScope -> B -- Regular handler inferHandler propagated expect handlerSort handlerScoped allowMask mbEffect (_:localPars) initially ret finally branches hrng rng - = do contextError hrng rng (text "Type.Infer.inferHandler: TODO: not supporting local parameters") [] + = do contextError TypeErrorHandlerParametersUnsupported hrng rng (text "Type.Infer.inferHandler: TODO: not supporting local parameters") [] failure "abort" inferHandler propagated expect handlerSort handlerScoped allowMask mbEffect [] initially ret finally branches hrng rng @@ -1056,7 +1059,7 @@ checkLinearity effectName heffect branches hrng rng check hbranch = if (hbranchSort hbranch <= OpFun) then return () else do penv <- getPrettyEnv - contextError rng (hbranchPatRange hbranch) + contextError TypeErrorLinearHandlerOperationNonLinear rng (hbranchPatRange hbranch) (text "operation" <+> ppName penv (hbranchName hbranch) <+> text ("needs to be linear but is handled in a non-linear way (as '" ++ show (hbranchSort hbranch) ++ "')")) [(text "hint",text "use a 'val' or 'fun' operation clause instead")] @@ -1066,7 +1069,7 @@ checkLinearity effectName heffect branches hrng rng --traceDoc $ \env -> text "operation" <+> text (show opName) <+> text ": " <+> niceType env effBranch -- hsep (map (\tp -> niceType env tp) effs) case (dropWhile labelIsLinear effs) of (e:_) -> do penv <- getPrettyEnv - contextError rng hrng + contextError TypeErrorLinearHandlerUsesNonLinearEffect rng hrng (text "handler for" <+> (ppName penv effectName) <+> text "needs to be linear but uses a non-linear effect:" <+> ppType penv e) [(text "hint",text "ensure only linear effects are used in a handler")] @@ -1101,18 +1104,18 @@ inferHandledEffect rng handlerSort mbeff ops case filter isHandledEffect ls of (l:_) -> return (l) -- TODO: can we assume the effect comes first? _ -> -- failure $ "Type.Infer.inferHandledEffect: cannot find handled effect in " ++ show eff - infError rng (text "not an effect operation:" <+> ppName env qname <.> text ".") - _ -> infError rng (text "cannot resolve effect operation:" <+> ppName env qname <.> text "." <--> text " hint: maybe wrong number of parameters?") - _ -> infError rng (text "unable to determine the handled effect." <--> text " hint: use a `handler` declaration?") + infError TypeErrorNotEffectOperation rng (text "not an effect operation:" <+> ppNameLink env qname nameRng <.> text ".") + _ -> infError TypeErrorEffectOperationNotFound rng (text "cannot resolve effect operation:" <+> ppNameLink env qname nameRng <.> text "." <--> text " hint: maybe wrong number of parameters?") + _ -> infError TypeErrorEffectNotFound rng (text "unable to determine the handled effect." <--> text " hint: use a `handler` declaration?") -- Check coverage is not needed for type inference but gives nicer error messages checkCoverage :: Range -> Effect -> Name -> [HandlerBranch Type] -> Inf () checkCoverage rng effect handlerConName branches - = do (_,gconTp,conRepr,conInfo) <- resolveConName handlerConName Nothing rng + = do (_,gconTp,conRepr,conInfo,effectRng) <- resolveConName handlerConName Nothing rng let opNames = map (fieldToOpName . fst) (drop 1 {-cfc-} (conInfoParams conInfo)) branchNames = map branchToOpName branches - checkCoverageOf rng (map fst opNames) opNames branchNames + checkCoverageOf rng (map fst opNames) opNames branchNames effectRng return () where modName = qualifier handlerConName @@ -1130,31 +1133,31 @@ checkCoverage rng effect handlerConName branches then fromValueOperationsName (hbranchName hbranch) else hbranchName hbranch, hbranchSort hbranch) - checkCoverageOf :: Range -> [Name] -> [(Name,OperationSort)] -> [(Name,OperationSort)] -> Inf () - checkCoverageOf rng allOpNames opNames branchNames + checkCoverageOf :: Range -> [Name] -> [(Name,OperationSort)] -> [(Name,OperationSort)] -> Range -> Inf () + checkCoverageOf rng allOpNames opNames branchNames effectRng = -- trace ("check coverage: " ++ show opNames ++ " vs. " ++ show branchNames) $ - do env <- getPrettyEnv + do env <- getPrettyEnv case opNames of [] -> if null branchNames then return () -- should not occur if branches typechecked previously else case (filter (\(bname,bsort) -> not (bname `elem` allOpNames)) branchNames) of - ((bname,bsort):_) -> termError rng (text "operator" <+> ppOpName env bname <+> - text "is not part of the handled effect") effect + ((bname,bsort):_) -> termError TypeErrorEffectOperationNotPartOfEffect rng (text "operator" <+> ppOpName env bname <+> + text "is not part of the handled effect") effect (Just effectRng) [] -- hints - _ -> infError rng (text "some operators are handled multiple times for effect " <+> ppType env effect) + _ -> infError TypeErrorEffectOperationMultiple rng (text "some operators are handled multiple times for effect " <+> ppType env effect) ((opName,opSort):opNames') -> do let (matches,branchNames') = partition (\(bname,_) -> bname==opName) branchNames case matches of [(bname,bsort)] -> if (opSort==OpVal && bsort /= opSort) - then infError rng (text "cannot handle a 'val' operation" <+> ppOpName env opName <+> text "with" <+> squotes (text (show bsort))) + then infError TypeErrorInvalidValOperation rng (text "cannot handle a 'val' operation" <+> ppOpName env opName <+> text "with" <+> squotes (text (show bsort))) else if (bsort > opSort) - then infWarning rng (text "operation" <+> ppOpName env opName <+> text "is declared as '" <.> text (show opSort) <.> text "' but handled here using '" <.> text (show bsort) <.> text "'") + then infWarning TypeErrorEffectOperationWrongSort rng (text "operation" <+> ppOpName env opName <+> text "is declared as '" <.> text (show opSort) <.> text "' but handled here using '" <.> text (show bsort) <.> text "'") else return () - [] -> infError rng (text "operator" <+> ppOpName env opName <+> text "is not handled") - _ -> infError rng (text "operator" <+> ppOpName env opName <+> text "is handled multiple times") - checkCoverageOf rng allOpNames opNames' branchNames' + [] -> infError TypeErrorEffectOperationNotHandled rng (text "operator" <+> ppOpName env opName <+> text "is not handled") + _ -> infError TypeErrorEffectOperationMultiple rng (text "operator" <+> ppOpName env opName <+> text "is handled multiple times") + checkCoverageOf rng allOpNames opNames' branchNames' effectRng where ppOpName env cname = ppName env cname @@ -1503,7 +1506,7 @@ inferLam topLevel propagated expect bindersL body0 rng if (null polyBinders) then return () else let b = head polyBinders - in typeError (rng) (binderNameRange b) (text "unannotated parameters cannot be polymorphic") (binderType b) [(text "hint",text "annotate the parameter with a polymorphic type")] + in typeError TypeErrorParameterPolymorphicNoAnnotation (rng) (binderNameRange b) (text "unannotated parameters cannot be polymorphic") (binderType b) [(text "hint",text "annotate the parameter with a polymorphic type")] mapM_ (\(binder,tp) -> addRangeInfo (binderNameRange binder) (RM.Id (binderName binder) (RM.NIValue "val" tp "" (case (propagated,binderType binder) of @@ -1526,7 +1529,7 @@ inferVar :: HasCallStack => Maybe (Type,Range) -> Expect -> Name -> Range -> Boo -- constructor inferVar propagated expect name rng isRhs | isConstructorName name = -- trace("inferVar: constructor: " ++ show name)$ - do (qname1,tp1,conRepr,conInfo) <- resolveConName name (fmap fst propagated) rng + do (qname1,tp1,conRepr,conInfo,_) <- resolveConName name (fmap fst propagated) rng let info1 = InfoCon Public tp1 conRepr conInfo rng (conInfoDoc conInfo) (qname,tp,info) <- do defName <- currentDefName let creatorName = newCreatorName qname1 @@ -1672,14 +1675,14 @@ inferCase propagated expect expr branches isLazyMatch rng stp <- subst ctp if (typeIsCaseLegal stp) then return () - else typeError rng (getRange expr) (text "can only match on literals or data types") stp [] + else typeError TypeErrorInvalidScrutinee rng (getRange expr) (text "can only match on literals or data types") stp [] -- get data info and analyze branches dataInfo <- findDataInfo (getTypeName stp) defName <- currentDefName sbcores <- subst bcores newtypes <- getNewtypes let (matchIsTotal,warnings,cbranches) = analyzeBranches newtypes defName rng sbcores [stp] [dataInfo] isLazyMatch - mapM_ (\(rng,warning) -> infWarning rng warning) warnings + mapM_ (\(code,rng,warning) -> infWarning code rng warning) warnings cbranches <- if matchIsTotal then return cbranches else do moduleName <- getModuleName @@ -1753,7 +1756,7 @@ inferBranch patkind propagated matchType matchRange matchedNames branch@(Branch case filter (\tname -> not (S.member (Core.getName tname) free)) (Core.tnamesList defined) of [] -> return () (name:_) -> do env <- getPrettyEnv - infWarning (getRange pattern) (text "pattern variable" <+> ppName env (Core.getName name) <+> text "is unused (or a wrongly spelled constructor?)" <-> + infWarning TypeWarningUnusedPatternBinder (getRange pattern) (text "pattern variable" <+> ppName env (Core.getName name) <+> text "is unused (or a wrongly spelled constructor?)" <-> text " hint: prepend an underscore to make it a wildcard pattern") return (Core.Branch [pcore] gcores) ) @@ -1838,10 +1841,10 @@ inferPattern patkind matchType branchRange (PatCon name patterns0 nameRange rang PatternOutermost isLazyMatch -> do when (conInfoIsLazy coninfo && not isLazyMatch) $ do penv <- getPrettyEnv - infError nameRange $ ppName penv qname <.> text ": lazy constructors are not allowed in a (non lazy) match" + infError TypeErrorLazyConstructorInMatch nameRange $ ppName penv qname <.> text ": lazy constructors are not allowed in a (non lazy) match" PatternNested -> do penv <- getPrettyEnv - infError nameRange $ ppName penv qname <.> text ": constructors of a lazy type cannot be matched in a nested pattern (but must always be matched as an outermost pattern)" + infError TypeErrorLazyConstructorInInnerPattern nameRange $ ppName penv qname <.> text ": constructors of a lazy type cannot be matched in a nested pattern (but must always be matched as an outermost pattern)" patterns <- matchPatterns range nameRange conRho conParTps patterns0 @@ -1960,7 +1963,7 @@ inferImplicitParam par Just (Parens (Var qname _ rng) _ _ _) -- encoded in the parser as a default expression -> inferImplicitUnpack (rangeHide (binderRange par)) (rangeHide rng) (binderName par) qname Nothing -> return id - Just expr -> do contextError (getRange par) (getRange expr) (text "the value of an implicit parameter must be a single identifier") [] + Just expr -> do contextError TypeErrorImplicitParamNoDefault (getRange par) (getRange expr) (text "the value of an implicit parameter must be a single identifier") [] return id return (par{ -- leave the binder name locally qualified as `@implicit/name` -- binderName = pname, binderExpr = Nothing }, unpack) @@ -2045,8 +2048,8 @@ inferOptionals allowImplictMask eff infgamma (par:pars) temp <- uniqueNameFrom (binderName par) -- let coreVar (qname,tp,info) = Core.Var (Core.TName qname tp) (coreVarInfoFromNameInfo info) dataInfo <- findDataInfo nameTpOptional - (coreNameOpt,coreTpOpt,coreReprOpt,conInfoOpt) <- resolveConName nameOptional Nothing fullRange - (coreNameOptNone,coreTpOptNone,coreReprOptNone,conInfoOptNone) <- resolveConName nameOptionalNone Nothing fullRange + (coreNameOpt,coreTpOpt,coreReprOpt,conInfoOpt,_) <- resolveConName nameOptional Nothing fullRange + (coreNameOptNone,coreTpOptNone,coreReprOptNone,conInfoOptNone,_) <- resolveConName nameOptionalNone Nothing fullRange let tempName = Core.TName temp tp let parName = Core.TName (binderName par) optTp corePar = Core.Var parName Core.InfoNone @@ -2235,7 +2238,7 @@ splitNamedArgs nargs (((name,rng),_):named) -> if (name `elem` seen) then do env <- getPrettyEnv - infError rng (text "named argument" <+> ppName env name <+> text "is given more than once") + infError TypeErrorDuplicateNamedArgument rng (text "named argument" <+> ppNameLink env name rng <+> text "is given more than once") else checkDuplicates (name:seen) named isNothing Nothing = True @@ -2245,7 +2248,7 @@ isNothing _ = False matchPatterns :: Range -> Range -> Type -> [(Name,Type)] -> [(Maybe (Name,Range),Pattern Type)] -> Inf [Pattern Type] matchPatterns context nameRange conTp conParTypes patterns0 = do patterns1 <- if (length conParTypes < length patterns0) - then do typeError context nameRange (text "constructor has too many arguments") (conTp) [] + then do typeError TypeErrorConstructorTooManyArguments context nameRange (text "constructor has too many arguments") (conTp) [] return (take (length conParTypes) patterns0) else return patterns0 @@ -2266,7 +2269,7 @@ matchPatterns context nameRange conTp conParTypes patterns0 return [] matchNamed pars (((name,rng),pat):named) = case remove name [] pars of - Nothing -> do typeError context rng (text "there is no constructor field with name" <+> pretty name) conTp [] + Nothing -> do typeError TypeErrorConstructorFieldNotFound context rng (text "there is no constructor field with name" <+> pretty name) conTp [] matchNamed pars named Just (i,pars1) -> do rest <- matchNamed pars1 named @@ -2308,7 +2311,7 @@ matchFunTypeArgs context fun tp fresolved fixed named TSyn _ _ t -> matchFunTypeArgs context fun t fresolved fixed named TVar tv -> do if (null named) -- TODO: take fresolved into account then return () - else infError range (text "cannot used named arguments on an inferred function" <-> text " hint: annotate the parameters") + else infError TypeErrorInferredFunctionNamedArgument range (text "cannot used named arguments on an inferred function" <-> text " hint: annotate the parameters") targs <- mapM (\name -> do{ tv <- Op.freshStar; return (name,tv)}) ([nameNil | a <- fixed] ++ map (fst . fst) named) teff <- Op.freshEffect tres <- Op.freshStar @@ -2357,7 +2360,7 @@ matchFunTypeArgs context fun tp fresolved fixed named return (prest, (i,ArgExpr newarg False):rest) matchFixed [] ((i,arg):_) fresolved - = do typeError context (getRange fun) (text "function is applied to too many arguments") tp [] + = do typeError TypeErrorFunctionTooManyArguments context (getRange fun) (text "function is applied to too many arguments") tp [] return ([],[]) -- in the result, the first int is position of the parameter `j`, the second int `i` is the original position of @@ -2366,11 +2369,11 @@ matchFunTypeArgs context fun tp fresolved fixed named matchNamed [] [] = return [] matchNamed [] ((i,((name,rng),arg)):named) - = do typeError context (getRange fun) {- (combineRanged rng arg) -} (text "function is applied to too many arguments") tp [] + = do typeError TypeErrorFunctionTooManyArguments context (getRange fun) {- (combineRanged rng arg) -} (text "function is applied to too many arguments") tp [] return [] matchNamed pars ((i,((name,rng),arg)):named) = case extract name [] pars of - Nothing -> do typeError context (getRange fun) (text "there is no parameter with name" <+> pretty name) tp [] + Nothing -> do typeError TypeErrorArgumentWithNameNotFound context (getRange fun) (text "there is no parameter with name" <+> pretty name) tp [] matchNamed pars named Just (j,tp,pars1) -> do newarg <- if (isOptional tp) @@ -2392,7 +2395,7 @@ matchFunTypeArgs context fun tp fresolved fixed named (Var name isOp nameRange) | name == newName "resume" -> [(text "hint", text "cannot use \"resume\" inside a val/fun/except clause")] _ -> [] - typeError context range (text "function has not enough arguments") tp hints + typeError TypeErrorFunctionTooFewArguments context range (text "function has not enough arguments") tp hints return [] extract name acc [] @@ -2441,7 +2444,7 @@ matchFunTypeArgs context fun tp fresolved fixed named reportNonCallable = do hints <- shadowHints - typeError context range (text "only functions or types with a copy constructor can be applied") tp hints + typeError TypeErrorNonCallableTarget context range (text "only functions or types with a copy constructor can be applied") tp hints return (zip [1..] (map (\x -> ArgExpr x True) (fixed ++ map snd named)), [], typeTotal, typeUnit, Core.App) where shadowHints @@ -2557,8 +2560,8 @@ coreVector tp cs coreList :: Type -> [Core.Expr] -> Inf Core.Expr coreList tp cs - = do (consName,consTp,consRepr,_) <- resolveConName nameCons Nothing rangeNull - (nilName,nilTp,nilRepr,_) <- resolveConName nameListNil Nothing rangeNull + = do (consName,consTp,consRepr,_,_) <- resolveConName nameCons Nothing rangeNull + (nilName,nilTp,nilRepr,_,_) <- resolveConName nameListNil Nothing rangeNull let consx = Core.TypeApp (Core.Con (Core.TName consName consTp) consRepr) [tp] cons x xs = Core.App consx (seqqList [x,xs]) nil = Core.TypeApp (Core.Con (Core.TName nilName nilTp) nilRepr) [tp] diff --git a/src/Type/InferMonad.hs b/src/Type/InferMonad.hs index d33e1c136..bba6988af 100644 --- a/src/Type/InferMonad.hs +++ b/src/Type/InferMonad.hs @@ -73,7 +73,7 @@ module Type.InferMonad( Inf, InfGamma , typeError , contextError , termError - , infError, infWarning + , infError, infWarning, TypeInferErrorCode(..) , withHiddenTermDoc, inHiddenTermDoc , withLocalScope, withNoLocalScope, localScopeDepth @@ -129,6 +129,7 @@ import Syntax.RangeMap( RangeMap, RangeInfo(..), rangeMapInsert ) import Syntax.Syntax(Expr(..),ValueBinder(..)) import qualified Debug.Trace as DT +import Compile.Options (Flags(showFileLinks)) trace s x = DT.trace (" " ++ s) @@ -700,7 +701,7 @@ checkSkolemEscape rng tp mhint skolems extraFree then return () else do stp <- subst tp let escaped = [v | v <- skolems, tvsMember v allfree] - termError rng (text "abstract type(s) escape(s) into the context") (stp) + termError TypeErrorSkolemEscape rng (text "abstract type(s) escape(s) into the context") (stp) Nothing (maybe [(text "hint",text "give a higher-rank type annotation to a function parameter?")] (\hint -> [(text "hint",hint)]) mhint) @@ -739,7 +740,7 @@ unifyError context range err xtp1 xtp2 unifyError' env context range err tp1 tp2 = do termInfo <- getTermDoc "term" range - infError range $ + infError (TypeErrorMismatch context) range $ text message <-> table ([(text "context", docFromRange (Pretty.colors env) rangeContext) , termInfo @@ -804,7 +805,7 @@ predicateError contextRange range message pred predicateError' env contextRange range message pred = do termInfo <- getTermDoc "origin" range - infError range $ + infError TypeErrorPredicateMismatch range $ text message <-> table [(text "context", docFromRange (Pretty.colors env) contextRange) , termInfo @@ -814,47 +815,51 @@ predicateError' env contextRange range message pred nicePred = Pretty.ppPred env pred -typeError :: Range -> Range -> Doc -> Type -> [(Doc,Doc)] -> Inf () -typeError contextRange range message xtp extra +typeError :: TypeInferErrorCode -> Range -> Range -> Doc -> Type -> [(Doc,Doc)] -> Inf () +typeError code contextRange range message xtp extra = do env <- getEnv free <- freeInGamma tp <- subst xtp >>= normalizeX False free - typeError' (prettyEnv env) contextRange range message tp extra + typeError' (prettyEnv env) code contextRange range message tp extra -typeError' env contextRange range message tp extra +typeError' env code contextRange range message tp extra = do termInfo <- getTermDoc "term" range - infError range $ + infError code range $ message <-> table ([(text "context", docFromRange (Pretty.colors env) contextRange) , termInfo ,(text "inferred type", Pretty.niceType env tp) ] ++ extra) -contextError :: Range -> Range -> Doc -> [(Doc,Doc)] -> Inf () -contextError contextRange range message extra +contextError :: TypeInferErrorCode -> Range -> Range -> Doc -> [(Doc,Doc)] -> Inf () +contextError code contextRange range message extra = do env <- getEnv - contextError' (prettyEnv env) contextRange range message extra + contextError' (prettyEnv env) code contextRange range message extra -contextError' env contextRange range message extra +contextError' env code contextRange range message extra = do termInfo <- getTermDoc "term" range - infError range $ + infError code range $ message <-> table ([(text "context", docFromRange (Pretty.colors env) contextRange) , termInfo ] ++ extra) -termError :: Range -> Doc -> Type -> [(Doc,Doc)] -> Inf () -termError range message tp extra +termError :: TypeInferErrorCode -> Range -> Doc -> Type -> Maybe Range -> [(Doc,Doc)] -> Inf () +termError code range message tp tpRng extra = do env <- getEnv - termError' (prettyEnv env) range message tp extra + termError' (prettyEnv env) code range message tp tpRng extra -termError' env range message tp extra +termError' env code range message tp tpRng extra = do termInfo <- getTermDoc "term" range - infError range $ + let tpDoc = Pretty.niceType env tp + let tpRngDoc = case tpRng of + Just r | (Pretty.showFileLinks env) -> Pretty.ppLink tpDoc r + _ -> tpDoc + infError code range $ message <-> table ([ termInfo - ,(text "inferred type", Pretty.niceType env tp) + ,(text "inferred type", tpRngDoc) ] ++ extra) @@ -900,10 +905,10 @@ resolveFunName name ctx rangeContext range infoFilter = isInfoValFunExt infoFilterAmb = not . isInfoImport -resolveConName :: Name -> Maybe (Type) -> Range -> Inf (Name,Type,Core.ConRepr,ConInfo) +resolveConName :: Name -> Maybe (Type) -> Range -> Inf (Name,Type,Core.ConRepr,ConInfo,Range) resolveConName name mbType range = do (qname,tp,info) <- resolveNameEx isInfoCon Nothing name (maybeToContext mbType) range range - return (qname,tp,infoRepr info,infoCon info) + return (qname,tp,infoRepr info,infoCon info,infoRange info) resolveConPatternName :: Name -> Type -> Int -> Range -> Inf (Name,Type,Core.ConRepr,ConInfo) resolveConPatternName name matchType patternCount range @@ -930,23 +935,23 @@ resolveNameEx infoFilter mbInfoFilterAmb name ctx rangeContext range case (ctx,amb) of (CtxType tp, [(qname,info)]) -> do let [nice1,nice2] = Pretty.niceTypes penv [tp,infoType info] - infError range (Pretty.ppName penv name <+> text "does not match the argument types" <-> + infError TypeErrorArgumentTypesMismatch range (Pretty.ppName penv name <+> text "does not match the argument types" <-> table (ctxTerm rangeContext ++ [(text "inferred type",nice2) ,(text "expected type",nice1)])) (CtxType tp, (_:rest)) - -> infError range (text "identifier" <+> Pretty.ppName penv name <+> text "has no matching definition" <-> + -> infError TypeErrorNameNotFound range (text "identifier" <+> Pretty.ppName penv name <+> text "has no matching definition" <-> table (ctxTerm rangeContext ++ [(text "inferred type", Pretty.niceType penv tp) ,(text "candidates", ppCandidates env amb)] ++ ppImplicitsHint env amb)) (CtxFunArgs matchSome fixed named (Just resTp), (_:rest)) -> do let message = "with " ++ show (fixed + length named) ++ " argument(s) matches the result type" - infError range (text "no function" <+> Pretty.ppName penv name <+> text message <+> + infError TypeErrorFunctionNotFoundForResultType range (text "no function" <+> Pretty.ppName penv name <+> text message <+> Pretty.niceType penv resTp <.> ppAmbiguous env "" amb) (CtxFunArgs matchSome fixed named Nothing, (_:rest)) -> do let message = "takes " ++ show (fixed + length named) ++ " argument(s)" ++ (if null named then "" else " with such parameter names") - infError range (text "no function" <+> Pretty.ppName penv name <+> text message <.> ppAmbiguous env "" amb) + infError TypeErrorFunctionNotFoundForArgumentNames range (text "no function" <+> Pretty.ppName penv name <+> text message <.> ppAmbiguous env "" amb) (CtxFunTypes partial fixed named mbResTp, (_:rest)) -> do let docs = Pretty.niceTypes penv (fixed ++ map snd named) fdocs = take (length fixed) docs @@ -956,7 +961,7 @@ resolveNameEx infoFilter mbInfoFilterAmb name ctx rangeContext range argsDoc = color (colorType (Pretty.colors penv)) $ parens (hsep (punctuate comma (fdocs ++ ndocs ++ pdocs))) <+> text "-> ..." -- todo: show nice mbResTp if present - infError range (text "no function" <+> Pretty.ppName penv name <+> text "is defined that matches the argument types" <-> + infError TypeErrorFunctionNotFoundForArgumentTypes range (text "no function" <+> Pretty.ppName penv name <+> text "is defined that matches the argument types" <-> table (ctxTerm rangeContext ++ [(text "inferred type", argsDoc) ,(text "candidates", ppCandidates env amb)] ++ ppImplicitsHint env amb @@ -971,9 +976,9 @@ resolveNameEx infoFilter mbInfoFilterAmb name ctx rangeContext range Nothing -> return [] case amb2 of (_:_) - -> infError range ((text "identifier" <+> Pretty.ppName penv name <+> text "cannot be found") <-> + -> infError TypeErrorNameAmbiguous range ((text "identifier" <+> Pretty.ppName penv name <+> text "cannot be found") <-> (text "perhaps you meant: " <.> ppOr penv (map fst amb2))) - _ -> infError range (text "identifier" <+> Pretty.ppName penv name <+> text "cannot be found") + _ -> infError TypeErrorNameNotFound range (text "identifier" <+> Pretty.ppName penv name <+> text "cannot be found") [(qname,info)] -> do -- when (not asPrefix) $ -- todo: check casing for asPrefix as well @@ -981,7 +986,7 @@ resolveNameEx infoFilter mbInfoFilterAmb name ctx rangeContext range return (qname,infoType info,info) _ -> do env <- getEnv (term,termInfo) <- getTermDoc "context" rangeContext - infError range (text "identifier" <+> Pretty.ppName (prettyEnv env) name <+> text "cannot be resolved." <-> + infError TypeErrorNameAmbiguous range (text "identifier" <+> Pretty.ppName (prettyEnv env) name <+> text "cannot be resolved." <-> table ([(term, termInfo), (text "inferred type", ppNameContext (prettyEnv env) ctx), (text "candidates", ppCandidates env matches), @@ -1027,7 +1032,7 @@ lookupAppName allowDisambiguate name ctx contextRange range -> if (allowDisambiguate && not (null docs)) then do env <- getEnv (term,termInfo) <- getTermDoc "context" contextRange - infError range (text "identifier" <+> Pretty.ppName (prettyEnv env) name <+> text "cannot be resolved" <-> + infError TypeErrorNameAmbiguous range (text "identifier" <+> Pretty.ppName (prettyEnv env) name <+> text "cannot be resolved" <-> table [(term, termInfo), (text "inferred type", ppNameContext (prettyEnv env) ctx), (text "candidates", ppAmbDocs docs), @@ -1046,7 +1051,7 @@ resolveImplicitName name tp contextRange range Right iarg -> do -- traceDefDoc $ \penv -> text "resolved implicit" <+> prettyImplicitAssign penv "?" name iarg return (toImplicitArgExpr range iarg, prettyImplicitArg penv iarg) Left docs -> do (term,termInfo) <- getTermDoc "context" contextRange - infError range + infError TypeErrorImplicitNotResolved range (text "cannot resolve implicit parameter" <-> table [(term, termInfo), (text "parameter", text "?" <.> ppNameType penv (name,tp)), @@ -1417,7 +1422,7 @@ lookupFunName name mbType range [] -> return Nothing [(name,info)] -> return (Just (name,infoType info,info)) _ -> do env <- getEnv - infError range (text "identifier" <+> Pretty.ppName (prettyEnv env) name <+> text "cannot be resolved" + infError TypeErrorNameAmbiguous range (text "identifier" <+> Pretty.ppName (prettyEnv env) name <+> text "cannot be resolved" <.> ppAmbiguous env hintQualify matches) where hintQualify = "qualify the name to disambiguate it?" @@ -1625,7 +1630,7 @@ checkCasingOverlap range name qname info = do case caseOverlaps name qname info of Just qname1 -> do env <- getEnv - infError range (text (infoElement info) <+> Pretty.ppName (prettyEnv env) (unqualify name) <+> text "is already in scope with a different casing as" <+> Pretty.ppName (prettyEnv env) (importsAlias qname1 (imports env))) + infError TypeErrorNameCaseOverlap range (text (infoElement info) <+> Pretty.ppName (prettyEnv env) (unqualify name) <+> text "is already in scope with a different casing as" <+> Pretty.ppName (prettyEnv env) (importsAlias qname1 (imports env))) _ -> return () checkCasing :: Range -> Name -> Name -> NameInfo -> Inf () @@ -1634,7 +1639,7 @@ checkCasing range name qname info Nothing -> return () Just qname1 -> do env <- getEnv - infError range (text (infoElement info) <+> Pretty.ppName (prettyEnv env) (unqualify name) <+> text "should be cased as" <+> Pretty.ppName (prettyEnv env) (importsAlias qname1 (imports env))) + infError TypeErrorNameWrongCase range (text (infoElement info) <+> Pretty.ppName (prettyEnv env) (unqualify name) <+> text "should be cased as" <+> Pretty.ppName (prettyEnv env) (importsAlias qname1 (imports env))) caseOverlaps :: Name -> Name -> NameInfo -> (Maybe Name) @@ -1702,8 +1707,8 @@ ppNameInfo env (name,info) data Inf a = Inf (Env -> St -> Res a) -data Res a = Ok !a !St ![(Range,Doc)] - | Err !(Range,Doc) ![(Range,Doc)] +data Res a = Ok !a !St ![(TypeInferErrorCode,Range,Doc)] + | Err !(TypeInferErrorCode,Range,Doc) ![(TypeInferErrorCode,Range,Doc)] data Env = Env{ prettyEnv :: !Pretty.Env , context :: !Name -- | current module name @@ -1721,15 +1726,201 @@ data Env = Env{ prettyEnv :: !Pretty.Env } data St = St{ uniq :: !Int, sub :: !Sub, preds :: ![Evidence], holeAllowed :: !Bool, mbRangeMap :: Maybe RangeMap } +data TypeInferErrorCode + = + -- Unification errors + TypeErrorMismatch Context + | TypeErrorPredicateMismatch + | TypeErrorSkolemEscape + | TypeErrorLocalEscape + -- Lookup errors + | TypeErrorArgumentTypesMismatch + | TypeErrorFunctionNotFoundForResultType + | TypeErrorFunctionNotFoundForArgumentNames + | TypeErrorFunctionNotFoundForArgumentTypes + | TypeErrorImplicitNotResolved + + -- Other name errors + | TypeErrorNameAmbiguous + | TypeErrorNameCaseOverlap + | TypeErrorNameWrongCase + | TypeErrorNameNotFound + | TypeErrorNameFunctionOverlapsArguments + | TypeErrorNameValueOverlaps + | TypeErrorNameAlreadyDefined + | TypeWarningNameShadowsDefinition + | TypeErrorOverloadedNameRecursionRequireTypes + | TypeErrorOverloadedNameRecursionNotTopLevel + | TypeErrorRecursiveValueDefinitions + | TypeWarningUnusedExpression + | TypeWarningUnusedPatternBinder + | TypeErrorIllegalReturnContext + | TypeErrorDuplicateNamedArgument + | TypeErrorInferredFunctionNamedArgument + | TypeErrorNotEffectOperation + | TypeErrorEffectOperationNotFound + | TypeErrorEffectNotFound + | TypeErrorEffectOperationNotHandled + | TypeErrorEffectOperationMultiple + | TypeErrorInvalidValOperation + | TypeErrorEffectOperationWrongSort + | TypeErrorLazyConstructorInMatch + | TypeErrorLazyConstructorInInnerPattern + -- Constructor contexts + | TypeErrorCCtxIllFormed + | TypeErrorCCtxHolePolymorphicType + | TypeErrorCCtxHoleInvalidType + | TypeErrorCCtxHoleValueType + -- Match Analysis + | TypeInferGuardUnreachable + | TypeInferGuardAlwaysFalse + | TypeInferBranchUnreachable + -- Other Syntax Errors + | TypeErrorNotAssignable + | TypeErrorCCtxMultipleHoles + | TypeErrorCCtxHoleNotFound + | TypeErrorHandlerParametersUnsupported + | TypeErrorLinearHandlerOperationNonLinear + | TypeErrorLinearHandlerUsesNonLinearEffect + | TypeErrorEffectOperationNotPartOfEffect + | TypeErrorParameterPolymorphicNoAnnotation + | TypeErrorInvalidScrutinee + | TypeErrorImplicitParamNoDefault + | TypeErrorConstructorFieldNotFound + | TypeErrorConstructorTooManyArguments + | TypeErrorFunctionTooFewArguments + | TypeErrorFunctionTooManyArguments + | TypeErrorArgumentWithNameNotFound + | TypeErrorNonCallableTarget + + +instance ErrorCode TypeInferErrorCode where + codeNum (TypeErrorMismatch _) = 0 + codeNum TypeErrorPredicateMismatch = 1 + codeNum TypeErrorSkolemEscape = 2 + codeNum TypeErrorLocalEscape = 3 + codeNum TypeErrorArgumentTypesMismatch = 100 + codeNum TypeErrorFunctionNotFoundForResultType = 101 + codeNum TypeErrorFunctionNotFoundForArgumentNames = 102 + codeNum TypeErrorFunctionNotFoundForArgumentTypes = 103 + codeNum TypeErrorImplicitNotResolved = 104 + codeNum TypeErrorNameAmbiguous = 200 + codeNum TypeErrorNameCaseOverlap = 201 + codeNum TypeErrorNameWrongCase = 202 + codeNum TypeErrorNameNotFound = 203 + codeNum TypeErrorNameFunctionOverlapsArguments = 204 + codeNum TypeErrorNameValueOverlaps = 205 + codeNum TypeErrorNameAlreadyDefined = 206 + codeNum TypeWarningNameShadowsDefinition = 207 + codeNum TypeErrorOverloadedNameRecursionRequireTypes = 300 + codeNum TypeErrorOverloadedNameRecursionNotTopLevel = 301 + codeNum TypeErrorRecursiveValueDefinitions = 302 + codeNum TypeWarningUnusedExpression = 303 + codeNum TypeWarningUnusedPatternBinder = 304 + codeNum TypeErrorIllegalReturnContext = 305 + codeNum TypeErrorDuplicateNamedArgument = 306 + codeNum TypeErrorInferredFunctionNamedArgument = 307 + codeNum TypeErrorNotEffectOperation = 400 + codeNum TypeErrorEffectOperationNotFound = 401 + codeNum TypeErrorEffectNotFound = 402 + codeNum TypeErrorEffectOperationNotHandled = 403 + codeNum TypeErrorEffectOperationMultiple = 404 + codeNum TypeErrorInvalidValOperation = 500 + codeNum TypeErrorEffectOperationWrongSort = 501 + codeNum TypeErrorLazyConstructorInMatch = 600 + codeNum TypeErrorLazyConstructorInInnerPattern = 601 + codeNum TypeErrorCCtxIllFormed = 700 + codeNum TypeErrorCCtxHolePolymorphicType = 701 + codeNum TypeErrorCCtxHoleInvalidType = 702 + codeNum TypeErrorCCtxHoleValueType = 703 + codeNum TypeInferGuardUnreachable = 800 + codeNum TypeInferGuardAlwaysFalse = 801 + codeNum TypeInferBranchUnreachable = 802 + codeNum TypeErrorNotAssignable = 900 + codeNum TypeErrorCCtxMultipleHoles = 901 + codeNum TypeErrorCCtxHoleNotFound = 902 + codeNum TypeErrorHandlerParametersUnsupported = 903 + codeNum TypeErrorLinearHandlerOperationNonLinear = 904 + codeNum TypeErrorLinearHandlerUsesNonLinearEffect = 905 + codeNum TypeErrorEffectOperationNotPartOfEffect = 906 + codeNum TypeErrorParameterPolymorphicNoAnnotation = 907 + codeNum TypeErrorInvalidScrutinee = 908 + codeNum TypeErrorImplicitParamNoDefault = 909 + codeNum TypeErrorConstructorFieldNotFound = 910 + codeNum TypeErrorConstructorTooManyArguments = 911 + codeNum TypeErrorFunctionTooFewArguments = 912 + codeNum TypeErrorFunctionTooManyArguments = 913 + codeNum TypeErrorArgumentWithNameNotFound = 914 + codeNum TypeErrorNonCallableTarget = 915 + + codeDoc (TypeErrorMismatch (Check msg _) ) = text $ "Type mismatch: " ++ msg + codeDoc (TypeErrorMismatch (Infer _) ) = text $ "Type mismatch" + codeDoc TypeErrorPredicateMismatch = text "predicate mismatch" + codeDoc TypeErrorSkolemEscape = text "polymorphic type variable escapes polymorphic scope" + codeDoc TypeErrorLocalEscape = text "local variable escapes" + codeDoc TypeErrorArgumentTypesMismatch = text "argument types mismatch" + codeDoc TypeErrorFunctionNotFoundForResultType = text "function not found for result type" + codeDoc TypeErrorFunctionNotFoundForArgumentNames = text "function not found for argument names" + codeDoc TypeErrorFunctionNotFoundForArgumentTypes = text "function not found for argument types" + codeDoc TypeErrorImplicitNotResolved = text "implicit argument not resolved" + codeDoc TypeErrorNameAmbiguous = text "ambiguous name" + codeDoc TypeErrorNameCaseOverlap = text "name overlaps previous definition with different case" + codeDoc TypeErrorNameWrongCase = text "name cased wrong" + codeDoc TypeErrorNameNotFound = text "name not found" + codeDoc TypeErrorNameFunctionOverlapsArguments = text "function overlaps argument names" + codeDoc TypeErrorNameValueOverlaps = text "value overlaps function" + codeDoc TypeErrorNameAlreadyDefined = text "name already defined" + codeDoc TypeWarningNameShadowsDefinition = text "name shadows previous definition" + codeDoc TypeErrorOverloadedNameRecursionRequireTypes = text "recursive functions with overloaded name requires type annotations" + codeDoc TypeErrorOverloadedNameRecursionNotTopLevel = text "recursive functions with overloaded name must be defined at the top level" + codeDoc TypeErrorRecursiveValueDefinitions = text "recursive value definitions" + codeDoc TypeWarningUnusedExpression = text "unused expression" + codeDoc TypeWarningUnusedPatternBinder = text "unused pattern binder" + codeDoc TypeErrorIllegalReturnContext = text "illegal return context" + codeDoc TypeErrorDuplicateNamedArgument = text "duplicate named argument" + codeDoc TypeErrorInferredFunctionNamedArgument = text "inferred function with named argument" + codeDoc TypeErrorNotEffectOperation = text "not an effect operation" + codeDoc TypeErrorEffectOperationNotFound = text "effect operation not found" + codeDoc TypeErrorEffectNotFound = text "unable to determine effect" + codeDoc TypeErrorInvalidValOperation = text "invalid value operation" + codeDoc TypeErrorEffectOperationMultiple = text "multiple handlers for the same operation found" + codeDoc TypeErrorEffectOperationNotHandled = text "effect operation not handled" + codeDoc TypeErrorEffectOperationWrongSort = text "effect operation wrong sort" + codeDoc TypeErrorLazyConstructorInMatch = text "lazy constructor in non-lazy match" + codeDoc TypeErrorLazyConstructorInInnerPattern = text "lazy constructor in inner pattern" + codeDoc TypeErrorCCtxIllFormed = text "constructor context ill-formed" + codeDoc TypeErrorCCtxHolePolymorphicType = text "constructor context has a hole with polymorphic type" + codeDoc TypeErrorCCtxHoleInvalidType = text "constructor context has a hole with invalid data type" + codeDoc TypeErrorCCtxHoleValueType = text "constructor context has a hole with value type" + codeDoc TypeInferGuardUnreachable = text "guard is unreachable" + codeDoc TypeInferGuardAlwaysFalse = text "guard is always false" + codeDoc TypeInferBranchUnreachable = text "branch is unreachable" + codeDoc TypeErrorNotAssignable = text "expression target not an assignable expression" + codeDoc TypeErrorCCtxMultipleHoles = text "multiple holes in constructor context" + codeDoc TypeErrorCCtxHoleNotFound = text "hole not found in constructor context" + codeDoc TypeErrorHandlerParametersUnsupported = text "parameters in handlers unsupported" + codeDoc TypeErrorLinearHandlerOperationNonLinear = text "linear handler operation is not used linearly" + codeDoc TypeErrorLinearHandlerUsesNonLinearEffect = text "linear handler uses non-linear effect" + codeDoc TypeErrorEffectOperationNotPartOfEffect = text "effect operation not part of effect" + codeDoc TypeErrorParameterPolymorphicNoAnnotation = text "parameter is polymorphic but has no polymorphic annotation" + codeDoc TypeErrorInvalidScrutinee = text "invalid scrutinee expression" + codeDoc TypeErrorImplicitParamNoDefault = text "implicit parameter should not have default value" + codeDoc TypeErrorConstructorFieldNotFound = text "constructor field not found" + codeDoc TypeErrorConstructorTooManyArguments = text "constructor has too many arguments" + codeDoc TypeErrorFunctionTooFewArguments = text "function has too few arguments" + codeDoc TypeErrorFunctionTooManyArguments = text "function has too many arguments" + codeDoc TypeErrorArgumentWithNameNotFound = text "argument with name not found" + codeDoc TypeErrorNonCallableTarget = text "target is not a callable expression" + runInfer :: Pretty.Env -> Maybe RangeMap -> Synonyms -> Newtypes -> ImportMap -> Gamma -> Name -> Int -> Inf a -> Error b (a,Int,Maybe RangeMap) runInfer env mbrm syns newTypes imports assumption context unique (Inf f) = case f (Env env context [] False newTypes syns assumption infgammaEmpty imports False False Nothing 0) (St unique subNull [] False mbrm) of - Err (rng,doc) warnings - -> addWarnings (map (toWarning ErrType) warnings) (errorMsg (errorMessageKind ErrType rng doc)) + Err (code,rng,doc) warnings + -> addWarnings (map (\(code, rng, doc) -> toWarning ErrType code rng doc) warnings) (errorMsg (errorMessageKind ErrType rng code doc)) Ok x st warnings - -> addWarnings (map (toWarning ErrType) warnings) (ok (x, uniq st, (sub st) |-> mbRangeMap st)) + -> addWarnings (map (\(code, rng, doc) -> toWarning ErrType code rng doc) warnings) (ok (x, uniq st, (sub st) |-> mbRangeMap st)) zapSubst :: Inf () @@ -1778,15 +1969,15 @@ updateSt :: (St -> St) -> Inf St updateSt f = Inf (\env st -> Ok st (f st) []) -infError :: Range -> Doc -> Inf a -infError range doc +infError :: TypeInferErrorCode -> Range -> Doc -> Inf a +infError code range doc = do addRangeInfo range (Error doc) - Inf (\env st -> Err (range,doc) []) + Inf (\env st -> Err (code,range,doc) []) -infWarning :: Range -> Doc -> Inf () -infWarning range doc +infWarning :: TypeInferErrorCode -> Range -> Doc -> Inf () +infWarning code range doc = do addRangeInfo range (Warning doc) - Inf (\env st -> Ok () st [(range,doc)]) + Inf (\env st -> Ok () st [(code,range,doc)]) getPrettyEnv :: Inf Pretty.Env getPrettyEnv @@ -1958,7 +2149,7 @@ extendGamma isAlreadyCanonical defs inf unqualify name == unqualify qname, isSameNamespace qname name ] case localMatches of - ((qname,qinfo):_) -> infError (infoRange info) (text "definition" <+> Pretty.ppName penv name <+> + ((qname,qinfo):_) -> infError TypeErrorNameAlreadyDefined (infoRange info) (text "definition" <+> Pretty.ppName penv name <+> text "is already defined in this module, at" <+> text (show (rangeStart (infoRange qinfo))) <-> text "hint: use a local qualifier?") [] -> return () @@ -1993,12 +2184,12 @@ extendGamma isAlreadyCanonical defs inf (_,_,rho2) = splitPredType (infoType info2) valueType = not (isFun rho1 && isFun rho2) if (isFun rho1 && isFun rho2) - then infError (infoRange info) (text "definition" <+> Pretty.ppName (prettyEnv env) name <+> text "overlaps with an earlier definition of the same name" <-> + then infError TypeErrorNameFunctionOverlapsArguments (infoRange info) (text "definition" <+> Pretty.ppName (prettyEnv env) name <+> text "overlaps with an earlier definition of the same name" <-> table ([(text "type",nice1) ,(text "overlaps",nice2) ,(text "because", text "definitions with the same name must differ on the argument types")]) ) - else infError (infoRange info) (text "definition" <+> Pretty.ppName (prettyEnv env) name <+> text "is already defined in this module" <-> + else infError TypeErrorNameValueOverlaps (infoRange info) (text "definition" <+> Pretty.ppName (prettyEnv env) name <+> text "is already defined in this module" <-> text "because: only functions can have overloaded names") Left _ -> return () @@ -2035,7 +2226,7 @@ extendInfGammaEx topLevel ignores tnames inf Just (info2) -> do checkCasingOverlap range name (infoCanonicalName name info2) info2 env <- getEnv - infError range (Pretty.ppName (prettyEnv env) name <+> text "is already defined at" <+> pretty (show (infoRange info2)) + infError TypeErrorNameAlreadyDefined range (Pretty.ppName (prettyEnv env) name <+> text "is already defined at" <+> pretty (show (infoRange info2)) <-> text " hint: if these are potentially recursive definitions, give a full type signature to disambiguate them.") Nothing -> do case (infgammaLookup name infgamma) of @@ -2043,7 +2234,7 @@ extendInfGammaEx topLevel ignores tnames inf -> do checkCasingOverlap range name cname info2 env <- getEnv if (not (isHiddenName name) && show name /= "resume" && show name /= "resume-shallow" && not (name `elem` ignores)) - then infWarning range (Pretty.ppName (prettyEnv env) name <+> text "shadows an earlier local definition or parameter") + then infWarning TypeWarningNameShadowsDefinition range (Pretty.ppName (prettyEnv env) name <+> text "shadows an earlier local definition or parameter") else return () _ -> return () extend ctx gamma (x:seen) rest (infgammaExtend qname (info{ infoCName = if topLevel then createCanonicalName ctx gamma qname else qname}) infgamma) diff --git a/src/Type/Pretty.hs b/src/Type/Pretty.hs index 7f5772681..49ae22c89 100644 --- a/src/Type/Pretty.hs +++ b/src/Type/Pretty.hs @@ -15,7 +15,7 @@ module Type.Pretty (-- * Pretty ,niceList, niceTypes, niceType, niceEnv ,typeColon, niceTypeVars, ppName, ppParam , canonical, minCanonical - , prettyComment, prettyRange, ppNamePlain + , prettyComment, prettyRange, ppNamePlain, ppLink, ppNameLink , keyword ) where @@ -39,6 +39,7 @@ import Kind.ImportMap import Type.Type import Type.TypeVar import Type.Kind +import Common.Range (Range, showFileUriRange) typeColon colors = color (colorSep colors) (text ":") @@ -139,6 +140,7 @@ data Env = Env{ showKinds :: !Bool , importsMap :: !ImportMap -- ^ import aliases , fullNames :: !Bool , alwaysUnqualify :: !Bool + , showFileLinks :: !Bool , indentation :: Int -- should not really belong here. Contains link bases for documentation generation (see Syntax.Colorize) @@ -168,6 +170,7 @@ defaultEnv defaultColorScheme niceEmpty (precTop-1) M.empty (newName "Main") (importsEmpty) False -- fullNames False + False -- diagnostic links 0 False [] @@ -438,6 +441,20 @@ ppParam env (name,tp) else color (colorParameter (colors env)) (ppNamePlain env (unqualify name)) <.> text " : ") <.> ppType env tp +ppLink :: Doc -> Range -> Doc +ppLink doc rng = + text "[" <.> doc <.> text "](" <.> text (showFileUriRange rng) <.> text ")" + +ppTypeLink :: Env -> Name -> Range -> Doc +ppTypeLink env name rng + = if showFileLinks env then ppLink (ppName env name) rng + else ppName env name + +ppNameLink :: Env -> Name -> Range -> Doc +ppNameLink env name rng + = if showFileLinks env + then ppLink (ppNamePlain env name) rng + else ppName env name ppName :: Env -> Name -> Doc ppName env name