diff --git a/encore.cabal b/encore.cabal index 67bf183af..856b64e06 100644 --- a/encore.cabal +++ b/encore.cabal @@ -47,6 +47,9 @@ executable encorec , unordered-containers , boxes , filepath + , ansi-terminal + , pager + , bytestring hs-source-dirs: src/back src/front src/ir src/opt src/parser src/types ghc-options: -Werror -fmax-pmcheck-iterations=10000000 default-language: Haskell2010 @@ -82,9 +85,13 @@ executable encorec , Optimizer.Optimizer , Parser.Parser , SystemUtils + , Typechecker.Backtrace , Typechecker.Capturechecker , Typechecker.Environment + , Typechecker.Errorprinter + , Typechecker.ExplainTable , Typechecker.Prechecker + , Typechecker.Suggestable , Typechecker.TypeError , Typechecker.Typechecker , Typechecker.Util diff --git a/modules/explanations/E0014.txt b/modules/explanations/E0014.txt new file mode 100644 index 000000000..a7b17dad7 --- /dev/null +++ b/modules/explanations/E0014.txt @@ -0,0 +1,19 @@ +Welcome to the Encore Compiler! +Here you will meet many wonderful methods and functions and whatnot! + +To be able to compile an Encore program you will need to have a Main-class +with a main-method inside. +Lets try a simple "Hello World"! + +For example: + + +``` +active class Main + + def main() : unit + println("hello world") + end + +end +``` \ No newline at end of file diff --git a/modules/explanations/E0073.txt b/modules/explanations/E0073.txt new file mode 100644 index 000000000..ae53ec861 --- /dev/null +++ b/modules/explanations/E0073.txt @@ -0,0 +1,17 @@ +This error occurs when the compiler was unable to infer the concrete type of a +variable. It can occur for several cases, the most common of which is a +mismatch in the expected type that the compiler inferred for a variable's +initializing expression, and the actual type explicitly assigned to the +variable. + +For example: + +``` +let x: int = "I am not a number!" +-- ~~~ ~~~~~~~~~~~~~~~~~~~~ +-- | | +-- | initializing expression; +-- | compiler infers type `String.String` +-- | +-- type `int` assigned to variable `x` +``` diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index c7a3d9971..6fbf075b4 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -14,6 +14,8 @@ import System.Directory import System.IO import System.Exit import System.Process +import qualified Data.ByteString.Lazy as B (readFile) +import System.Pager (sendToPager) import System.Posix.Directory import Data.List import Data.List.Utils(split) @@ -25,6 +27,7 @@ import qualified Data.Map.Strict as Map import SystemUtils import Language.Haskell.TH -- for Template Haskell hackery import Text.Printf +import qualified Text.PrettyPrint.Annotated as Pretty import qualified Text.PrettyPrint.Boxes as Box import System.FilePath (splitPath, joinPath) import Text.Megaparsec.Error(errorPos, parseErrorTextPretty) @@ -41,6 +44,7 @@ import ModuleExpander import Typechecker.Environment(buildLookupTable) import Typechecker.Prechecker(precheckProgram) import Typechecker.Typechecker(typecheckProgram, checkForMainClass) +import Typechecker.Errorprinter import Typechecker.Capturechecker(capturecheckProgram) import Optimizer.Optimizer import CodeGen.Main @@ -72,6 +76,7 @@ data Option = | Verbose | Literate | NoGC + | Explain String | Help | Undefined String | Malformed String @@ -122,6 +127,8 @@ optionMappings = "Compile and run the program, but do not produce executable file."), (NoArg NoGC, "", "--no-gc", "", "DEBUG: disable GC and use C-malloc for allocation."), + (Arg Explain, "-e", "--explain", "[error]", + "Display information for error code"), (NoArg Help, "", "--help", "", "Display this information.") ] @@ -293,6 +300,9 @@ main = checkForUndefined options when (Help `elem` options) (exit helpMessage) + case find isExplain options of + Just (Explain errCode) -> explainError errCode + Nothing -> return () when (null programs) (abort ("No program specified! Aborting.\n\n" <> usage <> "\n" <> @@ -349,7 +359,7 @@ main = unless (TypecheckOnly `elem` options) $ case checkForMainClass mainSource fullAst of - Just error -> abort $ show error + Just error -> errorAbort error Nothing -> return () exeName <- compileProgram fullAst sourceName options @@ -372,7 +382,7 @@ main = (Right ast, warnings) -> return (ast, warnings) (Left error, warnings) -> do showWarnings warnings - abort $ show error + errorAbort error showWarnings precheckingWarnings return precheckedAST @@ -387,7 +397,7 @@ main = (Right (newEnv, ast), warnings) -> return (ast, warnings) (Left error, warnings) -> do showWarnings warnings - abort $ show error + errorAbort error showWarnings typecheckingWarnings return typecheckedAST @@ -402,14 +412,14 @@ main = (Right (newEnv, ast), warnings) -> return (ast, warnings) (Left error, warnings) -> do showWarnings warnings - abort $ show error + errorAbort error showWarnings capturecheckingWarnings return capturecheckedAST usage = "Usage: encorec [flags] file" verbose options str = when (Verbose `elem` options) (putStrLn str) - showWarnings = mapM print + helpMessage = "Welcome to the Encore compiler!\n" <> usage <> "\n\n" <> @@ -428,4 +438,30 @@ main = optionBox = longBox Box.<+> shortBox Box.<+> descBox flags = intercalate "\n" $ map ((" " ++) . strip) . lines $ - Box.render optionBox \ No newline at end of file + Box.render optionBox + + errorAbort e = do + printf "*** Error during typechecking *** \n\n" + printError e + abort $ "Aborting due to previous error" + + showWarnings = mapM printWarning . reverse + + + isExplain (Explain _) = True + isExplain _ = False + + explainError errCode = do + isHash <- isExplanationHash errCode + case isHash of + False -> do + noExplanation errCode + exitSuccess + True -> do + let fnom = standardLibLocation ++ "/explanations/" ++ errCode ++ ".txt" + B.readFile fnom >>= sendToPager + exitSuccess + + isExplanationHash :: String -> IO Bool + isExplanationHash str@('E':_:_:_:_:[]) = doesFileExist $ standardLibLocation ++ "/explanations/" ++ str ++ ".txt" + isExplanationHash _ = return False diff --git a/src/ir/AST/Meta.hs b/src/ir/AST/Meta.hs index 13e48fe90..79b794bbb 100644 --- a/src/ir/AST/Meta.hs +++ b/src/ir/AST/Meta.hs @@ -24,6 +24,7 @@ instance Show Position where -- TODO: If we ever want to print ranges, this should be updated show = showSourcePos . startPos + newPos :: SourcePos -> Position newPos = SingletonPos @@ -54,7 +55,7 @@ showSourcePos pos = let line = unPos (sourceLine pos) col = unPos (sourceColumn pos) file = sourceName pos - in printf "%s (line %d, column %d)" (show file) line col + in printf "%s (Line:%d, Column:%d)" (show file) line col showPos :: Meta a -> String showPos = showSourcePos . startPos . position @@ -62,6 +63,18 @@ showPos = showSourcePos . startPos . position getPos :: Meta a -> Position getPos = position +getPositions :: Position -> ((Int, Int), (Int, Int)) +getPositions pos = + case pos of + SingletonPos start -> ((line start, column start), (line start, column start+1)) + RangePos start end -> ((line start, column start), (line end, column end)) + where + line p = fromIntegral $ unPos (sourceLine p) + column p = fromIntegral $ unPos (sourceColumn p) + +getPositionFile :: Position -> String +getPositionFile = sourceName . startPos + setType :: Type -> Meta a -> Meta a setType newType m = m {metaType = Just newType} diff --git a/src/ir/AST/PrettyPrinter.hs b/src/ir/AST/PrettyPrinter.hs index 12dee89c0..ed1e3db7c 100644 --- a/src/ir/AST/PrettyPrinter.hs +++ b/src/ir/AST/PrettyPrinter.hs @@ -16,11 +16,11 @@ module AST.PrettyPrinter (ppExpr ,indent ,ppSugared ,ppFunctionHeader + ,pipe ) where -- Library dependencies -import qualified Text.PrettyPrint as P -import Text.PrettyPrint hiding(brackets) +import Text.PrettyPrint.Annotated hiding(brackets) -- Module dependencies import Identifiers @@ -29,26 +29,28 @@ import AST.AST indent = nest 2 +pipe = char '|' + commaSep l = hcat $ punctuate ", " l brackets s = hcat ["[", s, "]"] -ppMut :: Mutability -> Doc +ppMut :: Mutability -> Doc a ppMut Val = "val" ppMut Var = "var" -ppName :: Name -> Doc +ppName :: Name -> Doc a ppName = text . show -ppNamespace :: Namespace -> Doc +ppNamespace :: Namespace -> Doc a ppNamespace = text . show -ppQName :: QualifiedName -> Doc +ppQName :: QualifiedName -> Doc a ppQName = text . show -ppType :: Type -> Doc +ppType :: Type -> Doc a ppType = text . show -ppProgram :: Program -> Doc +ppProgram :: Program -> Doc a ppProgram Program{moduledecl, etl, imports, typedefs, functions, traits, classes, adts, adtCases} = ppModuleDecl moduledecl $+$ vcat (map ppEmbedded etl) <+> @@ -70,7 +72,7 @@ ppHeader header code = then empty else "EMBED" $+$ text header $+$ "BODY" $+$ text code $+$ "END\n" -ppModuleDecl :: ModuleDecl -> Doc +ppModuleDecl :: ModuleDecl -> Doc a ppModuleDecl NoModule = empty ppModuleDecl Module{modname, modexports} = "module" <+> ppName modname <> @@ -78,7 +80,7 @@ ppModuleDecl Module{modname, modexports} = Just names -> parens (commaSep $ map ppName names) Nothing -> empty -ppImportDecl :: ImportDecl -> Doc +ppImportDecl :: ImportDecl -> Doc a ppImportDecl Import {itarget ,iqualified ,ihiding @@ -103,21 +105,21 @@ ppImportDecl Import {itarget Just alias -> " as" <+> ppNamespace alias Nothing -> empty -ppTypedef :: Typedef -> Doc +ppTypedef :: Typedef -> Doc a ppTypedef Typedef { typedefdef=t } = "typedef" <+> ppType t <+> "=" <+> ppType (typeSynonymRHS t) -ppFunctionHeader :: FunctionHeader -> Doc +ppFunctionHeader :: FunctionHeader -> Doc a ppFunctionHeader header = ppName (hname header) <> ppTypeParams (htypeparams header) <> parens (commaSep $ map ppParamDecl $ hparams header) <+> ":" <+> ppType (htype header) -ppTypeParams :: [Type] -> Doc +ppTypeParams :: [Type] -> Doc a ppTypeParams params = if null params then empty @@ -127,7 +129,7 @@ ppTypeParams params = | Just bound <- getBound ty = ppType ty <+> ":" <+> ppType bound | otherwise = ppType ty -ppFunctionHelper :: FunctionHeader -> Expr -> [Function] -> Doc +ppFunctionHelper :: FunctionHeader -> Expr -> [Function] -> Doc a ppFunctionHelper funheader funbody [] = "fun" <+> ppFunctionHeader funheader $+$ indent (ppBody funbody) $+$ @@ -139,11 +141,11 @@ ppFunctionHelper funheader funbody funlocals = indent (vcat $ map ppFunction funlocals) $+$ "end" -ppFunction :: Function -> Doc +ppFunction :: Function -> Doc a ppFunction Function {funheader, funbody, funlocals} = ppFunctionHelper funheader funbody funlocals -ppTraitDecl :: TraitDecl -> Doc +ppTraitDecl :: TraitDecl -> Doc a ppTraitDecl Trait {tname, treqs, tmethods} = trait <+> text (showWithoutMode tname) $+$ indent (vcat (map ppRequirement treqs) $$ @@ -157,11 +159,11 @@ ppTraitDecl Trait {tname, treqs, tmethods} = ppRequirement RequiredMethod{rheader} = "require" <+> "def" <+> ppFunctionHeader rheader -ppTraitExtension :: TraitExtension -> Doc +ppTraitExtension :: TraitExtension -> Doc a ppTraitExtension FieldExtension{extname} = ppName extname ppTraitExtension MethodExtension{extname} = ppName extname <> "()" -ppComposition :: TraitComposition -> Doc +ppComposition :: TraitComposition -> Doc a ppComposition Conjunction{tcleft, tcright} = ppConjunctionChild tcleft <+> "*" <+> ppConjunctionChild tcright where @@ -174,19 +176,19 @@ ppComposition TraitLeaf{tcname, tcext} = then empty else parens (commaSep (map ppTraitExtension tcext)) -ppAdtDecl :: AdtDecl -> Doc +ppAdtDecl :: AdtDecl -> Doc a ppAdtDecl ADT {ameta, aname, amethods} = "data" <+> text (showWithoutMode aname) $+$ indent (vcat (map ppMethodDecl amethods)) $+$ "end" -ppAdtCaseDecl :: AdtCase -> Doc +ppAdtCaseDecl :: AdtCase -> Doc a ppAdtCaseDecl ADTCase{acmeta, acname, acfields, acmethods} = "case" <+> text (showWithoutMode acname) <> parens (commaSep $ map ppParamDecl acfields) $+$ indent (vcat (map ppMethodDecl acmethods)) $+$ "end" -ppClassDecl :: ClassDecl -> Doc +ppClassDecl :: ClassDecl -> Doc a ppClassDecl Class {cname, cfields, cmethods, ccomposition} = clss <+> text (showWithoutMode cname) <+> compositionDoc $+$ indent (vcat (map ppFieldDecl cfields) $$ @@ -200,16 +202,16 @@ ppClassDecl Class {cname, cfields, cmethods, ccomposition} = Just c -> ":" <+> ppComposition c Nothing -> empty -ppFieldDecl :: FieldDecl -> Doc +ppFieldDecl :: FieldDecl -> Doc a ppFieldDecl = text . show -ppParamDecl :: ParamDecl -> Doc +ppParamDecl :: ParamDecl -> Doc a ppParamDecl (Param {pmut = Val, pname, ptype}) = ppName pname <+> ":" <+> ppType ptype ppParamDecl (Param {pmut = Var, pname, ptype}) = "var" <+> ppName pname <+> ":" <+> ppType ptype -ppMethodDecl :: MethodDecl -> Doc +ppMethodDecl :: MethodDecl -> Doc a ppMethodDecl m = let header = mheader m modifiers = hmodifiers header @@ -242,26 +244,27 @@ isSimple MessageSend {target} = isSimple target isSimple FunctionCall {} = True isSimple _ = False -maybeParens :: Expr -> Doc +maybeParens :: Expr -> Doc a maybeParens e | isSimple e = ppExpr e | otherwise = parens $ ppExpr e -ppSugared :: Expr -> Doc +ppSugared :: Expr -> Doc a ppSugared e = case getSugared e of Just e' -> ppExpr e' Nothing -> ppExpr e +ppBody :: Expr -> Doc a ppBody (Seq {eseq}) = vcat $ map ppExpr eseq ppBody e = ppExpr e -withTypeArguments :: [Type] -> Doc +withTypeArguments :: [Type] -> Doc a withTypeArguments typeArguments = if null typeArguments then empty else brackets (commaSep (map ppType typeArguments)) -ppExpr :: Expr -> Doc +ppExpr :: Expr -> Doc a ppExpr Skip {} = "()" ppExpr Break {} = "break" ppExpr Continue {} = "Continue" @@ -279,7 +282,7 @@ ppExpr Optional {optTag = QuestionDot FieldAccess {target, name}} = ppExpr Optional {optTag} = error $ "PrettyPrinter.hs: don't know how to " ++ "print expression '" ++ (render $ ppPath optTag) ++ "'" where - ppPath :: OptionalPathComponent -> Doc + ppPath :: OptionalPathComponent -> Doc a ppPath (QuestionBang e) = ppExpr e ppPath (QuestionDot e) = ppExpr e @@ -450,19 +453,19 @@ ppExpr Binop {binop, loper, roper} = ppExpr loper <+> ppBinop binop <+> ppExpr roper ppExpr TypedExpr {body, ty} = ppExpr body <+> ":" <+> ppType ty -ppDecl :: ([VarDecl], Expr) -> Doc +ppDecl :: ([VarDecl], Expr) -> Doc a ppDecl (vars, val) = commaSep (map ppVar vars) <+> "=" <+> ppExpr val -ppVar :: VarDecl -> Doc +ppVar :: VarDecl -> Doc a ppVar (VarType x ty) = ppName x <+> ":" <+> ppType ty ppVar (VarNoType x) = ppName x -ppUnary :: UnaryOp -> Doc +ppUnary :: UnaryOp -> Doc a ppUnary Identifiers.NOT = "not" ppUnary Identifiers.NEG = "-" -ppBinop :: BinaryOp -> Doc +ppBinop :: BinaryOp -> Doc a ppBinop Identifiers.AND = "&&" ppBinop Identifiers.OR = "||" ppBinop Identifiers.LT = "<" diff --git a/src/tests/encore/assert/assertFalse.err b/src/tests/encore/assert/assertFalse.err index 8e83d7386..1c08de3c1 100644 --- a/src/tests/encore/assert/assertFalse.err +++ b/src/tests/encore/assert/assertFalse.err @@ -1,2 +1,2 @@ -Assertion failed at "assertFalse.enc" (line 6, column 5): +Assertion failed at "assertFalse.enc" (Line:6, Column:5): Kingfisher diff --git a/src/tests/encore/assert/assertFalseMsg.err b/src/tests/encore/assert/assertFalseMsg.err index 7b95ffc8e..fcd31ec5b 100644 --- a/src/tests/encore/assert/assertFalseMsg.err +++ b/src/tests/encore/assert/assertFalseMsg.err @@ -1,2 +1,2 @@ -Assertion failed at "assertFalseMsg.enc" (line 6, column 5): +Assertion failed at "assertFalseMsg.enc" (Line:6, Column:5): Int 42 Bool false String Foo diff --git a/src/tests/encore/assert/assertTrue.err b/src/tests/encore/assert/assertTrue.err index a65f86d74..9270864a1 100644 --- a/src/tests/encore/assert/assertTrue.err +++ b/src/tests/encore/assert/assertTrue.err @@ -1,2 +1,2 @@ -Assertion failed at "assertTrue.enc" (line 6, column 5): +Assertion failed at "assertTrue.enc" (Line:6, Column:5): Kingfisher diff --git a/src/tests/encore/assert/assertTrueMsg.err b/src/tests/encore/assert/assertTrueMsg.err index a80c7923b..723c62261 100644 --- a/src/tests/encore/assert/assertTrueMsg.err +++ b/src/tests/encore/assert/assertTrueMsg.err @@ -1,2 +1,2 @@ -Assertion failed at "assertTrueMsg.enc" (line 6, column 5): +Assertion failed at "assertTrueMsg.enc" (Line:6, Column:5): Int 42 Bool false String Foo diff --git a/src/tests/encore/basic/abort.err b/src/tests/encore/basic/abort.err index d69511a94..ce7dabd57 100644 --- a/src/tests/encore/basic/abort.err +++ b/src/tests/encore/basic/abort.err @@ -1,2 +1,2 @@ This is LA8PV transmitting on the shortwave band -"abort.enc" (line 6, column 18) +"abort.enc" (Line:6, Column:18) diff --git a/src/tests/encore/basic/assignError.enc b/src/tests/encore/basic/assignError.enc new file mode 100644 index 000000000..780c32aca --- /dev/null +++ b/src/tests/encore/basic/assignError.enc @@ -0,0 +1,8 @@ + +class Main + def main() : unit + var x = 10 + x*2 = x * (2 / 3) + () + end +end diff --git a/src/tests/encore/basic/assignError.fail b/src/tests/encore/basic/assignError.fail new file mode 100644 index 000000000..a70ca49a3 --- /dev/null +++ b/src/tests/encore/basic/assignError.fail @@ -0,0 +1 @@ +Left-hand side of operand is not assignable diff --git a/src/tests/encore/basic/recvNullCall.err b/src/tests/encore/basic/recvNullCall.err index 0a6cde512..1ef49f9c0 100644 --- a/src/tests/encore/basic/recvNullCall.err +++ b/src/tests/encore/basic/recvNullCall.err @@ -1 +1 @@ -Error: empty receiver in x ! test(...) in "recvNullCall.enc" (line 11, column 9) +Error: empty receiver in x ! test(...) in "recvNullCall.enc" (Line:11, Column:9) diff --git a/src/tests/encore/basic/recvNullSend.err b/src/tests/encore/basic/recvNullSend.err index 387c67835..86e054714 100644 --- a/src/tests/encore/basic/recvNullSend.err +++ b/src/tests/encore/basic/recvNullSend.err @@ -1 +1 @@ -Error: empty receiver in x ! test(...) in "recvNullSend.enc" (line 11, column 8) +Error: empty receiver in x ! test(...) in "recvNullSend.enc" (Line:11, Column:8) diff --git a/src/tests/encore/forward/forwardTypeMismatch.fail b/src/tests/encore/forward/forwardTypeMismatch.fail index 6dc4a2c57..5fe64ed88 100644 --- a/src/tests/encore/forward/forwardTypeMismatch.fail +++ b/src/tests/encore/forward/forwardTypeMismatch.fail @@ -1 +1 @@ -"forwardTypeMismatch.enc" (line 8, column 22) +"forwardTypeMismatch.enc" (Line:8, Column:22) diff --git a/src/tests/encore/match/missing.err b/src/tests/encore/match/missing.err index 1a661c478..4ea56a92c 100644 --- a/src/tests/encore/match/missing.err +++ b/src/tests/encore/match/missing.err @@ -1 +1 @@ -*** Runtime error: No matching clause was found at "missing.enc" (line 3, column 5) *** +*** Runtime error: No matching clause was found at "missing.enc" (Line:3, Column:5) *** diff --git a/src/tests/encore/ui/errorHash.enc b/src/tests/encore/ui/errorHash.enc new file mode 100644 index 000000000..a71f8a6d8 --- /dev/null +++ b/src/tests/encore/ui/errorHash.enc @@ -0,0 +1,12 @@ + +active class Main + + def foo(i1 : int, i2 : int, i3 : int = 5.3) : unit + () + end + + def main() : unit + this.foo(10, 8) + end +end + diff --git a/src/tests/encore/ui/errorHash.fail b/src/tests/encore/ui/errorHash.fail new file mode 100644 index 000000000..92a323fde --- /dev/null +++ b/src/tests/encore/ui/errorHash.fail @@ -0,0 +1 @@ +Error\\[E0073\\]: diff --git a/src/tests/encore/ui/errorNoHash.enc b/src/tests/encore/ui/errorNoHash.enc new file mode 100644 index 000000000..6129a622d --- /dev/null +++ b/src/tests/encore/ui/errorNoHash.enc @@ -0,0 +1,17 @@ + + +active class Main + + def bar(x : int, num : int) : int + num*2 + + end + + def main(args : [String]) : unit + + var x = this.bar("i", + 2) + () + end +end + diff --git a/src/tests/encore/ui/errorNoHash.fail b/src/tests/encore/ui/errorNoHash.fail new file mode 100644 index 000000000..6c569e0e4 --- /dev/null +++ b/src/tests/encore/ui/errorNoHash.fail @@ -0,0 +1 @@ +Error: diff --git a/src/tests/encore/ui/multifullscopeError.enc b/src/tests/encore/ui/multifullscopeError.enc new file mode 100644 index 000000000..a71f8a6d8 --- /dev/null +++ b/src/tests/encore/ui/multifullscopeError.enc @@ -0,0 +1,12 @@ + +active class Main + + def foo(i1 : int, i2 : int, i3 : int = 5.3) : unit + () + end + + def main() : unit + this.foo(10, 8) + end +end + diff --git a/src/tests/encore/ui/multifullscopeError.fail b/src/tests/encore/ui/multifullscopeError.fail new file mode 100644 index 000000000..0d2877874 --- /dev/null +++ b/src/tests/encore/ui/multifullscopeError.fail @@ -0,0 +1,4 @@ +4 | / def foo(i1 : int, i2 : int, i3 : int = 5.3) : unit +5 | | () +6 | | end + | |______^ diff --git a/src/tests/encore/ui/multipartialscopeError.enc b/src/tests/encore/ui/multipartialscopeError.enc new file mode 100644 index 000000000..6129a622d --- /dev/null +++ b/src/tests/encore/ui/multipartialscopeError.enc @@ -0,0 +1,17 @@ + + +active class Main + + def bar(x : int, num : int) : int + num*2 + + end + + def main(args : [String]) : unit + + var x = this.bar("i", + 2) + () + end +end + diff --git a/src/tests/encore/ui/multipartialscopeError.fail b/src/tests/encore/ui/multipartialscopeError.fail new file mode 100644 index 000000000..2f4f3e89e --- /dev/null +++ b/src/tests/encore/ui/multipartialscopeError.fail @@ -0,0 +1,4 @@ +12 | var x = this.bar("i", + | ________________^ +13 | | 2) + | |__________________________^ diff --git a/src/tests/encore/ui/showPosition.enc b/src/tests/encore/ui/showPosition.enc new file mode 100644 index 000000000..014569468 --- /dev/null +++ b/src/tests/encore/ui/showPosition.enc @@ -0,0 +1,6 @@ +active class Main + def main(args : [String]) : unit + println("x = {}", (1+1) += 3) + end +end + diff --git a/src/tests/encore/ui/showPosition.fail b/src/tests/encore/ui/showPosition.fail new file mode 100644 index 000000000..afddc6fb9 --- /dev/null +++ b/src/tests/encore/ui/showPosition.fail @@ -0,0 +1 @@ + \\-\\-> \"showPosition.enc\" (Line:3, Column:33) diff --git a/src/tests/encore/ui/singleLineError.enc b/src/tests/encore/ui/singleLineError.enc new file mode 100644 index 000000000..014569468 --- /dev/null +++ b/src/tests/encore/ui/singleLineError.enc @@ -0,0 +1,6 @@ +active class Main + def main(args : [String]) : unit + println("x = {}", (1+1) += 3) + end +end + diff --git a/src/tests/encore/ui/singleLineError.fail b/src/tests/encore/ui/singleLineError.fail new file mode 100644 index 000000000..58ef79dc7 --- /dev/null +++ b/src/tests/encore/ui/singleLineError.fail @@ -0,0 +1,2 @@ +3 | println("x = {}", (1+1) += 3) + | ^^^ Can only be used on var or fields diff --git a/src/tests/encore/ui/warning.enc b/src/tests/encore/ui/warning.enc new file mode 100644 index 000000000..cd322ddad --- /dev/null +++ b/src/tests/encore/ui/warning.enc @@ -0,0 +1,9 @@ + +active class Main + + def foo(s : string) : unit + () + end + +end + diff --git a/src/tests/encore/ui/warning.fail b/src/tests/encore/ui/warning.fail new file mode 100644 index 000000000..8b28dbf82 --- /dev/null +++ b/src/tests/encore/ui/warning.fail @@ -0,0 +1,3 @@ +Warning: +4 | def foo(s : string) : unit + | ^^^^^^^^^^ diff --git a/src/types/Typechecker/Backtrace.hs b/src/types/Typechecker/Backtrace.hs new file mode 100644 index 000000000..0a9f3cce9 --- /dev/null +++ b/src/types/Typechecker/Backtrace.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-| + +The backtrace of the typechecker passes, used for tracking the +current position of the typechecker. + +-} + +module Typechecker.Backtrace(Backtrace + ,emptyBT + ,reduceBT + ,Pushable(push) + ,ExecutionContext(..) + ,currentContextFromBacktrace + ,validUseOfBreak + ,validUseOfContinue + ) where + +import Data.Maybe +import Data.List +import Text.PrettyPrint.Annotated + +import Identifiers +import AST.Meta(Position) +import AST.AST +import AST.PrettyPrinter +import Types + +data BacktraceNode = BTFunction Name Type + | BTTrait Type + | BTClass Type + | BTParam ParamDecl + | BTField FieldDecl + | BTMethod MethodDecl + | BTExpr Expr + | BTTypedef Type + | BTModule Name + | BTImport Namespace + deriving(Eq) + +isBTExpr :: BacktraceNode -> Bool +isBTExpr (BTExpr _) = True +isBTExpr _ = False + +instance Show BacktraceNode where + show (BTFunction n ty) = + concat ["In function '", show n, "' of type '", show ty, "'"] + show (BTClass ty) = concat ["In class '", show ty, "'"] + show (BTTrait ty) = concat ["In trait '", show ty, "'"] + show (BTParam p) = concat ["In parameter '", show (ppParamDecl p), "'"] + show (BTField f) = concat ["In field '", show (ppFieldDecl f), "'"] + show (BTMethod m) = + let name = hname $ mheader m + ty = htype $ mheader m + method | isStreamMethod m = "stream method" + | otherwise = "method" + in + concat ["In ", method, " '", show name, "' of type '", show ty, "'"] + show (BTExpr expr) + | (isNothing . getSugared) expr = "" + | otherwise = + let str = show $ nest 2 $ ppSugared expr + in "In expression: \n" ++ str + show (BTTypedef tl) = + concat ["In typedef '", show tl, "'"] + show (BTModule m) = + concat ["In declaration of module '", show m, "'"] + show (BTImport ns) = + concat ["In import of module '", show ns, "'"] + +type Backtrace = [(Position, BacktraceNode)] +emptyBT :: Backtrace +emptyBT = [] + +reduceBT :: Backtrace -> Backtrace +reduceBT = truncateExprs . dropMiniLets . mergeBlocks . nub + where + mergeBlocks ((pos1, BTExpr seq@Seq{}):(pos2, BTExpr e2):bt) = + if hasBody e2 + then mergeBlocks $ (pos2, BTExpr e2):bt + else (pos1, BTExpr seq) : mergeBlocks ((pos2, BTExpr e2) : bt) + mergeBlocks (node:bt) = node:mergeBlocks bt + mergeBlocks [] = [] + + dropMiniLets :: Backtrace -> Backtrace + dropMiniLets = filter (not . isMiniLetNode . snd) + isMiniLetNode node + | BTExpr e <- node + , Just MiniLet{} <- getSugared e = True + | otherwise = False + + truncateExprs ((pos1, BTExpr e1):(pos2, BTExpr e2):bt) = + (pos1, BTExpr e1):(pos2, BTExpr e2): + filter (not . isBTExpr . snd) bt + truncateExprs bt = bt + +data ExecutionContext = MethodContext MethodDecl + | ClosureContext (Maybe Type) + | FunctionContext Name Type + +currentContextFromBacktrace :: Backtrace -> ExecutionContext +currentContextFromBacktrace [] = error "TypeError.hs: No execution context" +currentContextFromBacktrace ((_, BTExpr Closure{mty}):_) = ClosureContext mty +currentContextFromBacktrace ((_, BTMethod m):_) = MethodContext m +currentContextFromBacktrace ((_, BTFunction f t):_) = FunctionContext f t +currentContextFromBacktrace (_:bt) = currentContextFromBacktrace bt + +validUseOfBreak :: Backtrace -> Bool +validUseOfBreak [] = False +validUseOfBreak ((_, BTExpr l@For{}):_) = True +validUseOfBreak ((_, BTExpr l@While{}):_) = True +validUseOfBreak ((_, BTExpr l@Repeat{}):_) = True +validUseOfBreak ((_, BTExpr c@Closure{}):_) = False +validUseOfBreak (_:bt) = validUseOfBreak bt + +validUseOfContinue :: Backtrace -> Bool +validUseOfContinue [] = False +validUseOfContinue ((_, BTExpr l@For{}):_) = False +validUseOfContinue ((_, BTExpr l@While{}):_) = True +validUseOfContinue ((_, BTExpr l@DoWhile{}):_) = True +validUseOfContinue ((_, BTExpr l@Repeat{}):_) = True +validUseOfContinue ((_, BTExpr c@Closure{}):_) = False +validUseOfContinue (_:bt) = validUseOfContinue bt + +-- | A type class for unifying the syntactic elements that can be pushed to the +-- backtrace stack. + +class Pushable a where + push :: a -> Backtrace -> Backtrace + pushMeta :: HasMeta a => a -> BacktraceNode -> Backtrace -> Backtrace + pushMeta m n bt = (getPos m, n) : bt + +instance Pushable Function where + push fun = + pushMeta fun (BTFunction (functionName fun) (functionType fun)) + +instance Pushable TraitDecl where + push t = pushMeta t (BTTrait (tname t)) + +instance Pushable ClassDecl where + push c = pushMeta c (BTClass (cname c)) + +instance Pushable FieldDecl where + push f = pushMeta f (BTField f) + +instance Pushable ParamDecl where + push p = pushMeta p (BTParam p) + +instance Pushable MethodDecl where + push m = pushMeta m (BTMethod m) + +instance Pushable Expr where + push expr = pushMeta expr (BTExpr expr) + +instance Pushable Typedef where + push t@(Typedef {typedefdef}) = pushMeta t (BTTypedef typedefdef) + +instance Pushable ModuleDecl where + push m@(Module{modname}) = pushMeta m (BTModule modname) + +instance Pushable ImportDecl where + push i@(Import{itarget}) = pushMeta i (BTImport itarget) diff --git a/src/types/Typechecker/Capturechecker.hs b/src/types/Typechecker/Capturechecker.hs index d2528cdb4..18dd7260b 100644 --- a/src/types/Typechecker/Capturechecker.hs +++ b/src/types/Typechecker/Capturechecker.hs @@ -26,6 +26,7 @@ import Types as Ty import Identifiers import Typechecker.Environment import Typechecker.TypeError +import Typechecker.Backtrace import Typechecker.Util import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map diff --git a/src/types/Typechecker/Environment.hs b/src/types/Typechecker/Environment.hs index 7994bec69..9375b8108 100644 --- a/src/types/Typechecker/Environment.hs +++ b/src/types/Typechecker/Environment.hs @@ -25,7 +25,7 @@ import Debug.Trace import Identifiers import AST.AST hiding(showWithKind) import Types -import Typechecker.TypeError +import Typechecker.Backtrace data LookupTable = LookupTable { sourceFile :: FilePath @@ -509,6 +509,27 @@ varLookup qname@QName{qnspace, qnlocal = x} } = Map.filterWithKey (\f _ -> f `elem` names) functionTable +visibleFunctions :: Environment -> [(Name, Type)] +visibleFunctions Env{locals, lookupTables} = + let + funcTable = extractTables filterFunctionTable lookupTables + -- Std only contains internal functions that are not ment to be operated by the user. + exposedTable = filter ((/= "Std") . show . fst) funcTable + localFunc = map (\(x,(_,z)) -> (x,z)) $ filter (isArrowType . snd . snd) locals + in + localFunc ++ concatMap (Map.assocs . snd) exposedTable + + where + filterFunctionTable LookupTable{functionTable + ,selectiveExports = Nothing + } = + functionTable + filterFunctionTable LookupTable{functionTable + ,selectiveExports = Just names + } = + Map.filterWithKey (\f _ -> f `elem` names) functionTable + + isLocal :: QualifiedName -> Environment -> Bool isLocal QName{qnspace = Nothing, qnlocal = x} Env{locals} = isJust $ lookup x locals diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs new file mode 100644 index 000000000..274129423 --- /dev/null +++ b/src/types/Typechecker/Errorprinter.hs @@ -0,0 +1,218 @@ + +module Typechecker.Errorprinter (printError, printWarning, noExplanation) where + + +-- Library dependencies +import Text.PrettyPrint.Annotated +import Text.PrettyPrint.Annotated.HughesPJ (renderDecoratedM) +import System.Console.ANSI +import Text.Printf (printf) +import Data.Ix(range) +import Data.Map.Strict (keys) +import Data.List.Utils (replace) +import Text.Megaparsec.Pos (defaultTabWidth, unPos) + +-- Module dependencies +import AST.Meta(Position, getPositionFile, getPositions) +import Identifiers +import Types +import Typechecker.Environment +import Typechecker.TypeError +import Typechecker.Util +import Typechecker.Suggestable +import Typechecker.ExplainTable +import System.IO + + + +printError :: TCError -> IO () +printError err@(TCError _ Env{bt = []}) = + renderTCType toErrorStyle $ prettyError err [] $+$ text "\n" +printError err@(TCError _ env) = do + code <- getCodeLines $ currentBTPos err + renderTCType toErrorStyle $ prettyError err code $+$ text "\n" + + +printWarning :: TCWarning -> IO () +printWarning w@(TCWarning _ Env{bt = []}) = + renderTCType toWarningStyle $ prettyWarning w [] $+$ text "\n" +printWarning w@(TCWarning _ env) = do + code <- getCodeLines $ currentBTPos w + renderTCType toWarningStyle $ prettyWarning w code $+$ text "\n" + + + +renderTCType :: (TCStyle -> IO ()) -> Doc TCStyle -> IO () +renderTCType colorStyle doc = do + istty <- hSupportsANSI stdout + if istty + then renderDecoratedM colorStyle endAnn textprinter endDoc doc + else printf $ render doc + + where + endAnn :: TCStyle -> IO () + endAnn _ = setSGR [Reset] + + textprinter :: String -> IO () + textprinter = printf + + endDoc :: IO () + endDoc = setSGR [Reset] + +toErrorStyle :: TCStyle -> IO () +toErrorStyle Classification = setSGR [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] +toErrorStyle Desc = setSGR [SetConsoleIntensity BoldIntensity] +toErrorStyle Logistic = setSGR [SetColor Foreground Vivid Blue] +toErrorStyle Highlight = setSGR [SetColor Foreground Dull Red] +toErrorStyle Code = return () + +toWarningStyle :: TCStyle -> IO () +toWarningStyle Classification = setSGR [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Yellow] +toWarningStyle Desc = setSGR [SetConsoleIntensity BoldIntensity] +toWarningStyle Logistic = setSGR [SetColor Foreground Vivid Blue] +toWarningStyle Highlight = setSGR [SetColor Foreground Dull Yellow] +toWarningStyle Code = return () + + + +-- As long as there is no way to either: +-- - Get the source code from all compiled files previous into Env +-- - Make prettyprinter.hs have the ability to include whitespace and parentheses +-- prettyError will need all lines of code it will print beforehand in its second argument + +prettyError :: TCError -> [String] -> Doc TCStyle +-- Do not show entire class if an unknown trait is declared +prettyError tcErr@(TCError err@(UnknownRefTypeError ty) _) _ + | isTraitType ty = declareError err <+> description err $+$ nest 2 (showPosition $ currentBTPos tcErr) + +-- Default errors +prettyError (TCError err Env{bt = []}) _ = + declareError err <+> description err +prettyError tcErr@(TCError err _) code = + declareError err <+> description err $+$ codeViewer tcErr code + +prettyWarning :: TCWarning -> [String] -> Doc TCStyle +-- Default warnings +prettyWarning (TCWarning w Env{bt = []}) _ = + declareWarning w <+> description w +prettyWarning tcWarn@(TCWarning w _) code = + declareWarning w <+> description w $+$ codeViewer tcWarn code + +declareError :: Error -> Doc TCStyle +declareError = formatDeclaration "[E%04d]" "Error" . explain + +declareWarning :: Warning -> Doc TCStyle +declareWarning = formatDeclaration "[W%04d]" "Warning" . explain + +-- Formats the declaration based on if there exists a explanation or not +formatDeclaration :: String -> String -> Maybe Int -> Doc TCStyle +formatDeclaration format msg explanation = styleClassify $ text msg <> hash <> char ':' + where hash = case explanation of + Nothing -> empty + Just num -> text $ printf format num + +description :: Show a => a -> Doc TCStyle +description ty = styleDesc $ text $ show ty + + +showPosition :: Position -> Doc TCStyle +showPosition pos = styleLogistic (text "-->") <+> (text $ show $ pos) + +codeViewer :: (TCType a, Suggestable a) => a -> [String] -> Doc TCStyle +codeViewer _ [] = error "TypeError.hs: No code to view" +codeViewer err (cHead:cTail) = + nest (digitLen) $ showPosition pos $+$ + styleLogistic pipe $+$ + showCodeHead + showTailCode <+> + styleHighlight (smallSuggest err) $+$ + longSuggest err + + where + pos = currentBTPos err + ((sL, sC), (eL, eC)) = getPositions pos + digitLen = 1 + (length $ show eL) -- One additional for the space between line-number and pipe + tailCode = zipWith (codeLine " |") cTail [(sL+1)..eL] + secondLineMergable + | not $ null cTail = let (secondLine:_) = cTail in emptyBeforePosition secondLine sC + | otherwise = False + + showCodeHead :: Doc TCStyle -> Doc TCStyle + showCodeHead tail + | sL == eL = + codeLine " " cHead sL $+$ + styleLogistic pipe <> + styleHighlight (singleLineHighlighter sC eC '^') <+> tail + | secondLineMergable = + codeLine " " cHead sL $+$ tail + | otherwise = + codeLine " " cHead sL $+$ + styleLogistic pipe <> + styleHighlight (multilineHighlighter sC FirstLine '^') $+$ tail + + showTailCode :: Doc TCStyle + showTailCode + | null tailCode = empty + | secondLineMergable = + codeLineWithFirstLineHighlight (head cTail) (sL+1) sC $+$ + vcat (tail tailCode) $+$ + styleLogistic pipe <> + styleHighlight (multilineHighlighter eC LastLine '^') + | otherwise = + vcat tailCode $+$ + styleLogistic pipe <> + styleHighlight (multilineHighlighter eC LastLine '^') + +emptyBeforePosition _ 0 = True +emptyBeforePosition (x:xs) n + | x == ' ' = emptyBeforePosition xs (n-1) + | otherwise = False + +singleLineHighlighter :: Int -> Int -> Char -> Doc ann +singleLineHighlighter s e c = space <+> text (replicate (s-1) ' ' ++ replicate (e-s) c) + +data MultiLineType = FirstLine | LastLine +multilineHighlighter :: Int -> MultiLineType -> Char -> Doc ann +multilineHighlighter col FirstLine c = space <> space <> text (replicate (col-1) '_') <> char c +multilineHighlighter col LastLine c = space <> pipe <> text (replicate (col-2) '_') <> char c + +codeLine ::String -> String -> Int -> Doc TCStyle +codeLine insertStr code lineNo = + let + pad = (length $ show lineNo) + 1 --One additional for the space between line-number and pipe + in + nest (-pad) $ + styleLogistic ((int lineNo) <+> pipe) <> + styleHighlight (text insertStr) <> + styleCode (text code) + +codeLineWithFirstLineHighlight code lineNo charbuff = + let + pad = (length $ show lineNo) + 1 --One additional for the space between line-number and pipe + in + nest (-pad) $ + styleLogistic ((int lineNo) <+> pipe) <> + styleHighlight (multilineHighlighter charbuff FirstLine '^') <> + styleCode (text $ drop charbuff code) + + +getCodeLines :: Position -> IO [String] +getCodeLines pos = do + let ((sL, _), (eL, _)) = getPositions pos + let start = sL-1 + let end = eL-start + contents <- readFile $ getPositionFile pos + case take end $ drop start $ lines contents of + [] -> error "\nFile has been edited between parsing and type checking" + l -> return $ map (replace "\t" spaces) l + where + -- Ugly workaround since the tab-width of MegaParsec and a users terminal can be inconsistent. + spaces = replicate (fromIntegral $ unPos defaultTabWidth) ' ' + +noExplanation :: String -> IO () +noExplanation errCode = + let + err = styleClassify $ text "error" + info = styleDesc $ text $ printf ": no extended information for %s\n" errCode + in + renderTCType toErrorStyle $ err <> info \ No newline at end of file diff --git a/src/types/Typechecker/ExplainTable.hs b/src/types/Typechecker/ExplainTable.hs new file mode 100644 index 000000000..004209237 --- /dev/null +++ b/src/types/Typechecker/ExplainTable.hs @@ -0,0 +1,181 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module Typechecker.ExplainTable (explain) where + +import Typechecker.TypeError (Error(..), Warning(..)) + + +class Explanainable a where + explain :: a -> Maybe Int + +instance Explanainable Error where + explain err = toKey err + +instance Explanainable Warning where + explain warn = toKeyW warn + + + + + +toKey :: Error -> Maybe Int +-- toKey (DistinctTypeParametersError _) = Just 1 +-- toKey (WrongNumberOfMethodArgumentsError _ _ _ _) = Just 2 +-- toKey (WrongNumberOfFunctionArgumentsError _ _ _) = Just 3 +-- toKey (WrongNumberOfFunctionTypeArgumentsError _ _ _) = Just 4 +-- toKey (WrongNumberOfTypeParametersError _ _ _ _) = Just 5 +-- toKey (MissingFieldRequirementError _ _) = Just 6 +-- toKey (CovarianceViolationError _ _ _) = Just 7 +-- toKey (RequiredFieldMismatchError _ _ _ _) = Just 8 +-- toKey (NonDisjointConjunctionError _ _ _) = Just 9 +-- toKey (OverriddenMethodTypeError _ _ _ _) = Just 10 +-- toKey (OverriddenMethodError _ _ _) = Just 11 +-- toKey (IncludedMethodConflictError _ _ _) = Just 12 +-- toKey (MissingMethodRequirementError _ _) = Just 13 +toKey (MissingMainClass) = Just 14 +-- toKey (SyncStreamCall) = Just 15 +-- toKey (UnknownTraitError _) = Just 16 +-- toKey (UnknownRefTypeError _) = Just 17 +-- toKey (MalformedCapabilityError _) = Just 18 +-- toKey (MalformedBoundError _) = Just 19 +-- toKey (RecursiveTypesynonymError _) = Just 20 +-- toKey (DuplicateThingError _ _) = Just 21 +-- toKey (PassiveStreamingMethodError) = Just 22 +-- toKey (PolymorphicConstructorError) = Just 23 +-- toKey (StreamingConstructorError) = Just 24 +-- toKey (MainMethodArgumentsError) = Just 25 +-- toKey (MainConstructorError) = Just 26 +-- toKey (FieldNotFoundError _ _) = Just 27 +-- toKey (MethodNotFoundError _ _) = Just 28 +-- toKey (BreakOutsideOfLoopError) = Just 29 +-- toKey (BreakUsedAsExpressionError) = Just 30 +-- toKey (ContinueOutsideOfLoopError) = Just 31 +-- toKey (ContinueUsedAsExpressionError) = Just 32 +-- toKey (NonCallableTargetError _) = Just 33 +-- toKey (NonSendableTargetError _) = Just 34 +-- toKey (MainMethodCallError) = Just 35 +-- toKey (ConstructorCallError) = Just 36 +-- toKey (ExpectingOtherTypeError _ _) = Just 37 +-- toKey (NonStreamingContextError _) = Just 38 +-- toKey (UnboundFunctionError _) = Just 39 +-- toKey (NonFunctionTypeError _) = Just 40 +-- toKey (BottomTypeInferenceError) = Just 41 +-- toKey (IfInferenceError) = Just 42 +-- toKey (IfBranchMismatchError _ _) = Just 43 +-- toKey (EmptyMatchClauseError) = Just 44 +-- toKey (ActiveMatchError) = Just 45 +-- toKey (MatchInferenceError) = Just 46 +-- toKey (ThisReassignmentError) = Just 47 +-- toKey (ImmutableVariableError _) = Just 48 +-- toKey (PatternArityMismatchError _ _ _) = Just 49 +-- toKey (PatternTypeMismatchError _ _) = Just 50 +-- toKey (NonMaybeExtractorPatternError _) = Just 51 +-- toKey (InvalidPatternError _) = Just 52 +-- toKey (InvalidTupleTargetError _ _ _) = Just 53 +-- toKey (InvalidTupleAccessError _ _) = Just 54 +-- toKey (CannotReadFieldError _) = Just 55 +-- toKey (NonAssignableLHSError) = Just 56 +-- toKey (ValFieldAssignmentError _ _) = Just 57 +-- toKey (UnboundVariableError _) = Just 58 +-- toKey (BuriedVariableError _) = Just 59 +-- toKey (ObjectCreationError _) = Just 60 +-- toKey (NonIterableError _) = Just 61 +-- toKey (EmptyArrayLiteralError) = Just 62 +-- toKey (NonIndexableError _) = Just 63 +-- toKey (NonSizeableError _) = Just 64 +-- toKey (FormatStringLiteralError) = Just 65 +-- toKey (UnprintableExpressionError _) = Just 66 +-- toKey (WrongNumberOfPrintArgumentsError _ _) = Just 67 +-- toKey (UnaryOperandMismatchError _ _) = Just 68 +-- toKey (BinaryOperandMismatchError _ _ _ _) = Just 69 +-- toKey (UndefinedBinaryOperatorError _) = Just 70 +-- toKey (NullTypeInferenceError) = Just 71 +-- toKey (CannotBeNullError _) = Just 72 +toKey (TypeMismatchError _ _) = Just 73 +-- toKey (TypeWithCapabilityMismatchError _ _ _) = Just 74 +-- toKey (TypeVariableAmbiguityError _ _ _) = Just 75 +-- toKey (FreeTypeVariableError _) = Just 76 +-- toKey (TypeVariableAndVariableCommonNameError _) = Just 77 +-- toKey (UnionMethodAmbiguityError _ _) = Just 78 +-- toKey (MalformedUnionTypeError _ _) = Just 79 +-- toKey (RequiredFieldMutabilityError _ _) = Just 80 +-- toKey (ProvidingTraitFootprintError _ _ _ _) = Just 81 +-- toKey (TypeArgumentInferenceError _ _) = Just 82 +-- toKey (AmbiguousTypeError _ _) = Just 83 +-- toKey (UnknownTypeUsageError _ _) = Just 84 +-- toKey (AmbiguousNameError _ _) = Just 85 +-- toKey (UnknownNamespaceError _) = Just 86 +-- toKey (UnknownNameError _ _) = Just 87 +-- toKey (ShadowedImportError _) = Just 88 +-- toKey (WrongModuleNameError _ _) = Just 89 +-- toKey (BadSyncCallError) = Just 90 +-- toKey (PrivateAccessModifierTargetError _) = Just 91 +-- toKey (ClosureReturnError) = Just 92 +-- toKey (ClosureForwardError) = Just 93 +-- toKey (MatchMethodNonMaybeReturnError) = Just 94 +-- toKey (MatchMethodNonEmptyParameterListError) = Just 95 +-- toKey (ImpureMatchMethodError _) = Just 96 +-- toKey (IdComparisonNotSupportedError _) = Just 97 +-- toKey (IdComparisonTypeMismatchError _ _) = Just 98 +-- toKey (ForwardInPassiveContext _) = Just 99 +-- toKey (ForwardInFunction) = Just 100 +-- toKey (ForwardTypeError _ _) = Just 101 +-- toKey (ForwardTypeClosError _ _) = Just 102 +-- toKey (CannotHaveModeError _) = Just 103 +-- toKey (ModelessError _) = Just 104 +-- toKey (ModeOverrideError _) = Just 105 +-- toKey (CannotConsumeError _) = Just 106 +-- toKey (CannotConsumeTypeError _) = Just 107 +-- toKey (ImmutableConsumeError _) = Just 108 +-- toKey (CannotGiveReadModeError _) = Just 109 +-- toKey (CannotGiveSharableModeError _) = Just 110 +-- toKey (NonValInReadContextError _) = Just 111 +-- toKey (NonSafeInReadContextError _ _) = Just 112 +-- toKey (NonSafeInExtendedReadTraitError _ _ _) = Just 113 +-- toKey (ProvidingToReadTraitError _ _ _) = Just 114 +-- toKey (SubordinateReturnError _ _) = Just 115 +-- toKey (SubordinateArgumentError _) = Just 116 +-- toKey (SubordinateFieldError _) = Just 117 +-- toKey (ThreadLocalFieldError _) = Just 118 +-- toKey (ThreadLocalFieldExtensionError _ _) = Just 119 +-- toKey (ThreadLocalArgumentError _) = Just 120 +-- toKey (PolymorphicArgumentSendError _ _) = Just 121 +-- toKey (PolymorphicReturnError _ _) = Just 122 +-- toKey (ThreadLocalReturnError _ _) = Just 123 +-- toKey (MalformedConjunctionError _ _ _) = Just 124 +-- toKey (CannotUnpackError _) = Just 125 +-- toKey (CannotInferUnpackingError _) = Just 126 +-- toKey (UnsplittableTypeError _) = Just 127 +-- toKey (DuplicatingSplitError _) = Just 128 +-- toKey (StackboundArrayTypeError _) = Just 129 +-- toKey (ManifestConflictError _ _) = Just 130 +-- toKey (ManifestClassConflictError _ _) = Just 131 +-- toKey (UnmodedMethodExtensionError _ _) = Just 132 +-- toKey (ActiveTraitError _ _) = Just 133 +-- toKey (NewWithModeError) = Just 134 +-- toKey (UnsafeTypeArgumentError _ _) = Just 135 +-- toKey (OverlapWithBuiltins) = Just 136 +-- toKey (SimpleError _) = Just 137 +-- toKey (ReverseBorrowingError) = Just 138 +-- toKey (BorrowedFieldError _) = Just 139 +-- toKey (LinearClosureError _ _) = Just 140 +-- toKey (BorrowedLeakError _) = Just 141 +-- toKey (NonBorrowableError _) = Just 142 +-- toKey (ActiveBorrowError _ _) = Just 143 +-- toKey (ActiveBorrowSendError _ _) = Just 144 +-- toKey (DuplicateBorrowError _) = Just 145 +-- toKey (StackboundednessMismatchError _ _) = Just 146 +-- toKey (LinearCaptureError _ _) = Just 147 +toKey _ = Nothing + +toKeyW :: Warning -> Maybe Int +-- toKeyW (StringDeprecatedWarning) = Just 1 +-- toKeyW (StringIdentityWarning) = Just 2 +-- toKeyW (PolymorphicIdentityWarning) = Just 3 +-- toKeyW (ShadowedMethodWarning _) = Just 4 +-- toKeyW (ExpressionResultIgnoredWarning _) = Just 5 +-- toKeyW (ArrayTypeArgumentWarning) = Just 6 +-- toKeyW (ArrayInReadContextWarning) = Just 7 +-- toKeyW (SharedArrayWarning) = Just 8 +-- toKeyW (CapabilitySplitWarning) = Just 9 +toKeyW _ = Nothing \ No newline at end of file diff --git a/src/types/Typechecker/Prechecker.hs b/src/types/Typechecker/Prechecker.hs index 8aef5516d..d21220d40 100644 --- a/src/types/Typechecker/Prechecker.hs +++ b/src/types/Typechecker/Prechecker.hs @@ -31,6 +31,7 @@ import Identifiers import Types import Typechecker.Environment import Typechecker.TypeError +import Typechecker.Backtrace import Typechecker.Util -- | The top-level type checking function diff --git a/src/types/Typechecker/Suggestable.hs b/src/types/Typechecker/Suggestable.hs new file mode 100644 index 000000000..b18556d18 --- /dev/null +++ b/src/types/Typechecker/Suggestable.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Typechecker.Suggestable ( + Suggestable + ,smallSuggest + ,longSuggest + ,pipe -- from AST.PrettyPrinter + )where + +-- Library dependencies +import Text.PrettyPrint.Annotated +import Text.Printf (printf) +import Data.Maybe + +-- Module dependencies +import AST.AST +import AST.PrettyPrinter hiding (indent) +import Typechecker.TypeError +import Typechecker.Environment +import Typechecker.Util +import Identifiers +import Types + + +makeNotation :: Doc TCStyle +makeNotation = styleLogistic (pipe $+$ equals) <+> styleDesc (text "note:") + +-- How to determine if to use a smallSuggest or longSuggest: +-- If a problem justifies it, you could use both, +-- they are made so that from none to both are able to be used at the same time. +-- +-- a smallSuggest are inlined with the highlighting of an error, +-- therefore it is good practice for the text to be fairly short, +-- about 32 characters seem to be a good maximum to strive for. +-- If more are needed, use longSuggest instead. +class Suggestable a where + smallSuggest :: a -> Doc ann + longSuggest :: a -> Doc TCStyle + +instance Suggestable TCError where + smallSuggest (TCError (NonAssignableLHSError) _) = "Can only be used on var or fields" + smallSuggest (TCError (MethodNotFoundError name ty) env) + | isMethodNameAFunction name ty env = text $ printf "Did you mean function `%s`?" (show name) + smallSuggest _ = empty + + + + longSuggest (TCError (TypeMismatchError actual expected) _) = + makeNotation <+> vcat [expect expected, found actual] + where + expect e = text "expected type" <+> styleDesc (text $ show e) + found a = text " found type" <+> styleDesc (text $ show a) + + longSuggest (TCError (WrongNumberOfMethodArgumentsError name targetType _ _) env) = + let + header = snd . fromJust $ findMethodWithEnvironment name targetType env + types = hparams header + in + makeNotation <+> hang ("Method" <+> quotes (text $ show name) <+> "is declared:") 0 + (styleDesc (ppFunctionHeader header)) + + longSuggest (TCError (BinaryOperandMismatchError _ _ lType rType) _) = + let + left = text " Left type: " <+> styleDesc (text $ show lType) + right = text "Right type: " <+> styleDesc (text $ show rType) + in + makeNotation <+> vcat [left, right] + + longSuggest _ = empty + + +instance Suggestable TCWarning where + smallSuggest _ = empty + longSuggest _ = empty + + + +isMethodNameAFunction name ty env = + let (_, functions) = getFunctionNames ty env + in elem name functions + + diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 5431bfb99..44a8f844c 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -3,24 +3,26 @@ {-| The machinery used by "Typechecker.Typechecker" and -"Typechecker.Capturechecker" for handling errors and backtracing. +"Typechecker.Capturechecker" for handling and showing errors. -} -module Typechecker.TypeError (Backtrace - ,emptyBT - ,Pushable(push) +module Typechecker.TypeError ( + TCType + ,currentBTPos ,TCError(TCError) ,Error(..) ,TCWarning(TCWarning) ,Warning(..) - ,ExecutionContext(..) - ,currentContextFromBacktrace - ,validUseOfBreak - ,validUseOfContinue + ,TCStyle(..) + ,styleClassify + ,styleDesc + ,styleLogistic + ,styleHighlight + ,styleCode ) where -import Text.PrettyPrint +import Text.PrettyPrint.Annotated.HughesPJ import Data.Maybe import Data.List import Data.Char @@ -28,144 +30,15 @@ import Text.Printf (printf) import Identifiers import Types +import Typechecker.Environment +import Typechecker.Backtrace import AST.AST hiding (showWithKind) -import AST.PrettyPrinter -import AST.Meta(Position) +import AST.PrettyPrinter hiding (indent) +import qualified System.Console.ANSI as A +import AST.Meta(Position, getPositionFile, getPositions) +import Data.Ix(range) +import Control.Monad(zipWithM_) -data BacktraceNode = BTFunction Name Type - | BTTrait Type - | BTClass Type - | BTParam ParamDecl - | BTField FieldDecl - | BTMethod MethodDecl - | BTExpr Expr - | BTTypedef Type - | BTModule Name - | BTImport Namespace - deriving(Eq) - -isBTExpr :: BacktraceNode -> Bool -isBTExpr (BTExpr _) = True -isBTExpr _ = False - -instance Show BacktraceNode where - show (BTFunction n ty) = - concat ["In function '", show n, "' of type '", show ty, "'"] - show (BTClass ty) = concat ["In class '", show ty, "'"] - show (BTTrait ty) = concat ["In trait '", show ty, "'"] - show (BTParam p) = concat ["In parameter '", show (ppParamDecl p), "'"] - show (BTField f) = concat ["In field '", show (ppFieldDecl f), "'"] - show (BTMethod m) = - let name = hname $ mheader m - ty = htype $ mheader m - method | isStreamMethod m = "stream method" - | otherwise = "method" - in - concat ["In ", method, " '", show name, "' of type '", show ty, "'"] - show (BTExpr expr) - | (isNothing . getSugared) expr = "" - | otherwise = - let str = show $ nest 2 $ ppSugared expr - in "In expression: \n" ++ str - show (BTTypedef tl) = - concat ["In typedef '", show tl, "'"] - show (BTModule m) = - concat ["In declaration of module '", show m, "'"] - show (BTImport ns) = - concat ["In import of module '", show ns, "'"] - -type Backtrace = [(Position, BacktraceNode)] -emptyBT :: Backtrace -emptyBT = [] - -reduceBT :: Backtrace -> Backtrace -reduceBT = truncateExprs . dropMiniLets . mergeBlocks . nub - where - mergeBlocks ((pos1, BTExpr seq@Seq{}):(pos2, BTExpr e2):bt) = - if hasBody e2 - then mergeBlocks $ (pos2, BTExpr e2):bt - else (pos1, BTExpr seq) : mergeBlocks ((pos2, BTExpr e2) : bt) - mergeBlocks (node:bt) = node:mergeBlocks bt - mergeBlocks [] = [] - - dropMiniLets :: Backtrace -> Backtrace - dropMiniLets = filter (not . isMiniLetNode . snd) - isMiniLetNode node - | BTExpr e <- node - , Just MiniLet{} <- getSugared e = True - | otherwise = False - - truncateExprs ((pos1, BTExpr e1):(pos2, BTExpr e2):bt) = - (pos1, BTExpr e1):(pos2, BTExpr e2): - filter (not . isBTExpr . snd) bt - truncateExprs bt = bt - -data ExecutionContext = MethodContext MethodDecl - | ClosureContext (Maybe Type) - | FunctionContext Name Type - -currentContextFromBacktrace :: Backtrace -> ExecutionContext -currentContextFromBacktrace [] = error "TypeError.hs: No execution context" -currentContextFromBacktrace ((_, BTExpr Closure{mty}):_) = ClosureContext mty -currentContextFromBacktrace ((_, BTMethod m):_) = MethodContext m -currentContextFromBacktrace ((_, BTFunction f t):_) = FunctionContext f t -currentContextFromBacktrace (_:bt) = currentContextFromBacktrace bt - -validUseOfBreak :: Backtrace -> Bool -validUseOfBreak [] = False -validUseOfBreak ((_, BTExpr l@For{}):_) = True -validUseOfBreak ((_, BTExpr l@While{}):_) = True -validUseOfBreak ((_, BTExpr l@Repeat{}):_) = True -validUseOfBreak ((_, BTExpr c@Closure{}):_) = False -validUseOfBreak (_:bt) = validUseOfBreak bt - -validUseOfContinue :: Backtrace -> Bool -validUseOfContinue [] = False -validUseOfContinue ((_, BTExpr l@For{}):_) = False -validUseOfContinue ((_, BTExpr l@While{}):_) = True -validUseOfContinue ((_, BTExpr l@DoWhile{}):_) = True -validUseOfContinue ((_, BTExpr l@Repeat{}):_) = True -validUseOfContinue ((_, BTExpr c@Closure{}):_) = False -validUseOfContinue (_:bt) = validUseOfContinue bt - --- | A type class for unifying the syntactic elements that can be pushed to the --- backtrace stack. - -class Pushable a where - push :: a -> Backtrace -> Backtrace - pushMeta :: HasMeta a => a -> BacktraceNode -> Backtrace -> Backtrace - pushMeta m n bt = (getPos m, n) : bt - -instance Pushable Function where - push fun = - pushMeta fun (BTFunction (functionName fun) (functionType fun)) - -instance Pushable TraitDecl where - push t = pushMeta t (BTTrait (tname t)) - -instance Pushable ClassDecl where - push c = pushMeta c (BTClass (cname c)) - -instance Pushable FieldDecl where - push f = pushMeta f (BTField f) - -instance Pushable ParamDecl where - push p = pushMeta p (BTParam p) - -instance Pushable MethodDecl where - push m = pushMeta m (BTMethod m) - -instance Pushable Expr where - push expr = pushMeta expr (BTExpr expr) - -instance Pushable Typedef where - push t@(Typedef {typedefdef}) = pushMeta t (BTTypedef typedefdef) - -instance Pushable ModuleDecl where - push m@(Module{modname}) = pushMeta m (BTModule modname) - -instance Pushable ImportDecl where - push i@(Import{itarget}) = pushMeta i (BTImport itarget) refTypeName :: Type -> String refTypeName ty @@ -183,23 +56,16 @@ refTypeName ty | otherwise = error $ "TypeError.hs: No refTypeName for " ++ showWithKind ty +class TCType a where + currentBTPos :: TCType a => a -> Position + -- | The data type for a type checking error. Showing it will -- produce an error message and print the backtrace. -data TCError = TCError Error Backtrace -instance Show TCError where - show (TCError err []) = - " *** Error during typechecking *** \n" ++ - show err ++ "\n" - show (TCError err bt@((pos, _):_)) = - " *** Error during typechecking *** \n" ++ - show pos ++ "\n" ++ - show err ++ "\n" ++ - concatMap showBT (reduceBT bt) - where - showBT (_, node) = - case show node of - "" -> "" - s -> s ++ "\n" +data TCError = TCError Error Environment + +instance TCType TCError where + currentBTPos (TCError _ Env{bt = ((pos, _):_)}) = pos + data Error = DistinctTypeParametersError Type @@ -359,8 +225,8 @@ data Error = arguments 1 = "argument" arguments _ = "arguments" -typeParameters 1 = "type parameter" -typeParameters _ = "type parameters" +typeParams 1 = "type parameter" +typeParams _ = "type parameters" enumerateSafeTypes = "Safe types are primitives and types with read, active or local mode." @@ -381,7 +247,7 @@ instance Show Error where (show name) expected (arguments expected) actual show (WrongNumberOfFunctionTypeArgumentsError name expected actual) = printf "Function %s expects %d %s. Got %d" - (show name) expected (typeParameters expected) actual + (show name) expected (typeParams expected) actual show (WrongNumberOfTypeParametersError ty1 n1 ty2 n2) = printf "'%s' expects %d type %s, but '%s' has %d" (showWithoutMode ty1) n1 (arguments n1) (showWithoutMode ty2) n2 @@ -582,7 +448,7 @@ instance Show Error where printf "Cannot read field of expression '%s' of %s" (show $ ppSugared target) (showWithKind targetType) show NonAssignableLHSError = - "Left-hand side cannot be assigned to" + "Left-hand side of operand is not assignable" show (ValFieldAssignmentError name targetType) = printf "Cannot assign to val-field '%s' in %s" (show name) (refTypeName targetType) @@ -613,11 +479,9 @@ instance Show Error where show (UnaryOperandMismatchError op ty) = printf "Operator '%s' is not defined for values of type '%s'" (show op) (show ty) - show (BinaryOperandMismatchError op kind lType rType) = - printf ("Operator '%s' is only defined for %s types\n" ++ - " Left type: %s\n" ++ - " Right type: %s") - (show op) kind (show lType) (show rType) + show (BinaryOperandMismatchError op kind _ _) = + printf ("Operator '%s' is only defined for %s types") + (show op) kind show (UndefinedBinaryOperatorError op) = printf "Undefined binary operator '%s'" (show op) show NullTypeInferenceError = @@ -959,16 +823,13 @@ instance Show Error where in toLower c:s show (LinearCaptureError e ty) = printf "Cannot capture expression '%s' of linear type '%s'" - (show (ppSugared e)) (show ty) + (show (ppSugared e)) (show ty) + +data TCWarning = TCWarning Warning Environment + +instance TCType TCWarning where + currentBTPos (TCWarning _ Env{bt = ((pos, _):_)}) = pos -data TCWarning = TCWarning Backtrace Warning -instance Show TCWarning where - show (TCWarning [] w) = - "Warning:\n" ++ - show w - show (TCWarning ((pos, _):_) w) = - "Warning at " ++ show pos ++ ":\n" ++ - show w data Warning = StringDeprecatedWarning | StringIdentityWarning @@ -1012,3 +873,14 @@ instance Show Warning where show (ShadowingADTCaseWarning name) = "Variable '" ++ show name ++ "' shadows ADT case of same name. " ++ "You most likely want to write '" ++ show name ++ "()'." + + + +data TCStyle = Classification | Desc | Logistic | Highlight | Code + +styleClassify, styleDesc, styleLogistic, styleHighlight, styleCode :: Doc TCStyle -> Doc TCStyle +styleClassify = annotate Classification +styleDesc = annotate Desc +styleLogistic = annotate Logistic +styleHighlight = annotate Highlight +styleCode = annotate Code \ No newline at end of file diff --git a/src/types/Typechecker/Typechecker.hs b/src/types/Typechecker/Typechecker.hs index 0e78b63fb..2930bd630 100644 --- a/src/types/Typechecker/Typechecker.hs +++ b/src/types/Typechecker/Typechecker.hs @@ -32,9 +32,9 @@ import AST.Util(extend) import Types as Ty import Typechecker.Environment import Typechecker.TypeError +import Typechecker.Backtrace import Typechecker.Util import Text.Printf (printf) -import Debug.Trace -- | The top-level type checking function typecheckProgram :: Map FilePath LookupTable -> Program -> @@ -50,8 +50,8 @@ checkForMainClass source Program{classes} = Just Class{cname,cmethods} -> if any (isMainMethod cname . methodName) cmethods then Nothing - else Just $ TCError (MethodNotFoundError (Name "main") cname) [] - Nothing -> Just $ TCError MissingMainClass [] + else Just $ TCError (MethodNotFoundError (Name "main") cname) emptyEnv + Nothing -> Just $ TCError MissingMainClass emptyEnv where isLocalMain source c@Class{cname} = isMainClass c && @@ -412,10 +412,10 @@ checkOverriding cname typeParameters methods extendedTraits = do OverriddenMethodTypeError (methodName method) expectedMethodType requirer actualMethodType typecheckWithTrait `catchError` - \(TCError e bt) -> + \(TCError e env) -> throwError $ TCError (OverriddenMethodError - (methodName method) requirer e) bt + (methodName method) requirer e) env where addAbstractTrait = withAbstractTrait abstractDecl @@ -1301,12 +1301,12 @@ instance Checkable Expr where where handleBurying :: Expr -> TCError -> TypecheckM Expr handleBurying VarAccess{qname} - (TCError err@(UnboundVariableError unbound) bt) = + (TCError err@(UnboundVariableError unbound) env) = if unbound == qname - then throwError $ TCError (BuriedVariableError qname) bt - else throwError $ TCError err bt - handleBurying _ (TCError err bt) = - throwError $ TCError err bt + then throwError $ TCError (BuriedVariableError qname) env + else throwError $ TCError err env + handleBurying _ (TCError err env) = + throwError $ TCError err env -- E |- cond : bool -- E |- body : t @@ -1513,14 +1513,14 @@ instance Checkable Expr where unless varIsMutable $ if varIsLocal then tcError $ ImmutableVariableError qname - else pushError eLhs NonAssignableLHSError + else pushError assign NonAssignableLHSError eRhs <- hasType rhs (AST.getType eLhs) return $ setType unitType assign {lhs = eLhs, rhs = eRhs} doTypecheck assign@(Assign {lhs, rhs}) = do eLhs <- typecheck lhs unless (isLval eLhs) $ - pushError eLhs NonAssignableLHSError + pushError assign NonAssignableLHSError context <- asks currentExecutionContext case context of MethodContext mtd -> diff --git a/src/types/Typechecker/Util.hs b/src/types/Typechecker/Util.hs index 40bd1a684..77c3b3052 100644 --- a/src/types/Typechecker/Util.hs +++ b/src/types/Typechecker/Util.hs @@ -47,6 +47,8 @@ module Typechecker.Util(TypecheckM ,isSharableType ,checkConjunction ,includesMarkerTrait + ,getFunctionNames + ,findMethodWithEnvironment ) where import Identifiers @@ -63,7 +65,9 @@ import Control.Monad.State -- Module dependencies import Typechecker.TypeError +import Typechecker.Backtrace import Typechecker.Environment +import AST.Meta (Meta) -- Monadic versions of common functions anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool @@ -110,20 +114,20 @@ type TypecheckM a = -- | Convenience function for throwing an exception with the -- current backtrace tcError err = - do bt <- asks backtrace - throwError $ TCError err bt + do env <- ask + throwError $ TCError err env -- | Push the expression @expr@ and throw error err pushError expr err = local (pushBT expr) $ tcError err tcWarning wrn = - do bt <- asks backtrace - modify (TCWarning bt wrn:) + do env <- ask + modify (TCWarning wrn env:) pushWarning expr wrn = local (pushBT expr) $ tcWarning wrn -checkValidUseOfBreak = Typechecker.TypeError.validUseOfBreak . bt -checkValidUseOfContinue = Typechecker.TypeError.validUseOfContinue . bt +checkValidUseOfBreak = validUseOfBreak . bt +checkValidUseOfContinue = validUseOfContinue . bt -- | @matchTypeParameterLength ty1 ty2@ ensures that the type parameter -- lists of its arguments have the same length. @@ -536,6 +540,59 @@ findField ty f = do findMethod :: Type -> Name -> TypecheckM FunctionHeader findMethod ty = liftM fst . findMethodWithCalledType ty +getClassDecl :: Type -> Environment -> ClassDecl +getClassDecl ty env + | isClassType ty = + case classLookup ty env of + Just [cls] -> cls + Just l -> + error $ "Util.hs: Class " ++ show ty ++ " is ambiguous." + Nothing -> + error $ "Util.hs: Class " ++ show ty ++ " is unresolved." + | otherwise = + error $ "Util.hs: Trying to get class declaration of " ++ + Ty.showWithKind ty + +getTraitDecl :: Type -> Environment -> TraitDecl +getTraitDecl ty env + | isTraitType ty = + case traitLookup ty env of + Just [trts] -> trts + Just l -> + error $ "Util.hs: Trait " ++ show ty ++ " is ambiguous." + Nothing -> + error $ "Util.hs: Trait " ++ show ty ++ " is unresolved." + | otherwise = + error $ "Util.hs: Trying to get trait declaration of " ++ + Ty.showWithKind ty + +getMethods :: Type -> Environment -> [(Meta MethodDecl, FunctionHeader)] +getMethods ty env + | isClassType ty = traitTy ++ (map (\x -> (mmeta x, mheader x)) $ cmethods $ getClassDecl ty env) + | isTraitType ty = map (\x -> (mmeta x, mheader x)) $ tmethods $ getTraitDecl ty env + | otherwise = + error $ "Util.hs: Trying to get methods of " ++ + Ty.showWithKind ty + where + traitTy = concatMap (\ty -> getMethods ty env) $ typesFromTraitComposition $ ccomposition $ getClassDecl ty env + +-- Returns a tuple with all method names and all function names visible +getFunctionNames :: Type -> Environment -> ([Name], [Name]) +getFunctionNames ty env = + let + methods = map (hname . snd) $ getMethods ty env + cleanMethods = Prelude.filter (not . (`elem` ["await", "suspend", "main", "init"]) . show) methods + functions = map (fst) $ visibleFunctions env + in + (cleanMethods, functions) + +findMethodWithEnvironment :: Name -> Type -> Environment -> Maybe (Meta MethodDecl, FunctionHeader) +findMethodWithEnvironment name ty env = + let + methods = getMethods ty env + in + find (\(_, h) -> name == (hname h)) methods + findMethodWithCalledType :: Type -> Name -> TypecheckM (FunctionHeader, Type) findMethodWithCalledType ty name | isUnionType ty = do