From abd0f35fff57b65cb68eb3630f0a57d9756ef687 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Fri, 25 May 2018 13:43:20 +0200 Subject: [PATCH 01/31] Basic implementation of new error-printer - Only shows the new error on NonAssignableLHSError - Only displays the first line of the errored code, if the expression/etc is segmented on multiple lines it will for now not show the entire part --- encore.cabal | 1 + src/front/TopLevel.hs | 10 ++- src/ir/AST/Meta.hs | 39 +++++++++ src/types/Typechecker/TypeError.hs | 114 ++++++++++++++++++++++++++- src/types/Typechecker/Typechecker.hs | 4 +- stack.yaml | 1 + 6 files changed, 163 insertions(+), 6 deletions(-) diff --git a/encore.cabal b/encore.cabal index 98c2bf4b4..34604f35d 100644 --- a/encore.cabal +++ b/encore.cabal @@ -47,6 +47,7 @@ executable encorec , unordered-containers , boxes , filepath + , ansi-terminal hs-source-dirs: src/back src/front src/ir src/opt src/parser src/types ghc-options: -Werror default-language: Haskell2010 diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index c7a3d9971..2a20c8cbb 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -41,6 +41,7 @@ import ModuleExpander import Typechecker.Environment(buildLookupTable) import Typechecker.Prechecker(precheckProgram) import Typechecker.Typechecker(typecheckProgram, checkForMainClass) +import Typechecker.TypeError(ioShow) import Typechecker.Capturechecker(capturecheckProgram) import Optimizer.Optimizer import CodeGen.Main @@ -387,10 +388,17 @@ main = (Right (newEnv, ast), warnings) -> return (ast, warnings) (Left error, warnings) -> do showWarnings warnings - abort $ show error + printf "*** Error during typechecking *** \n\n" + ioShow [error] + let errorlen = length [error] + abort $ "\nAborting due to " ++ show errorlen ++ errors errorlen + --abort $ show error showWarnings typecheckingWarnings return typecheckedAST + errors 1 = " error" + errors _ = " errors" + capturecheckProgramTable :: ProgramTable -> IO ProgramTable capturecheckProgramTable table = do let lookupTableTable = fmap buildLookupTable table diff --git a/src/ir/AST/Meta.hs b/src/ir/AST/Meta.hs index 13e48fe90..acd302cf5 100644 --- a/src/ir/AST/Meta.hs +++ b/src/ir/AST/Meta.hs @@ -24,6 +24,17 @@ instance Show Position where -- TODO: If we ever want to print ranges, this should be updated show = showSourcePos . startPos +instance Ord Position where + p1 `compare` p2 = + let + start1 = getStartPos p1 + start2 = getStartPos p2 + compFile = (sourceName start1) `compare` (sourceName start2) + compLine = unPos (sourceLine start1) `compare` unPos (sourceLine start2) + in + compFile `mappend` compLine + --start1 `compare` start2 + newPos :: SourcePos -> Position newPos = SingletonPos @@ -56,12 +67,40 @@ showSourcePos pos = file = sourceName pos in printf "%s (line %d, column %d)" (show file) line col +showRangePosition :: Position -> String +showRangePosition pos = + case pos of + SingletonPos start -> showSourcePos start + RangePos start end -> getposFile pos ++ " (" ++ (show $ getposLine start) ++ ":" ++ (show $ getposCol start) ++ + " -> " ++ (show $ getposLine end) ++ ":" ++ (show $ getposCol end) ++ ")" + + showPos :: Meta a -> String showPos = showSourcePos . startPos . position getPos :: Meta a -> Position getPos = position +getStartPos :: Position -> SourcePos +getStartPos = startPos + +getPosColumns :: Position -> (Int, Int) +getPosColumns pos = + case pos of + SingletonPos start -> (column start, (column start)+1) + RangePos start end -> (column start, column end) + where + column p = fromIntegral $ unPos (sourceColumn p) + +getposFile :: Position -> String +getposFile pos = sourceName $ getStartPos pos + +getposLine :: SourcePos -> Int +getposLine pos = fromIntegral $ unPos $ sourceLine pos + +getposCol :: SourcePos -> Int +getposCol pos = fromIntegral $ unPos $ sourceColumn pos + setType :: Type -> Meta a -> Meta a setType newType m = m {metaType = Just newType} diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 0798ee865..ad2e4a710 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -18,6 +18,7 @@ module Typechecker.TypeError (Backtrace ,currentContextFromBacktrace ,validUseOfBreak ,validUseOfContinue + ,ioShow ) where import Text.PrettyPrint @@ -30,7 +31,8 @@ import Identifiers import Types import AST.AST hiding (showWithKind) import AST.PrettyPrinter -import AST.Meta(Position) +import System.Console.ANSI +import AST.Meta(Position, showRangePosition, getStartPos, getPosColumns, getposFile, getposLine) data BacktraceNode = BTFunction Name Type | BTTrait Type @@ -100,6 +102,30 @@ reduceBT = truncateExprs . dropMiniLets . mergeBlocks . nub filter (not . isBTExpr . snd) bt truncateExprs bt = bt +reduceBTToLine :: Backtrace -> Backtrace +reduceBTToLine = filterLine . 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 + + filterLine ((pos1, BTExpr e1):(pos2, node2):bt) + | pos1 <= pos2 = filterLine ((pos2, node2):bt) + | otherwise = [(pos1, BTExpr e1)] + filterLine bt = bt + --filterLine ((pos2, BTExpr e2):_) = [(pos2, BTExpr e2)] + + data ExecutionContext = MethodContext MethodDecl | ClosureContext (Maybe Type) | FunctionContext Name Type @@ -188,7 +214,7 @@ instance Show TCError where show err ++ "\n" show (TCError err bt@((pos, _):_)) = " *** Error during typechecking *** \n" ++ - show pos ++ "\n" ++ + showRangePosition pos ++ "\n" ++ show err ++ "\n" ++ concatMap showBT (reduceBT bt) where @@ -197,6 +223,83 @@ instance Show TCError where "" -> "" s -> s ++ "\n" + +ioShow :: [TCError] -> IO () +ioShow [] = return () +ioShow ((TCError err@NonAssignableLHSError bt@((pos, _):_)) :xs) = do + + printError err +-- setSGR [ SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] +-- printf "Error: " + printErrorDescription err +-- setSGR [SetColor Foreground Vivid White] +-- printf $ show err ++ "\n" + printPosition pos +-- setSGR [ SetConsoleIntensity NormalIntensity, SetColor Foreground Vivid Blue] +-- printf " --> " +-- setSGR [Reset] +-- printf $ showRangePosition pos + + printCodeViewer pos "Insert good suggestion here" +-- setSGR [SetColor Foreground Vivid Blue] +-- printf "\n|\n|" +-- setSGR [Reset] +-- printFileLine (getposFile pos) (getposLine $ getStartPos pos) +-- setSGR [SetColor Foreground Vivid Blue] +-- printf "\n|" +-- setSGR [SetColor Foreground Dull Red] +-- printf $ errorIndicator startCol endCol +-- setSGR [Reset] + ioShow xs + + where + + printError _ = do + setSGR [ SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] + printf "Error: " + setSGR [Reset] + + printErrorDescription err = do + setSGR [SetColor Foreground Vivid White] + printf $ show err ++ "\n" + setSGR [Reset] + + printPosition pos = do + setSGR [ SetConsoleIntensity NormalIntensity, SetColor Foreground Vivid Blue] + printf " --> " + setSGR [Reset] + printf $ showRangePosition pos + + printCodeViewer pos smallSuggestion = do + let startLine = getposLine $ getStartPos pos + let digits = fromIntegral $ round $ logBase 10 (fromIntegral startLine) + let (startCol, endCol) = getPosColumns pos + setSGR [SetColor Foreground Vivid Blue] + printf $ "\n" ++ replicate digits ' ' ++ " |\n" ++ show startLine ++ " |" + + setSGR [Reset] + printFileLine (getposFile pos) (getposLine $ getStartPos pos) + setSGR [SetColor Foreground Vivid Blue] + printf $ "\n" ++ replicate digits ' ' ++ " |" + + setSGR [SetColor Foreground Dull Red] + printf $ errorIndicator startCol endCol + printf $ ' ' : smallSuggestion ++ "\n\n" + setSGR [Reset] + + + errorIndicator :: Int -> Int -> [Char] + errorIndicator s e = "" ++ replicate (s-1) ' ' ++ replicate (e-s) '^' + +ioShow err = printf $ show err + +printFileLine :: String -> Int -> IO () +printFileLine file line = do + contents <- readFile file + case drop (line-1) $ lines contents of + [] -> error "File has been edited between parsing and type checking" + l:_ -> printf l + data Error = DistinctTypeParametersError Type | WrongNumberOfMethodArgumentsError Name Type Int Int @@ -568,7 +671,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) @@ -994,3 +1097,8 @@ instance Show Warning where show CapabilitySplitWarning = "Unpacking linear capabilities is not fully supported and may be unsafe. " ++ "This will be fixed in a later version of Encore." + + + --hash (UnionMethodAmbiguityError _ _) = 3 + + --explain 3 = "stuff" \ No newline at end of file diff --git a/src/types/Typechecker/Typechecker.hs b/src/types/Typechecker/Typechecker.hs index c281f72d6..80c18a260 100644 --- a/src/types/Typechecker/Typechecker.hs +++ b/src/types/Typechecker/Typechecker.hs @@ -1461,14 +1461,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/stack.yaml b/stack.yaml index 06687d0b4..966b36d36 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,4 +4,5 @@ packages: - '.' extra-deps: - megaparsec-5.1.2 +- ansi-terminal-0.8.0.4 resolver: lts-6.0 From 0a8274a7ae37407f6fe24df54247b1aa4dcad65e Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Fri, 25 May 2018 13:48:30 +0200 Subject: [PATCH 02/31] test for NonAssignableLHSError --- src/tests/encore/basic/assignError.enc | 8 ++++++++ src/tests/encore/basic/assignError.fail | 1 + 2 files changed, 9 insertions(+) create mode 100644 src/tests/encore/basic/assignError.enc create mode 100644 src/tests/encore/basic/assignError.fail 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..2cd229f84 --- /dev/null +++ b/src/tests/encore/basic/assignError.fail @@ -0,0 +1 @@ +Left-hand side cannot be assigned to \ No newline at end of file From ddc9b0b6d120c66cbcfefef4645b5cd571d42f3c Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Fri, 25 May 2018 14:38:23 +0200 Subject: [PATCH 03/31] Elias TCError now takes Environment instead of Backtrace --- src/types/Typechecker/Backtrace.hs | 161 ++++++++++++++++++++++ src/types/Typechecker/Capturechecker.hs | 1 + src/types/Typechecker/Environment.hs | 2 +- src/types/Typechecker/Prechecker.hs | 1 + src/types/Typechecker/TypeError.hs | 171 +++--------------------- src/types/Typechecker/Typechecker.hs | 19 +-- src/types/Typechecker/Util.hs | 13 +- 7 files changed, 196 insertions(+), 172 deletions(-) create mode 100644 src/types/Typechecker/Backtrace.hs diff --git a/src/types/Typechecker/Backtrace.hs b/src/types/Typechecker/Backtrace.hs new file mode 100644 index 000000000..13946e4d9 --- /dev/null +++ b/src/types/Typechecker/Backtrace.hs @@ -0,0 +1,161 @@ +{-| + +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 + +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 f01feaef6..89857f1e1 100644 --- a/src/types/Typechecker/Capturechecker.hs +++ b/src/types/Typechecker/Capturechecker.hs @@ -25,6 +25,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..5bf5744d5 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 diff --git a/src/types/Typechecker/Prechecker.hs b/src/types/Typechecker/Prechecker.hs index 931aa8f3a..f612ab799 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/TypeError.hs b/src/types/Typechecker/TypeError.hs index 0798ee865..cfbef9448 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -3,24 +3,17 @@ {-| 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) - ,TCError(TCError) +module Typechecker.TypeError ( + TCError(TCError) ,Error(..) ,TCWarning(TCWarning) ,Warning(..) - ,ExecutionContext(..) - ,currentContextFromBacktrace - ,validUseOfBreak - ,validUseOfContinue ) where -import Text.PrettyPrint import Data.Maybe import Data.List import Data.Char @@ -28,144 +21,10 @@ 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) - -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 @@ -181,12 +40,12 @@ refTypeName ty -- | The data type for a type checking error. Showing it will -- produce an error message and print the backtrace. -data TCError = TCError Error Backtrace +data TCError = TCError Error Environment instance Show TCError where - show (TCError err []) = + show (TCError err Env{bt = []}) = " *** Error during typechecking *** \n" ++ show err ++ "\n" - show (TCError err bt@((pos, _):_)) = + show (TCError err Env{bt = bt@((pos, _):_)}) = " *** Error during typechecking *** \n" ++ show pos ++ "\n" ++ show err ++ "\n" ++ @@ -352,8 +211,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." @@ -374,7 +233,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 @@ -520,7 +379,7 @@ instance Show Error where printf "Unbound function variable '%s'" (show name) show (NonFunctionTypeError ty) = printf "Cannot use value of type '%s' as a function" (show ty) - show BottomTypeInferenceError = "Not enough information to infer the type.\n" ++ + show BottomTypeInferenceError = "Not enough information to infer the type.\n" ++ "Try adding more type information." show IfInferenceError = "Cannot infer result type of if-statement" show (IfBranchMismatchError ty1 ty2) = @@ -947,12 +806,12 @@ instance Show Error where printf "Cannot capture expression '%s' of linear type '%s'" (show (ppSugared e)) (show ty) -data TCWarning = TCWarning Backtrace Warning +data TCWarning = TCWarning Warning Environment instance Show TCWarning where - show (TCWarning [] w) = + show (TCWarning w Env{bt = []}) = "Warning:\n" ++ show w - show (TCWarning ((pos, _):_) w) = + show (TCWarning w Env{bt = ((pos, _):_)}) = "Warning at " ++ show pos ++ ":\n" ++ show w diff --git a/src/types/Typechecker/Typechecker.hs b/src/types/Typechecker/Typechecker.hs index c281f72d6..0ceceeccb 100644 --- a/src/types/Typechecker/Typechecker.hs +++ b/src/types/Typechecker/Typechecker.hs @@ -32,6 +32,7 @@ import AST.Util(extend) import Types as Ty import Typechecker.Environment import Typechecker.TypeError +import Typechecker.Backtrace import Typechecker.Util import Text.Printf (printf) @@ -49,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 && @@ -411,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 @@ -1249,12 +1250,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 diff --git a/src/types/Typechecker/Util.hs b/src/types/Typechecker/Util.hs index 541058300..34275868f 100644 --- a/src/types/Typechecker/Util.hs +++ b/src/types/Typechecker/Util.hs @@ -62,6 +62,7 @@ import Control.Monad.State -- Module dependencies import Typechecker.TypeError +import Typechecker.Backtrace import Typechecker.Environment -- Monadic versions of common functions @@ -109,20 +110,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. From 8f4f26530727682a8d992d032f9eb9272d5a85e4 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Fri, 25 May 2018 16:42:43 +0200 Subject: [PATCH 04/31] Update output of tests --- src/tests/encore/basic/assignError.fail | 2 +- src/tests/encore/forward/forwardTypeMismatch.fail | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tests/encore/basic/assignError.fail b/src/tests/encore/basic/assignError.fail index 2cd229f84..a70ca49a3 100644 --- a/src/tests/encore/basic/assignError.fail +++ b/src/tests/encore/basic/assignError.fail @@ -1 +1 @@ -Left-hand side cannot be assigned to \ No newline at end of file +Left-hand side of operand is not assignable diff --git a/src/tests/encore/forward/forwardTypeMismatch.fail b/src/tests/encore/forward/forwardTypeMismatch.fail index 6dc4a2c57..ecdf88fee 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 (8:22 -> 8:28) From 3131c66d016dfbc2293b1c48e0d09ec02f72413b Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Tue, 29 May 2018 15:38:15 +0200 Subject: [PATCH 05/31] Updated Meta.hs for new way to print position --- src/ir/AST/Meta.hs | 47 +++++++------------ src/tests/encore/assert/assertFalse.err | 2 +- src/tests/encore/assert/assertFalseMsg.err | 2 +- src/tests/encore/assert/assertTrue.err | 2 +- src/tests/encore/assert/assertTrueMsg.err | 2 +- src/tests/encore/basic/abort.err | 2 +- src/tests/encore/basic/recvNullCall.err | 2 +- src/tests/encore/basic/recvNullSend.err | 2 +- .../encore/forward/forwardTypeMismatch.fail | 2 +- src/tests/encore/match/missing.err | 2 +- 10 files changed, 27 insertions(+), 38 deletions(-) diff --git a/src/ir/AST/Meta.hs b/src/ir/AST/Meta.hs index 87faba79c..46025603b 100644 --- a/src/ir/AST/Meta.hs +++ b/src/ir/AST/Meta.hs @@ -21,8 +21,13 @@ data Position = SingletonPos {startPos :: SourcePos} deriving (Eq) instance Show Position where - -- TODO: If we ever want to print ranges, this should be updated - show = showSourcePos . startPos + show (SingletonPos start) = showSourcePos start + show pos@(RangePos start _) = + let + ((sL, sC), (eL,eC)) = getPositions pos + file = sourceName start + in + printf "%s (%d:%d -> %d:%d)" (show file) sL sC eL eC newPos :: SourcePos -> Position @@ -55,41 +60,25 @@ 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 - -showRangePosition :: Position -> String -showRangePosition pos = - case pos of - SingletonPos start -> showSourcePos start - RangePos start end -> getposFile pos ++ " (" ++ (show $ getposLine start) ++ ":" ++ (show $ getposCol start) ++ - " -> " ++ (show $ getposLine end) ++ ":" ++ (show $ getposCol end) ++ ")" - + in printf "%s (%d:%d)" (show file) line col showPos :: Meta a -> String -showPos = showSourcePos . startPos . position +showPos = show . position getPos :: Meta a -> Position getPos = position -getStartPos :: Position -> SourcePos -getStartPos = startPos - -getPosColumns :: Position -> (Int, Int) -getPosColumns pos = +getPositions :: Position -> ((Int, Int), (Int, Int)) +getPositions pos = case pos of - SingletonPos start -> (column start, (column start)+1) - RangePos start end -> (column start, column end) - where - column p = fromIntegral $ unPos (sourceColumn p) - -getposFile :: Position -> String -getposFile pos = sourceName $ getStartPos pos - -getposLine :: SourcePos -> Int -getposLine pos = fromIntegral $ unPos $ sourceLine pos + SingletonPos start -> ((line start, column start), (line start, column start)) + RangePos start end -> ((line start, column start), (line end, column end)) + where + line p = fromIntegral $ unPos (sourceLine p) + column p = fromIntegral $ unPos (sourceColumn p) -getposCol :: SourcePos -> Int -getposCol pos = fromIntegral $ unPos $ sourceColumn pos +getPositionFile :: Position -> String +getPositionFile = sourceName . startPos setType :: Type -> Meta a -> Meta a setType newType m = m {metaType = Just newType} diff --git a/src/tests/encore/assert/assertFalse.err b/src/tests/encore/assert/assertFalse.err index 8e83d7386..f7d5f2f6a 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" (6:5 -> 6:36): Kingfisher diff --git a/src/tests/encore/assert/assertFalseMsg.err b/src/tests/encore/assert/assertFalseMsg.err index 7b95ffc8e..a1947765c 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" (6:5 -> 6:68): Int 42 Bool false String Foo diff --git a/src/tests/encore/assert/assertTrue.err b/src/tests/encore/assert/assertTrue.err index a65f86d74..d2d8aff6f 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" (6:5 -> 6:36): Kingfisher diff --git a/src/tests/encore/assert/assertTrueMsg.err b/src/tests/encore/assert/assertTrueMsg.err index a80c7923b..85f493c3c 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" (6:5 -> 6:68): Int 42 Bool false String Foo diff --git a/src/tests/encore/basic/abort.err b/src/tests/encore/basic/abort.err index d69511a94..04c66ad12 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" (6:18 -> 6:75) diff --git a/src/tests/encore/basic/recvNullCall.err b/src/tests/encore/basic/recvNullCall.err index 0a6cde512..cb28989d6 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" (11:9 -> 11:17) diff --git a/src/tests/encore/basic/recvNullSend.err b/src/tests/encore/basic/recvNullSend.err index 387c67835..14d026b70 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" (11:8 -> 11:15) diff --git a/src/tests/encore/forward/forwardTypeMismatch.fail b/src/tests/encore/forward/forwardTypeMismatch.fail index ecdf88fee..cfcce61fa 100644 --- a/src/tests/encore/forward/forwardTypeMismatch.fail +++ b/src/tests/encore/forward/forwardTypeMismatch.fail @@ -1 +1 @@ -forwardTypeMismatch.enc (8:22 -> 8:28) +"forwardTypeMismatch.enc" (8:22 -> 8:28) diff --git a/src/tests/encore/match/missing.err b/src/tests/encore/match/missing.err index 1a661c478..1741f30b2 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" (3:5 -> 7:8) *** From 3939c1320454d6639242bb75d64291af1fcadbbb Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Tue, 29 May 2018 15:57:48 +0200 Subject: [PATCH 06/31] Printer accepts multi-line errors with no additional arguments --- src/front/TopLevel.hs | 4 +- src/types/Typechecker/TypeError.hs | 108 ++++++++++++++++------------- 2 files changed, 63 insertions(+), 49 deletions(-) diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index 2a20c8cbb..5c264f9ea 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -41,7 +41,7 @@ import ModuleExpander import Typechecker.Environment(buildLookupTable) import Typechecker.Prechecker(precheckProgram) import Typechecker.Typechecker(typecheckProgram, checkForMainClass) -import Typechecker.TypeError(ioShow) +import Typechecker.TypeError(printError) import Typechecker.Capturechecker(capturecheckProgram) import Optimizer.Optimizer import CodeGen.Main @@ -389,7 +389,7 @@ main = (Left error, warnings) -> do showWarnings warnings printf "*** Error during typechecking *** \n\n" - ioShow [error] + printError error let errorlen = length [error] abort $ "\nAborting due to " ++ show errorlen ++ errors errorlen --abort $ show error diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index e86436f5e..981e3788d 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -12,7 +12,7 @@ module Typechecker.TypeError ( ,Error(..) ,TCWarning(TCWarning) ,Warning(..) - ,ioShow + ,printError ) where import Data.Maybe @@ -27,7 +27,8 @@ import Typechecker.Backtrace import AST.AST hiding (showWithKind) import AST.PrettyPrinter import System.Console.ANSI -import AST.Meta(Position, showRangePosition, getStartPos, getPosColumns, getposFile, getposLine) +import AST.Meta(Position, getPositionFile, getPositions) +import Data.Ix(range) refTypeName :: Type -> String refTypeName ty @@ -50,7 +51,7 @@ instance Show TCError where show err ++ "\n" show (TCError err Env{bt = bt@((pos, _):_)}) = " *** Error during typechecking *** \n" ++ - showRangePosition pos ++ "\n" ++ + show pos ++ "\n" ++ show err ++ "\n" ++ concatMap showBT (reduceBT bt) where @@ -59,75 +60,88 @@ instance Show TCError where "" -> "" s -> s ++ "\n" +--TypeWithCapabilityMismatchError Type Type Type +--TypeWithCapabilityMismatchError actual cap expected -ioShow :: [TCError] -> IO () -ioShow [] = return () -ioShow ((TCError err@NonAssignableLHSError Env{bt = bt@((pos, _):_)}) :xs) = do +colorError = setSGR [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] +colorDescription = setSGR [SetColor Foreground Vivid White] +colorLogistic = setSGR [SetColor Foreground Vivid Blue] +colorErrorIndicator = setSGR [SetColor Foreground Dull Red] + +printError :: TCError -> IO () +--printError (TCError err@NonAssignableLHSError Env{bt = bt@((pos, _):_)}) = do +printError (TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((pos, _):_)}) = do printError err --- setSGR [ SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] --- printf "Error: " - printErrorDescription err --- setSGR [SetColor Foreground Vivid White] --- printf $ show err ++ "\n" printPosition pos --- setSGR [ SetConsoleIntensity NormalIntensity, SetColor Foreground Vivid Blue] --- printf " --> " --- setSGR [Reset] --- printf $ showRangePosition pos - printCodeViewer pos "Insert good suggestion here" --- setSGR [SetColor Foreground Vivid Blue] --- printf "\n|\n|" --- setSGR [Reset] --- printFileLine (getposFile pos) (getposLine $ getStartPos pos) --- setSGR [SetColor Foreground Vivid Blue] --- printf "\n|" --- setSGR [SetColor Foreground Dull Red] --- printf $ errorIndicator startCol endCol --- setSGR [Reset] - ioShow xs where printError _ = do - setSGR [ SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] + colorError printf "Error: " - setSGR [Reset] - - printErrorDescription err = do - setSGR [SetColor Foreground Vivid White] + colorDescription printf $ show err ++ "\n" setSGR [Reset] printPosition pos = do - setSGR [ SetConsoleIntensity NormalIntensity, SetColor Foreground Vivid Blue] + colorLogistic printf " --> " setSGR [Reset] - printf $ showRangePosition pos + printf $ show pos + printCodeViewer :: Position -> String -> IO () printCodeViewer pos smallSuggestion = do - let startLine = getposLine $ getStartPos pos - let digits = fromIntegral $ round $ logBase 10 (fromIntegral startLine) - let (startCol, endCol) = getPosColumns pos - setSGR [SetColor Foreground Vivid Blue] - printf $ "\n" ++ replicate digits ' ' ++ " |\n" ++ show startLine ++ " |" + let ((sL, sC), (eL, eC)) = getPositions pos + let digitSpace = replicate (length $ show sL) ' ' + colorLogistic + printf "\n%s |" digitSpace setSGR [Reset] - printFileLine (getposFile pos) (getposLine $ getStartPos pos) - setSGR [SetColor Foreground Vivid Blue] - printf $ "\n" ++ replicate digits ' ' ++ " |" - setSGR [SetColor Foreground Dull Red] - printf $ errorIndicator startCol endCol - printf $ ' ' : smallSuggestion ++ "\n\n" + if sL == eL + then do + printLine pos "" sL + colorLogistic + printf "\n%s |" digitSpace + colorErrorIndicator + printf $ errorIndicator sC eC + else do + printLine pos " " sL + colorLogistic + printf "\n%s |" digitSpace + colorErrorIndicator + printf " %s^" (replicate (sC-1) '_') + mapM_ (printLine pos " |") $ range (sL+1, eL) + colorLogistic + printf "\n%s |" digitSpace + colorErrorIndicator + printf " |%s^" (replicate (eC-2) '_') + + printf " %s\n\n" smallSuggestion setSGR [Reset] - errorIndicator :: Int -> Int -> [Char] - errorIndicator s e = "" ++ replicate (s-1) ' ' ++ replicate (e-s) '^' + errorIndicator :: Int -> Int -> String + errorIndicator s e = replicate (s-1) ' ' ++ replicate (e-s) '^' + + printLine :: Position -> String -> Int -> IO () + printLine pos strInsert line = do + contents <- readFile $ getPositionFile pos + result <- case drop (line-1) $ lines contents of + [] -> error "File has been edited between parsing and type checking" + l:_ -> return l + + colorLogistic + printf "\n%s |" (show line) + colorErrorIndicator + printf strInsert + setSGR [Reset] + printf result + --printFileLine file line -ioShow err = printf $ show err +printError err = printf $ show err printFileLine :: String -> Int -> IO () printFileLine file line = do From f826e7604e45bd6f2fa1724ff05a2c1b1fad23a5 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Thu, 31 May 2018 14:04:39 +0200 Subject: [PATCH 07/31] Optimized code-input as well as refactored for future function purification --- src/types/Typechecker/TypeError.hs | 38 ++++++++++++++---------------- 1 file changed, 18 insertions(+), 20 deletions(-) diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 981e3788d..6db73863d 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -29,6 +29,7 @@ import AST.PrettyPrinter import System.Console.ANSI import AST.Meta(Position, getPositionFile, getPositions) import Data.Ix(range) +import Control.Monad(zipWithM_) refTypeName :: Type -> String refTypeName ty @@ -95,6 +96,7 @@ printError (TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((po printCodeViewer pos smallSuggestion = do let ((sL, sC), (eL, eC)) = getPositions pos let digitSpace = replicate (length $ show sL) ' ' + cHead:cTail <- getCodeLines pos sL eL colorLogistic printf "\n%s |" digitSpace @@ -102,18 +104,18 @@ printError (TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((po if sL == eL then do - printLine pos "" sL + printLine "" cHead sL colorLogistic printf "\n%s |" digitSpace colorErrorIndicator printf $ errorIndicator sC eC else do - printLine pos " " sL + printLine " " cHead sL colorLogistic printf "\n%s |" digitSpace colorErrorIndicator printf " %s^" (replicate (sC-1) '_') - mapM_ (printLine pos " |") $ range (sL+1, eL) + zipWithM_ (printLine " |") cTail $ range (sL+1, eL) colorLogistic printf "\n%s |" digitSpace colorErrorIndicator @@ -126,29 +128,25 @@ printError (TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((po errorIndicator :: Int -> Int -> String errorIndicator s e = replicate (s-1) ' ' ++ replicate (e-s) '^' - printLine :: Position -> String -> Int -> IO () - printLine pos strInsert line = do - contents <- readFile $ getPositionFile pos - result <- case drop (line-1) $ lines contents of - [] -> error "File has been edited between parsing and type checking" - l:_ -> return l - + printLine :: String -> String -> Int -> IO () + printLine insertStr codeLine lineNo = do colorLogistic - printf "\n%s |" (show line) + printf "\n%s |" (show lineNo) colorErrorIndicator - printf strInsert + printf insertStr setSGR [Reset] - printf result - --printFileLine file line + printf codeLine printError err = printf $ show err -printFileLine :: String -> Int -> IO () -printFileLine file line = do - contents <- readFile file - case drop (line-1) $ lines contents of - [] -> error "File has been edited between parsing and type checking" - l:_ -> printf l +getCodeLines :: Position -> Int -> Int -> IO [String] +getCodeLines pos sL eL = do + 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 l data Error = DistinctTypeParametersError Type From b08e8b56d5ffe6bf598d7cad8cfe7c1008612bb8 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Thu, 14 Jun 2018 12:22:30 +0200 Subject: [PATCH 08/31] Reverted back to not show ranges in error position --- src/front/TopLevel.hs | 2 +- src/ir/AST/Meta.hs | 13 ++++--------- src/tests/encore/assert/assertFalse.err | 2 +- src/tests/encore/assert/assertFalseMsg.err | 2 +- src/tests/encore/assert/assertTrue.err | 2 +- src/tests/encore/assert/assertTrueMsg.err | 2 +- src/tests/encore/basic/abort.err | 2 +- src/tests/encore/basic/recvNullCall.err | 2 +- src/tests/encore/basic/recvNullSend.err | 2 +- src/tests/encore/forward/forwardTypeMismatch.fail | 2 +- src/tests/encore/match/missing.err | 2 +- 11 files changed, 14 insertions(+), 19 deletions(-) diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index 5c264f9ea..14593aaee 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -244,7 +244,7 @@ compileProgram prog sourcePath options = customFlags = case find isCustomFlags options of Just (CustomFlags str) -> str Nothing -> "" - flags = "-std=gnu11 -Wall -fms-extensions -Wno-format -Wno-microsoft -Wno-parentheses-equality -Wno-unused-variable -Wno-unused-value" <+> customFlags <+> "-lpthread -ldl -lm -Wno-attributes" + flags = "-std=gnu11 -Wall -fms-extensions -Wno-format -Wno-microsoft -Wno-parentheses-equality -Wno-unused-variable -Wno-unused-value" <+> customFlags <+> "-lpthread -latomic -ldl -lm -Wno-attributes" oFlag = "-o" <+> execName defines = getDefines options incs = "-I" <+> incPath <+> "-I ." diff --git a/src/ir/AST/Meta.hs b/src/ir/AST/Meta.hs index 46025603b..e2ffa5b95 100644 --- a/src/ir/AST/Meta.hs +++ b/src/ir/AST/Meta.hs @@ -21,13 +21,8 @@ data Position = SingletonPos {startPos :: SourcePos} deriving (Eq) instance Show Position where - show (SingletonPos start) = showSourcePos start - show pos@(RangePos start _) = - let - ((sL, sC), (eL,eC)) = getPositions pos - file = sourceName start - in - printf "%s (%d:%d -> %d:%d)" (show file) sL sC eL eC + -- TODO: If we ever want to print ranges, this should be updated + show = showSourcePos . startPos newPos :: SourcePos -> Position @@ -60,10 +55,10 @@ showSourcePos pos = let line = unPos (sourceLine pos) col = unPos (sourceColumn pos) file = sourceName pos - in printf "%s (%d:%d)" (show file) line col + in printf "%s (Line:%d, Column:%d)" (show file) line col showPos :: Meta a -> String -showPos = show . position +showPos = showSourcePos . startPos . position getPos :: Meta a -> Position getPos = position diff --git a/src/tests/encore/assert/assertFalse.err b/src/tests/encore/assert/assertFalse.err index f7d5f2f6a..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" (6:5 -> 6:36): +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 a1947765c..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" (6:5 -> 6:68): +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 d2d8aff6f..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" (6:5 -> 6:36): +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 85f493c3c..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" (6:5 -> 6:68): +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 04c66ad12..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" (6:18 -> 6:75) +"abort.enc" (Line:6, Column:18) diff --git a/src/tests/encore/basic/recvNullCall.err b/src/tests/encore/basic/recvNullCall.err index cb28989d6..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" (11:9 -> 11:17) +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 14d026b70..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" (11:8 -> 11:15) +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 cfcce61fa..5fe64ed88 100644 --- a/src/tests/encore/forward/forwardTypeMismatch.fail +++ b/src/tests/encore/forward/forwardTypeMismatch.fail @@ -1 +1 @@ -"forwardTypeMismatch.enc" (8:22 -> 8:28) +"forwardTypeMismatch.enc" (Line:8, Column:22) diff --git a/src/tests/encore/match/missing.err b/src/tests/encore/match/missing.err index 1741f30b2..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" (3:5 -> 7:8) *** +*** Runtime error: No matching clause was found at "missing.enc" (Line:3, Column:5) *** From ec8364ac80cf25a9eb6ec7f7288c7fbaf59ce549 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Wed, 13 Jun 2018 16:02:58 +0200 Subject: [PATCH 09/31] Swapped Text.PrettyPrint to Data.Text.Prettyprint.Doc --- encore.cabal | 3 +- src/back/CCode/PrettyCCode.hs | 90 ++++++++++---------- src/front/Makefile.hs | 66 +++++++-------- src/ir/AST/PrettyPrinter.hs | 131 +++++++++++++++-------------- src/types/Typechecker/Backtrace.hs | 2 +- src/types/Typechecker/TypeError.hs | 1 + stack.yaml | 2 + 7 files changed, 148 insertions(+), 147 deletions(-) diff --git a/encore.cabal b/encore.cabal index 34604f35d..be55e5b05 100644 --- a/encore.cabal +++ b/encore.cabal @@ -38,7 +38,6 @@ executable encorec , mtl ==2.2.* , megaparsec >= 5.1.2 , semigroups - , pretty >=1.1 && <1.2 , process >=1.2 && <1.3 , template-haskell , text >=1.1 @@ -48,6 +47,8 @@ executable encorec , boxes , filepath , ansi-terminal + , prettyprinter + , prettyprinter-ansi-terminal hs-source-dirs: src/back src/front src/ir src/opt src/parser src/types ghc-options: -Werror default-language: Haskell2010 diff --git a/src/back/CCode/PrettyCCode.hs b/src/back/CCode/PrettyCCode.hs index abecd7aeb..be90fffd1 100644 --- a/src/back/CCode/PrettyCCode.hs +++ b/src/back/CCode/PrettyCCode.hs @@ -8,101 +8,99 @@ Converting CCode (see "CCode.Main") to C source. module CCode.PrettyCCode (pp) where import CCode.Main -import Text.PrettyPrint +import Data.Text.Prettyprint.Doc hiding(indent) import Data.List indent = nest 2 +($+$) s e = s <> line <> e -- | Converts a CCode value to its source representation pp :: CCode a -> String pp = show . pp' -tshow :: Show t => t -> Doc -tshow = text . show - -addSemi :: Doc -> Doc +addSemi :: Doc ann -> Doc ann addSemi d | null (show d) || isSuffixOf ";" (show d) = d | otherwise = d <> ";" -commaSep :: [Doc] -> Doc +commaSep :: [Doc ann] -> Doc ann commaSep = hcat . intersperse ", " -switchBody :: [(CCode Name, CCode Stat)] -> CCode Stat -> Doc +switchBody :: [(CCode Name, CCode Stat)] -> CCode Stat -> Doc ann switchBody ccodes defCase = bracedBlock $ vcat (map switchClause ccodes) $+$ "default:" $+$ (bracedBlock . vcat . map pp') [defCase] where - switchClause :: (CCode Name, CCode Stat) -> Doc + switchClause :: (CCode Name, CCode Stat) -> Doc ann switchClause (lhs,rhs) = "case" <+> pp' lhs <> ":" $+$ (bracedBlock . vcat . map pp') (rhs:[Embed "break;"]) -pp' :: CCode a -> Doc +pp' :: CCode a -> Doc ann pp' (Program cs) = pp' cs -pp' Skip = empty +pp' Skip = emptyDoc pp' Null = "NULL" -pp' (Includes ls) = vcat $ map (text . ("#include <"++) . (++">")) ls -pp' (LocalInclude s) = "#include" <+> doubleQuotes (text s) +pp' (Includes ls) = vcat $ map (pretty . ("#include <"++) . (++">")) ls +pp' (LocalInclude s) = "#include" <+> dquotes (pretty s) pp' (IfDefine str ccode) = - "#ifdef" <+> text str $+$ pp' ccode $+$ - "#endif /* ifdef" <+> text str <+> "*/" + "#ifdef" <+> pretty str $+$ pp' ccode $+$ + "#endif /* ifdef" <+> pretty str <+> "*/" pp' (IfNDefine str ccode) = - "#ifndef" <+> text str $+$ pp' ccode $+$ - "#endif /* ifndef" <+> text str <+> text "*/" -pp' (HashDefine str) = "#define" <+> text str + "#ifndef" <+> pretty str $+$ pp' ccode $+$ + "#endif /* ifndef" <+> pretty str <+> "*/" +pp' (HashDefine str) = "#define" <+> pretty str pp' (Statement other) = addSemi $ pp' other pp' (Switch tst ccodes def) = - "switch" <+> parens (tshow tst) $+$ + "switch" <+> parens (viaShow tst) $+$ switchBody ccodes def pp' (StructDecl name vardecls) = - "struct " <> tshow name $+$ (addSemi . bracedBlock . vcat) (map pp' fields) + "struct " <> viaShow name $+$ (addSemi . bracedBlock . vcat) (map pp' fields) where fields = map (\(ty, id) -> Embed $ show ty ++ " " ++ show id ++ ";") vardecls -pp' (Struct name) = "struct " <> tshow name +pp' (Struct name) = "struct " <> viaShow name pp' (Record ccodes) = braces $ commaList ccodes pp' (Assign lhs rhs) = addSemi $ pp' lhs <+> "=" <+> pp' rhs pp' (AssignTL lhs rhs) = addSemi $ pp' lhs <+> "=" <+> pp' rhs -pp' (Decl (ty, id)) = tshow ty <+> tshow id -pp' (DeclTL (ty, id)) = addSemi $ tshow ty <+> tshow id +pp' (Decl (ty, id)) = viaShow ty <+> viaShow id +pp' (DeclTL (ty, id)) = addSemi $ viaShow ty <+> viaShow id pp' (FunTypeDef id ty argTys) = - addSemi $ "typedef" <+> tshow ty <+> parens ("*" <> tshow id) <> + addSemi $ "typedef" <+> viaShow ty <+> parens ("*" <> viaShow id) <> parens (commaList argTys) pp' (Concat ccodes) = vcat $ intersperse "\n" $ map pp' ccodes pp' (Seq ccodes) = vcat $ map (addSemi . pp') ccodes pp' (Enum ids) = - "enum" $+$ bracedBlock (vcat $ map (\id -> tshow id <> ",") ids) <> ";" + "enum" $+$ bracedBlock (vcat $ map (\id -> viaShow id <> ",") ids) <> ";" pp' (Braced ccode) = (bracedBlock . pp') ccode pp' (Parens ccode) = parens $ pp' ccode pp' (CUnary o e) = parens $ pp' o <+> pp' e pp' (BinOp o e1 e2) = parens $ pp' e1 <+> pp' o <+> pp' e2 -pp' (Dot ccode id) = pp' ccode <> "." <> tshow id -pp' (Arrow ccode id) = pp' ccode <> "->" <> tshow id +pp' (Dot ccode id) = pp' ccode <> "." <> viaShow id +pp' (Arrow ccode id) = pp' ccode <> "->" <> viaShow id pp' (Deref ccode) = parens $ "*" <> pp' ccode pp' (Cast ty e) = parens $ parens (pp' ty) <+> pp' e -pp' (ArrAcc i l) = parens $ pp' l <> brackets (tshow i) +pp' (ArrAcc i l) = parens $ pp' l <> brackets (viaShow i) pp' (Amp ccode) = parens $ "&" <> parens (pp' ccode) pp' (Ptr ty) = pp' ty <> "*" pp' (FunctionDecl retTy name args) = - tshow retTy <+> tshow name <> + viaShow retTy <+> viaShow name <> parens (commaList args) <> ";" pp' (Function retTy name args body) = - tshow retTy <+> tshow name <> + viaShow retTy <+> viaShow name <> parens (ppArgs args) $+$ (bracedBlock . pp') body pp' (AsExpr c) = pp' c pp' (AsLval c) = pp' c pp' (AsType c) = pp' c -pp' (Nam st) = text st -pp' (Var st) = text st -pp' (Typ st) = text st +pp' (Nam st) = pretty st +pp' (Var st) = pretty st +pp' (Typ st) = pretty st pp' (Static ty) = "static" <+> pp' ty pp' (Extern ty) = "extern" <+> pp' ty -pp' (Embed string) = text string +pp' (Embed string) = pretty string pp' (EmbedC ccode) = pp' ccode -pp' (Call name args) = tshow name <> parens (commaList args) -pp' (Typedef ty name) = "typedef" <+> pp' ty <+> tshow name <> ";" +pp' (Call name args) = viaShow name <> parens (commaList args) +pp' (Typedef ty name) = "typedef" <+> pp' ty <+> viaShow name <> ";" pp' (Sizeof ty) = "sizeof" <> parens (pp' ty) pp' (While cond body) = "while" <+> parens (pp' cond) $+$ @@ -119,12 +117,12 @@ pp' (Ternary c t e) = pp' c <> "?" <+> pp' t <> ":" <+> pp' e pp' (Return e) = "return" <+> pp' e <> ";" pp' (Break) = "break;" pp' (Continue) = "continue;" -pp' (UnionInst name e) = "{." <> tshow name <+> "=" <+> pp' e <> "}" -pp' (Int n) = tshow n -pp' (String s) = tshow s -pp' (Char c) = tshow c -pp' (Double d) = tshow d -pp' (Comm s) = text $ "/* " ++ s ++ " */" +pp' (UnionInst name e) = "{." <> viaShow name <+> "=" <+> pp' e <> "}" +pp' (Int n) = viaShow n +pp' (String s) = viaShow s +pp' (Char c) = viaShow c +pp' (Double d) = viaShow d +pp' (Comm s) = pretty $ "/* " ++ s ++ " */" pp' (Annotated s ccode) = pp' ccode <+> pp' (Comm s) pp' (FunPtrDecl t name argTypes) = let @@ -147,15 +145,15 @@ pp' (DesignatedInitializer pairs) = in "{" <> body <> "}" -commaList :: [CCode a] -> Doc +commaList :: [CCode a] -> Doc ann commaList l = commaSep $ map pp' l -ppArgs :: [CVarSpec] -> Doc -ppArgs [] = empty +ppArgs :: [CVarSpec] -> Doc ann +ppArgs [] = emptyDoc ppArgs as = commaSep $ map ppArg as -ppArg (ty, id) = tshow ty <+> tshow id +ppArg (ty, id) = viaShow ty <+> viaShow id -bracedBlock :: Doc -> Doc +bracedBlock :: Doc ann -> Doc ann bracedBlock doc = lbrace $+$ indent doc $+$ rbrace diff --git a/src/front/Makefile.hs b/src/front/Makefile.hs index a6c3569db..1bdb98ef8 100644 --- a/src/front/Makefile.hs +++ b/src/front/Makefile.hs @@ -1,34 +1,35 @@ module Makefile where -import Text.PrettyPrint +import Data.Text.Prettyprint.Doc import Data.String.Utils import Prelude hiding(all) -($\$) t = ((t <> text "\n") $$) -tab = text "\t" -all = text "all" -bench = text "bench" -clean = text "clean" -rm args = (text "rm -rf" <+> hsep args) -phony = text ".PHONY" -cc args = (text "$(CC)" <+> hsep args) -flags = text "$(FLAGS)" -benchFlags = text "$(BENCH_FLAGS)" -target = text "$(TARGET)" -inc = text "$(INC)" -lib = text "$(LIB)" -deps = text "$(DEPS)" -defs = text "$(DEFINES)" -dSYM = text ".dSYM" -i = (text "-I" <+>) -o = (text "-o" <+>) -parent = text ".." +($$) s e = s <> hardline <> e +($\$) t ts = (t <> hardline <> hardline <> ts) +tab = pretty "\t" +all = pretty "all" +bench = pretty "bench" +clean = pretty "clean" +rm args = (pretty "rm -rf" <+> hsep args) +phony = pretty ".PHONY" +cc args = (pretty "$(CC)" <+> hsep args) +flags = pretty "$(FLAGS)" +benchFlags = pretty "$(BENCH_FLAGS)" +target = pretty "$(TARGET)" +inc = pretty "$(INC)" +lib = pretty "$(LIB)" +deps = pretty "$(DEPS)" +defs = pretty "$(DEFINES)" +dSYM = pretty ".dSYM" +i = (pretty "-I" <+>) +o = (pretty "-o" <+>) +parent = pretty ".." generateMakefile :: [String] -> - String -> String -> String -> String -> String -> String -> Doc + String -> String -> String -> String -> String -> String -> Doc ann generateMakefile classFiles progName compiler ccFlags incPath defines libs = decl "CC" [compiler] $$ @@ -46,23 +47,20 @@ generateMakefile classFiles progName compiler ccFlags incPath defines libs = $$ decl "DEPS" ("shared.c" : classFiles) $\$ - rule all target - empty + noCmdRule all target $\$ rule target deps - (cc [flags, i inc, i parent, deps, lib, lib, defs, o target]) + (cc [flags, i inc, i parent, deps, lib, lib, defs, o target]) $\$ rule bench deps - (cc [benchFlags, i inc, i parent, deps, lib, lib, defs, o target]) + (cc [benchFlags, i inc, i parent, deps, lib, lib, defs, o target]) $\$ - rule clean empty - (rm [target, target <> dSYM]) + rule clean emptyDoc + (rm [target, target <> dSYM]) $\$ - rule phony (all <+> bench <+> clean) - empty + noCmdRule phony (all <+> bench <+> clean) where - decl var rhs = text var <> equals <> hsep (map text rhs) - rule target deps cmd - | isEmpty cmd = target <> colon <+> deps - | otherwise = target <> colon <+> deps $$ - tab <> cmd + decl var rhs = pretty var <> equals <> hsep (map pretty rhs) + rule target deps cmd = target <> colon <+> deps $$ + tab <> cmd + noCmdRule target deps = target <> colon <+> deps diff --git a/src/ir/AST/PrettyPrinter.hs b/src/ir/AST/PrettyPrinter.hs index 057e4eb9c..390dc85c0 100644 --- a/src/ir/AST/PrettyPrinter.hs +++ b/src/ir/AST/PrettyPrinter.hs @@ -19,8 +19,7 @@ module AST.PrettyPrinter (ppExpr ) where -- Library dependencies -import qualified Text.PrettyPrint as P -import Text.PrettyPrint hiding(brackets) +import Data.Text.Prettyprint.Doc hiding(indent) -- Module dependencies import Identifiers @@ -28,27 +27,28 @@ import Types import AST.AST indent = nest 2 +($+$) s e = s <> line <> e commaSep l = hcat $ punctuate ", " l -brackets s = hcat ["[", s, "]"] +--brackets s = hcat ["[", s, "]"] -ppMut :: Mutability -> Doc +ppMut :: Mutability -> Doc ann ppMut Val = "val" ppMut Var = "var" -ppName :: Name -> Doc -ppName = text . show +ppName :: Name -> Doc ann +ppName = viaShow -ppNamespace :: Namespace -> Doc -ppNamespace = text . show +ppNamespace :: Namespace -> Doc ann +ppNamespace = viaShow -ppQName :: QualifiedName -> Doc -ppQName = text . show +ppQName :: QualifiedName -> Doc ann +ppQName = viaShow -ppType :: Type -> Doc -ppType = text . show +ppType :: Type -> Doc ann +ppType = viaShow -ppProgram :: Program -> Doc +ppProgram :: Program -> Doc ann ppProgram Program{moduledecl, etl, imports, typedefs, functions, traits, classes} = ppModuleDecl moduledecl $+$ vcat (map ppEmbedded etl) <+> @@ -65,18 +65,18 @@ ppEmbedded EmbedTL{etlheader=header, etlbody=code} = ppHeader header code = if null header && null code - then empty - else "EMBED" $+$ text header $+$ "BODY" $+$ text code $+$ "END\n" + then emptyDoc + else "EMBED" $+$ pretty header $+$ "BODY" $+$ pretty code $+$ "END\n" -ppModuleDecl :: ModuleDecl -> Doc -ppModuleDecl NoModule = empty +ppModuleDecl :: ModuleDecl -> Doc ann +ppModuleDecl NoModule = emptyDoc ppModuleDecl Module{modname, modexports} = "module" <+> ppName modname <> case modexports of Just names -> parens (commaSep $ map ppName names) - Nothing -> empty + Nothing -> emptyDoc -ppImportDecl :: ImportDecl -> Doc +ppImportDecl :: ImportDecl -> Doc ann ppImportDecl Import {itarget ,iqualified ,ihiding @@ -91,41 +91,41 @@ ppImportDecl Import {itarget maybeSelect = case iselect of Just names -> parens (commaSep $ map ppName names) - Nothing -> empty + Nothing -> emptyDoc maybeHiding = case ihiding of Just names -> " hiding" <> parens (commaSep $ map ppName names) - Nothing -> empty + Nothing -> emptyDoc maybeAlias = case ialias of Just alias -> " as" <+> ppNamespace alias - Nothing -> empty + Nothing -> emptyDoc -ppTypedef :: Typedef -> Doc +ppTypedef :: Typedef -> Doc ann ppTypedef Typedef { typedefdef=t } = "typedef" <+> ppType t <+> "=" <+> ppType (typeSynonymRHS t) -ppFunctionHeader :: FunctionHeader -> Doc +ppFunctionHeader :: FunctionHeader -> Doc ann ppFunctionHeader header = ppName (hname header) <> ppTypeParams (htypeparams header) <> parens (commaSep $ map ppParamDecl $ hparams header) <+> ":" <+> ppType (htype header) -ppTypeParams :: [Type] -> Doc +ppTypeParams :: [Type] -> Doc ann ppTypeParams params = if null params - then empty + then emptyDoc else brackets (commaSep $ map ppTypeParam params) where ppTypeParam ty | Just bound <- getBound ty = ppType ty <+> ":" <+> ppType bound | otherwise = ppType ty -ppFunctionHelper :: FunctionHeader -> Expr -> [Function] -> Doc +ppFunctionHelper :: FunctionHeader -> Expr -> [Function] -> Doc ann ppFunctionHelper funheader funbody [] = "fun" <+> ppFunctionHeader funheader $+$ indent (ppBody funbody) $+$ @@ -137,29 +137,29 @@ ppFunctionHelper funheader funbody funlocals = indent (vcat $ map ppFunction funlocals) $+$ "end" -ppFunction :: Function -> Doc +ppFunction :: Function -> Doc ann ppFunction Function {funheader, funbody, funlocals} = ppFunctionHelper funheader funbody funlocals -ppTraitDecl :: TraitDecl -> Doc +ppTraitDecl :: TraitDecl -> Doc ann ppTraitDecl Trait {tname, treqs, tmethods} = - trait <+> text (showWithoutMode tname) $+$ - indent (vcat (map ppRequirement treqs) $$ + trait <+> pretty (showWithoutMode tname) $+$ + indent (vcat (map ppRequirement treqs) $+$ vcat (map ppMethodDecl tmethods)) $+$ "end" where trait | isModeless tname = "trait" - | otherwise = text $ showModeOf tname ++ " trait" + | otherwise = pretty $ showModeOf tname ++ " trait" ppRequirement RequiredField{rfield} = "require" <+> ppFieldDecl rfield ppRequirement RequiredMethod{rheader} = "require" <+> "def" <+> ppFunctionHeader rheader -ppTraitExtension :: TraitExtension -> Doc +ppTraitExtension :: TraitExtension -> Doc ann ppTraitExtension FieldExtension{extname} = ppName extname ppTraitExtension MethodExtension{extname} = ppName extname <> "()" -ppComposition :: TraitComposition -> Doc +ppComposition :: TraitComposition -> Doc ann ppComposition Conjunction{tcleft, tcright} = ppConjunctionChild tcleft <+> "*" <+> ppConjunctionChild tcright where @@ -169,33 +169,33 @@ ppComposition Disjunction{tcleft, tcright} = ppComposition tcleft <+> "+" <+> ppComposition tcright ppComposition TraitLeaf{tcname, tcext} = ppType tcname <> if null tcext - then empty + then emptyDoc else parens (commaSep (map ppTraitExtension tcext)) -ppClassDecl :: ClassDecl -> Doc +ppClassDecl :: ClassDecl -> Doc ann ppClassDecl Class {cname, cfields, cmethods, ccomposition} = - clss <+> text (showWithoutMode cname) <+> compositionDoc $+$ - indent (vcat (map ppFieldDecl cfields) $$ + clss <+> pretty (showWithoutMode cname) <+> compositionDoc $+$ + indent (vcat (map ppFieldDecl cfields) $+$ vcat (map ppMethodDecl cmethods)) $+$ "end" where clss | isModeless cname = "class" - | otherwise = text $ showModeOf cname ++ " class" + | otherwise = pretty $ showModeOf cname ++ " class" compositionDoc = case ccomposition of Just c -> ":" <+> ppComposition c - Nothing -> empty + Nothing -> emptyDoc -ppFieldDecl :: FieldDecl -> Doc -ppFieldDecl = text . show +ppFieldDecl :: FieldDecl -> Doc ann +ppFieldDecl = viaShow -ppParamDecl :: ParamDecl -> Doc +ppParamDecl :: ParamDecl -> Doc ann 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 ann ppMethodDecl m = let header = mheader m modifiers = hmodifiers header @@ -210,9 +210,9 @@ ppMethodDecl m = indent (ppBody body) $+$ endOrLocals where - ppModifiers [] = empty + ppModifiers [] = emptyDoc ppModifiers mods = hcat $ punctuate " " $ - map (text . show) mods + map (viaShow) mods endOrLocals | null (mlocals m) = "end" | otherwise = @@ -228,26 +228,27 @@ isSimple MessageSend {target} = isSimple target isSimple FunctionCall {} = True isSimple _ = False -maybeParens :: Expr -> Doc +maybeParens :: Expr -> Doc ann maybeParens e | isSimple e = ppExpr e | otherwise = parens $ ppExpr e -ppSugared :: Expr -> Doc +ppSugared :: Expr -> Doc ann ppSugared e = case getSugared e of Just e' -> ppExpr e' Nothing -> ppExpr e +ppBody :: Expr -> Doc ann ppBody (Seq {eseq}) = vcat $ map ppExpr eseq ppBody e = ppExpr e -withTypeArguments :: [Type] -> Doc +withTypeArguments :: [Type] -> Doc ann withTypeArguments typeArguments = if null typeArguments - then empty + then emptyDoc else brackets (commaSep (map ppType typeArguments)) -ppExpr :: Expr -> Doc +ppExpr :: Expr -> Doc ann ppExpr Skip {} = "()" ppExpr Break {} = "break" ppExpr Continue {} = "Continue" @@ -263,9 +264,9 @@ ppExpr Optional {optTag = QuestionDot MethodCall {target, name, args, typeArgume ppExpr Optional {optTag = QuestionDot FieldAccess {target, name}} = maybeParens target <> "?." <> ppName name ppExpr Optional {optTag} = error $ "PrettyPrinter.hs: don't know how to " ++ - "print expression '" ++ (render $ ppPath optTag) ++ "'" + "print expression '" ++ (show $ ppPath optTag) ++ "'" where - ppPath :: OptionalPathComponent -> Doc + ppPath :: OptionalPathComponent -> Doc ann ppPath (QuestionBang e) = ppExpr e ppPath (QuestionDot e) = ppExpr e @@ -396,7 +397,7 @@ ppExpr ArraySize {target} = "|" <> ppExpr target <> "|" ppExpr ArrayNew {ty, size} = "new" <+> brackets (ppType ty) <> parens (ppExpr size) ppExpr ArrayLiteral {args} = brackets $ commaSep (map ppExpr args) ppExpr VarAccess {qname} = ppQName qname -ppExpr TupleAccess {target, compartment} = ppExpr target <> "." <> int compartment +ppExpr TupleAccess {target, compartment} = ppExpr target <> "." <> pretty compartment ppExpr Consume {target} = "consume" <+> ppExpr target ppExpr Assign {lhs, rhs} = ppExpr lhs <+> "=" <+> ppExpr rhs ppExpr Null {} = "null" @@ -408,11 +409,11 @@ ppExpr New {ty} = "new" <+> ppType ty ppExpr Print {args} = "print" <> parens (commaSep (map ppExpr args)) ppExpr Exit {args} = "exit" <> parens (commaSep (map ppExpr args)) ppExpr Abort {args} = "abort" <> parens (commaSep (map ppExpr args)) -ppExpr StringLiteral {stringLit} = text $ show stringLit -ppExpr CharLiteral {charLit} = text $ show charLit -ppExpr UIntLiteral {intLit} = int intLit <> "u" -ppExpr IntLiteral {intLit} = int intLit -ppExpr RealLiteral {realLit} = double realLit +ppExpr StringLiteral {stringLit} = viaShow stringLit +ppExpr CharLiteral {charLit} = viaShow charLit +ppExpr UIntLiteral {intLit} = pretty intLit <> "u" +ppExpr IntLiteral {intLit} = pretty intLit +ppExpr RealLiteral {realLit} = pretty realLit ppExpr RangeLiteral {start, stop, step} = "[" <> ppExpr start <> ".." <> ppExpr stop <> ppStep step <> "]" where @@ -423,26 +424,26 @@ ppExpr Embed {ty, embedded} = indent (hcat (map (uncurry ppPair) embedded)) $+$ "END" where - ppPair code Skip{} = text code - ppPair code expr = text code <> "#{" <> ppExpr expr <> "}" + ppPair code Skip{} = pretty code + ppPair code expr = pretty code <> "#{" <> ppExpr expr <> "}" ppExpr Unary {uop, operand} = ppUnary uop <> parens (ppExpr operand) 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 ann ppDecl (vars, val) = commaSep (map ppVar vars) <+> "=" <+> ppExpr val -ppVar :: VarDecl -> Doc +ppVar :: VarDecl -> Doc ann ppVar (VarType x ty) = ppName x <+> ":" <+> ppType ty ppVar (VarNoType x) = ppName x -ppUnary :: UnaryOp -> Doc +ppUnary :: UnaryOp -> Doc ann ppUnary Identifiers.NOT = "not" ppUnary Identifiers.NEG = "-" -ppBinop :: BinaryOp -> Doc +ppBinop :: BinaryOp -> Doc ann ppBinop Identifiers.AND = "&&" ppBinop Identifiers.OR = "||" ppBinop Identifiers.LT = "<" diff --git a/src/types/Typechecker/Backtrace.hs b/src/types/Typechecker/Backtrace.hs index 13946e4d9..07a1eb0b1 100644 --- a/src/types/Typechecker/Backtrace.hs +++ b/src/types/Typechecker/Backtrace.hs @@ -17,7 +17,7 @@ module Typechecker.Backtrace(Backtrace import Data.Maybe import Data.List -import Text.PrettyPrint +import Data.Text.Prettyprint.Doc import Identifiers import AST.Meta(Position) diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 6db73863d..db302255f 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -15,6 +15,7 @@ module Typechecker.TypeError ( ,printError ) where +import Data.Text.Prettyprint.Doc import Data.Maybe import Data.List import Data.Char diff --git a/stack.yaml b/stack.yaml index 966b36d36..285423291 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,4 +5,6 @@ packages: extra-deps: - megaparsec-5.1.2 - ansi-terminal-0.8.0.4 +- prettyprinter-1.2.0.1 +- prettyprinter-ansi-terminal-1.1.1.2 resolver: lts-6.0 From a1a3acb91fa132c8f7083d473c712581b1505609 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Thu, 14 Jun 2018 19:41:50 +0200 Subject: [PATCH 10/31] Remade errorprinter to use rich text Doc instead of ANSI Console --- src/types/Typechecker/TypeError.hs | 125 ++++++++++++++++++++++++----- 1 file changed, 107 insertions(+), 18 deletions(-) diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index db302255f..1bdc4e08e 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -16,6 +16,7 @@ module Typechecker.TypeError ( ) where import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Terminal import Data.Maybe import Data.List import Data.Char @@ -26,12 +27,14 @@ import Types import Typechecker.Environment import Typechecker.Backtrace import AST.AST hiding (showWithKind) -import AST.PrettyPrinter -import System.Console.ANSI +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_) +($+$) s e = s <> line <> e + refTypeName :: Type -> String refTypeName ty | isClassType ty = "class '" ++ getId ty ++ "'" @@ -62,17 +65,102 @@ instance Show TCError where "" -> "" s -> s ++ "\n" ---TypeWithCapabilityMismatchError Type Type Type ---TypeWithCapabilityMismatchError actual cap expected +colorError = A.setSGR [A.SetConsoleIntensity A.BoldIntensity, A.SetColor A.Foreground A.Vivid A.Red] +colorDescription = A.setSGR [A.SetColor A.Foreground A.Vivid A.White] +colorLogistic = A.setSGR [A.SetColor A.Foreground A.Vivid A.Blue] +colorErrorIndicator = A.setSGR [A.SetColor A.Foreground A.Dull A.Red] + +data TCStyle = Classification | Desc | Logistic | Highlight + +classify, desc, logistic, highlight :: Doc TCStyle -> Doc TCStyle +classify = annotate Classification +desc = annotate Desc +logistic = annotate Logistic +highlight = annotate Highlight + +-- Possible Ansi render settings +-- +-- Color commands: color, colorDull +-- Colors: Black, Red, Green, Yellow, Blue, Magenta, Cyan, White +-- Font Styles: bold, italicized, underlined +toErrorStyle :: TCStyle -> AnsiStyle +toErrorStyle Classification = color Red <> bold +toErrorStyle Desc = bold +toErrorStyle Logistic = color Blue +toErrorStyle Highlight = colorDull Red + +toWarningStyle :: TCStyle -> AnsiStyle +toWarningStyle Classification = color Yellow <> bold +toWarningStyle Desc = bold +toWarningStyle Logistic = color Blue +toWarningStyle Highlight = colorDull Yellow + + +ppError ::TCError -> IO () +ppError (TCError err Env{bt = []}) = + putDoc $ reAnnotate toErrorStyle $ pError err <+> description err <> line +ppError err@(TCError _ Env{bt = ((pos, _):_)}) = do + code <- getCodeLines pos + putDoc $ reAnnotate toErrorStyle $ richError err code <> line <> line + +richError :: TCError -> [String] -> Doc TCStyle +richError (TCError err Env{bt = bt@((pos, _):_)}) code = + pError err <+> description err $+$ codeViewer pos code <+> smallSuggest err + + +pError :: Error -> Doc TCStyle +pError _ = classify $ pretty "Error:" +description :: Error -> Doc TCStyle +description err = desc $ viaShow err + +codeLine :: String -> String -> Int -> Doc TCStyle +codeLine insertStr codeLine lineNo = + logistic ((pretty lineNo) <+> pipe) <> + highlight (pretty insertStr) <> + pretty codeLine + +showPosition :: Position -> Int -> Doc TCStyle +showPosition pos offset = indent offset $ logistic (pretty "-->") <+> viaShow pos + +lineHighlighter :: Int -> Int -> Char -> Doc ann +lineHighlighter s e c = indent (s-1) $ pretty $ replicate (e-s) c + +multilineHighlighter :: Int -> Bool -> Char -> Doc ann +multilineHighlighter col True c = indent 2 (pretty (replicate (col-1) '_') <> pretty c) +multilineHighlighter col False c = indent 1 pipe <> (pretty (replicate (col-2) '_') <> pretty c) + +codeViewer :: Position -> [String] -> Doc TCStyle +codeViewer pos (cHead:cTail)= + let + ((sL, sC), (eL, eC)) = getPositions pos + digitLen = length $ show sL + tailCode = zipWith (codeLine " |") cTail (range (sL+1, eL)) + in + if sL == eL + then + showPosition pos digitLen $+$ + logistic (indent (digitLen+1) pipe) $+$ + codeLine "" cHead sL $+$ + logistic (indent (digitLen+1) pipe) <> + highlight (lineHighlighter sC eC '^') + else + showPosition pos digitLen $+$ + logistic (indent (digitLen+1) pipe) $+$ + codeLine " " cHead sL $+$ + logistic (indent (digitLen+1) pipe) <> + highlight (multilineHighlighter sC True '^') $+$ + vsep tailCode $+$ + logistic (indent (digitLen+1) pipe) <> + highlight (multilineHighlighter eC False '^') + +smallSuggest :: Error -> Doc TCStyle +smallSuggest err = highlight $ pretty "-> Something useful <-" -colorError = setSGR [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Red] -colorDescription = setSGR [SetColor Foreground Vivid White] -colorLogistic = setSGR [SetColor Foreground Vivid Blue] -colorErrorIndicator = setSGR [SetColor Foreground Dull Red] printError :: TCError -> IO () --printError (TCError err@NonAssignableLHSError Env{bt = bt@((pos, _):_)}) = do -printError (TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((pos, _):_)}) = do +printError err = ppError err +printErrorOld hm@(TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((pos, _):_)}) = do printError err printPosition pos @@ -85,23 +173,23 @@ printError (TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((po printf "Error: " colorDescription printf $ show err ++ "\n" - setSGR [Reset] + A.setSGR [A.Reset] printPosition pos = do colorLogistic printf " --> " - setSGR [Reset] + A.setSGR [A.Reset] printf $ show pos printCodeViewer :: Position -> String -> IO () printCodeViewer pos smallSuggestion = do let ((sL, sC), (eL, eC)) = getPositions pos let digitSpace = replicate (length $ show sL) ' ' - cHead:cTail <- getCodeLines pos sL eL + cHead:cTail <- getCodeLines pos colorLogistic printf "\n%s |" digitSpace - setSGR [Reset] + A.setSGR [A.Reset] if sL == eL then do @@ -123,7 +211,7 @@ printError (TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((po printf " |%s^" (replicate (eC-2) '_') printf " %s\n\n" smallSuggestion - setSGR [Reset] + A.setSGR [A.Reset] errorIndicator :: Int -> Int -> String @@ -135,13 +223,14 @@ printError (TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((po printf "\n%s |" (show lineNo) colorErrorIndicator printf insertStr - setSGR [Reset] + A.setSGR [A.Reset] printf codeLine -printError err = printf $ show err +printErrorOld err = printf $ show err -getCodeLines :: Position -> Int -> Int -> IO [String] -getCodeLines pos sL eL = do +getCodeLines :: Position -> IO [String] +getCodeLines pos = do + let ((sL, _), (eL, _)) = getPositions pos let start = sL-1 let end = eL-start contents <- readFile $ getPositionFile pos From a63903dd76c892a7ad9288b764239129a8ea275f Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Fri, 15 Jun 2018 18:52:14 +0200 Subject: [PATCH 11/31] Refactoring and modularization Extracted the printer to own file so that TypeError only holds the data structures and text for different error descriptions/suggestions. Also removed all deprecated code. --- src/front/TopLevel.hs | 24 ++- src/ir/AST/Meta.hs | 2 +- src/types/Typechecker/Errorprinter.hs | 118 +++++++++++++ src/types/Typechecker/TypeError.hs | 230 +++++--------------------- 4 files changed, 172 insertions(+), 202 deletions(-) create mode 100644 src/types/Typechecker/Errorprinter.hs diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index 14593aaee..acae43f34 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -41,7 +41,7 @@ import ModuleExpander import Typechecker.Environment(buildLookupTable) import Typechecker.Prechecker(precheckProgram) import Typechecker.Typechecker(typecheckProgram, checkForMainClass) -import Typechecker.TypeError(printError) +import Typechecker.Errorprinter import Typechecker.Capturechecker(capturecheckProgram) import Optimizer.Optimizer import CodeGen.Main @@ -350,7 +350,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 @@ -373,7 +373,7 @@ main = (Right ast, warnings) -> return (ast, warnings) (Left error, warnings) -> do showWarnings warnings - abort $ show error + errorAbort error showWarnings precheckingWarnings return precheckedAST @@ -388,17 +388,10 @@ main = (Right (newEnv, ast), warnings) -> return (ast, warnings) (Left error, warnings) -> do showWarnings warnings - printf "*** Error during typechecking *** \n\n" - printError error - let errorlen = length [error] - abort $ "\nAborting due to " ++ show errorlen ++ errors errorlen - --abort $ show error + errorAbort error showWarnings typecheckingWarnings return typecheckedAST - errors 1 = " error" - errors _ = " errors" - capturecheckProgramTable :: ProgramTable -> IO ProgramTable capturecheckProgramTable table = do let lookupTableTable = fmap buildLookupTable table @@ -410,7 +403,7 @@ 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" @@ -436,4 +429,9 @@ 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 $ "\nAborting due to previous error" \ No newline at end of file diff --git a/src/ir/AST/Meta.hs b/src/ir/AST/Meta.hs index e2ffa5b95..79b794bbb 100644 --- a/src/ir/AST/Meta.hs +++ b/src/ir/AST/Meta.hs @@ -66,7 +66,7 @@ getPos = position getPositions :: Position -> ((Int, Int), (Int, Int)) getPositions pos = case pos of - SingletonPos start -> ((line start, column start), (line start, column start)) + 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) diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs new file mode 100644 index 000000000..413dbf9d8 --- /dev/null +++ b/src/types/Typechecker/Errorprinter.hs @@ -0,0 +1,118 @@ + +module Typechecker.Errorprinter (printError) where + + +import Typechecker.Environment +import Typechecker.TypeError +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Terminal +import AST.Meta(Position, getPositionFile, getPositions) +import Data.Ix(range) + +($+$) s e = s <> line <> e + + +-- Possible Ansi render settings +-- +-- Color commands: color, colorDull +-- Colors: Black, Red, Green, Yellow, Blue, Magenta, Cyan, White +-- Font Styles: bold, italicized, underlined +toErrorStyle :: TCStyle -> AnsiStyle +toErrorStyle Classification = color Red <> bold +toErrorStyle Desc = bold +toErrorStyle Logistic = color Blue +toErrorStyle Highlight = colorDull Red + +toWarningStyle :: TCStyle -> AnsiStyle +toWarningStyle Classification = color Yellow <> bold +toWarningStyle Desc = bold +toWarningStyle Logistic = color Blue +toWarningStyle Highlight = colorDull Yellow + + +printError :: TCError -> IO () +printError err@(TCError _ Env{bt = []}) = + putDoc $ reAnnotate toErrorStyle $ prettyError err [] <> line +printError err@(TCError _ Env{bt = ((pos, _):_)}) = do + code <- getCodeLines pos + putDoc $ reAnnotate toErrorStyle $ prettyError err code <> line + + +-- 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 +prettyError (TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((pos, _):_)}) code = + declareError err <+> description err $+$ codeViewer pos code err +prettyError (TCError err Env{bt = []}) _ = + declareError err <+> description err +prettyError (TCError err Env{bt = bt@((pos, _):_)}) code = + declareError err <+> description err $+$ codeViewer pos code err +-- Possible extensions: +-- Duplicate Class -> print positions (File + line) of the two classes +-- Type error in func call -> print a version of codeViewer that also shows the function head + + +declareError :: Error -> Doc TCStyle +declareError _ = classify $ pretty "Error:" + +description :: Error -> Doc TCStyle +description err = desc $ viaShow err + +codeLine :: String -> String -> Int -> Doc TCStyle +codeLine insertStr codeLine lineNo = + logistic ((pretty lineNo) <+> pipe) <> + highlight (pretty insertStr) <> + pretty codeLine + +showPosition :: Position -> Doc TCStyle +showPosition pos = logistic (pretty "-->") <+> viaShow pos + +lineHighlighter :: Int -> Int -> Char -> Doc ann +lineHighlighter s e c = indent (s-1) $ pretty $ replicate (e-s) c + +multilineHighlighter :: Int -> Bool -> Char -> Doc ann +multilineHighlighter col True c = indent 2 (pretty (replicate (col-1) '_') <> pretty c) +multilineHighlighter col False c = indent 1 pipe <> (pretty (replicate (col-2) '_') <> pretty c) + +codeViewer :: Position -> [String] -> Error -> Doc TCStyle +codeViewer _ [] _ = error "TypeError.hs: No code to view" +codeViewer pos (cHead:cTail) err = + let + ((sL, sC), (eL, eC)) = getPositions pos + digitLen = length $ show sL + tailCode = zipWith (codeLine " |") cTail (range (sL+1, eL)) + in + if sL == eL + then + nest (digitLen+1) $ indent digitLen (showPosition pos) $+$ + logistic pipe <> + nest (-(digitLen+1)) (line <> codeLine "" cHead sL) $+$ + logistic pipe <> + highlight (lineHighlighter sC eC '^') <+> + smallSuggest err $+$ + longSuggest err + else + nest (digitLen+1) $ indent digitLen (showPosition pos) $+$ + logistic pipe <> + nest (-(digitLen+1)) (line <> codeLine " " cHead sL) $+$ + logistic pipe <> + highlight (multilineHighlighter sC True '^') <> + nest (-(digitLen+1)) (line <> vsep tailCode) $+$ + logistic pipe <> + highlight (multilineHighlighter eC False '^') <+> + smallSuggest err $+$ + longSuggest err + + +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 l diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 1bdc4e08e..45a347b3d 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -12,7 +12,13 @@ module Typechecker.TypeError ( ,Error(..) ,TCWarning(TCWarning) ,Warning(..) - ,printError + ,smallSuggest + ,longSuggest + ,TCStyle(..) + ,classify + ,desc + ,logistic + ,highlight ) where import Data.Text.Prettyprint.Doc @@ -33,7 +39,6 @@ import AST.Meta(Position, getPositionFile, getPositions) import Data.Ix(range) import Control.Monad(zipWithM_) -($+$) s e = s <> line <> e refTypeName :: Type -> String refTypeName ty @@ -50,193 +55,7 @@ refTypeName ty -- | The data type for a type checking error. Showing it will -- produce an error message and print the backtrace. data TCError = TCError Error Environment -instance Show TCError where - show (TCError err Env{bt = []}) = - " *** Error during typechecking *** \n" ++ - show err ++ "\n" - show (TCError err Env{bt = 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" - -colorError = A.setSGR [A.SetConsoleIntensity A.BoldIntensity, A.SetColor A.Foreground A.Vivid A.Red] -colorDescription = A.setSGR [A.SetColor A.Foreground A.Vivid A.White] -colorLogistic = A.setSGR [A.SetColor A.Foreground A.Vivid A.Blue] -colorErrorIndicator = A.setSGR [A.SetColor A.Foreground A.Dull A.Red] - -data TCStyle = Classification | Desc | Logistic | Highlight - -classify, desc, logistic, highlight :: Doc TCStyle -> Doc TCStyle -classify = annotate Classification -desc = annotate Desc -logistic = annotate Logistic -highlight = annotate Highlight - --- Possible Ansi render settings --- --- Color commands: color, colorDull --- Colors: Black, Red, Green, Yellow, Blue, Magenta, Cyan, White --- Font Styles: bold, italicized, underlined -toErrorStyle :: TCStyle -> AnsiStyle -toErrorStyle Classification = color Red <> bold -toErrorStyle Desc = bold -toErrorStyle Logistic = color Blue -toErrorStyle Highlight = colorDull Red - -toWarningStyle :: TCStyle -> AnsiStyle -toWarningStyle Classification = color Yellow <> bold -toWarningStyle Desc = bold -toWarningStyle Logistic = color Blue -toWarningStyle Highlight = colorDull Yellow - - -ppError ::TCError -> IO () -ppError (TCError err Env{bt = []}) = - putDoc $ reAnnotate toErrorStyle $ pError err <+> description err <> line -ppError err@(TCError _ Env{bt = ((pos, _):_)}) = do - code <- getCodeLines pos - putDoc $ reAnnotate toErrorStyle $ richError err code <> line <> line - -richError :: TCError -> [String] -> Doc TCStyle -richError (TCError err Env{bt = bt@((pos, _):_)}) code = - pError err <+> description err $+$ codeViewer pos code <+> smallSuggest err - - -pError :: Error -> Doc TCStyle -pError _ = classify $ pretty "Error:" -description :: Error -> Doc TCStyle -description err = desc $ viaShow err - -codeLine :: String -> String -> Int -> Doc TCStyle -codeLine insertStr codeLine lineNo = - logistic ((pretty lineNo) <+> pipe) <> - highlight (pretty insertStr) <> - pretty codeLine - -showPosition :: Position -> Int -> Doc TCStyle -showPosition pos offset = indent offset $ logistic (pretty "-->") <+> viaShow pos - -lineHighlighter :: Int -> Int -> Char -> Doc ann -lineHighlighter s e c = indent (s-1) $ pretty $ replicate (e-s) c - -multilineHighlighter :: Int -> Bool -> Char -> Doc ann -multilineHighlighter col True c = indent 2 (pretty (replicate (col-1) '_') <> pretty c) -multilineHighlighter col False c = indent 1 pipe <> (pretty (replicate (col-2) '_') <> pretty c) - -codeViewer :: Position -> [String] -> Doc TCStyle -codeViewer pos (cHead:cTail)= - let - ((sL, sC), (eL, eC)) = getPositions pos - digitLen = length $ show sL - tailCode = zipWith (codeLine " |") cTail (range (sL+1, eL)) - in - if sL == eL - then - showPosition pos digitLen $+$ - logistic (indent (digitLen+1) pipe) $+$ - codeLine "" cHead sL $+$ - logistic (indent (digitLen+1) pipe) <> - highlight (lineHighlighter sC eC '^') - else - showPosition pos digitLen $+$ - logistic (indent (digitLen+1) pipe) $+$ - codeLine " " cHead sL $+$ - logistic (indent (digitLen+1) pipe) <> - highlight (multilineHighlighter sC True '^') $+$ - vsep tailCode $+$ - logistic (indent (digitLen+1) pipe) <> - highlight (multilineHighlighter eC False '^') - -smallSuggest :: Error -> Doc TCStyle -smallSuggest err = highlight $ pretty "-> Something useful <-" - - -printError :: TCError -> IO () ---printError (TCError err@NonAssignableLHSError Env{bt = bt@((pos, _):_)}) = do -printError err = ppError err -printErrorOld hm@(TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((pos, _):_)}) = do - - printError err - printPosition pos - printCodeViewer pos "Insert good suggestion here" - - where - printError _ = do - colorError - printf "Error: " - colorDescription - printf $ show err ++ "\n" - A.setSGR [A.Reset] - - printPosition pos = do - colorLogistic - printf " --> " - A.setSGR [A.Reset] - printf $ show pos - - printCodeViewer :: Position -> String -> IO () - printCodeViewer pos smallSuggestion = do - let ((sL, sC), (eL, eC)) = getPositions pos - let digitSpace = replicate (length $ show sL) ' ' - cHead:cTail <- getCodeLines pos - - colorLogistic - printf "\n%s |" digitSpace - A.setSGR [A.Reset] - - if sL == eL - then do - printLine "" cHead sL - colorLogistic - printf "\n%s |" digitSpace - colorErrorIndicator - printf $ errorIndicator sC eC - else do - printLine " " cHead sL - colorLogistic - printf "\n%s |" digitSpace - colorErrorIndicator - printf " %s^" (replicate (sC-1) '_') - zipWithM_ (printLine " |") cTail $ range (sL+1, eL) - colorLogistic - printf "\n%s |" digitSpace - colorErrorIndicator - printf " |%s^" (replicate (eC-2) '_') - - printf " %s\n\n" smallSuggestion - A.setSGR [A.Reset] - - - errorIndicator :: Int -> Int -> String - errorIndicator s e = replicate (s-1) ' ' ++ replicate (e-s) '^' - - printLine :: String -> String -> Int -> IO () - printLine insertStr codeLine lineNo = do - colorLogistic - printf "\n%s |" (show lineNo) - colorErrorIndicator - printf insertStr - A.setSGR [A.Reset] - printf codeLine - -printErrorOld err = printf $ show err - -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 l data Error = DistinctTypeParametersError Type @@ -1037,6 +856,41 @@ instance Show Warning where "This will be fixed in a later version of Encore." +($+$) s e = s <> line <> e +data TCStyle = Classification | Desc | Logistic | Highlight + +classify, desc, logistic, highlight :: Doc TCStyle -> Doc TCStyle +classify = annotate Classification +desc = annotate Desc +logistic = annotate Logistic +highlight = annotate Highlight + +highlightPretty :: String -> Doc TCStyle +highlightPretty = highlight . pretty + +makeNotation :: Doc TCStyle +makeNotation = logistic (pipe $+$ equals) <+> desc (pretty "note:") + + +class Suggestable a where + smallSuggest :: a -> Doc TCStyle + longSuggest :: a -> Doc TCStyle + +instance Suggestable Error where + smallSuggest (NonAssignableLHSError) = highlightPretty "Can only be used on var or fields" + smallSuggest _ = emptyDoc + + longSuggest (TypeWithCapabilityMismatchError actual cap expected) = + let typelist = pretty "expected type" <+> desc (viaShow expected) $+$ pretty "found type" <+> desc (viaShow actual) in + makeNotation <+> hang 3 typelist + longSuggest _ = emptyDoc + + +instance Suggestable Warning where + smallSuggest _ = emptyDoc + longSuggest _ = emptyDoc + + --hash (UnionMethodAmbiguityError _ _) = 3 --explain 3 = "stuff" \ No newline at end of file From b79364930924ced50e784a5835bbf7cd698dc189 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Sat, 23 Jun 2018 13:54:07 +0200 Subject: [PATCH 12/31] Reverted to use pretty-1.1.3.* instead of prettyprinter-1.2.1 This is due to the visual bugs in prettyprinter.hs introduced by the differences on how the libraries handle empty documents as well as differences with functions such as nest and hang. --- encore.cabal | 3 +- src/back/CCode/PrettyCCode.hs | 90 +++++++++--------- src/front/Makefile.hs | 66 ++++++------- src/ir/AST/PrettyPrinter.hs | 131 +++++++++++++------------- src/types/Typechecker/Backtrace.hs | 2 +- src/types/Typechecker/Errorprinter.hs | 91 ++++++++++-------- src/types/Typechecker/TypeError.hs | 25 ++--- stack.yaml | 4 +- 8 files changed, 213 insertions(+), 199 deletions(-) diff --git a/encore.cabal b/encore.cabal index be55e5b05..34604f35d 100644 --- a/encore.cabal +++ b/encore.cabal @@ -38,6 +38,7 @@ executable encorec , mtl ==2.2.* , megaparsec >= 5.1.2 , semigroups + , pretty >=1.1 && <1.2 , process >=1.2 && <1.3 , template-haskell , text >=1.1 @@ -47,8 +48,6 @@ executable encorec , boxes , filepath , ansi-terminal - , prettyprinter - , prettyprinter-ansi-terminal hs-source-dirs: src/back src/front src/ir src/opt src/parser src/types ghc-options: -Werror default-language: Haskell2010 diff --git a/src/back/CCode/PrettyCCode.hs b/src/back/CCode/PrettyCCode.hs index be90fffd1..abecd7aeb 100644 --- a/src/back/CCode/PrettyCCode.hs +++ b/src/back/CCode/PrettyCCode.hs @@ -8,99 +8,101 @@ Converting CCode (see "CCode.Main") to C source. module CCode.PrettyCCode (pp) where import CCode.Main -import Data.Text.Prettyprint.Doc hiding(indent) +import Text.PrettyPrint import Data.List indent = nest 2 -($+$) s e = s <> line <> e -- | Converts a CCode value to its source representation pp :: CCode a -> String pp = show . pp' -addSemi :: Doc ann -> Doc ann +tshow :: Show t => t -> Doc +tshow = text . show + +addSemi :: Doc -> Doc addSemi d | null (show d) || isSuffixOf ";" (show d) = d | otherwise = d <> ";" -commaSep :: [Doc ann] -> Doc ann +commaSep :: [Doc] -> Doc commaSep = hcat . intersperse ", " -switchBody :: [(CCode Name, CCode Stat)] -> CCode Stat -> Doc ann +switchBody :: [(CCode Name, CCode Stat)] -> CCode Stat -> Doc switchBody ccodes defCase = bracedBlock $ vcat (map switchClause ccodes) $+$ "default:" $+$ (bracedBlock . vcat . map pp') [defCase] where - switchClause :: (CCode Name, CCode Stat) -> Doc ann + switchClause :: (CCode Name, CCode Stat) -> Doc switchClause (lhs,rhs) = "case" <+> pp' lhs <> ":" $+$ (bracedBlock . vcat . map pp') (rhs:[Embed "break;"]) -pp' :: CCode a -> Doc ann +pp' :: CCode a -> Doc pp' (Program cs) = pp' cs -pp' Skip = emptyDoc +pp' Skip = empty pp' Null = "NULL" -pp' (Includes ls) = vcat $ map (pretty . ("#include <"++) . (++">")) ls -pp' (LocalInclude s) = "#include" <+> dquotes (pretty s) +pp' (Includes ls) = vcat $ map (text . ("#include <"++) . (++">")) ls +pp' (LocalInclude s) = "#include" <+> doubleQuotes (text s) pp' (IfDefine str ccode) = - "#ifdef" <+> pretty str $+$ pp' ccode $+$ - "#endif /* ifdef" <+> pretty str <+> "*/" + "#ifdef" <+> text str $+$ pp' ccode $+$ + "#endif /* ifdef" <+> text str <+> "*/" pp' (IfNDefine str ccode) = - "#ifndef" <+> pretty str $+$ pp' ccode $+$ - "#endif /* ifndef" <+> pretty str <+> "*/" -pp' (HashDefine str) = "#define" <+> pretty str + "#ifndef" <+> text str $+$ pp' ccode $+$ + "#endif /* ifndef" <+> text str <+> text "*/" +pp' (HashDefine str) = "#define" <+> text str pp' (Statement other) = addSemi $ pp' other pp' (Switch tst ccodes def) = - "switch" <+> parens (viaShow tst) $+$ + "switch" <+> parens (tshow tst) $+$ switchBody ccodes def pp' (StructDecl name vardecls) = - "struct " <> viaShow name $+$ (addSemi . bracedBlock . vcat) (map pp' fields) + "struct " <> tshow name $+$ (addSemi . bracedBlock . vcat) (map pp' fields) where fields = map (\(ty, id) -> Embed $ show ty ++ " " ++ show id ++ ";") vardecls -pp' (Struct name) = "struct " <> viaShow name +pp' (Struct name) = "struct " <> tshow name pp' (Record ccodes) = braces $ commaList ccodes pp' (Assign lhs rhs) = addSemi $ pp' lhs <+> "=" <+> pp' rhs pp' (AssignTL lhs rhs) = addSemi $ pp' lhs <+> "=" <+> pp' rhs -pp' (Decl (ty, id)) = viaShow ty <+> viaShow id -pp' (DeclTL (ty, id)) = addSemi $ viaShow ty <+> viaShow id +pp' (Decl (ty, id)) = tshow ty <+> tshow id +pp' (DeclTL (ty, id)) = addSemi $ tshow ty <+> tshow id pp' (FunTypeDef id ty argTys) = - addSemi $ "typedef" <+> viaShow ty <+> parens ("*" <> viaShow id) <> + addSemi $ "typedef" <+> tshow ty <+> parens ("*" <> tshow id) <> parens (commaList argTys) pp' (Concat ccodes) = vcat $ intersperse "\n" $ map pp' ccodes pp' (Seq ccodes) = vcat $ map (addSemi . pp') ccodes pp' (Enum ids) = - "enum" $+$ bracedBlock (vcat $ map (\id -> viaShow id <> ",") ids) <> ";" + "enum" $+$ bracedBlock (vcat $ map (\id -> tshow id <> ",") ids) <> ";" pp' (Braced ccode) = (bracedBlock . pp') ccode pp' (Parens ccode) = parens $ pp' ccode pp' (CUnary o e) = parens $ pp' o <+> pp' e pp' (BinOp o e1 e2) = parens $ pp' e1 <+> pp' o <+> pp' e2 -pp' (Dot ccode id) = pp' ccode <> "." <> viaShow id -pp' (Arrow ccode id) = pp' ccode <> "->" <> viaShow id +pp' (Dot ccode id) = pp' ccode <> "." <> tshow id +pp' (Arrow ccode id) = pp' ccode <> "->" <> tshow id pp' (Deref ccode) = parens $ "*" <> pp' ccode pp' (Cast ty e) = parens $ parens (pp' ty) <+> pp' e -pp' (ArrAcc i l) = parens $ pp' l <> brackets (viaShow i) +pp' (ArrAcc i l) = parens $ pp' l <> brackets (tshow i) pp' (Amp ccode) = parens $ "&" <> parens (pp' ccode) pp' (Ptr ty) = pp' ty <> "*" pp' (FunctionDecl retTy name args) = - viaShow retTy <+> viaShow name <> + tshow retTy <+> tshow name <> parens (commaList args) <> ";" pp' (Function retTy name args body) = - viaShow retTy <+> viaShow name <> + tshow retTy <+> tshow name <> parens (ppArgs args) $+$ (bracedBlock . pp') body pp' (AsExpr c) = pp' c pp' (AsLval c) = pp' c pp' (AsType c) = pp' c -pp' (Nam st) = pretty st -pp' (Var st) = pretty st -pp' (Typ st) = pretty st +pp' (Nam st) = text st +pp' (Var st) = text st +pp' (Typ st) = text st pp' (Static ty) = "static" <+> pp' ty pp' (Extern ty) = "extern" <+> pp' ty -pp' (Embed string) = pretty string +pp' (Embed string) = text string pp' (EmbedC ccode) = pp' ccode -pp' (Call name args) = viaShow name <> parens (commaList args) -pp' (Typedef ty name) = "typedef" <+> pp' ty <+> viaShow name <> ";" +pp' (Call name args) = tshow name <> parens (commaList args) +pp' (Typedef ty name) = "typedef" <+> pp' ty <+> tshow name <> ";" pp' (Sizeof ty) = "sizeof" <> parens (pp' ty) pp' (While cond body) = "while" <+> parens (pp' cond) $+$ @@ -117,12 +119,12 @@ pp' (Ternary c t e) = pp' c <> "?" <+> pp' t <> ":" <+> pp' e pp' (Return e) = "return" <+> pp' e <> ";" pp' (Break) = "break;" pp' (Continue) = "continue;" -pp' (UnionInst name e) = "{." <> viaShow name <+> "=" <+> pp' e <> "}" -pp' (Int n) = viaShow n -pp' (String s) = viaShow s -pp' (Char c) = viaShow c -pp' (Double d) = viaShow d -pp' (Comm s) = pretty $ "/* " ++ s ++ " */" +pp' (UnionInst name e) = "{." <> tshow name <+> "=" <+> pp' e <> "}" +pp' (Int n) = tshow n +pp' (String s) = tshow s +pp' (Char c) = tshow c +pp' (Double d) = tshow d +pp' (Comm s) = text $ "/* " ++ s ++ " */" pp' (Annotated s ccode) = pp' ccode <+> pp' (Comm s) pp' (FunPtrDecl t name argTypes) = let @@ -145,15 +147,15 @@ pp' (DesignatedInitializer pairs) = in "{" <> body <> "}" -commaList :: [CCode a] -> Doc ann +commaList :: [CCode a] -> Doc commaList l = commaSep $ map pp' l -ppArgs :: [CVarSpec] -> Doc ann -ppArgs [] = emptyDoc +ppArgs :: [CVarSpec] -> Doc +ppArgs [] = empty ppArgs as = commaSep $ map ppArg as -ppArg (ty, id) = viaShow ty <+> viaShow id +ppArg (ty, id) = tshow ty <+> tshow id -bracedBlock :: Doc ann -> Doc ann +bracedBlock :: Doc -> Doc bracedBlock doc = lbrace $+$ indent doc $+$ rbrace diff --git a/src/front/Makefile.hs b/src/front/Makefile.hs index 1bdb98ef8..a6c3569db 100644 --- a/src/front/Makefile.hs +++ b/src/front/Makefile.hs @@ -1,35 +1,34 @@ module Makefile where -import Data.Text.Prettyprint.Doc +import Text.PrettyPrint import Data.String.Utils import Prelude hiding(all) -($$) s e = s <> hardline <> e -($\$) t ts = (t <> hardline <> hardline <> ts) -tab = pretty "\t" -all = pretty "all" -bench = pretty "bench" -clean = pretty "clean" -rm args = (pretty "rm -rf" <+> hsep args) -phony = pretty ".PHONY" -cc args = (pretty "$(CC)" <+> hsep args) -flags = pretty "$(FLAGS)" -benchFlags = pretty "$(BENCH_FLAGS)" -target = pretty "$(TARGET)" -inc = pretty "$(INC)" -lib = pretty "$(LIB)" -deps = pretty "$(DEPS)" -defs = pretty "$(DEFINES)" -dSYM = pretty ".dSYM" -i = (pretty "-I" <+>) -o = (pretty "-o" <+>) -parent = pretty ".." +($\$) t = ((t <> text "\n") $$) +tab = text "\t" +all = text "all" +bench = text "bench" +clean = text "clean" +rm args = (text "rm -rf" <+> hsep args) +phony = text ".PHONY" +cc args = (text "$(CC)" <+> hsep args) +flags = text "$(FLAGS)" +benchFlags = text "$(BENCH_FLAGS)" +target = text "$(TARGET)" +inc = text "$(INC)" +lib = text "$(LIB)" +deps = text "$(DEPS)" +defs = text "$(DEFINES)" +dSYM = text ".dSYM" +i = (text "-I" <+>) +o = (text "-o" <+>) +parent = text ".." generateMakefile :: [String] -> - String -> String -> String -> String -> String -> String -> Doc ann + String -> String -> String -> String -> String -> String -> Doc generateMakefile classFiles progName compiler ccFlags incPath defines libs = decl "CC" [compiler] $$ @@ -47,20 +46,23 @@ generateMakefile classFiles progName compiler ccFlags incPath defines libs = $$ decl "DEPS" ("shared.c" : classFiles) $\$ - noCmdRule all target + rule all target + empty $\$ rule target deps - (cc [flags, i inc, i parent, deps, lib, lib, defs, o target]) + (cc [flags, i inc, i parent, deps, lib, lib, defs, o target]) $\$ rule bench deps - (cc [benchFlags, i inc, i parent, deps, lib, lib, defs, o target]) + (cc [benchFlags, i inc, i parent, deps, lib, lib, defs, o target]) $\$ - rule clean emptyDoc - (rm [target, target <> dSYM]) + rule clean empty + (rm [target, target <> dSYM]) $\$ - noCmdRule phony (all <+> bench <+> clean) + rule phony (all <+> bench <+> clean) + empty where - decl var rhs = pretty var <> equals <> hsep (map pretty rhs) - rule target deps cmd = target <> colon <+> deps $$ - tab <> cmd - noCmdRule target deps = target <> colon <+> deps + decl var rhs = text var <> equals <> hsep (map text rhs) + rule target deps cmd + | isEmpty cmd = target <> colon <+> deps + | otherwise = target <> colon <+> deps $$ + tab <> cmd diff --git a/src/ir/AST/PrettyPrinter.hs b/src/ir/AST/PrettyPrinter.hs index 390dc85c0..057e4eb9c 100644 --- a/src/ir/AST/PrettyPrinter.hs +++ b/src/ir/AST/PrettyPrinter.hs @@ -19,7 +19,8 @@ module AST.PrettyPrinter (ppExpr ) where -- Library dependencies -import Data.Text.Prettyprint.Doc hiding(indent) +import qualified Text.PrettyPrint as P +import Text.PrettyPrint hiding(brackets) -- Module dependencies import Identifiers @@ -27,28 +28,27 @@ import Types import AST.AST indent = nest 2 -($+$) s e = s <> line <> e commaSep l = hcat $ punctuate ", " l ---brackets s = hcat ["[", s, "]"] +brackets s = hcat ["[", s, "]"] -ppMut :: Mutability -> Doc ann +ppMut :: Mutability -> Doc ppMut Val = "val" ppMut Var = "var" -ppName :: Name -> Doc ann -ppName = viaShow +ppName :: Name -> Doc +ppName = text . show -ppNamespace :: Namespace -> Doc ann -ppNamespace = viaShow +ppNamespace :: Namespace -> Doc +ppNamespace = text . show -ppQName :: QualifiedName -> Doc ann -ppQName = viaShow +ppQName :: QualifiedName -> Doc +ppQName = text . show -ppType :: Type -> Doc ann -ppType = viaShow +ppType :: Type -> Doc +ppType = text . show -ppProgram :: Program -> Doc ann +ppProgram :: Program -> Doc ppProgram Program{moduledecl, etl, imports, typedefs, functions, traits, classes} = ppModuleDecl moduledecl $+$ vcat (map ppEmbedded etl) <+> @@ -65,18 +65,18 @@ ppEmbedded EmbedTL{etlheader=header, etlbody=code} = ppHeader header code = if null header && null code - then emptyDoc - else "EMBED" $+$ pretty header $+$ "BODY" $+$ pretty code $+$ "END\n" + then empty + else "EMBED" $+$ text header $+$ "BODY" $+$ text code $+$ "END\n" -ppModuleDecl :: ModuleDecl -> Doc ann -ppModuleDecl NoModule = emptyDoc +ppModuleDecl :: ModuleDecl -> Doc +ppModuleDecl NoModule = empty ppModuleDecl Module{modname, modexports} = "module" <+> ppName modname <> case modexports of Just names -> parens (commaSep $ map ppName names) - Nothing -> emptyDoc + Nothing -> empty -ppImportDecl :: ImportDecl -> Doc ann +ppImportDecl :: ImportDecl -> Doc ppImportDecl Import {itarget ,iqualified ,ihiding @@ -91,41 +91,41 @@ ppImportDecl Import {itarget maybeSelect = case iselect of Just names -> parens (commaSep $ map ppName names) - Nothing -> emptyDoc + Nothing -> empty maybeHiding = case ihiding of Just names -> " hiding" <> parens (commaSep $ map ppName names) - Nothing -> emptyDoc + Nothing -> empty maybeAlias = case ialias of Just alias -> " as" <+> ppNamespace alias - Nothing -> emptyDoc + Nothing -> empty -ppTypedef :: Typedef -> Doc ann +ppTypedef :: Typedef -> Doc ppTypedef Typedef { typedefdef=t } = "typedef" <+> ppType t <+> "=" <+> ppType (typeSynonymRHS t) -ppFunctionHeader :: FunctionHeader -> Doc ann +ppFunctionHeader :: FunctionHeader -> Doc ppFunctionHeader header = ppName (hname header) <> ppTypeParams (htypeparams header) <> parens (commaSep $ map ppParamDecl $ hparams header) <+> ":" <+> ppType (htype header) -ppTypeParams :: [Type] -> Doc ann +ppTypeParams :: [Type] -> Doc ppTypeParams params = if null params - then emptyDoc + then empty else brackets (commaSep $ map ppTypeParam params) where ppTypeParam ty | Just bound <- getBound ty = ppType ty <+> ":" <+> ppType bound | otherwise = ppType ty -ppFunctionHelper :: FunctionHeader -> Expr -> [Function] -> Doc ann +ppFunctionHelper :: FunctionHeader -> Expr -> [Function] -> Doc ppFunctionHelper funheader funbody [] = "fun" <+> ppFunctionHeader funheader $+$ indent (ppBody funbody) $+$ @@ -137,29 +137,29 @@ ppFunctionHelper funheader funbody funlocals = indent (vcat $ map ppFunction funlocals) $+$ "end" -ppFunction :: Function -> Doc ann +ppFunction :: Function -> Doc ppFunction Function {funheader, funbody, funlocals} = ppFunctionHelper funheader funbody funlocals -ppTraitDecl :: TraitDecl -> Doc ann +ppTraitDecl :: TraitDecl -> Doc ppTraitDecl Trait {tname, treqs, tmethods} = - trait <+> pretty (showWithoutMode tname) $+$ - indent (vcat (map ppRequirement treqs) $+$ + trait <+> text (showWithoutMode tname) $+$ + indent (vcat (map ppRequirement treqs) $$ vcat (map ppMethodDecl tmethods)) $+$ "end" where trait | isModeless tname = "trait" - | otherwise = pretty $ showModeOf tname ++ " trait" + | otherwise = text $ showModeOf tname ++ " trait" ppRequirement RequiredField{rfield} = "require" <+> ppFieldDecl rfield ppRequirement RequiredMethod{rheader} = "require" <+> "def" <+> ppFunctionHeader rheader -ppTraitExtension :: TraitExtension -> Doc ann +ppTraitExtension :: TraitExtension -> Doc ppTraitExtension FieldExtension{extname} = ppName extname ppTraitExtension MethodExtension{extname} = ppName extname <> "()" -ppComposition :: TraitComposition -> Doc ann +ppComposition :: TraitComposition -> Doc ppComposition Conjunction{tcleft, tcright} = ppConjunctionChild tcleft <+> "*" <+> ppConjunctionChild tcright where @@ -169,33 +169,33 @@ ppComposition Disjunction{tcleft, tcright} = ppComposition tcleft <+> "+" <+> ppComposition tcright ppComposition TraitLeaf{tcname, tcext} = ppType tcname <> if null tcext - then emptyDoc + then empty else parens (commaSep (map ppTraitExtension tcext)) -ppClassDecl :: ClassDecl -> Doc ann +ppClassDecl :: ClassDecl -> Doc ppClassDecl Class {cname, cfields, cmethods, ccomposition} = - clss <+> pretty (showWithoutMode cname) <+> compositionDoc $+$ - indent (vcat (map ppFieldDecl cfields) $+$ + clss <+> text (showWithoutMode cname) <+> compositionDoc $+$ + indent (vcat (map ppFieldDecl cfields) $$ vcat (map ppMethodDecl cmethods)) $+$ "end" where clss | isModeless cname = "class" - | otherwise = pretty $ showModeOf cname ++ " class" + | otherwise = text $ showModeOf cname ++ " class" compositionDoc = case ccomposition of Just c -> ":" <+> ppComposition c - Nothing -> emptyDoc + Nothing -> empty -ppFieldDecl :: FieldDecl -> Doc ann -ppFieldDecl = viaShow +ppFieldDecl :: FieldDecl -> Doc +ppFieldDecl = text . show -ppParamDecl :: ParamDecl -> Doc ann +ppParamDecl :: ParamDecl -> Doc ppParamDecl (Param {pmut = Val, pname, ptype}) = ppName pname <+> ":" <+> ppType ptype ppParamDecl (Param {pmut = Var, pname, ptype}) = "var" <+> ppName pname <+> ":" <+> ppType ptype -ppMethodDecl :: MethodDecl -> Doc ann +ppMethodDecl :: MethodDecl -> Doc ppMethodDecl m = let header = mheader m modifiers = hmodifiers header @@ -210,9 +210,9 @@ ppMethodDecl m = indent (ppBody body) $+$ endOrLocals where - ppModifiers [] = emptyDoc + ppModifiers [] = empty ppModifiers mods = hcat $ punctuate " " $ - map (viaShow) mods + map (text . show) mods endOrLocals | null (mlocals m) = "end" | otherwise = @@ -228,27 +228,26 @@ isSimple MessageSend {target} = isSimple target isSimple FunctionCall {} = True isSimple _ = False -maybeParens :: Expr -> Doc ann +maybeParens :: Expr -> Doc maybeParens e | isSimple e = ppExpr e | otherwise = parens $ ppExpr e -ppSugared :: Expr -> Doc ann +ppSugared :: Expr -> Doc ppSugared e = case getSugared e of Just e' -> ppExpr e' Nothing -> ppExpr e -ppBody :: Expr -> Doc ann ppBody (Seq {eseq}) = vcat $ map ppExpr eseq ppBody e = ppExpr e -withTypeArguments :: [Type] -> Doc ann +withTypeArguments :: [Type] -> Doc withTypeArguments typeArguments = if null typeArguments - then emptyDoc + then empty else brackets (commaSep (map ppType typeArguments)) -ppExpr :: Expr -> Doc ann +ppExpr :: Expr -> Doc ppExpr Skip {} = "()" ppExpr Break {} = "break" ppExpr Continue {} = "Continue" @@ -264,9 +263,9 @@ ppExpr Optional {optTag = QuestionDot MethodCall {target, name, args, typeArgume ppExpr Optional {optTag = QuestionDot FieldAccess {target, name}} = maybeParens target <> "?." <> ppName name ppExpr Optional {optTag} = error $ "PrettyPrinter.hs: don't know how to " ++ - "print expression '" ++ (show $ ppPath optTag) ++ "'" + "print expression '" ++ (render $ ppPath optTag) ++ "'" where - ppPath :: OptionalPathComponent -> Doc ann + ppPath :: OptionalPathComponent -> Doc ppPath (QuestionBang e) = ppExpr e ppPath (QuestionDot e) = ppExpr e @@ -397,7 +396,7 @@ ppExpr ArraySize {target} = "|" <> ppExpr target <> "|" ppExpr ArrayNew {ty, size} = "new" <+> brackets (ppType ty) <> parens (ppExpr size) ppExpr ArrayLiteral {args} = brackets $ commaSep (map ppExpr args) ppExpr VarAccess {qname} = ppQName qname -ppExpr TupleAccess {target, compartment} = ppExpr target <> "." <> pretty compartment +ppExpr TupleAccess {target, compartment} = ppExpr target <> "." <> int compartment ppExpr Consume {target} = "consume" <+> ppExpr target ppExpr Assign {lhs, rhs} = ppExpr lhs <+> "=" <+> ppExpr rhs ppExpr Null {} = "null" @@ -409,11 +408,11 @@ ppExpr New {ty} = "new" <+> ppType ty ppExpr Print {args} = "print" <> parens (commaSep (map ppExpr args)) ppExpr Exit {args} = "exit" <> parens (commaSep (map ppExpr args)) ppExpr Abort {args} = "abort" <> parens (commaSep (map ppExpr args)) -ppExpr StringLiteral {stringLit} = viaShow stringLit -ppExpr CharLiteral {charLit} = viaShow charLit -ppExpr UIntLiteral {intLit} = pretty intLit <> "u" -ppExpr IntLiteral {intLit} = pretty intLit -ppExpr RealLiteral {realLit} = pretty realLit +ppExpr StringLiteral {stringLit} = text $ show stringLit +ppExpr CharLiteral {charLit} = text $ show charLit +ppExpr UIntLiteral {intLit} = int intLit <> "u" +ppExpr IntLiteral {intLit} = int intLit +ppExpr RealLiteral {realLit} = double realLit ppExpr RangeLiteral {start, stop, step} = "[" <> ppExpr start <> ".." <> ppExpr stop <> ppStep step <> "]" where @@ -424,26 +423,26 @@ ppExpr Embed {ty, embedded} = indent (hcat (map (uncurry ppPair) embedded)) $+$ "END" where - ppPair code Skip{} = pretty code - ppPair code expr = pretty code <> "#{" <> ppExpr expr <> "}" + ppPair code Skip{} = text code + ppPair code expr = text code <> "#{" <> ppExpr expr <> "}" ppExpr Unary {uop, operand} = ppUnary uop <> parens (ppExpr operand) ppExpr Binop {binop, loper, roper} = ppExpr loper <+> ppBinop binop <+> ppExpr roper ppExpr TypedExpr {body, ty} = ppExpr body <+> ":" <+> ppType ty -ppDecl :: ([VarDecl], Expr) -> Doc ann +ppDecl :: ([VarDecl], Expr) -> Doc ppDecl (vars, val) = commaSep (map ppVar vars) <+> "=" <+> ppExpr val -ppVar :: VarDecl -> Doc ann +ppVar :: VarDecl -> Doc ppVar (VarType x ty) = ppName x <+> ":" <+> ppType ty ppVar (VarNoType x) = ppName x -ppUnary :: UnaryOp -> Doc ann +ppUnary :: UnaryOp -> Doc ppUnary Identifiers.NOT = "not" ppUnary Identifiers.NEG = "-" -ppBinop :: BinaryOp -> Doc ann +ppBinop :: BinaryOp -> Doc ppBinop Identifiers.AND = "&&" ppBinop Identifiers.OR = "||" ppBinop Identifiers.LT = "<" diff --git a/src/types/Typechecker/Backtrace.hs b/src/types/Typechecker/Backtrace.hs index 07a1eb0b1..13946e4d9 100644 --- a/src/types/Typechecker/Backtrace.hs +++ b/src/types/Typechecker/Backtrace.hs @@ -17,7 +17,7 @@ module Typechecker.Backtrace(Backtrace import Data.Maybe import Data.List -import Data.Text.Prettyprint.Doc +import Text.PrettyPrint import Identifiers import AST.Meta(Position) diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs index 413dbf9d8..4922b1cda 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -4,38 +4,48 @@ module Typechecker.Errorprinter (printError) where import Typechecker.Environment import Typechecker.TypeError -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.Terminal import AST.Meta(Position, getPositionFile, getPositions) import Data.Ix(range) +import Text.PrettyPrint.Annotated.HughesPJ +import Text.Printf +import System.Console.ANSI -($+$) s e = s <> line <> e - - --- Possible Ansi render settings --- --- Color commands: color, colorDull --- Colors: Black, Red, Green, Yellow, Blue, Magenta, Cyan, White --- Font Styles: bold, italicized, underlined -toErrorStyle :: TCStyle -> AnsiStyle -toErrorStyle Classification = color Red <> bold -toErrorStyle Desc = bold -toErrorStyle Logistic = color Blue -toErrorStyle Highlight = colorDull Red - -toWarningStyle :: TCStyle -> AnsiStyle -toWarningStyle Classification = color Yellow <> bold -toWarningStyle Desc = bold -toWarningStyle Logistic = color Blue -toWarningStyle Highlight = colorDull Yellow printError :: TCError -> IO () printError err@(TCError _ Env{bt = []}) = - putDoc $ reAnnotate toErrorStyle $ prettyError err [] <> line + renderError $ prettyError err [] $+$ text "" + -- putDoc $ reAnnotate toErrorStyle $ prettyError err [] $+$ text "" printError err@(TCError _ Env{bt = ((pos, _):_)}) = do code <- getCodeLines pos - putDoc $ reAnnotate toErrorStyle $ prettyError err code <> line + renderError $ prettyError err code $+$ text "" + -- putDoc $ reAnnotate toErrorStyle $ prettyError err code $+$ text "" + +-- renderDecoratedM :: Monad m => (ann -> m r) -> (ann -> m r) -> (String -> m r) -> m r -> Doc ann -> m r +renderError doc = + renderDecoratedM toErrorStyle endAnn textprinter endDoc 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] + +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] + -- As long as there is no way to either: @@ -54,28 +64,29 @@ prettyError (TCError err Env{bt = bt@((pos, _):_)}) code = -- Duplicate Class -> print positions (File + line) of the two classes -- Type error in func call -> print a version of codeViewer that also shows the function head +pipe = char '|' declareError :: Error -> Doc TCStyle -declareError _ = classify $ pretty "Error:" +declareError _ = classify $ text "Error:" description :: Error -> Doc TCStyle -description err = desc $ viaShow err +description err = desc $ text $ show err codeLine :: String -> String -> Int -> Doc TCStyle codeLine insertStr codeLine lineNo = - logistic ((pretty lineNo) <+> pipe) <> - highlight (pretty insertStr) <> - pretty codeLine + logistic ((int lineNo) <+> pipe) <> + highlight (text insertStr) <> + text codeLine showPosition :: Position -> Doc TCStyle -showPosition pos = logistic (pretty "-->") <+> viaShow pos +showPosition pos = logistic (text "-->") <+> (text $ show $ pos) lineHighlighter :: Int -> Int -> Char -> Doc ann -lineHighlighter s e c = indent (s-1) $ pretty $ replicate (e-s) c +lineHighlighter s e c = text $ replicate (s-1) ' ' ++ replicate (e-s) c multilineHighlighter :: Int -> Bool -> Char -> Doc ann -multilineHighlighter col True c = indent 2 (pretty (replicate (col-1) '_') <> pretty c) -multilineHighlighter col False c = indent 1 pipe <> (pretty (replicate (col-2) '_') <> pretty c) +multilineHighlighter col True c = space <> space <> text (replicate (col-1) '_') <> char c +multilineHighlighter col False c = space <> pipe <> text (replicate (col-2) '_') <> char c codeViewer :: Position -> [String] -> Error -> Doc TCStyle codeViewer _ [] _ = error "TypeError.hs: No code to view" @@ -87,20 +98,20 @@ codeViewer pos (cHead:cTail) err = in if sL == eL then - nest (digitLen+1) $ indent digitLen (showPosition pos) $+$ - logistic pipe <> - nest (-(digitLen+1)) (line <> codeLine "" cHead sL) $+$ + nest (digitLen+1) $ showPosition pos $+$ + logistic pipe $+$ + nest (-(digitLen+1)) (codeLine "" cHead sL) $+$ logistic pipe <> highlight (lineHighlighter sC eC '^') <+> smallSuggest err $+$ longSuggest err else - nest (digitLen+1) $ indent digitLen (showPosition pos) $+$ - logistic pipe <> - nest (-(digitLen+1)) (line <> codeLine " " cHead sL) $+$ + nest (digitLen+1) $ showPosition pos $+$ + logistic pipe $+$ + nest (-(digitLen+1)) (codeLine " " cHead sL) $+$ logistic pipe <> - highlight (multilineHighlighter sC True '^') <> - nest (-(digitLen+1)) (line <> vsep tailCode) $+$ + highlight (multilineHighlighter sC True '^') $+$ + nest (-(digitLen+1)) (vcat tailCode) $+$ logistic pipe <> highlight (multilineHighlighter eC False '^') <+> smallSuggest err $+$ diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 45a347b3d..a61cb5dc4 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -21,8 +21,7 @@ module Typechecker.TypeError ( ,highlight ) where -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.Terminal +import Text.PrettyPrint.Annotated.HughesPJ import Data.Maybe import Data.List import Data.Char @@ -856,9 +855,10 @@ instance Show Warning where "This will be fixed in a later version of Encore." -($+$) s e = s <> line <> e data TCStyle = Classification | Desc | Logistic | Highlight +pipe = char '|' + classify, desc, logistic, highlight :: Doc TCStyle -> Doc TCStyle classify = annotate Classification desc = annotate Desc @@ -866,10 +866,10 @@ logistic = annotate Logistic highlight = annotate Highlight highlightPretty :: String -> Doc TCStyle -highlightPretty = highlight . pretty +highlightPretty s = highlight $ text s makeNotation :: Doc TCStyle -makeNotation = logistic (pipe $+$ equals) <+> desc (pretty "note:") +makeNotation = logistic (pipe $+$ equals) <+> desc (text "note:") class Suggestable a where @@ -878,17 +878,20 @@ class Suggestable a where instance Suggestable Error where smallSuggest (NonAssignableLHSError) = highlightPretty "Can only be used on var or fields" - smallSuggest _ = emptyDoc + smallSuggest _ = empty longSuggest (TypeWithCapabilityMismatchError actual cap expected) = - let typelist = pretty "expected type" <+> desc (viaShow expected) $+$ pretty "found type" <+> desc (viaShow actual) in - makeNotation <+> hang 3 typelist - longSuggest _ = emptyDoc + let + expect = text "expected type" <+> desc (text $ show expected) + found = text " found type" <+> desc (text $ show actual) + in + makeNotation <+> vcat [expect, found] + longSuggest _ = empty instance Suggestable Warning where - smallSuggest _ = emptyDoc - longSuggest _ = emptyDoc + smallSuggest _ = empty + longSuggest _ = empty --hash (UnionMethodAmbiguityError _ _) = 3 diff --git a/stack.yaml b/stack.yaml index 285423291..1bdc32600 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,5 @@ packages: - '.' extra-deps: - megaparsec-5.1.2 -- ansi-terminal-0.8.0.4 -- prettyprinter-1.2.0.1 -- prettyprinter-ansi-terminal-1.1.1.2 +- pretty-1.1.3.6 resolver: lts-6.0 From 6303390d29a87f5babb604ca00be735dc9cd3f15 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Mon, 18 Jun 2018 23:51:28 +0200 Subject: [PATCH 13/31] Added annotation for code blocks --- src/types/Typechecker/Errorprinter.hs | 2 +- src/types/Typechecker/TypeError.hs | 7 +++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs index 4922b1cda..22b33cc34 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -76,7 +76,7 @@ codeLine :: String -> String -> Int -> Doc TCStyle codeLine insertStr codeLine lineNo = logistic ((int lineNo) <+> pipe) <> highlight (text insertStr) <> - text codeLine + code (text codeLine) showPosition :: Position -> Doc TCStyle showPosition pos = logistic (text "-->") <+> (text $ show $ pos) diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index a61cb5dc4..5d81dfd33 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -19,6 +19,7 @@ module Typechecker.TypeError ( ,desc ,logistic ,highlight + ,code ) where import Text.PrettyPrint.Annotated.HughesPJ @@ -855,15 +856,17 @@ instance Show Warning where "This will be fixed in a later version of Encore." -data TCStyle = Classification | Desc | Logistic | Highlight pipe = char '|' -classify, desc, logistic, highlight :: Doc TCStyle -> Doc TCStyle +data TCStyle = Classification | Desc | Logistic | Highlight | Code + +classify, desc, logistic, highlight, code :: Doc TCStyle -> Doc TCStyle classify = annotate Classification desc = annotate Desc logistic = annotate Logistic highlight = annotate Highlight +code = annotate Code highlightPretty :: String -> Doc TCStyle highlightPretty s = highlight $ text s From 8987ed412dd74ec1cf17f79fb629dd799d5a11d5 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Fri, 22 Jun 2018 15:07:54 +0200 Subject: [PATCH 14/31] List visible methods/functions and added method suggestions --- src/ir/AST/PrettyPrinter.hs | 62 +++++++++++----------- src/types/Typechecker/Backtrace.hs | 2 +- src/types/Typechecker/Environment.hs | 25 +++++++++ src/types/Typechecker/Errorprinter.hs | 75 ++++++++++++++++---------- src/types/Typechecker/Suggestable.hs | 76 +++++++++++++++++++++++++++ src/types/Typechecker/TypeError.hs | 32 +---------- src/types/Typechecker/Util.hs | 56 ++++++++++++++++++++ 7 files changed, 238 insertions(+), 90 deletions(-) create mode 100644 src/types/Typechecker/Suggestable.hs diff --git a/src/ir/AST/PrettyPrinter.hs b/src/ir/AST/PrettyPrinter.hs index 057e4eb9c..d61ff4219 100644 --- a/src/ir/AST/PrettyPrinter.hs +++ b/src/ir/AST/PrettyPrinter.hs @@ -19,8 +19,7 @@ module AST.PrettyPrinter (ppExpr ) where -- Library dependencies -import qualified Text.PrettyPrint as P -import Text.PrettyPrint hiding(brackets) +import Text.PrettyPrint.Annotated hiding(brackets) -- Module dependencies import Identifiers @@ -32,23 +31,23 @@ indent = nest 2 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} = ppModuleDecl moduledecl $+$ vcat (map ppEmbedded etl) <+> @@ -68,7 +67,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 <> @@ -76,7 +75,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 @@ -101,21 +100,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 @@ -125,7 +124,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) $+$ @@ -137,11 +136,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) $$ @@ -155,11 +154,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 @@ -172,7 +171,7 @@ ppComposition TraitLeaf{tcname, tcext} = then empty else parens (commaSep (map ppTraitExtension tcext)) -ppClassDecl :: ClassDecl -> Doc +ppClassDecl :: ClassDecl -> Doc a ppClassDecl Class {cname, cfields, cmethods, ccomposition} = clss <+> text (showWithoutMode cname) <+> compositionDoc $+$ indent (vcat (map ppFieldDecl cfields) $$ @@ -186,16 +185,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 @@ -228,26 +227,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" @@ -265,7 +265,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 @@ -430,19 +430,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/types/Typechecker/Backtrace.hs b/src/types/Typechecker/Backtrace.hs index 13946e4d9..1ba11a723 100644 --- a/src/types/Typechecker/Backtrace.hs +++ b/src/types/Typechecker/Backtrace.hs @@ -17,7 +17,7 @@ module Typechecker.Backtrace(Backtrace import Data.Maybe import Data.List -import Text.PrettyPrint +import Text.PrettyPrint.Annotated import Identifiers import AST.Meta(Position) diff --git a/src/types/Typechecker/Environment.hs b/src/types/Typechecker/Environment.hs index 5bf5744d5..0afe6cd74 100644 --- a/src/types/Typechecker/Environment.hs +++ b/src/types/Typechecker/Environment.hs @@ -509,6 +509,31 @@ varLookup qname@QName{qnspace, qnlocal = x} } = Map.filterWithKey (\f _ -> f `elem` names) functionTable +visibleFunctions :: Environment -> [(Name, Type)] +visibleFunctions Env{locals, lookupTables} = + -- List of all available (non-local) function names + -- fst / snd => module name / table of functions + -- keys / elems => function name / types (inputparameter types -> result type) + let + ftable = extractTables filterFunctionTable lookupTables + selfMadeFunc = filter (not . (`elem` ["Std", "String"]) . show . fst) ftable + localFunc = map (\(x,(_,z)) -> (x,z)) $ filter (isArrowType . snd . snd) locals + --localNames = map (fst) localFunc + in + localFunc ++ concatMap (Map.assocs . snd) selfMadeFunc + --localNames ++ concatMap (Map.keys . snd) selfMadeFunc + + 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 index 22b33cc34..6f44bac0a 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -2,26 +2,36 @@ module Typechecker.Errorprinter (printError) 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) + +-- Module dependencies +import AST.Meta(Position, getPositionFile, getPositions) +import Identifiers +import Types import Typechecker.Environment import Typechecker.TypeError -import AST.Meta(Position, getPositionFile, getPositions) -import Data.Ix(range) -import Text.PrettyPrint.Annotated.HughesPJ -import Text.Printf -import System.Console.ANSI +import Typechecker.Util +import Typechecker.Suggestable +currentPos (TCError _ Env{bt = ((pos, _):_)}) = pos printError :: TCError -> IO () +-- Default errors printError err@(TCError _ Env{bt = []}) = renderError $ prettyError err [] $+$ text "" - -- putDoc $ reAnnotate toErrorStyle $ prettyError err [] $+$ text "" -printError err@(TCError _ Env{bt = ((pos, _):_)}) = do - code <- getCodeLines pos - renderError $ prettyError err code $+$ text "" - -- putDoc $ reAnnotate toErrorStyle $ prettyError err code $+$ text "" +printError error = do + code <- getCodeLines $ currentPos error + renderError $ prettyError error [code] $+$ text "" -- renderDecoratedM :: Monad m => (ann -> m r) -> (ann -> m r) -> (String -> m r) -> m r -> Doc ann -> m r +renderError :: Doc TCStyle -> IO () renderError doc = renderDecoratedM toErrorStyle endAnn textprinter endDoc doc where @@ -39,12 +49,14 @@ toErrorStyle Classification = setSGR [SetConsoleIntensity BoldIntensity, SetColo 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 () @@ -53,13 +65,16 @@ toWarningStyle Highlight = setSGR [SetColor Foreground Dull Yellow] -- - 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 -prettyError (TCError err@(TypeWithCapabilityMismatchError _ _ _) Env{bt = bt@((pos, _):_)}) code = - declareError err <+> description err $+$ codeViewer pos code err +prettyError :: TCError -> [[String]] -> Doc TCStyle +--prettyError tcErr@(TCError err@(TypeWithCapabilityMismatchError _ _ _) _) [code] = +-- declareError err <+> description err $+$ codeViewer code tcErr +prettyError tcErr@(TCError err@(UnknownRefTypeError _) _) [code] = + declareError err <+> description err $+$ nest 2 (showPosition $ currentPos tcErr) +-- Default errors prettyError (TCError err Env{bt = []}) _ = declareError err <+> description err -prettyError (TCError err Env{bt = bt@((pos, _):_)}) code = - declareError err <+> description err $+$ codeViewer pos code err +prettyError tcErr@(TCError err _) [code] = + declareError err <+> description err $+$ codeViewer tcErr code -- Possible extensions: -- Duplicate Class -> print positions (File + line) of the two classes -- Type error in func call -> print a version of codeViewer that also shows the function head @@ -72,11 +87,14 @@ declareError _ = classify $ text "Error:" description :: Error -> Doc TCStyle description err = desc $ text $ show err -codeLine :: String -> String -> Int -> Doc TCStyle -codeLine insertStr codeLine lineNo = - logistic ((int lineNo) <+> pipe) <> - highlight (text insertStr) <> - code (text codeLine) +codeLine ::Int -> String -> String -> Int -> Doc TCStyle +codeLine digitSpace insertStr codeLine lineNo = + let + pad = digitSpace - (length $ show lineNo) + in + logistic (nest pad $ (int lineNo) <+> pipe) <> + highlight (text insertStr) <> + code (text codeLine) showPosition :: Position -> Doc TCStyle showPosition pos = logistic (text "-->") <+> (text $ show $ pos) @@ -88,19 +106,20 @@ multilineHighlighter :: Int -> Bool -> Char -> Doc ann multilineHighlighter col True c = space <> space <> text (replicate (col-1) '_') <> char c multilineHighlighter col False c = space <> pipe <> text (replicate (col-2) '_') <> char c -codeViewer :: Position -> [String] -> Error -> Doc TCStyle -codeViewer _ [] _ = error "TypeError.hs: No code to view" -codeViewer pos (cHead:cTail) err = +codeViewer :: TCError -> [String] -> Doc TCStyle +codeViewer _ [] = error "TypeError.hs: No code to view" +codeViewer err (cHead:cTail) = let + pos = currentPos err ((sL, sC), (eL, eC)) = getPositions pos - digitLen = length $ show sL - tailCode = zipWith (codeLine " |") cTail (range (sL+1, eL)) + digitLen = length $ show eL + tailCode = zipWith (codeLine digitLen " |") cTail (range (sL+1, eL)) in if sL == eL then nest (digitLen+1) $ showPosition pos $+$ logistic pipe $+$ - nest (-(digitLen+1)) (codeLine "" cHead sL) $+$ + nest (-(digitLen+1)) (codeLine digitLen "" cHead sL) $+$ logistic pipe <> highlight (lineHighlighter sC eC '^') <+> smallSuggest err $+$ @@ -108,7 +127,7 @@ codeViewer pos (cHead:cTail) err = else nest (digitLen+1) $ showPosition pos $+$ logistic pipe $+$ - nest (-(digitLen+1)) (codeLine " " cHead sL) $+$ + nest (-(digitLen+1)) (codeLine digitLen " " cHead sL) $+$ logistic pipe <> highlight (multilineHighlighter sC True '^') $+$ nest (-(digitLen+1)) (vcat tailCode) $+$ @@ -116,7 +135,7 @@ codeViewer pos (cHead:cTail) err = highlight (multilineHighlighter eC False '^') <+> smallSuggest err $+$ longSuggest err - + getCodeLines :: Position -> IO [String] getCodeLines pos = do diff --git a/src/types/Typechecker/Suggestable.hs b/src/types/Typechecker/Suggestable.hs new file mode 100644 index 000000000..356cdcd15 --- /dev/null +++ b/src/types/Typechecker/Suggestable.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Typechecker.Suggestable ( + smallSuggest + ,longSuggest + )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 + + +pipe = char '|' + +highlightPretty :: String -> Doc TCStyle +highlightPretty s = highlight $ text s + +makeNotation :: Doc TCStyle +makeNotation = logistic (pipe $+$ equals) <+> desc (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 to the text printed fairly short, +-- about 32 characters seem to be a good maxximum to strive for. +-- If more are needed, use longSuggest instead. +class Suggestable a where + smallSuggest :: a -> Doc TCStyle + longSuggest :: a -> Doc TCStyle + +instance Suggestable TCError where + smallSuggest (TCError (NonAssignableLHSError) _) = highlightPretty "Can only be used on var or fields" + smallSuggest (TCError (MethodNotFoundError name ty) env) + | isMethodNameAFunction name ty env = highlightPretty $ printf "Did you mean function `%s`?" (show name) + smallSuggest _ = empty + + longSuggest (TCError (TypeWithCapabilityMismatchError actual cap expected) _) = + let + expect = text "expected type" <+> desc (text $ show expected) + found = text " found type" <+> desc (text $ show actual) + in + makeNotation <+> vcat [expect, found] + 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:,\n") 0 + (desc (ppFunctionHeader header)) + + longSuggest _ = empty + + +instance Suggestable Warning 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 5d81dfd33..666e835d1 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -12,8 +12,8 @@ module Typechecker.TypeError ( ,Error(..) ,TCWarning(TCWarning) ,Warning(..) - ,smallSuggest - ,longSuggest + --,smallSuggest + --,longSuggest ,TCStyle(..) ,classify ,desc @@ -868,34 +868,6 @@ logistic = annotate Logistic highlight = annotate Highlight code = annotate Code -highlightPretty :: String -> Doc TCStyle -highlightPretty s = highlight $ text s - -makeNotation :: Doc TCStyle -makeNotation = logistic (pipe $+$ equals) <+> desc (text "note:") - - -class Suggestable a where - smallSuggest :: a -> Doc TCStyle - longSuggest :: a -> Doc TCStyle - -instance Suggestable Error where - smallSuggest (NonAssignableLHSError) = highlightPretty "Can only be used on var or fields" - smallSuggest _ = empty - - longSuggest (TypeWithCapabilityMismatchError actual cap expected) = - let - expect = text "expected type" <+> desc (text $ show expected) - found = text " found type" <+> desc (text $ show actual) - in - makeNotation <+> vcat [expect, found] - longSuggest _ = empty - - -instance Suggestable Warning where - smallSuggest _ = empty - longSuggest _ = empty - --hash (UnionMethodAmbiguityError _ _) = 3 diff --git a/src/types/Typechecker/Util.hs b/src/types/Typechecker/Util.hs index 34275868f..01b5cad68 100644 --- a/src/types/Typechecker/Util.hs +++ b/src/types/Typechecker/Util.hs @@ -46,6 +46,8 @@ module Typechecker.Util(TypecheckM ,isSharableType ,checkConjunction ,includesMarkerTrait + ,getFunctionNames + ,findMethodWithEnvironment ) where import Identifiers @@ -64,6 +66,7 @@ import Control.Monad.State 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 @@ -523,6 +526,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 From be981183854708a4bd86500a4bb3708c8e7f7098 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Sat, 23 Jun 2018 16:25:56 +0200 Subject: [PATCH 15/31] Minor touchups --- src/types/Typechecker/Environment.hs | 5 ----- src/types/Typechecker/Errorprinter.hs | 14 ++++++-------- src/types/Typechecker/Suggestable.hs | 4 ++-- src/types/Typechecker/TypeError.hs | 2 -- 4 files changed, 8 insertions(+), 17 deletions(-) diff --git a/src/types/Typechecker/Environment.hs b/src/types/Typechecker/Environment.hs index 0afe6cd74..079dc9861 100644 --- a/src/types/Typechecker/Environment.hs +++ b/src/types/Typechecker/Environment.hs @@ -511,17 +511,12 @@ varLookup qname@QName{qnspace, qnlocal = x} visibleFunctions :: Environment -> [(Name, Type)] visibleFunctions Env{locals, lookupTables} = - -- List of all available (non-local) function names - -- fst / snd => module name / table of functions - -- keys / elems => function name / types (inputparameter types -> result type) let ftable = extractTables filterFunctionTable lookupTables selfMadeFunc = filter (not . (`elem` ["Std", "String"]) . show . fst) ftable localFunc = map (\(x,(_,z)) -> (x,z)) $ filter (isArrowType . snd . snd) locals - --localNames = map (fst) localFunc in localFunc ++ concatMap (Map.assocs . snd) selfMadeFunc - --localNames ++ concatMap (Map.keys . snd) selfMadeFunc where filterFunctionTable LookupTable{functionTable diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs index 6f44bac0a..c128e6001 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -23,14 +23,13 @@ import Typechecker.Suggestable currentPos (TCError _ Env{bt = ((pos, _):_)}) = pos printError :: TCError -> IO () --- Default errors printError err@(TCError _ Env{bt = []}) = renderError $ prettyError err [] $+$ text "" printError error = do code <- getCodeLines $ currentPos error - renderError $ prettyError error [code] $+$ text "" + renderError $ prettyError error code $+$ text "" + --- renderDecoratedM :: Monad m => (ann -> m r) -> (ann -> m r) -> (String -> m r) -> m r -> Doc ann -> m r renderError :: Doc TCStyle -> IO () renderError doc = renderDecoratedM toErrorStyle endAnn textprinter endDoc doc @@ -65,15 +64,14 @@ toWarningStyle Code = return () -- - 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 ---prettyError tcErr@(TCError err@(TypeWithCapabilityMismatchError _ _ _) _) [code] = --- declareError err <+> description err $+$ codeViewer code tcErr -prettyError tcErr@(TCError err@(UnknownRefTypeError _) _) [code] = +prettyError :: TCError -> [String] -> Doc TCStyle +prettyError tcErr@(TCError err@(UnknownRefTypeError _) _) _ = declareError err <+> description err $+$ nest 2 (showPosition $ currentPos tcErr) + -- Default errors prettyError (TCError err Env{bt = []}) _ = declareError err <+> description err -prettyError tcErr@(TCError err _) [code] = +prettyError tcErr@(TCError err _) code = declareError err <+> description err $+$ codeViewer tcErr code -- Possible extensions: -- Duplicate Class -> print positions (File + line) of the two classes diff --git a/src/types/Typechecker/Suggestable.hs b/src/types/Typechecker/Suggestable.hs index 356cdcd15..1317bb8d3 100644 --- a/src/types/Typechecker/Suggestable.hs +++ b/src/types/Typechecker/Suggestable.hs @@ -33,8 +33,8 @@ makeNotation = logistic (pipe $+$ equals) <+> desc (text "note:") -- 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 to the text printed fairly short, --- about 32 characters seem to be a good maxximum to strive for. +-- 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 TCStyle diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 666e835d1..1c55b6c36 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -12,8 +12,6 @@ module Typechecker.TypeError ( ,Error(..) ,TCWarning(TCWarning) ,Warning(..) - --,smallSuggest - --,longSuggest ,TCStyle(..) ,classify ,desc From 54524656dd9c80830cd9a0105ede99756f29a301 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Sat, 23 Jun 2018 21:48:44 +0200 Subject: [PATCH 16/31] stupid typo --- src/types/Typechecker/Suggestable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/types/Typechecker/Suggestable.hs b/src/types/Typechecker/Suggestable.hs index 1317bb8d3..fd52a6cec 100644 --- a/src/types/Typechecker/Suggestable.hs +++ b/src/types/Typechecker/Suggestable.hs @@ -57,7 +57,7 @@ instance Suggestable TCError where header = snd . fromJust $ findMethodWithEnvironment name targetType env types = hparams header in - makeNotation <+> hang ("Method" <+> quotes (text $ show name) <+> "is declared:,\n") 0 + makeNotation <+> hang ("Method" <+> quotes (text $ show name) <+> "is declared:") 0 (desc (ppFunctionHeader header)) longSuggest _ = empty From 72dff6b7a208249081904cd72ff785b2d0c32a62 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Tue, 12 Jun 2018 16:56:16 +0200 Subject: [PATCH 17/31] Working explainer with sub-par data structure --- src/front/TopLevel.hs | 16 + src/types/Typechecker/ErrorExplainer.hs | 348 +++++++ src/types/Typechecker/TypeError.hs | 1180 ++++++++++++----------- 3 files changed, 955 insertions(+), 589 deletions(-) create mode 100644 src/types/Typechecker/ErrorExplainer.hs diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index acae43f34..33a9e27f8 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -42,6 +42,7 @@ import Typechecker.Environment(buildLookupTable) import Typechecker.Prechecker(precheckProgram) import Typechecker.Typechecker(typecheckProgram, checkForMainClass) import Typechecker.Errorprinter +import Typechecker.ErrorExplainer(getErrorExplanation) import Typechecker.Capturechecker(capturecheckProgram) import Optimizer.Optimizer import CodeGen.Main @@ -73,6 +74,7 @@ data Option = | Verbose | Literate | NoGC + | Explain String | Help | Undefined String | Malformed String @@ -123,6 +125,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.") ] @@ -294,6 +298,9 @@ main = checkForUndefined options when (Help `elem` options) (exit helpMessage) + case find isExplain options of + Just (Explain errCode) -> exit $ explainError errCode + Nothing -> return () when (null programs) (abort ("No program specified! Aborting.\n\n" <> usage <> "\n" <> @@ -411,6 +418,15 @@ main = (putStrLn str) showWarnings = mapM print + + isExplain (Explain _) = True + isExplain _ = False + + explainError errCode = + case getErrorExplanation errCode of + Just explain -> explain + Nothing -> printf "error: no extended information for %s" errCode + helpMessage = "Welcome to the Encore compiler!\n" <> usage <> "\n\n" <> diff --git a/src/types/Typechecker/ErrorExplainer.hs b/src/types/Typechecker/ErrorExplainer.hs new file mode 100644 index 000000000..3c7aba533 --- /dev/null +++ b/src/types/Typechecker/ErrorExplainer.hs @@ -0,0 +1,348 @@ + +module Typechecker.ErrorExplainer where + +--import Typechecker.TypeError(TCError(TCError),TCWarning(TCWarning)) +import Text.PrettyPrint hiding(brackets) +import qualified Data.Map.Strict as Map +import Data.Char (digitToInt) +import Text.Read (readMaybe) + +--hash (UnionMethodAmbiguityError _ _) = 3 + +--explain 3 = "stuff" + + + +getErrorindex :: String -> Maybe Int +getErrorindex k = case Map.lookupIndex k createMap of + Nothing -> Nothing + Just x -> Just (x+1) + + +getErrorExplanation :: String -> Maybe String +getErrorExplanation ('E':err) = let map = createMap in + case readMaybe err :: Maybe Int of + Just num + | num > 0 && num <= Map.size map -> Just $ snd $ Map.elemAt (num-1) map + | otherwise -> Nothing + Nothing -> Nothing +getErrorExplanation _ = Nothing + + + +{- + This code is probably highly inefficient. Should be refactored in the future. + It should not be neccesary to recreate this list every time during runtime, + either use template haskell or place it somewhere useful. +-} +createMap :: Map.Map String String +createMap = Map.fromList [ + ("NonAssignableLHSError","This is a test...") + , ("BinaryOperandMismatchError","This is an error for BinaryOperandMismatchError, but its only a test, nothing more :)") + ] + +-- toHashNum :: Error -> Maybe Int +-- toHashNum (DistinctTypeParametersError _) = Just 1 +-- toHashNum (WrongNumberOfMethodArgumentsError _ _ _ _) = Just 2 +-- toHashNum (WrongNumberOfFunctionArgumentsError _ _ _) = Just 3 +-- toHashNum (WrongNumberOfFunctionTypeArgumentsError _ _ _) = Just 4 +-- toHashNum (WrongNumberOfTypeParametersError _ _ _ _) = Just 5 +-- toHashNum (MissingFieldRequirementError _ _) = Just 6 +-- toHashNum (CovarianceViolationError _ _ _) = Just 7 +-- toHashNum (RequiredFieldMismatchError _ _ _ _) = Just 8 +-- toHashNum (NonDisjointConjunctionError _ _ _) = Just 9 +-- toHashNum (OverriddenMethodTypeError _ _ _ _) = Just 10 +-- toHashNum (OverriddenMethodError _ _ _) = Just 11 +-- toHashNum (IncludedMethodConflictError _ _ _) = Just 12 +-- toHashNum (MissingMethodRequirementError _ _) = Just 13 +-- toHashNum (MissingMainClass) = Just 14 +-- toHashNum (SyncStreamCall) = Just 15 +-- toHashNum (UnknownTraitError _) = Just 16 +-- toHashNum (UnknownRefTypeError _) = Just 17 +-- toHashNum (MalformedCapabilityError _) = Just 18 +-- toHashNum (MalformedBoundError _) = Just 19 +-- toHashNum (RecursiveTypesynonymError _) = Just 20 +-- toHashNum (DuplicateThingError _ _) = Just 21 +-- toHashNum (PassiveStreamingMethodError) = Just 22 +-- toHashNum (PolymorphicConstructorError) = Just 23 +-- toHashNum (StreamingConstructorError) = Just 24 +-- toHashNum (MainMethodArgumentsError) = Just 25 +-- toHashNum (MainConstructorError) = Just 26 +-- toHashNum (FieldNotFoundError _ _) = Just 27 +-- toHashNum (MethodNotFoundError _ _) = Just 28 +-- toHashNum (BreakOutsideOfLoopError) = Just 29 +-- toHashNum (BreakUsedAsExpressionError) = Just 30 +-- toHashNum (ContinueOutsideOfLoopError) = Just 31 +-- toHashNum (ContinueUsedAsExpressionError) = Just 32 +-- toHashNum (NonCallableTargetError _) = Just 33 +-- toHashNum (NonSendableTargetError _) = Just 34 +-- toHashNum (MainMethodCallError) = Just 35 +-- toHashNum (ConstructorCallError) = Just 36 +-- toHashNum (ExpectingOtherTypeError _ _) = Just 37 +-- toHashNum (NonStreamingContextError _) = Just 38 +-- toHashNum (UnboundFunctionError _) = Just 39 +-- toHashNum (NonFunctionTypeError _) = Just 40 +-- toHashNum (BottomTypeInferenceError) = Just 41 +-- toHashNum (IfInferenceError) = Just 42 +-- toHashNum (IfBranchMismatchError _ _) = Just 43 +-- toHashNum (EmptyMatchClauseError) = Just 44 +-- toHashNum (ActiveMatchError) = Just 45 +-- toHashNum (MatchInferenceError) = Just 46 +-- toHashNum (ThisReassignmentError) = Just 47 +-- toHashNum (ImmutableVariableError _) = Just 48 +-- toHashNum (PatternArityMismatchError _ _ _) = Just 49 +-- toHashNum (PatternTypeMismatchError _ _) = Just 50 +-- toHashNum (NonMaybeExtractorPatternError _) = Just 51 +-- toHashNum (InvalidPatternError _) = Just 52 +-- toHashNum (InvalidTupleTargetError _ _ _) = Just 53 +-- toHashNum (InvalidTupleAccessError _ _) = Just 54 +-- toHashNum (CannotReadFieldError _) = Just 55 +-- toHashNum (NonAssignableLHSError) = Just 56 +-- toHashNum (ValFieldAssignmentError _ _) = Just 57 +-- toHashNum (UnboundVariableError _) = Just 58 +-- toHashNum (BuriedVariableError _) = Just 59 +-- toHashNum (ObjectCreationError _) = Just 60 +-- toHashNum (NonIterableError _) = Just 61 +-- toHashNum (EmptyArrayLiteralError) = Just 62 +-- toHashNum (NonIndexableError _) = Just 63 +-- toHashNum (NonSizeableError _) = Just 64 +-- toHashNum (FormatStringLiteralError) = Just 65 +-- toHashNum (UnprintableExpressionError _) = Just 66 +-- toHashNum (WrongNumberOfPrintArgumentsError _ _) = Just 67 +-- toHashNum (UnaryOperandMismatchError _ _) = Just 68 +-- toHashNum (BinaryOperandMismatchError _ _ _ _) = Just 69 +-- toHashNum (UndefinedBinaryOperatorError _) = Just 70 +-- toHashNum (NullTypeInferenceError) = Just 71 +-- toHashNum (CannotBeNullError _) = Just 72 +-- toHashNum (TypeMismatchError _ _) = Just 73 +-- toHashNum (TypeWithCapabilityMismatchError _ _ _) = Just 74 +-- toHashNum (TypeVariableAmbiguityError _ _ _) = Just 75 +-- toHashNum (FreeTypeVariableError _) = Just 76 +-- toHashNum (TypeVariableAndVariableCommonNameError _) = Just 77 +-- toHashNum (UnionMethodAmbiguityError _ _) = Just 78 +-- toHashNum (MalformedUnionTypeError _ _) = Just 79 +-- toHashNum (RequiredFieldMutabilityError _ _) = Just 80 +-- toHashNum (ProvidingTraitFootprintError _ _ _ _) = Just 81 +-- toHashNum (TypeArgumentInferenceError _ _) = Just 82 +-- toHashNum (AmbiguousTypeError _ _) = Just 83 +-- toHashNum (UnknownTypeUsageError _ _) = Just 84 +-- toHashNum (AmbiguousNameError _ _) = Just 85 +-- toHashNum (UnknownNamespaceError _) = Just 86 +-- toHashNum (UnknownNameError _ _) = Just 87 +-- toHashNum (ShadowedImportError _) = Just 88 +-- toHashNum (WrongModuleNameError _ _) = Just 89 +-- toHashNum (BadSyncCallError) = Just 90 +-- toHashNum (PrivateAccessModifierTargetError _) = Just 91 +-- toHashNum (ClosureReturnError) = Just 92 +-- toHashNum (ClosureForwardError) = Just 93 +-- toHashNum (MatchMethodNonMaybeReturnError) = Just 94 +-- toHashNum (MatchMethodNonEmptyParameterListError) = Just 95 +-- toHashNum (ImpureMatchMethodError _) = Just 96 +-- toHashNum (IdComparisonNotSupportedError _) = Just 97 +-- toHashNum (IdComparisonTypeMismatchError _ _) = Just 98 +-- toHashNum (ForwardInPassiveContext _) = Just 99 +-- toHashNum (ForwardInFunction) = Just 100 +-- toHashNum (ForwardTypeError _ _) = Just 101 +-- toHashNum (ForwardTypeClosError _ _) = Just 102 +-- toHashNum (CannotHaveModeError _) = Just 103 +-- toHashNum (ModelessError _) = Just 104 +-- toHashNum (ModeOverrideError _) = Just 105 +-- toHashNum (CannotConsumeError _) = Just 106 +-- toHashNum (CannotConsumeTypeError _) = Just 107 +-- toHashNum (ImmutableConsumeError _) = Just 108 +-- toHashNum (CannotGiveReadModeError _) = Just 109 +-- toHashNum (CannotGiveSharableModeError _) = Just 110 +-- toHashNum (NonValInReadContextError _) = Just 111 +-- toHashNum (NonSafeInReadContextError _ _) = Just 112 +-- toHashNum (NonSafeInExtendedReadTraitError _ _ _) = Just 113 +-- toHashNum (ProvidingToReadTraitError _ _ _) = Just 114 +-- toHashNum (SubordinateReturnError _ _) = Just 115 +-- toHashNum (SubordinateArgumentError _) = Just 116 +-- toHashNum (SubordinateFieldError _) = Just 117 +-- toHashNum (ThreadLocalFieldError _) = Just 118 +-- toHashNum (ThreadLocalFieldExtensionError _ _) = Just 119 +-- toHashNum (ThreadLocalArgumentError _) = Just 120 +-- toHashNum (PolymorphicArgumentSendError _ _) = Just 121 +-- toHashNum (PolymorphicReturnError _ _) = Just 122 +-- toHashNum (ThreadLocalReturnError _ _) = Just 123 +-- toHashNum (MalformedConjunctionError _ _ _) = Just 124 +-- toHashNum (CannotUnpackError _) = Just 125 +-- toHashNum (CannotInferUnpackingError _) = Just 126 +-- toHashNum (UnsplittableTypeError _) = Just 127 +-- toHashNum (DuplicatingSplitError _) = Just 128 +-- toHashNum (StackboundArrayTypeError _) = Just 129 +-- toHashNum (ManifestConflictError _ _) = Just 130 +-- toHashNum (ManifestClassConflictError _ _) = Just 131 +-- toHashNum (UnmodedMethodExtensionError _ _) = Just 132 +-- toHashNum (ActiveTraitError _ _) = Just 133 +-- toHashNum (NewWithModeError) = Just 134 +-- toHashNum (UnsafeTypeArgumentError _ _) = Just 135 +-- toHashNum (OverlapWithBuiltins) = Just 136 +-- toHashNum (SimpleError _) = Just 137 +-- toHashNum (ReverseBorrowingError) = Just 138 +-- toHashNum (BorrowedFieldError _) = Just 139 +-- toHashNum (LinearClosureError _ _) = Just 140 +-- toHashNum (BorrowedLeakError _) = Just 141 +-- toHashNum (NonBorrowableError _) = Just 142 +-- toHashNum (ActiveBorrowError _ _) = Just 143 +-- toHashNum (ActiveBorrowSendError _ _) = Just 144 +-- toHashNum (DuplicateBorrowError _) = Just 145 +-- toHashNum (StackboundednessMismatchError _ _) = Just 146 +-- toHashNum (LinearCaptureError _ _) = Just 147 +-- toHashNum _ = Nothing + + + + + + + +-- explainErr :: Int -> String +-- explainErr 1 = +-- explainErr 2 = +-- explainErr 3 = +-- explainErr 4 = +-- explainErr 5 = +-- explainErr 6 = +-- explainErr 7 = +-- explainErr 8 = +-- explainErr 9 = +-- explainErr 10 = +-- explainErr 11 = +-- explainErr 12 = +-- explainErr 13 = +-- explainErr 14 = "You seem to have lost you main class,\nthat is needed if you want to make an executable program." +-- explainErr 15 = +-- explainErr 16 = +-- explainErr 17 = +-- explainErr 18 = +-- explainErr 19 = +-- explainErr 20 = +-- explainErr 21 = +-- explainErr 22 = +-- explainErr 23 = +-- explainErr 24 = +-- explainErr 25 = +-- explainErr 26 = +-- explainErr 27 = +-- explainErr 28 = +-- explainErr 29 = +-- explainErr 30 = +-- explainErr 31 = +-- explainErr 32 = +-- explainErr 33 = +-- explainErr 34 = +-- explainErr 35 = +-- explainErr 36 = +-- explainErr 37 = +-- explainErr 38 = +-- explainErr 39 = +-- explainErr 40 = +-- explainErr 41 = +-- explainErr 42 = +-- explainErr 43 = +-- explainErr 44 = +-- explainErr 45 = +-- explainErr 46 = +-- explainErr 47 = +-- explainErr 48 = +-- explainErr 49 = +-- explainErr 50 = +-- explainErr 51 = +-- explainErr 52 = +-- explainErr 53 = +-- explainErr 54 = +-- explainErr 55 = +-- explainErr 56 = +-- explainErr 57 = +-- explainErr 58 = +-- explainErr 59 = +-- explainErr 60 = +-- explainErr 61 = +-- explainErr 62 = +-- explainErr 63 = +-- explainErr 64 = +-- explainErr 65 = +-- explainErr 66 = +-- explainErr 67 = +-- explainErr 68 = +-- explainErr 69 = +-- explainErr 70 = +-- explainErr 71 = +-- explainErr 72 = +-- explainErr 73 = +-- explainErr 74 = +-- explainErr 75 = +-- explainErr 76 = +-- explainErr 77 = +-- explainErr 78 = +-- explainErr 79 = +-- explainErr 80 = +-- explainErr 81 = +-- explainErr 82 = +-- explainErr 83 = +-- explainErr 84 = +-- explainErr 85 = +-- explainErr 86 = +-- explainErr 87 = +-- explainErr 88 = +-- explainErr 89 = +-- explainErr 90 = +-- explainErr 91 = +-- explainErr 92 = +-- explainErr 93 = +-- explainErr 94 = +-- explainErr 95 = +-- explainErr 96 = +-- explainErr 97 = +-- explainErr 98 = +-- explainErr 99 = +-- explainErr 100 = +-- explainErr 101 = +-- explainErr 102 = +-- explainErr 103 = +-- explainErr 104 = +-- explainErr 105 = +-- explainErr 106 = +-- explainErr 107 = +-- explainErr 108 = +-- explainErr 109 = +-- explainErr 110 = +-- explainErr 111 = +-- explainErr 112 = +-- explainErr 113 = +-- explainErr 114 = +-- explainErr 115 = +-- explainErr 116 = +-- explainErr 117 = +-- explainErr 118 = +-- explainErr 119 = +-- explainErr 120 = +-- explainErr 121 = +-- explainErr 122 = +-- explainErr 123 = +-- explainErr 124 = +-- explainErr 125 = +-- explainErr 126 = +-- explainErr 127 = +-- explainErr 128 = +-- explainErr 129 = +-- explainErr 130 = +-- explainErr 131 = +-- explainErr 132 = +-- explainErr 133 = +-- explainErr 134 = +-- explainErr 135 = +-- explainErr 136 = +-- explainErr 137 = +-- explainErr 138 = +-- explainErr 139 = +-- explainErr 140 = +-- explainErr 141 = +-- explainErr 142 = +-- explainErr 143 = +-- explainErr 144 = +-- explainErr 145 = +-- explainErr 146 = +-- explainErr 147 = +-- explainErr _ = "" \ No newline at end of file diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 1c55b6c36..fe6123197 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -30,6 +30,7 @@ import Identifiers import Types import Typechecker.Environment import Typechecker.Backtrace +import Typechecker.ErrorExplainer import AST.AST hiding (showWithKind) import AST.PrettyPrinter hiding (indent) import qualified System.Console.ANSI as A @@ -206,6 +207,7 @@ data Error = | DuplicateBorrowError Expr | StackboundednessMismatchError Type Type | LinearCaptureError Expr Type + deriving (Show) arguments 1 = "argument" arguments _ = "arguments" @@ -216,594 +218,594 @@ typeParams _ = "type parameters" enumerateSafeTypes = "Safe types are primitives and types with read, active or local mode." -instance Show Error where - show (DistinctTypeParametersError ty) = - printf "Type parameters of '%s' must be distinct" (show ty) - show (WrongNumberOfMethodArgumentsError name targetType expected actual) = - let nameWithKind = - (if name == constructorName - then "Constructor" - else "Method '" ++ show name ++ "'") ++ - " in " ++ refTypeName targetType - in printf "%s expects %d %s. Got %d" - nameWithKind expected (arguments expected) actual - show (WrongNumberOfFunctionArgumentsError name expected actual) = - printf "Function %s expects %d %s. Got %d" - (show name) expected (arguments expected) actual - show (WrongNumberOfFunctionTypeArgumentsError name expected actual) = - printf "Function %s expects %d %s. Got %d" - (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 - show (MissingFieldRequirementError field trait) = - printf "Cannot find field '%s' required by included %s" - (show field) (refTypeName trait) - show (CovarianceViolationError field expected trait) = - printf ("Field '%s' must have a subtype of '%s' to meet " ++ - "the requirements of included %s") - (show field) (show expected) (refTypeName trait) - show (RequiredFieldMismatchError field expected trait isSub) = - printf ("Field '%s' must exactly match type '%s' " ++ - "to meet the requirements of included %s%s") - (show field) (show expected) (refTypeName trait) - (if isSub - then ". Consider turning '" ++ show (fname field) ++ - "' into a val-field in " ++ refTypeName trait - else "") - show (NonDisjointConjunctionError left right field) = - printf - "Conjunctive traits '%s' and '%s' cannot share mutable field '%s'" - (show left) (show right) (show field) - show (OverriddenMethodTypeError name expected trait actual) = - printf ("Overridden method '%s' does not " ++ - "have the expected type '%s' required by %s.\n" ++ - "Actual type is '%s'") - (show name) (show expected) (refTypeName trait) (show actual) - show (OverriddenMethodError name trait err) = - case err of - FieldNotFoundError f _ -> - printf ("Overridden method '%s' requires access to field '%s' " ++ - "which is not in requiring %s.\n" ++ - "Consider extending the trait on inclusion: %s(%s)") - (show name) (show f) (refTypeName trait) (show trait) (show f) - MethodNotFoundError m _ -> - printf ("Overridden method '%s' calls method '%s' " ++ - "which is not in requiring %s.\n" ++ - "Consider extending the trait on inclusion: %s(%s())") - (show name) (show m) (refTypeName trait) (show trait) (show m) - TypeMismatchError actual expected -> - if actual == abstractTraitFromTraitType trait - then printf ("Overridden method '%s' uses 'this' as %s " ++ - "and cannot be typechecked in requiring %s") - (show name) (show expected) (refTypeName trait) - else defaultMessage - ValFieldAssignmentError f targetType -> - if targetType == abstractTraitFromTraitType trait - then printf ("Overridden method '%s' writes field '%s' " ++ - "which is marked as immutable in requiring %s.") - (show name) (show f) (refTypeName trait) - else defaultMessage - err -> defaultMessage - where - defaultMessage = - printf ("Overridden method '%s' cannot be typechecked in " ++ - "requiring %s:\n%s") - (show name) (refTypeName trait) (show err) - show (IncludedMethodConflictError name left right) = - printf "Conflicting inclusion of method '%s' from %s and %s" - (show name) (refTypeName left) (refTypeName right) - show (MissingMethodRequirementError header trait) = - printf "Cannot find method '%s' required by included %s" - (show $ ppFunctionHeader header) (refTypeName trait) - show (UnknownTraitError ty) = - printf "Couldn't find trait '%s'" (getId ty) - show MissingMainClass = "Couldn't find active class 'Main'" - show SyncStreamCall = "A stream method can not be called synchronously since it will invariably deadlock" - show (IdComparisonNotSupportedError ty) = - printf "Type '%s' does not support identity comparison%s" (show ty) - (if isRefType ty - then " (must include Id trait)" - else "") - show (IdComparisonTypeMismatchError lty rty) - | isTupleType lty && isTupleType rty && - length (getArgTypes lty) /= length (getArgTypes rty) = - printf "Cannot compare tuples of different sizes: %s and %s" - (show lty) (show rty) - | otherwise = - printf "Cannot compare values across types %s and %s" - (show lty) (show rty) - show BadSyncCallError = "Synchronous method calls on actors are not allowed (except on the current this)" - show (PrivateAccessModifierTargetError name) = - printf "Cannot call private %s" kind - where - kind = if name == constructorName - then "constructor" - else "method '" ++ show name ++ "'" - show (UnknownRefTypeError ty) = - printf "Couldn't find class, trait or typedef '%s'" (show ty) - show (MalformedCapabilityError ty) = - printf "Cannot form capability with %s" (showWithKind ty) - show (MalformedBoundError bound) = - printf "Cannot use %s as bound (must have trait)" (showWithKind bound) - show (RecursiveTypesynonymError ty) = - printf "Type synonyms cannot be recursive. One of the culprits is %s" - (getId ty) - show (DuplicateThingError kind thing) = - printf "Duplicate %s of %s" kind thing - show PassiveStreamingMethodError = - "Cannot have streaming methods in a passive class" - show StreamingConstructorError = - "Constructor cannot be streaming" - show MainMethodArgumentsError = - "Main method must have argument type () or ([String])" - show MainConstructorError = - "Main class cannot have a constructor" - show (FieldNotFoundError name ty) = - printf "No field '%s' in %s" - (show name) (refTypeName ty) - show (MethodNotFoundError name ty) = - let nameWithKind = if name == constructorName - then "constructor" - else "method '" ++ show name ++ "'" - targetType = if isRefType ty - then refTypeName ty - else showWithKind ty - in printf "No %s in %s" - nameWithKind targetType - show BreakUsedAsExpressionError = - "Break is a statement and cannot be used as a value or expression" - show BreakOutsideOfLoopError = - "Break can only be used inside loops" - show ContinueUsedAsExpressionError = - "Continue is a statement and cannot be used as a value or expression" - show ContinueOutsideOfLoopError = - "Continue can only be used inside while, do/while, and repeat loops" - show (NonCallableTargetError targetType) = - printf "Cannot call method on expression of type '%s'" - (show targetType) - show (NonSendableTargetError targetType) = - printf "Cannot send message to expression of type '%s'" - (show targetType) - show MainMethodCallError = "Cannot call the main method" - show ConstructorCallError = - "Constructor method 'init' can only be called during object creation" - show (ExpectingOtherTypeError something ty) = - printf "Expected %s but found expression of type '%s'" - something (show ty) - show (NonStreamingContextError e) = - printf "Cannot have '%s' outside of a streaming method" - (show $ ppSugared e) - show (UnboundFunctionError name) = - printf "Unbound function variable '%s'" (show name) - show (NonFunctionTypeError ty) = - printf "Cannot use value of type '%s' as a function" (show ty) - show BottomTypeInferenceError = "Not enough information to infer the type.\n" ++ - "Try adding more type information." - show IfInferenceError = "Cannot infer result type of if-statement" - show (IfBranchMismatchError ty1 ty2) = - "Type mismatch in different branches of if-statement:\n" ++ - " then: " ++ show ty1 ++ "\n" ++ - " else: " ++ show ty2 - show EmptyMatchClauseError = "Match statement must have at least one clause" - show ActiveMatchError = "Cannot match on an active object" - show MatchInferenceError = "Cannot infer result type of match expression" - show ThisReassignmentError = "Cannot rebind variable 'this'" - show (ImmutableVariableError qname) = - printf "Variable '%s' is immutable and cannot be re-assigned" - (show qname) - show (PatternArityMismatchError name expected actual) = - printf "Extractor '%s' returns %s. Pattern has %s" - (show name) - (if expected == 1 - then "1 value" - else show expected ++ " values") - (show actual) - show (PatternTypeMismatchError pattern ty) = - printf "Pattern '%s' does not match expected type '%s'" - (show $ ppSugared pattern) (show ty) - show (NonMaybeExtractorPatternError pattern) = - printf "Extractor '%s' must return a Maybe type to be used as a pattern" - (show $ ppSugared pattern) - show (InvalidPatternError pattern) = - printf "'%s' is not a valid pattern" - (show $ ppSugared pattern) - show (InvalidTupleTargetError target compartment ty) = - printf "Compartment access %s.%d expects a tuple target, found %s" - (show $ ppSugared target) - compartment - (show ty) - show (InvalidTupleAccessError target compartment) = - printf "No .%d compartment in tuple %s" - compartment - (show $ ppSugared target) - show (CannotReadFieldError target) = - let targetType = getType target in - if isClassType targetType && isModeless targetType then - printf "Cannot access field of expression '%s' of unmoded class '%s'" - (show $ ppSugared target) (show targetType) - else - printf "Cannot read field of expression '%s' of %s" - (show $ ppSugared target) (showWithKind targetType) - show NonAssignableLHSError = - "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) - show (UnboundVariableError name) = - printf "Unbound variable '%s'" (show name) - show (BuriedVariableError name) = - printf "Variable '%s' cannot be accessed during borrowing" (show name) - show (ObjectCreationError ty) - | isMainType ty = "Cannot create additional Main objects" - | isCapabilityType ty = - printf "Cannot create instance of %s (type must be a class)" - (refTypeName ty) - | otherwise = printf "Cannot create object of type '%s'" (show ty) - show (NonIterableError ty) = - printf "Type '%s' is not iterable" (show ty) - show EmptyArrayLiteralError = "Array literal must have at least one element" - show (NonIndexableError ty) = - printf "Type '%s' is not indexable" (show ty) - show (NonSizeableError ty) = - printf "Type '%s' has no size" (show ty) - show FormatStringLiteralError = - "Formatted printing expects first argument to be a string literal" - show (UnprintableExpressionError ty) = - printf "Expression of type '%s' is not printable" (show ty) - show (WrongNumberOfPrintArgumentsError expected actual) = - printf ("Wrong number of arguments to print. Format string " ++ - "expects %d %s. Found %d") expected (arguments expected) actual - 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 (UndefinedBinaryOperatorError op) = - printf "Undefined binary operator '%s'" (show op) - show NullTypeInferenceError = - "Cannot infer type of null valued expression. " ++ - "Try adding type annotations" - show (CannotBeNullError ty) = - printf ("Null valued expression cannot have type '%s' " ++ - "(must have reference type)") (show ty) - show (TypeMismatchError actual expected) - | isTypeVar actual && isJust (getBound actual) = - printf "Type '%s' with bound '%s' does not match expected type '%s'" - (show actual) (show . fromJust $ getBound actual) (show expected) - | isArrowType actual - , isArrowType expected - , actual `withModeOf` expected == expected = - printf ("Closure of type '%s' captures %s state and cannot " ++ - "be used as type '%s'") - (show actual) (showModeOf actual) (show expected) - | otherwise = printf "Type '%s' does not match expected type '%s'" - (show actual) (show expected) - show (TypeWithCapabilityMismatchError actual cap expected) = - printf "Type '%s' with capability '%s' does not match expected type '%s'%s" - (show actual) (show cap) (show expected) pointer - where - pointer = - let actualTraits = typesFromCapability cap - expectedTraits = typesFromCapability expected - remainders = actualTraits \\ expectedTraits - nonDroppables = filter (not . isReadSingleType) remainders - nonDroppable = head nonDroppables - in if isCapabilityType expected && - all (\te -> any (\ta -> ta == te && - ta `modeSubtypeOf` te) actualTraits) - expectedTraits - then ". Cannot drop mode '" ++ showModeOf nonDroppable ++ "'" - else "" - show (TypeVariableAmbiguityError expected ty1 ty2) = - printf "Type variable '%s' cannot be bound to both '%s' and '%s'" - (getId expected) (show ty1) (show ty2) - show (FreeTypeVariableError ty) = - if getId ty == "void" - then printf "Type 'void' is deprecated. Use 'unit' instead" - else printf "Type variable '%s' is unbound" (show ty) - show (TypeVariableAndVariableCommonNameError [name]) = - printf "Type variable '%s' clashes with existing variable name." - (show name) - show (TypeVariableAndVariableCommonNameError names) = - printf "Type variables %s clash with existing variable names." - formattingName - where - formattingName = - let ns = map (\n -> "'" ++ show n ++ "', ") (init names) - lastName = "'" ++ show (last names) ++ "'" - in show ns ++ "and " ++ lastName - show (UnionMethodAmbiguityError ty name) = - printf "Cannot disambiguate method '%s' in %s" - (show name) (showWithKind ty) - show (MalformedUnionTypeError ty union) = - printf "Type '%s' is not compatible with %s" - (show ty) (showWithKind union) - show (TypeArgumentInferenceError call param) = - printf "Cannot infer the type of parameter '%s' of %s '%s'" - (show param) kind calledName - where - mname = name call - kind | isFunctionCall call = "function" - | isMethodCallOrMessageSend call = - if mname == constructorName - then "class" - else "method" - | otherwise = error msg - calledName | isFunctionCall call = show $ qname call - | isMethodCallOrMessageSend call = - if mname == constructorName - then show $ getType (target call) - else show mname - | otherwise = error msg - msg = "TypeError.hs: " ++ show call ++ - " is not a function or method call" - show (RequiredFieldMutabilityError requirer field) = - printf "Trait '%s' requires field '%s' to be mutable" - (getId requirer) (show field) - show (ProvidingTraitFootprintError provider requirer mname fields) = - printf ("Trait '%s' cannot provide method '%s' to %s.\n" ++ - "'%s' can mutate fields that are marked immutable in '%s':\n%s") - (getId provider) (show mname) (refTypeName requirer) - (getId provider) (getId requirer) - (unlines (map ((" " ++) . show) fields)) - show (AmbiguousTypeError ty candidates) = - printf "Ambiguous reference to %s. Possible candidates are:\n%s" - (showWithKind ty) (unlines $ map ((" " ++) . show) candidates) - show (UnknownTypeUsageError usage ty) = - printf "Cannot %s unimported type %s" - usage (show ty) - show (AmbiguousNameError qname candidates) = - printf "Ambiguous reference to function %s. Possible candidates are:\n%s" - (show qname) candidateList - where - candidateList = - unlines $ map ((" " ++) . showCandidate) candidates - showCandidate (qn, ty) = show qn ++ " : " ++ show ty - show (UnknownNamespaceError maybeNs) = - printf "Unknown namespace %s" - (maybe "" show maybeNs) - show (UnknownNameError ns name) = - printf "Module %s has no function or type called '%s'" - (show ns) (show name) - show (ShadowedImportError i) = - printf "Introduction of module alias '%s' shadows existing import" - (show $ itarget i) - show (WrongModuleNameError modname expected) = - printf "Module name '%s' and file name '%s' must match" - (show modname) expected - show PolymorphicConstructorError = - printf "Constructors (a.k.a. 'init methods') cannot use parametric methods" - show ClosureReturnError = - "Closures must declare their type to use return" - show ClosureForwardError = - "Closures must declare their type to use forward" - show MatchMethodNonMaybeReturnError = - "Match methods must return a Maybe type" - show MatchMethodNonEmptyParameterListError = - "Match methods cannot have parameters" - show (ImpureMatchMethodError e) = - printf "Match methods must be pure%s" - pointer - where - pointer - | While{} <- e = ". Consider using a for loop" - | otherwise = "" - show (ForwardTypeError retType ty) = - printf ("Returned type %s of forward should match with " ++ - "the result type of the containing method %s") - (show retType) (show ty) - show (ForwardTypeClosError retType ty) = - printf ("Result type %s of the closure should match with " ++ - "the return type %s of the forward") - (show retType) (show ty) - show (ForwardInPassiveContext cname) = - printf "Forward can not be used in passive class '%s'" - (show cname) - show (ForwardInFunction) = "Forward cannot be used in functions" - show (CannotHaveModeError ty) = - if isClassType ty - then printf "Cannot give mode to unmoded %s" (refTypeName ty) - else printf "Cannot give mode to %s" (Types.showWithKind ty) - show (ModelessError ty) = - printf "No mode given to %s" (refTypeName ty) - show (ModeOverrideError ty) = - printf "Cannot override declared mode '%s' of %s" - (showModeOf ty) (refTypeName ty) - show (CannotConsumeError expr) = - printf "Cannot consume '%s'" (show (ppSugared expr)) - show (CannotConsumeTypeError expr) = - printf ("Cannot consume '%s' of type '%s'. " ++ - "Consider using a Maybe-type") - (show (ppSugared expr)) (show (getType expr)) - show (ImmutableConsumeError expr) - | VarAccess{} <- expr = - printf "Cannot consume immutable variable '%s'" - (show (ppSugared expr)) - | FieldAccess{} <- expr = - printf "Cannot consume immutable field '%s'" - (show (ppSugared expr)) - | otherwise = - printf "Cannot consume immutable target '%s'" - (show (ppSugared expr)) - show (CannotGiveReadModeError trait) = - printf ("Cannot give read mode to trait '%s'. " ++ - "It must be declared as read at its declaration site") - (getId trait) - show (CannotGiveSharableModeError ty) = - printf ("Cannot give sharable mode to %s. " ++ - "It can only be used for type parameters") - (refTypeName ty) - show (NonValInReadContextError ctx) = - printf "Read %s can only have val fields" - (if isTraitType ctx then "traits" else "classes") - show (NonSafeInReadContextError ctx ty) = - printf "Read %s can not have field of non-safe type '%s'. \n%s" - (if isTraitType ctx then "trait" else "class") (show ty) - enumerateSafeTypes - show (NonSafeInExtendedReadTraitError t f ty) = - printf "Read trait '%s' cannot be extended with field '%s' of non-safe type '%s'. \n%s" - (getId t) (show f) (show ty) - enumerateSafeTypes - show (ProvidingToReadTraitError provider requirer mname) = - printf "Non-read trait '%s' cannot provide method '%s' to read trait '%s'" - (getId provider) (show mname) (getId requirer) - show (SubordinateReturnError name ty) = - printf ("Method '%s' returns a %s and cannot " ++ - "be called from outside of its aggregate") - (show name) (if isArrowType ty - then "closure that captures subordinate state" - else "subordinate capability") - show (SubordinateArgumentError arg) = - if isArrowType (getType arg) - then printf ("Closure '%s' captures subordinate state " ++ - "and cannot be passed outside of its aggregate") - (show (ppSugared arg)) - else printf ("Cannot pass subordinate argument '%s' " ++ - "outside of its aggregate") - (show (ppSugared arg)) - show (SubordinateFieldError name) = - printf ("Field '%s' is subordinate and cannot be accessed " ++ - "from outside of its aggregate") - (show name) - show (ThreadLocalFieldError ty) = - printf "%s must have declared 'local' or 'active' mode to have actor local fields" - (if isTraitType ty then "Traits" else "Classes") - show (ThreadLocalFieldExtensionError trait field) = - printf ("Trait '%s' must have local mode to be extended " ++ - "with field '%s' of actor local type '%s'") - (show trait) (show $ fname field) - (showWithoutMode $ ftype field) - show (ThreadLocalArgumentError arg) = - if isArrowType (getType arg) - then printf ("Closure '%s' captures actor local variables " ++ - "and cannot be passed to another active object") - (show (ppSugared arg)) - else printf ("Cannot pass actor local argument '%s' " ++ - "to another active object") - (show (ppSugared arg)) - show (ThreadLocalReturnError name ty) = - printf ("Method '%s' returns a %s and cannot " ++ - "be called by a different active object") - (show name) (if isArrowType ty - then "closure that captures local state" - else "local capability") - show (PolymorphicArgumentSendError arg ty) = - printf ("Cannot pass value of '%s' between active objects. " ++ - "Its type is polymorphic so it may not be safe to share.\n" ++ - "Consider marking the type variable '%s' as 'sharable'") - (show (ppSugared arg)) (getId ty) - show (PolymorphicReturnError name ty) = - printf ("Method '%s' returns a value of polymorphic type, and sharing " ++ - "it between active objects may not be safe. \n" ++ - "Consider marking the type variable '%s' as 'sharable'.") - (show name) (getId ty) - show (MalformedConjunctionError ty nonDisjoint source) = - printf "Type '%s' does not form a conjunction with '%s' in %s" - (show ty) (show nonDisjoint) (Types.showWithKind source) - show (CannotUnpackError source) = - printf "Cannot unpack empty capability of class '%s'" - (show source) - show (CannotInferUnpackingError cap) = - printf ("Unpacking of %s cannot be inferred. " ++ - "Try adding type annotations") - (Types.showWithKind cap) - show (UnsplittableTypeError ty) = - printf "Cannot unpack %s" - (Types.showWithKind ty) - show (DuplicatingSplitError ty) = - printf "Cannot duplicate linear trait '%s'" - (showWithoutMode ty) - show (StackboundArrayTypeError ty) = - printf "Arrays cannot store borrowed values of type '%s'" - (show ty) - show (ManifestConflictError formal conflicting) = - printf ("Trait '%s' with declared mode '%s' can only be " ++ - "composed with traits of the same mode. Found '%s'") - (showWithoutMode formal) (showModeOf formal) (show conflicting) - show (ManifestClassConflictError cls conflicting) = - printf "Trait '%s' cannot be included by class '%s' of declared mode '%s'" - (show conflicting) (showWithoutMode cls) (showModeOf cls) - show (UnmodedMethodExtensionError cls name) = - printf ("Unmoded class '%s' cannot declare new method '%s'. " ++ - "Possible fixes: \n" ++ - " - Add a mode to the class (e.g. %s)\n" ++ - " - Assign the method to an included trait: T(%s())") - (show cls) (show name) - "active, local, read, linear or subord" (show name) - show (ActiveTraitError active nonActive) = - printf ("Active trait '%s' can only be included together with " ++ - "other active traits. Found '%s'") - (showWithoutMode active) (show nonActive) - show (UnsafeTypeArgumentError formal ty) = - if isModeless ty then - -- TODO: Could be more precise (e.g. distinguish between linear/subord) - printf ("Cannot use non-aliasable type '%s' as type argument. " ++ - "Type parameter '%s' requires the type to have %s mode") - (show ty) (getId formal) (if isModeless formal - then "an aliasable" - else showModeOf formal) - else - printf ("Cannot use %s type '%s' as type argument. " ++ - "Type parameter '%s' requires the type to have %s mode") - (showModeOf ty) (showWithoutMode ty) - (getId formal) (if isModeless formal - then "an aliasable" - else showModeOf formal) - show OverlapWithBuiltins = - printf ("Types Maybe, Fut, Stream, and Par are built-in and cannot be redefined.") - show (SimpleError msg) = msg - ---------------------------- - -- Capturechecking errors -- - ---------------------------- - show ReverseBorrowingError = - "Reverse borrowing (returning borrowed values) " ++ - "is currently not supported" - show (BorrowedFieldError ftype) = - printf "Cannot have field of borrowed type '%s'" - (show ftype) - show (LinearClosureError name ty) = - printf "Cannot capture variable '%s' of linear type '%s' in a closure" - (show name) (show ty) - show (BorrowedLeakError e) = - printf "Cannot pass borrowed expression '%s' as non-borrowed parameter" - (show (ppSugared e)) - show (NonBorrowableError FieldAccess{target, name}) = - printf "Cannot borrow linear field '%s' from non-linear path '%s'" - (show name) (show (ppSugared target)) - show (NonBorrowableError ArrayAccess{target}) = - printf "Cannot borrow linear array value from non-linear path '%s'" - (show (ppSugared target)) - show (NonBorrowableError e) = - printf "Expression '%s' cannot be borrowed." - (show (ppSugared e)) - show (ActiveBorrowError arg targetType) = - printf ("Expression '%s' cannot be borrowed " ++ - "by active object of type '%s'") - (show (ppSugared arg)) (show targetType) - show (ActiveBorrowSendError arg targetType) = - printf ("Cannot send borrowed expression '%s' to active object " ++ - "of type '%s'") - (show (ppSugared arg)) (show targetType) - show (DuplicateBorrowError root) = - printf ("Borrowed variable '%s' cannot be used more than once " ++ - "in an argument list") - (show (ppSugared root)) - show (StackboundednessMismatchError ty expected) = - printf "%s does not match %s" (kindOf ty) (kindOf' expected) - where - kindOf ty - | isStackboundType ty = "Borrowed type '" ++ show ty ++ "'" - | otherwise = "Non-borrowed type '" ++ show ty ++ "'" - kindOf' ty = - let c:s = kindOf ty - in toLower c:s - show (LinearCaptureError e ty) = - printf "Cannot capture expression '%s' of linear type '%s'" - (show (ppSugared e)) (show ty) +-- instance Show Error where +-- show (DistinctTypeParametersError ty) = +-- printf "Type parameters of '%s' must be distinct" (show ty) +-- show (WrongNumberOfMethodArgumentsError name targetType expected actual) = +-- let nameWithKind = +-- (if name == constructorName +-- then "Constructor" +-- else "Method '" ++ show name ++ "'") ++ +-- " in " ++ refTypeName targetType +-- in printf "%s expects %d %s. Got %d" +-- nameWithKind expected (arguments expected) actual +-- show (WrongNumberOfFunctionArgumentsError name expected actual) = +-- printf "Function %s expects %d %s. Got %d" +-- (show name) expected (arguments expected) actual +-- show (WrongNumberOfFunctionTypeArgumentsError name expected actual) = +-- printf "Function %s expects %d %s. Got %d" +-- (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 +-- show (MissingFieldRequirementError field trait) = +-- printf "Cannot find field '%s' required by included %s" +-- (show field) (refTypeName trait) +-- show (CovarianceViolationError field expected trait) = +-- printf ("Field '%s' must have a subtype of '%s' to meet " ++ +-- "the requirements of included %s") +-- (show field) (show expected) (refTypeName trait) +-- show (RequiredFieldMismatchError field expected trait isSub) = +-- printf ("Field '%s' must exactly match type '%s' " ++ +-- "to meet the requirements of included %s%s") +-- (show field) (show expected) (refTypeName trait) +-- (if isSub +-- then ". Consider turning '" ++ show (fname field) ++ +-- "' into a val-field in " ++ refTypeName trait +-- else "") +-- show (NonDisjointConjunctionError left right field) = +-- printf +-- "Conjunctive traits '%s' and '%s' cannot share mutable field '%s'" +-- (show left) (show right) (show field) +-- show (OverriddenMethodTypeError name expected trait actual) = +-- printf ("Overridden method '%s' does not " ++ +-- "have the expected type '%s' required by %s.\n" ++ +-- "Actual type is '%s'") +-- (show name) (show expected) (refTypeName trait) (show actual) +-- show (OverriddenMethodError name trait err) = +-- case err of +-- FieldNotFoundError f _ -> +-- printf ("Overridden method '%s' requires access to field '%s' " ++ +-- "which is not in requiring %s.\n" ++ +-- "Consider extending the trait on inclusion: %s(%s)") +-- (show name) (show f) (refTypeName trait) (show trait) (show f) +-- MethodNotFoundError m _ -> +-- printf ("Overridden method '%s' calls method '%s' " ++ +-- "which is not in requiring %s.\n" ++ +-- "Consider extending the trait on inclusion: %s(%s())") +-- (show name) (show m) (refTypeName trait) (show trait) (show m) +-- TypeMismatchError actual expected -> +-- if actual == abstractTraitFromTraitType trait +-- then printf ("Overridden method '%s' uses 'this' as %s " ++ +-- "and cannot be typechecked in requiring %s") +-- (show name) (show expected) (refTypeName trait) +-- else defaultMessage +-- ValFieldAssignmentError f targetType -> +-- if targetType == abstractTraitFromTraitType trait +-- then printf ("Overridden method '%s' writes field '%s' " ++ +-- "which is marked as immutable in requiring %s.") +-- (show name) (show f) (refTypeName trait) +-- else defaultMessage +-- err -> defaultMessage +-- where +-- defaultMessage = +-- printf ("Overridden method '%s' cannot be typechecked in " ++ +-- "requiring %s:\n%s") +-- (show name) (refTypeName trait) (show err) +-- show (IncludedMethodConflictError name left right) = +-- printf "Conflicting inclusion of method '%s' from %s and %s" +-- (show name) (refTypeName left) (refTypeName right) +-- show (MissingMethodRequirementError header trait) = +-- printf "Cannot find method '%s' required by included %s" +-- (show $ ppFunctionHeader header) (refTypeName trait) +-- show (UnknownTraitError ty) = +-- printf "Couldn't find trait '%s'" (getId ty) +-- show MissingMainClass = "Couldn't find active class 'Main'" +-- show SyncStreamCall = "A stream method can not be called synchronously since it will invariably deadlock" +-- show (IdComparisonNotSupportedError ty) = +-- printf "Type '%s' does not support identity comparison%s" (show ty) +-- (if isRefType ty +-- then " (must include Id trait)" +-- else "") +-- show (IdComparisonTypeMismatchError lty rty) +-- | isTupleType lty && isTupleType rty && +-- length (getArgTypes lty) /= length (getArgTypes rty) = +-- printf "Cannot compare tuples of different sizes: %s and %s" +-- (show lty) (show rty) +-- | otherwise = +-- printf "Cannot compare values across types %s and %s" +-- (show lty) (show rty) +-- show BadSyncCallError = "Synchronous method calls on actors are not allowed (except on the current this)" +-- show (PrivateAccessModifierTargetError name) = +-- printf "Cannot call private %s" kind +-- where +-- kind = if name == constructorName +-- then "constructor" +-- else "method '" ++ show name ++ "'" +-- show (UnknownRefTypeError ty) = +-- printf "Couldn't find class, trait or typedef '%s'" (show ty) +-- show (MalformedCapabilityError ty) = +-- printf "Cannot form capability with %s" (showWithKind ty) +-- show (MalformedBoundError bound) = +-- printf "Cannot use %s as bound (must have trait)" (showWithKind bound) +-- show (RecursiveTypesynonymError ty) = +-- printf "Type synonyms cannot be recursive. One of the culprits is %s" +-- (getId ty) +-- show (DuplicateThingError kind thing) = +-- printf "Duplicate %s of %s" kind thing +-- show PassiveStreamingMethodError = +-- "Cannot have streaming methods in a passive class" +-- show StreamingConstructorError = +-- "Constructor cannot be streaming" +-- show MainMethodArgumentsError = +-- "Main method must have argument type () or ([String])" +-- show MainConstructorError = +-- "Main class cannot have a constructor" +-- show (FieldNotFoundError name ty) = +-- printf "No field '%s' in %s" +-- (show name) (refTypeName ty) +-- show (MethodNotFoundError name ty) = +-- let nameWithKind = if name == constructorName +-- then "constructor" +-- else "method '" ++ show name ++ "'" +-- targetType = if isRefType ty +-- then refTypeName ty +-- else showWithKind ty +-- in printf "No %s in %s" +-- nameWithKind targetType +-- show BreakUsedAsExpressionError = +-- "Break is a statement and cannot be used as a value or expression" +-- show BreakOutsideOfLoopError = +-- "Break can only be used inside loops" +-- show ContinueUsedAsExpressionError = +-- "Continue is a statement and cannot be used as a value or expression" +-- show ContinueOutsideOfLoopError = +-- "Continue can only be used inside while, do/while, and repeat loops" +-- show (NonCallableTargetError targetType) = +-- printf "Cannot call method on expression of type '%s'" +-- (show targetType) +-- show (NonSendableTargetError targetType) = +-- printf "Cannot send message to expression of type '%s'" +-- (show targetType) +-- show MainMethodCallError = "Cannot call the main method" +-- show ConstructorCallError = +-- "Constructor method 'init' can only be called during object creation" +-- show (ExpectingOtherTypeError something ty) = +-- printf "Expected %s but found expression of type '%s'" +-- something (show ty) +-- show (NonStreamingContextError e) = +-- printf "Cannot have '%s' outside of a streaming method" +-- (show $ ppSugared e) +-- show (UnboundFunctionError name) = +-- printf "Unbound function variable '%s'" (show name) +-- show (NonFunctionTypeError ty) = +-- printf "Cannot use value of type '%s' as a function" (show ty) +-- show BottomTypeInferenceError = "Not enough information to infer the type.\n" ++ +-- "Try adding more type information." +-- show IfInferenceError = "Cannot infer result type of if-statement" +-- show (IfBranchMismatchError ty1 ty2) = +-- "Type mismatch in different branches of if-statement:\n" ++ +-- " then: " ++ show ty1 ++ "\n" ++ +-- " else: " ++ show ty2 +-- show EmptyMatchClauseError = "Match statement must have at least one clause" +-- show ActiveMatchError = "Cannot match on an active object" +-- show MatchInferenceError = "Cannot infer result type of match expression" +-- show ThisReassignmentError = "Cannot rebind variable 'this'" +-- show (ImmutableVariableError qname) = +-- printf "Variable '%s' is immutable and cannot be re-assigned" +-- (show qname) +-- show (PatternArityMismatchError name expected actual) = +-- printf "Extractor '%s' returns %s. Pattern has %s" +-- (show name) +-- (if expected == 1 +-- then "1 value" +-- else show expected ++ " values") +-- (show actual) +-- show (PatternTypeMismatchError pattern ty) = +-- printf "Pattern '%s' does not match expected type '%s'" +-- (show $ ppSugared pattern) (show ty) +-- show (NonMaybeExtractorPatternError pattern) = +-- printf "Extractor '%s' must return a Maybe type to be used as a pattern" +-- (show $ ppSugared pattern) +-- show (InvalidPatternError pattern) = +-- printf "'%s' is not a valid pattern" +-- (show $ ppSugared pattern) +-- show (InvalidTupleTargetError target compartment ty) = +-- printf "Compartment access %s.%d expects a tuple target, found %s" +-- (show $ ppSugared target) +-- compartment +-- (show ty) +-- show (InvalidTupleAccessError target compartment) = +-- printf "No .%d compartment in tuple %s" +-- compartment +-- (show $ ppSugared target) +-- show (CannotReadFieldError target) = +-- let targetType = getType target in +-- if isClassType targetType && isModeless targetType then +-- printf "Cannot access field of expression '%s' of unmoded class '%s'" +-- (show $ ppSugared target) (show targetType) +-- else +-- printf "Cannot read field of expression '%s' of %s" +-- (show $ ppSugared target) (showWithKind targetType) +-- show NonAssignableLHSError = +-- "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) +-- show (UnboundVariableError name) = +-- printf "Unbound variable '%s'" (show name) +-- show (BuriedVariableError name) = +-- printf "Variable '%s' cannot be accessed during borrowing" (show name) +-- show (ObjectCreationError ty) +-- | isMainType ty = "Cannot create additional Main objects" +-- | isCapabilityType ty = +-- printf "Cannot create instance of %s (type must be a class)" +-- (refTypeName ty) +-- | otherwise = printf "Cannot create object of type '%s'" (show ty) +-- show (NonIterableError ty) = +-- printf "Type '%s' is not iterable" (show ty) +-- show EmptyArrayLiteralError = "Array literal must have at least one element" +-- show (NonIndexableError ty) = +-- printf "Type '%s' is not indexable" (show ty) +-- show (NonSizeableError ty) = +-- printf "Type '%s' has no size" (show ty) +-- show FormatStringLiteralError = +-- "Formatted printing expects first argument to be a string literal" +-- show (UnprintableExpressionError ty) = +-- printf "Expression of type '%s' is not printable" (show ty) +-- show (WrongNumberOfPrintArgumentsError expected actual) = +-- printf ("Wrong number of arguments to print. Format string " ++ +-- "expects %d %s. Found %d") expected (arguments expected) actual +-- 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 (UndefinedBinaryOperatorError op) = +-- printf "Undefined binary operator '%s'" (show op) +-- show NullTypeInferenceError = +-- "Cannot infer type of null valued expression. " ++ +-- "Try adding type annotations" +-- show (CannotBeNullError ty) = +-- printf ("Null valued expression cannot have type '%s' " ++ +-- "(must have reference type)") (show ty) +-- show (TypeMismatchError actual expected) +-- | isTypeVar actual && isJust (getBound actual) = +-- printf "Type '%s' with bound '%s' does not match expected type '%s'" +-- (show actual) (show . fromJust $ getBound actual) (show expected) +-- | isArrowType actual +-- , isArrowType expected +-- , actual `withModeOf` expected == expected = +-- printf ("Closure of type '%s' captures %s state and cannot " ++ +-- "be used as type '%s'") +-- (show actual) (showModeOf actual) (show expected) +-- | otherwise = printf "Type '%s' does not match expected type '%s'" +-- (show actual) (show expected) +-- show (TypeWithCapabilityMismatchError actual cap expected) = +-- printf "Type '%s' with capability '%s' does not match expected type '%s'%s" +-- (show actual) (show cap) (show expected) pointer +-- where +-- pointer = +-- let actualTraits = typesFromCapability cap +-- expectedTraits = typesFromCapability expected +-- remainders = actualTraits \\ expectedTraits +-- nonDroppables = filter (not . isReadSingleType) remainders +-- nonDroppable = head nonDroppables +-- in if isCapabilityType expected && +-- all (\te -> any (\ta -> ta == te && +-- ta `modeSubtypeOf` te) actualTraits) +-- expectedTraits +-- then ". Cannot drop mode '" ++ showModeOf nonDroppable ++ "'" +-- else "" +-- show (TypeVariableAmbiguityError expected ty1 ty2) = +-- printf "Type variable '%s' cannot be bound to both '%s' and '%s'" +-- (getId expected) (show ty1) (show ty2) +-- show (FreeTypeVariableError ty) = +-- if getId ty == "void" +-- then printf "Type 'void' is deprecated. Use 'unit' instead" +-- else printf "Type variable '%s' is unbound" (show ty) +-- show (TypeVariableAndVariableCommonNameError [name]) = +-- printf "Type variable '%s' clashes with existing variable name." +-- (show name) +-- show (TypeVariableAndVariableCommonNameError names) = +-- printf "Type variables %s clash with existing variable names." +-- formattingName +-- where +-- formattingName = +-- let ns = map (\n -> "'" ++ show n ++ "', ") (init names) +-- lastName = "'" ++ show (last names) ++ "'" +-- in show ns ++ "and " ++ lastName +-- show (UnionMethodAmbiguityError ty name) = +-- printf "Cannot disambiguate method '%s' in %s" +-- (show name) (showWithKind ty) +-- show (MalformedUnionTypeError ty union) = +-- printf "Type '%s' is not compatible with %s" +-- (show ty) (showWithKind union) +-- show (TypeArgumentInferenceError call param) = +-- printf "Cannot infer the type of parameter '%s' of %s '%s'" +-- (show param) kind calledName +-- where +-- mname = name call +-- kind | isFunctionCall call = "function" +-- | isMethodCallOrMessageSend call = +-- if mname == constructorName +-- then "class" +-- else "method" +-- | otherwise = error msg +-- calledName | isFunctionCall call = show $ qname call +-- | isMethodCallOrMessageSend call = +-- if mname == constructorName +-- then show $ getType (target call) +-- else show mname +-- | otherwise = error msg +-- msg = "TypeError.hs: " ++ show call ++ +-- " is not a function or method call" +-- show (RequiredFieldMutabilityError requirer field) = +-- printf "Trait '%s' requires field '%s' to be mutable" +-- (getId requirer) (show field) +-- show (ProvidingTraitFootprintError provider requirer mname fields) = +-- printf ("Trait '%s' cannot provide method '%s' to %s.\n" ++ +-- "'%s' can mutate fields that are marked immutable in '%s':\n%s") +-- (getId provider) (show mname) (refTypeName requirer) +-- (getId provider) (getId requirer) +-- (unlines (map ((" " ++) . show) fields)) +-- show (AmbiguousTypeError ty candidates) = +-- printf "Ambiguous reference to %s. Possible candidates are:\n%s" +-- (showWithKind ty) (unlines $ map ((" " ++) . show) candidates) +-- show (UnknownTypeUsageError usage ty) = +-- printf "Cannot %s unimported type %s" +-- usage (show ty) +-- show (AmbiguousNameError qname candidates) = +-- printf "Ambiguous reference to function %s. Possible candidates are:\n%s" +-- (show qname) candidateList +-- where +-- candidateList = +-- unlines $ map ((" " ++) . showCandidate) candidates +-- showCandidate (qn, ty) = show qn ++ " : " ++ show ty +-- show (UnknownNamespaceError maybeNs) = +-- printf "Unknown namespace %s" +-- (maybe "" show maybeNs) +-- show (UnknownNameError ns name) = +-- printf "Module %s has no function or type called '%s'" +-- (show ns) (show name) +-- show (ShadowedImportError i) = +-- printf "Introduction of module alias '%s' shadows existing import" +-- (show $ itarget i) +-- show (WrongModuleNameError modname expected) = +-- printf "Module name '%s' and file name '%s' must match" +-- (show modname) expected +-- show PolymorphicConstructorError = +-- printf "Constructors (a.k.a. 'init methods') cannot use parametric methods" +-- show ClosureReturnError = +-- "Closures must declare their type to use return" +-- show ClosureForwardError = +-- "Closures must declare their type to use forward" +-- show MatchMethodNonMaybeReturnError = +-- "Match methods must return a Maybe type" +-- show MatchMethodNonEmptyParameterListError = +-- "Match methods cannot have parameters" +-- show (ImpureMatchMethodError e) = +-- printf "Match methods must be pure%s" +-- pointer +-- where +-- pointer +-- | While{} <- e = ". Consider using a for loop" +-- | otherwise = "" +-- show (ForwardTypeError retType ty) = +-- printf ("Returned type %s of forward should match with " ++ +-- "the result type of the containing method %s") +-- (show retType) (show ty) +-- show (ForwardTypeClosError retType ty) = +-- printf ("Result type %s of the closure should match with " ++ +-- "the return type %s of the forward") +-- (show retType) (show ty) +-- show (ForwardInPassiveContext cname) = +-- printf "Forward can not be used in passive class '%s'" +-- (show cname) +-- show (ForwardInFunction) = "Forward cannot be used in functions" +-- show (CannotHaveModeError ty) = +-- if isClassType ty +-- then printf "Cannot give mode to unmoded %s" (refTypeName ty) +-- else printf "Cannot give mode to %s" (Types.showWithKind ty) +-- show (ModelessError ty) = +-- printf "No mode given to %s" (refTypeName ty) +-- show (ModeOverrideError ty) = +-- printf "Cannot override declared mode '%s' of %s" +-- (showModeOf ty) (refTypeName ty) +-- show (CannotConsumeError expr) = +-- printf "Cannot consume '%s'" (show (ppSugared expr)) +-- show (CannotConsumeTypeError expr) = +-- printf ("Cannot consume '%s' of type '%s'. " ++ +-- "Consider using a Maybe-type") +-- (show (ppSugared expr)) (show (getType expr)) +-- show (ImmutableConsumeError expr) +-- | VarAccess{} <- expr = +-- printf "Cannot consume immutable variable '%s'" +-- (show (ppSugared expr)) +-- | FieldAccess{} <- expr = +-- printf "Cannot consume immutable field '%s'" +-- (show (ppSugared expr)) +-- | otherwise = +-- printf "Cannot consume immutable target '%s'" +-- (show (ppSugared expr)) +-- show (CannotGiveReadModeError trait) = +-- printf ("Cannot give read mode to trait '%s'. " ++ +-- "It must be declared as read at its declaration site") +-- (getId trait) +-- show (CannotGiveSharableModeError ty) = +-- printf ("Cannot give sharable mode to %s. " ++ +-- "It can only be used for type parameters") +-- (refTypeName ty) +-- show (NonValInReadContextError ctx) = +-- printf "Read %s can only have val fields" +-- (if isTraitType ctx then "traits" else "classes") +-- show (NonSafeInReadContextError ctx ty) = +-- printf "Read %s can not have field of non-safe type '%s'. \n%s" +-- (if isTraitType ctx then "trait" else "class") (show ty) +-- enumerateSafeTypes +-- show (NonSafeInExtendedReadTraitError t f ty) = +-- printf "Read trait '%s' cannot be extended with field '%s' of non-safe type '%s'. \n%s" +-- (getId t) (show f) (show ty) +-- enumerateSafeTypes +-- show (ProvidingToReadTraitError provider requirer mname) = +-- printf "Non-read trait '%s' cannot provide method '%s' to read trait '%s'" +-- (getId provider) (show mname) (getId requirer) +-- show (SubordinateReturnError name ty) = +-- printf ("Method '%s' returns a %s and cannot " ++ +-- "be called from outside of its aggregate") +-- (show name) (if isArrowType ty +-- then "closure that captures subordinate state" +-- else "subordinate capability") +-- show (SubordinateArgumentError arg) = +-- if isArrowType (getType arg) +-- then printf ("Closure '%s' captures subordinate state " ++ +-- "and cannot be passed outside of its aggregate") +-- (show (ppSugared arg)) +-- else printf ("Cannot pass subordinate argument '%s' " ++ +-- "outside of its aggregate") +-- (show (ppSugared arg)) +-- show (SubordinateFieldError name) = +-- printf ("Field '%s' is subordinate and cannot be accessed " ++ +-- "from outside of its aggregate") +-- (show name) +-- show (ThreadLocalFieldError ty) = +-- printf "%s must have declared 'local' or 'active' mode to have actor local fields" +-- (if isTraitType ty then "Traits" else "Classes") +-- show (ThreadLocalFieldExtensionError trait field) = +-- printf ("Trait '%s' must have local mode to be extended " ++ +-- "with field '%s' of actor local type '%s'") +-- (show trait) (show $ fname field) +-- (showWithoutMode $ ftype field) +-- show (ThreadLocalArgumentError arg) = +-- if isArrowType (getType arg) +-- then printf ("Closure '%s' captures actor local variables " ++ +-- "and cannot be passed to another active object") +-- (show (ppSugared arg)) +-- else printf ("Cannot pass actor local argument '%s' " ++ +-- "to another active object") +-- (show (ppSugared arg)) +-- show (ThreadLocalReturnError name ty) = +-- printf ("Method '%s' returns a %s and cannot " ++ +-- "be called by a different active object") +-- (show name) (if isArrowType ty +-- then "closure that captures local state" +-- else "local capability") +-- show (PolymorphicArgumentSendError arg ty) = +-- printf ("Cannot pass value of '%s' between active objects. " ++ +-- "Its type is polymorphic so it may not be safe to share.\n" ++ +-- "Consider marking the type variable '%s' as 'sharable'") +-- (show (ppSugared arg)) (getId ty) +-- show (PolymorphicReturnError name ty) = +-- printf ("Method '%s' returns a value of polymorphic type, and sharing " ++ +-- "it between active objects may not be safe. \n" ++ +-- "Consider marking the type variable '%s' as 'sharable'.") +-- (show name) (getId ty) +-- show (MalformedConjunctionError ty nonDisjoint source) = +-- printf "Type '%s' does not form a conjunction with '%s' in %s" +-- (show ty) (show nonDisjoint) (Types.showWithKind source) +-- show (CannotUnpackError source) = +-- printf "Cannot unpack empty capability of class '%s'" +-- (show source) +-- show (CannotInferUnpackingError cap) = +-- printf ("Unpacking of %s cannot be inferred. " ++ +-- "Try adding type annotations") +-- (Types.showWithKind cap) +-- show (UnsplittableTypeError ty) = +-- printf "Cannot unpack %s" +-- (Types.showWithKind ty) +-- show (DuplicatingSplitError ty) = +-- printf "Cannot duplicate linear trait '%s'" +-- (showWithoutMode ty) +-- show (StackboundArrayTypeError ty) = +-- printf "Arrays cannot store borrowed values of type '%s'" +-- (show ty) +-- show (ManifestConflictError formal conflicting) = +-- printf ("Trait '%s' with declared mode '%s' can only be " ++ +-- "composed with traits of the same mode. Found '%s'") +-- (showWithoutMode formal) (showModeOf formal) (show conflicting) +-- show (ManifestClassConflictError cls conflicting) = +-- printf "Trait '%s' cannot be included by class '%s' of declared mode '%s'" +-- (show conflicting) (showWithoutMode cls) (showModeOf cls) +-- show (UnmodedMethodExtensionError cls name) = +-- printf ("Unmoded class '%s' cannot declare new method '%s'. " ++ +-- "Possible fixes: \n" ++ +-- " - Add a mode to the class (e.g. %s)\n" ++ +-- " - Assign the method to an included trait: T(%s())") +-- (show cls) (show name) +-- "active, local, read, linear or subord" (show name) +-- show (ActiveTraitError active nonActive) = +-- printf ("Active trait '%s' can only be included together with " ++ +-- "other active traits. Found '%s'") +-- (showWithoutMode active) (show nonActive) +-- show (UnsafeTypeArgumentError formal ty) = +-- if isModeless ty then +-- -- TODO: Could be more precise (e.g. distinguish between linear/subord) +-- printf ("Cannot use non-aliasable type '%s' as type argument. " ++ +-- "Type parameter '%s' requires the type to have %s mode") +-- (show ty) (getId formal) (if isModeless formal +-- then "an aliasable" +-- else showModeOf formal) +-- else +-- printf ("Cannot use %s type '%s' as type argument. " ++ +-- "Type parameter '%s' requires the type to have %s mode") +-- (showModeOf ty) (showWithoutMode ty) +-- (getId formal) (if isModeless formal +-- then "an aliasable" +-- else showModeOf formal) +-- show OverlapWithBuiltins = +-- printf ("Types Maybe, Fut, Stream, and Par are built-in and cannot be redefined.") +-- show (SimpleError msg) = msg +-- ---------------------------- +-- -- Capturechecking errors -- +-- ---------------------------- +-- show ReverseBorrowingError = +-- "Reverse borrowing (returning borrowed values) " ++ +-- "is currently not supported" +-- show (BorrowedFieldError ftype) = +-- printf "Cannot have field of borrowed type '%s'" +-- (show ftype) +-- show (LinearClosureError name ty) = +-- printf "Cannot capture variable '%s' of linear type '%s' in a closure" +-- (show name) (show ty) +-- show (BorrowedLeakError e) = +-- printf "Cannot pass borrowed expression '%s' as non-borrowed parameter" +-- (show (ppSugared e)) +-- show (NonBorrowableError FieldAccess{target, name}) = +-- printf "Cannot borrow linear field '%s' from non-linear path '%s'" +-- (show name) (show (ppSugared target)) +-- show (NonBorrowableError ArrayAccess{target}) = +-- printf "Cannot borrow linear array value from non-linear path '%s'" +-- (show (ppSugared target)) +-- show (NonBorrowableError e) = +-- printf "Expression '%s' cannot be borrowed." +-- (show (ppSugared e)) +-- show (ActiveBorrowError arg targetType) = +-- printf ("Expression '%s' cannot be borrowed " ++ +-- "by active object of type '%s'") +-- (show (ppSugared arg)) (show targetType) +-- show (ActiveBorrowSendError arg targetType) = +-- printf ("Cannot send borrowed expression '%s' to active object " ++ +-- "of type '%s'") +-- (show (ppSugared arg)) (show targetType) +-- show (DuplicateBorrowError root) = +-- printf ("Borrowed variable '%s' cannot be used more than once " ++ +-- "in an argument list") +-- (show (ppSugared root)) +-- show (StackboundednessMismatchError ty expected) = +-- printf "%s does not match %s" (kindOf ty) (kindOf' expected) +-- where +-- kindOf ty +-- | isStackboundType ty = "Borrowed type '" ++ show ty ++ "'" +-- | otherwise = "Non-borrowed type '" ++ show ty ++ "'" +-- kindOf' ty = +-- let c:s = kindOf ty +-- in toLower c:s +-- show (LinearCaptureError e ty) = +-- printf "Cannot capture expression '%s' of linear type '%s'" +-- (show (ppSugared e)) (show ty) data TCWarning = TCWarning Warning Environment instance Show TCWarning where @@ -869,4 +871,4 @@ code = annotate Code --hash (UnionMethodAmbiguityError _ _) = 3 - --explain 3 = "stuff" \ No newline at end of file + --explain 3 = "stuff" From c710af515e7e49d7c3d8166242cd9430b1da8fa3 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Sat, 23 Jun 2018 18:13:22 +0200 Subject: [PATCH 18/31] Added rudimentary fixed table --- src/types/Typechecker/ExplainTable.hs | 55 +++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 src/types/Typechecker/ExplainTable.hs diff --git a/src/types/Typechecker/ExplainTable.hs b/src/types/Typechecker/ExplainTable.hs new file mode 100644 index 000000000..779aa14dc --- /dev/null +++ b/src/types/Typechecker/ExplainTable.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Typechecker.ExplainTable ( + Table + ,lookupHash + ,getErrorExplanation + ) where + +import Text.PrettyPrint +import Text.Read (readMaybe) + + +lookupHash :: String -> Maybe Int +lookupHash k = + let T t = table in + lookup' t k 0 + where + lookup' [] k _ = Nothing + lookup' ((k', v):as) k x + | k == k'= Just x + | otherwise = lookup' as k (x+1) + + +getErrorExplanation :: String -> Maybe Doc +getErrorExplanation ('E':err) = + case readMaybe err :: Maybe Int of + Just num + | num > 0 -> let T t = table in lookupExplain num t + | otherwise -> Nothing + Nothing -> Nothing +getErrorExplanation _ = Nothing + + +lookupExplain _ [] = Nothing +lookupExplain 0 ((_, v):_) = Just v +lookupExplain x (_:ls) = lookupExplain (x-1) ls + + +newtype Table k v = T [(k, v)] + +table :: Table String Doc +table = + T [ + ( + "MissingMainClass", + "Welcome to the Encore Compiler!" $$ + "Here you will meet many wonderful methods and functions and whatnot!" + ) + ] + +{- +error <- case lookupHash (head $ words $ show err) of + Nothing -> return "Error: " + Just num -> return $ printf "Error[E%04d]: " num +-} \ No newline at end of file From b31315b8fef26431eb335a417aff6d9c10e775c3 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Sat, 23 Jun 2018 21:46:24 +0200 Subject: [PATCH 19/31] Ability to construct explanations of different error types --- src/front/TopLevel.hs | 16 ++++++++++++---- src/types/Typechecker/Errorprinter.hs | 20 ++++++++++++++++++-- src/types/Typechecker/ExplainTable.hs | 13 ++++++++----- 3 files changed, 38 insertions(+), 11 deletions(-) diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index 33a9e27f8..bc50162d9 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -25,6 +25,8 @@ import qualified Data.Map.Strict as Map import SystemUtils import Language.Haskell.TH -- for Template Haskell hackery import Text.Printf +import System.Console.ANSI +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) @@ -42,7 +44,7 @@ import Typechecker.Environment(buildLookupTable) import Typechecker.Prechecker(precheckProgram) import Typechecker.Typechecker(typecheckProgram, checkForMainClass) import Typechecker.Errorprinter -import Typechecker.ErrorExplainer(getErrorExplanation) +import Typechecker.ExplainTable(getErrorExplanation) import Typechecker.Capturechecker(capturecheckProgram) import Optimizer.Optimizer import CodeGen.Main @@ -299,7 +301,7 @@ main = when (Help `elem` options) (exit helpMessage) case find isExplain options of - Just (Explain errCode) -> exit $ explainError errCode + Just (Explain errCode) -> explainError errCode Nothing -> return () when (null programs) (abort ("No program specified! Aborting.\n\n" <> @@ -424,8 +426,14 @@ main = explainError errCode = case getErrorExplanation errCode of - Just explain -> explain - Nothing -> printf "error: no extended information for %s" errCode + Nothing -> do + noExplanation errCode + exit "" + Just explain -> do + resetScreen >> exit (Pretty.render $ explain Pretty.<> Pretty.text "\n") + where + resetScreen :: IO () + resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0 helpMessage = "Welcome to the Encore compiler!\n" <> diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs index c128e6001..9d2124f07 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -1,5 +1,5 @@ -module Typechecker.Errorprinter (printError) where +module Typechecker.Errorprinter (printError, noExplanation) where -- Library dependencies @@ -18,6 +18,7 @@ import Typechecker.Environment import Typechecker.TypeError import Typechecker.Util import Typechecker.Suggestable +import Typechecker.ExplainTable currentPos (TCError _ Env{bt = ((pos, _):_)}) = pos @@ -30,6 +31,14 @@ printError error = do renderError $ prettyError error code $+$ text "" +noExplanation :: String -> IO () +noExplanation errCode = + let + err = classify $ text "error" + info = desc $ text $ printf ": no extended information for %s\n" errCode + in + renderError $ err <> info + renderError :: Doc TCStyle -> IO () renderError doc = renderDecoratedM toErrorStyle endAnn textprinter endDoc doc @@ -80,7 +89,14 @@ prettyError tcErr@(TCError err _) code = pipe = char '|' declareError :: Error -> Doc TCStyle -declareError _ = classify $ text "Error:" +declareError err = + let + hash = case lookupHash (head $ words $ show err) of + Nothing -> empty + Just num -> text $ printf "[E%04d]" num + in + classify $ text "Error" <> hash <> char ':' + description :: Error -> Doc TCStyle description err = desc $ text $ show err diff --git a/src/types/Typechecker/ExplainTable.hs b/src/types/Typechecker/ExplainTable.hs index 779aa14dc..8b0602edb 100644 --- a/src/types/Typechecker/ExplainTable.hs +++ b/src/types/Typechecker/ExplainTable.hs @@ -6,14 +6,17 @@ module Typechecker.ExplainTable ( ,getErrorExplanation ) where -import Text.PrettyPrint +import Typechecker.TypeError + +import Text.PrettyPrint.Annotated import Text.Read (readMaybe) +import Text.Printf (printf) lookupHash :: String -> Maybe Int lookupHash k = let T t = table in - lookup' t k 0 + lookup' t k 1 where lookup' [] k _ = Nothing lookup' ((k', v):as) k x @@ -21,11 +24,11 @@ lookupHash k = | otherwise = lookup' as k (x+1) -getErrorExplanation :: String -> Maybe Doc +getErrorExplanation :: String -> Maybe (Doc a) getErrorExplanation ('E':err) = case readMaybe err :: Maybe Int of Just num - | num > 0 -> let T t = table in lookupExplain num t + | num > 0 -> let T t = table in lookupExplain (num-1) t | otherwise -> Nothing Nothing -> Nothing getErrorExplanation _ = Nothing @@ -38,7 +41,7 @@ lookupExplain x (_:ls) = lookupExplain (x-1) ls newtype Table k v = T [(k, v)] -table :: Table String Doc +table :: Table String (Doc a) table = T [ ( From 64297e4e3af3c59c9138446a5ebdb464579bfbc5 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Sat, 23 Jun 2018 22:20:59 +0200 Subject: [PATCH 20/31] Re-added instance Show for Error --- src/types/Typechecker/Errorprinter.hs | 2 +- src/types/Typechecker/ExplainTable.hs | 175 +++- src/types/Typechecker/TypeError.hs | 1177 ++++++++++++------------- 3 files changed, 750 insertions(+), 604 deletions(-) diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs index 9d2124f07..19cbbb30e 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -91,7 +91,7 @@ pipe = char '|' declareError :: Error -> Doc TCStyle declareError err = let - hash = case lookupHash (head $ words $ show err) of + hash = case lookupHash err of Nothing -> empty Just num -> text $ printf "[E%04d]" num in diff --git a/src/types/Typechecker/ExplainTable.hs b/src/types/Typechecker/ExplainTable.hs index 8b0602edb..50256522c 100644 --- a/src/types/Typechecker/ExplainTable.hs +++ b/src/types/Typechecker/ExplainTable.hs @@ -13,15 +13,15 @@ import Text.Read (readMaybe) import Text.Printf (printf) -lookupHash :: String -> Maybe Int -lookupHash k = - let T t = table in - lookup' t k 1 - where - lookup' [] k _ = Nothing - lookup' ((k', v):as) k x - | k == k'= Just x - | otherwise = lookup' as k (x+1) +lookupHash :: Error -> Maybe Int +lookupHash err + | Just k <- toKey err = let T t = table in lookup' t k 1 + | otherwise = Nothing + where + lookup' [] k _ = Nothing + lookup' ((k', v):as) k x + | k == k'= Just x + | otherwise = lookup' as k (x+1) getErrorExplanation :: String -> Maybe (Doc a) @@ -51,8 +51,155 @@ table = ) ] -{- -error <- case lookupHash (head $ words $ show err) of - Nothing -> return "Error: " - Just num -> return $ printf "Error[E%04d]: " num --} \ No newline at end of file + +-- I want to have a guarding Nothing in case if an error is introdused, +-- but the compiler gives me an overlapped-error.... +toKey :: Error -> Maybe String +toKey (DistinctTypeParametersError _) = Just "DistinctTypeParametersError" +toKey (WrongNumberOfMethodArgumentsError _ _ _ _) = Just "WrongNumberOfMethodArgumentsError" +toKey (WrongNumberOfFunctionArgumentsError _ _ _) = Just "WrongNumberOfFunctionArgumentsError" +toKey (WrongNumberOfFunctionTypeArgumentsError _ _ _) = Just "WrongNumberOfFunctionTypeArgumentsError" +toKey (WrongNumberOfTypeParametersError _ _ _ _) = Just "WrongNumberOfTypeParametersError" +toKey (MissingFieldRequirementError _ _) = Just "MissingFieldRequirementError" +toKey (CovarianceViolationError _ _ _) = Just "CovarianceViolationError" +toKey (RequiredFieldMismatchError _ _ _ _) = Just "RequiredFieldMismatchError" +toKey (NonDisjointConjunctionError _ _ _) = Just "NonDisjointConjunctionError" +toKey (OverriddenMethodTypeError _ _ _ _) = Just "OverriddenMethodTypeError" +toKey (OverriddenMethodError _ _ _) = Just "OverriddenMethodError" +toKey (IncludedMethodConflictError _ _ _) = Just "IncludedMethodConflictError" +toKey (MissingMethodRequirementError _ _) = Just "MissingMethodRequirementError" +toKey (MissingMainClass) = Just "MissingMainClass" +toKey (SyncStreamCall) = Just "SyncStreamCall" +toKey (UnknownTraitError _) = Just "UnknownTraitError" +toKey (UnknownRefTypeError _) = Just "UnknownRefTypeError" +toKey (MalformedCapabilityError _) = Just "MalformedCapabilityError" +toKey (MalformedBoundError _) = Just "MalformedBoundError" +toKey (RecursiveTypesynonymError _) = Just "RecursiveTypesynonymError" +toKey (DuplicateThingError _ _) = Just "DuplicateThingError" +toKey (PassiveStreamingMethodError) = Just "PassiveStreamingMethodError" +toKey (PolymorphicConstructorError) = Just "PolymorphicConstructorError" +toKey (StreamingConstructorError) = Just "StreamingConstructorError" +toKey (MainMethodArgumentsError) = Just "MainMethodArgumentsError" +toKey (MainConstructorError) = Just "MainConstructorError" +toKey (FieldNotFoundError _ _) = Just "FieldNotFoundError" +toKey (MethodNotFoundError _ _) = Just "MethodNotFoundError" +toKey (BreakOutsideOfLoopError) = Just "BreakOutsideOfLoopError" +toKey (BreakUsedAsExpressionError) = Just "BreakUsedAsExpressionError" +toKey (ContinueOutsideOfLoopError) = Just "ContinueOutsideOfLoopError" +toKey (ContinueUsedAsExpressionError) = Just "ContinueUsedAsExpressionError" +toKey (NonCallableTargetError _) = Just "NonCallableTargetError" +toKey (NonSendableTargetError _) = Just "NonSendableTargetError" +toKey (MainMethodCallError) = Just "MainMethodCallError" +toKey (ConstructorCallError) = Just "ConstructorCallError" +toKey (ExpectingOtherTypeError _ _) = Just "ExpectingOtherTypeError" +toKey (NonStreamingContextError _) = Just "NonStreamingContextError" +toKey (UnboundFunctionError _) = Just "UnboundFunctionError" +toKey (NonFunctionTypeError _) = Just "NonFunctionTypeError" +toKey (BottomTypeInferenceError) = Just "BottomTypeInferenceError" +toKey (IfInferenceError) = Just "IfInferenceError" +toKey (IfBranchMismatchError _ _) = Just "IfBranchMismatchError" +toKey (EmptyMatchClauseError) = Just "EmptyMatchClauseError" +toKey (ActiveMatchError) = Just "ActiveMatchError" +toKey (MatchInferenceError) = Just "MatchInferenceError" +toKey (ThisReassignmentError) = Just "ThisReassignmentError" +toKey (ImmutableVariableError _) = Just "ImmutableVariableError" +toKey (PatternArityMismatchError _ _ _) = Just "PatternArityMismatchError" +toKey (PatternTypeMismatchError _ _) = Just "PatternTypeMismatchError" +toKey (NonMaybeExtractorPatternError _) = Just "NonMaybeExtractorPatternError" +toKey (InvalidPatternError _) = Just "InvalidPatternError" +toKey (InvalidTupleTargetError _ _ _) = Just "InvalidTupleTargetError" +toKey (InvalidTupleAccessError _ _) = Just "InvalidTupleAccessError" +toKey (CannotReadFieldError _) = Just "CannotReadFieldError" +toKey (NonAssignableLHSError) = Just "NonAssignableLHSError" +toKey (ValFieldAssignmentError _ _) = Just "ValFieldAssignmentError" +toKey (UnboundVariableError _) = Just "UnboundVariableError" +toKey (BuriedVariableError _) = Just "BuriedVariableError" +toKey (ObjectCreationError _) = Just "ObjectCreationError" +toKey (NonIterableError _) = Just "NonIterableError" +toKey (EmptyArrayLiteralError) = Just "EmptyArrayLiteralError" +toKey (NonIndexableError _) = Just "NonIndexableError" +toKey (NonSizeableError _) = Just "NonSizeableError" +toKey (FormatStringLiteralError) = Just "FormatStringLiteralError" +toKey (UnprintableExpressionError _) = Just "UnprintableExpressionError" +toKey (WrongNumberOfPrintArgumentsError _ _) = Just "WrongNumberOfPrintArgumentsError" +toKey (UnaryOperandMismatchError _ _) = Just "UnaryOperandMismatchError" +toKey (BinaryOperandMismatchError _ _ _ _) = Just "BinaryOperandMismatchError" +toKey (UndefinedBinaryOperatorError _) = Just "UndefinedBinaryOperatorError" +toKey (NullTypeInferenceError) = Just "NullTypeInferenceError" +toKey (CannotBeNullError _) = Just "CannotBeNullError" +toKey (TypeMismatchError _ _) = Just "TypeMismatchError" +toKey (TypeWithCapabilityMismatchError _ _ _) = Just "TypeWithCapabilityMismatchError" +toKey (TypeVariableAmbiguityError _ _ _) = Just "TypeVariableAmbiguityError" +toKey (FreeTypeVariableError _) = Just "FreeTypeVariableError" +toKey (TypeVariableAndVariableCommonNameError _) = Just "TypeVariableAndVariableCommonNameError" +toKey (UnionMethodAmbiguityError _ _) = Just "UnionMethodAmbiguityError" +toKey (MalformedUnionTypeError _ _) = Just "MalformedUnionTypeError" +toKey (RequiredFieldMutabilityError _ _) = Just "RequiredFieldMutabilityError" +toKey (ProvidingTraitFootprintError _ _ _ _) = Just "ProvidingTraitFootprintError" +toKey (TypeArgumentInferenceError _ _) = Just "TypeArgumentInferenceError" +toKey (AmbiguousTypeError _ _) = Just "AmbiguousTypeError" +toKey (UnknownTypeUsageError _ _) = Just "UnknownTypeUsageError" +toKey (AmbiguousNameError _ _) = Just "AmbiguousNameError" +toKey (UnknownNamespaceError _) = Just "UnknownNamespaceError" +toKey (UnknownNameError _ _) = Just "UnknownNameError" +toKey (ShadowedImportError _) = Just "ShadowedImportError" +toKey (WrongModuleNameError _ _) = Just "WrongModuleNameError" +toKey (BadSyncCallError) = Just "BadSyncCallError" +toKey (PrivateAccessModifierTargetError _) = Just "PrivateAccessModifierTargetError" +toKey (ClosureReturnError) = Just "ClosureReturnError" +toKey (ClosureForwardError) = Just "ClosureForwardError" +toKey (MatchMethodNonMaybeReturnError) = Just "MatchMethodNonMaybeReturnError" +toKey (MatchMethodNonEmptyParameterListError) = Just "MatchMethodNonEmptyParameterListError" +toKey (ImpureMatchMethodError _) = Just "ImpureMatchMethodError" +toKey (IdComparisonNotSupportedError _) = Just "IdComparisonNotSupportedError" +toKey (IdComparisonTypeMismatchError _ _) = Just "IdComparisonTypeMismatchError" +toKey (ForwardInPassiveContext _) = Just "ForwardInPassiveContext" +toKey (ForwardInFunction) = Just "ForwardInFunction" +toKey (ForwardTypeError _ _) = Just "ForwardTypeError" +toKey (ForwardTypeClosError _ _) = Just "ForwardTypeClosError" +toKey (CannotHaveModeError _) = Just "CannotHaveModeError" +toKey (ModelessError _) = Just "ModelessError" +toKey (ModeOverrideError _) = Just "ModeOverrideError" +toKey (CannotConsumeError _) = Just "CannotConsumeError" +toKey (CannotConsumeTypeError _) = Just "CannotConsumeTypeError" +toKey (ImmutableConsumeError _) = Just "ImmutableConsumeError" +toKey (CannotGiveReadModeError _) = Just "CannotGiveReadModeError" +toKey (CannotGiveSharableModeError _) = Just "CannotGiveSharableModeError" +toKey (NonValInReadContextError _) = Just "NonValInReadContextError" +toKey (NonSafeInReadContextError _ _) = Just "NonSafeInReadContextError" +toKey (NonSafeInExtendedReadTraitError _ _ _) = Just "NonSafeInExtendedReadTraitError" +toKey (ProvidingToReadTraitError _ _ _) = Just "ProvidingToReadTraitError" +toKey (SubordinateReturnError _ _) = Just "SubordinateReturnError" +toKey (SubordinateArgumentError _) = Just "SubordinateArgumentError" +toKey (SubordinateFieldError _) = Just "SubordinateFieldError" +toKey (ThreadLocalFieldError _) = Just "ThreadLocalFieldError" +toKey (ThreadLocalFieldExtensionError _ _) = Just "ThreadLocalFieldExtensionError" +toKey (ThreadLocalArgumentError _) = Just "ThreadLocalArgumentError" +toKey (PolymorphicArgumentSendError _ _) = Just "PolymorphicArgumentSendError" +toKey (PolymorphicReturnError _ _) = Just "PolymorphicReturnError" +toKey (ThreadLocalReturnError _ _) = Just "ThreadLocalReturnError" +toKey (MalformedConjunctionError _ _ _) = Just "MalformedConjunctionError" +toKey (CannotUnpackError _) = Just "CannotUnpackError" +toKey (CannotInferUnpackingError _) = Just "CannotInferUnpackingError" +toKey (UnsplittableTypeError _) = Just "UnsplittableTypeError" +toKey (DuplicatingSplitError _) = Just "DuplicatingSplitError" +toKey (StackboundArrayTypeError _) = Just "StackboundArrayTypeError" +toKey (ManifestConflictError _ _) = Just "ManifestConflictError" +toKey (ManifestClassConflictError _ _) = Just "ManifestClassConflictError" +toKey (UnmodedMethodExtensionError _ _) = Just "UnmodedMethodExtensionError" +toKey (ActiveTraitError _ _) = Just "ActiveTraitError" +toKey (NewWithModeError) = Just "NewWithModeError" +toKey (UnsafeTypeArgumentError _ _) = Just "UnsafeTypeArgumentError" +toKey (OverlapWithBuiltins) = Just "OverlapWithBuiltins" +toKey (SimpleError _) = Just "SimpleError" +toKey (ReverseBorrowingError) = Just "ReverseBorrowingError" +toKey (BorrowedFieldError _) = Just "BorrowedFieldError" +toKey (LinearClosureError _ _) = Just "LinearClosureError" +toKey (BorrowedLeakError _) = Just "BorrowedLeakError" +toKey (NonBorrowableError _) = Just "NonBorrowableError" +toKey (ActiveBorrowError _ _) = Just "ActiveBorrowError" +toKey (ActiveBorrowSendError _ _) = Just "ActiveBorrowSendError" +toKey (DuplicateBorrowError _) = Just "DuplicateBorrowError" +toKey (StackboundednessMismatchError _ _) = Just "StackboundednessMismatchError" +toKey (LinearCaptureError _ _) = Just "LinearCaptureError" +--toKey _ = Nothing \ No newline at end of file diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index fe6123197..b3fd13d8a 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -207,7 +207,6 @@ data Error = | DuplicateBorrowError Expr | StackboundednessMismatchError Type Type | LinearCaptureError Expr Type - deriving (Show) arguments 1 = "argument" arguments _ = "arguments" @@ -218,594 +217,594 @@ typeParams _ = "type parameters" enumerateSafeTypes = "Safe types are primitives and types with read, active or local mode." --- instance Show Error where --- show (DistinctTypeParametersError ty) = --- printf "Type parameters of '%s' must be distinct" (show ty) --- show (WrongNumberOfMethodArgumentsError name targetType expected actual) = --- let nameWithKind = --- (if name == constructorName --- then "Constructor" --- else "Method '" ++ show name ++ "'") ++ --- " in " ++ refTypeName targetType --- in printf "%s expects %d %s. Got %d" --- nameWithKind expected (arguments expected) actual --- show (WrongNumberOfFunctionArgumentsError name expected actual) = --- printf "Function %s expects %d %s. Got %d" --- (show name) expected (arguments expected) actual --- show (WrongNumberOfFunctionTypeArgumentsError name expected actual) = --- printf "Function %s expects %d %s. Got %d" --- (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 --- show (MissingFieldRequirementError field trait) = --- printf "Cannot find field '%s' required by included %s" --- (show field) (refTypeName trait) --- show (CovarianceViolationError field expected trait) = --- printf ("Field '%s' must have a subtype of '%s' to meet " ++ --- "the requirements of included %s") --- (show field) (show expected) (refTypeName trait) --- show (RequiredFieldMismatchError field expected trait isSub) = --- printf ("Field '%s' must exactly match type '%s' " ++ --- "to meet the requirements of included %s%s") --- (show field) (show expected) (refTypeName trait) --- (if isSub --- then ". Consider turning '" ++ show (fname field) ++ --- "' into a val-field in " ++ refTypeName trait --- else "") --- show (NonDisjointConjunctionError left right field) = --- printf --- "Conjunctive traits '%s' and '%s' cannot share mutable field '%s'" --- (show left) (show right) (show field) --- show (OverriddenMethodTypeError name expected trait actual) = --- printf ("Overridden method '%s' does not " ++ --- "have the expected type '%s' required by %s.\n" ++ --- "Actual type is '%s'") --- (show name) (show expected) (refTypeName trait) (show actual) --- show (OverriddenMethodError name trait err) = --- case err of --- FieldNotFoundError f _ -> --- printf ("Overridden method '%s' requires access to field '%s' " ++ --- "which is not in requiring %s.\n" ++ --- "Consider extending the trait on inclusion: %s(%s)") --- (show name) (show f) (refTypeName trait) (show trait) (show f) --- MethodNotFoundError m _ -> --- printf ("Overridden method '%s' calls method '%s' " ++ --- "which is not in requiring %s.\n" ++ --- "Consider extending the trait on inclusion: %s(%s())") --- (show name) (show m) (refTypeName trait) (show trait) (show m) --- TypeMismatchError actual expected -> --- if actual == abstractTraitFromTraitType trait --- then printf ("Overridden method '%s' uses 'this' as %s " ++ --- "and cannot be typechecked in requiring %s") --- (show name) (show expected) (refTypeName trait) --- else defaultMessage --- ValFieldAssignmentError f targetType -> --- if targetType == abstractTraitFromTraitType trait --- then printf ("Overridden method '%s' writes field '%s' " ++ --- "which is marked as immutable in requiring %s.") --- (show name) (show f) (refTypeName trait) --- else defaultMessage --- err -> defaultMessage --- where --- defaultMessage = --- printf ("Overridden method '%s' cannot be typechecked in " ++ --- "requiring %s:\n%s") --- (show name) (refTypeName trait) (show err) --- show (IncludedMethodConflictError name left right) = --- printf "Conflicting inclusion of method '%s' from %s and %s" --- (show name) (refTypeName left) (refTypeName right) --- show (MissingMethodRequirementError header trait) = --- printf "Cannot find method '%s' required by included %s" --- (show $ ppFunctionHeader header) (refTypeName trait) --- show (UnknownTraitError ty) = --- printf "Couldn't find trait '%s'" (getId ty) --- show MissingMainClass = "Couldn't find active class 'Main'" --- show SyncStreamCall = "A stream method can not be called synchronously since it will invariably deadlock" --- show (IdComparisonNotSupportedError ty) = --- printf "Type '%s' does not support identity comparison%s" (show ty) --- (if isRefType ty --- then " (must include Id trait)" --- else "") --- show (IdComparisonTypeMismatchError lty rty) --- | isTupleType lty && isTupleType rty && --- length (getArgTypes lty) /= length (getArgTypes rty) = --- printf "Cannot compare tuples of different sizes: %s and %s" --- (show lty) (show rty) --- | otherwise = --- printf "Cannot compare values across types %s and %s" --- (show lty) (show rty) --- show BadSyncCallError = "Synchronous method calls on actors are not allowed (except on the current this)" --- show (PrivateAccessModifierTargetError name) = --- printf "Cannot call private %s" kind --- where --- kind = if name == constructorName --- then "constructor" --- else "method '" ++ show name ++ "'" --- show (UnknownRefTypeError ty) = --- printf "Couldn't find class, trait or typedef '%s'" (show ty) --- show (MalformedCapabilityError ty) = --- printf "Cannot form capability with %s" (showWithKind ty) --- show (MalformedBoundError bound) = --- printf "Cannot use %s as bound (must have trait)" (showWithKind bound) --- show (RecursiveTypesynonymError ty) = --- printf "Type synonyms cannot be recursive. One of the culprits is %s" --- (getId ty) --- show (DuplicateThingError kind thing) = --- printf "Duplicate %s of %s" kind thing --- show PassiveStreamingMethodError = --- "Cannot have streaming methods in a passive class" --- show StreamingConstructorError = --- "Constructor cannot be streaming" --- show MainMethodArgumentsError = --- "Main method must have argument type () or ([String])" --- show MainConstructorError = --- "Main class cannot have a constructor" --- show (FieldNotFoundError name ty) = --- printf "No field '%s' in %s" --- (show name) (refTypeName ty) --- show (MethodNotFoundError name ty) = --- let nameWithKind = if name == constructorName --- then "constructor" --- else "method '" ++ show name ++ "'" --- targetType = if isRefType ty --- then refTypeName ty --- else showWithKind ty --- in printf "No %s in %s" --- nameWithKind targetType --- show BreakUsedAsExpressionError = --- "Break is a statement and cannot be used as a value or expression" --- show BreakOutsideOfLoopError = --- "Break can only be used inside loops" --- show ContinueUsedAsExpressionError = --- "Continue is a statement and cannot be used as a value or expression" --- show ContinueOutsideOfLoopError = --- "Continue can only be used inside while, do/while, and repeat loops" --- show (NonCallableTargetError targetType) = --- printf "Cannot call method on expression of type '%s'" --- (show targetType) --- show (NonSendableTargetError targetType) = --- printf "Cannot send message to expression of type '%s'" --- (show targetType) --- show MainMethodCallError = "Cannot call the main method" --- show ConstructorCallError = --- "Constructor method 'init' can only be called during object creation" --- show (ExpectingOtherTypeError something ty) = --- printf "Expected %s but found expression of type '%s'" --- something (show ty) --- show (NonStreamingContextError e) = --- printf "Cannot have '%s' outside of a streaming method" --- (show $ ppSugared e) --- show (UnboundFunctionError name) = --- printf "Unbound function variable '%s'" (show name) --- show (NonFunctionTypeError ty) = --- printf "Cannot use value of type '%s' as a function" (show ty) --- show BottomTypeInferenceError = "Not enough information to infer the type.\n" ++ --- "Try adding more type information." --- show IfInferenceError = "Cannot infer result type of if-statement" --- show (IfBranchMismatchError ty1 ty2) = --- "Type mismatch in different branches of if-statement:\n" ++ --- " then: " ++ show ty1 ++ "\n" ++ --- " else: " ++ show ty2 --- show EmptyMatchClauseError = "Match statement must have at least one clause" --- show ActiveMatchError = "Cannot match on an active object" --- show MatchInferenceError = "Cannot infer result type of match expression" --- show ThisReassignmentError = "Cannot rebind variable 'this'" --- show (ImmutableVariableError qname) = --- printf "Variable '%s' is immutable and cannot be re-assigned" --- (show qname) --- show (PatternArityMismatchError name expected actual) = --- printf "Extractor '%s' returns %s. Pattern has %s" --- (show name) --- (if expected == 1 --- then "1 value" --- else show expected ++ " values") --- (show actual) --- show (PatternTypeMismatchError pattern ty) = --- printf "Pattern '%s' does not match expected type '%s'" --- (show $ ppSugared pattern) (show ty) --- show (NonMaybeExtractorPatternError pattern) = --- printf "Extractor '%s' must return a Maybe type to be used as a pattern" --- (show $ ppSugared pattern) --- show (InvalidPatternError pattern) = --- printf "'%s' is not a valid pattern" --- (show $ ppSugared pattern) --- show (InvalidTupleTargetError target compartment ty) = --- printf "Compartment access %s.%d expects a tuple target, found %s" --- (show $ ppSugared target) --- compartment --- (show ty) --- show (InvalidTupleAccessError target compartment) = --- printf "No .%d compartment in tuple %s" --- compartment --- (show $ ppSugared target) --- show (CannotReadFieldError target) = --- let targetType = getType target in --- if isClassType targetType && isModeless targetType then --- printf "Cannot access field of expression '%s' of unmoded class '%s'" --- (show $ ppSugared target) (show targetType) --- else --- printf "Cannot read field of expression '%s' of %s" --- (show $ ppSugared target) (showWithKind targetType) --- show NonAssignableLHSError = --- "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) --- show (UnboundVariableError name) = --- printf "Unbound variable '%s'" (show name) --- show (BuriedVariableError name) = --- printf "Variable '%s' cannot be accessed during borrowing" (show name) --- show (ObjectCreationError ty) --- | isMainType ty = "Cannot create additional Main objects" --- | isCapabilityType ty = --- printf "Cannot create instance of %s (type must be a class)" --- (refTypeName ty) --- | otherwise = printf "Cannot create object of type '%s'" (show ty) --- show (NonIterableError ty) = --- printf "Type '%s' is not iterable" (show ty) --- show EmptyArrayLiteralError = "Array literal must have at least one element" --- show (NonIndexableError ty) = --- printf "Type '%s' is not indexable" (show ty) --- show (NonSizeableError ty) = --- printf "Type '%s' has no size" (show ty) --- show FormatStringLiteralError = --- "Formatted printing expects first argument to be a string literal" --- show (UnprintableExpressionError ty) = --- printf "Expression of type '%s' is not printable" (show ty) --- show (WrongNumberOfPrintArgumentsError expected actual) = --- printf ("Wrong number of arguments to print. Format string " ++ --- "expects %d %s. Found %d") expected (arguments expected) actual --- 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 (UndefinedBinaryOperatorError op) = --- printf "Undefined binary operator '%s'" (show op) --- show NullTypeInferenceError = --- "Cannot infer type of null valued expression. " ++ --- "Try adding type annotations" --- show (CannotBeNullError ty) = --- printf ("Null valued expression cannot have type '%s' " ++ --- "(must have reference type)") (show ty) --- show (TypeMismatchError actual expected) --- | isTypeVar actual && isJust (getBound actual) = --- printf "Type '%s' with bound '%s' does not match expected type '%s'" --- (show actual) (show . fromJust $ getBound actual) (show expected) --- | isArrowType actual --- , isArrowType expected --- , actual `withModeOf` expected == expected = --- printf ("Closure of type '%s' captures %s state and cannot " ++ --- "be used as type '%s'") --- (show actual) (showModeOf actual) (show expected) --- | otherwise = printf "Type '%s' does not match expected type '%s'" --- (show actual) (show expected) --- show (TypeWithCapabilityMismatchError actual cap expected) = --- printf "Type '%s' with capability '%s' does not match expected type '%s'%s" --- (show actual) (show cap) (show expected) pointer --- where --- pointer = --- let actualTraits = typesFromCapability cap --- expectedTraits = typesFromCapability expected --- remainders = actualTraits \\ expectedTraits --- nonDroppables = filter (not . isReadSingleType) remainders --- nonDroppable = head nonDroppables --- in if isCapabilityType expected && --- all (\te -> any (\ta -> ta == te && --- ta `modeSubtypeOf` te) actualTraits) --- expectedTraits --- then ". Cannot drop mode '" ++ showModeOf nonDroppable ++ "'" --- else "" --- show (TypeVariableAmbiguityError expected ty1 ty2) = --- printf "Type variable '%s' cannot be bound to both '%s' and '%s'" --- (getId expected) (show ty1) (show ty2) --- show (FreeTypeVariableError ty) = --- if getId ty == "void" --- then printf "Type 'void' is deprecated. Use 'unit' instead" --- else printf "Type variable '%s' is unbound" (show ty) --- show (TypeVariableAndVariableCommonNameError [name]) = --- printf "Type variable '%s' clashes with existing variable name." --- (show name) --- show (TypeVariableAndVariableCommonNameError names) = --- printf "Type variables %s clash with existing variable names." --- formattingName --- where --- formattingName = --- let ns = map (\n -> "'" ++ show n ++ "', ") (init names) --- lastName = "'" ++ show (last names) ++ "'" --- in show ns ++ "and " ++ lastName --- show (UnionMethodAmbiguityError ty name) = --- printf "Cannot disambiguate method '%s' in %s" --- (show name) (showWithKind ty) --- show (MalformedUnionTypeError ty union) = --- printf "Type '%s' is not compatible with %s" --- (show ty) (showWithKind union) --- show (TypeArgumentInferenceError call param) = --- printf "Cannot infer the type of parameter '%s' of %s '%s'" --- (show param) kind calledName --- where --- mname = name call --- kind | isFunctionCall call = "function" --- | isMethodCallOrMessageSend call = --- if mname == constructorName --- then "class" --- else "method" --- | otherwise = error msg --- calledName | isFunctionCall call = show $ qname call --- | isMethodCallOrMessageSend call = --- if mname == constructorName --- then show $ getType (target call) --- else show mname --- | otherwise = error msg --- msg = "TypeError.hs: " ++ show call ++ --- " is not a function or method call" --- show (RequiredFieldMutabilityError requirer field) = --- printf "Trait '%s' requires field '%s' to be mutable" --- (getId requirer) (show field) --- show (ProvidingTraitFootprintError provider requirer mname fields) = --- printf ("Trait '%s' cannot provide method '%s' to %s.\n" ++ --- "'%s' can mutate fields that are marked immutable in '%s':\n%s") --- (getId provider) (show mname) (refTypeName requirer) --- (getId provider) (getId requirer) --- (unlines (map ((" " ++) . show) fields)) --- show (AmbiguousTypeError ty candidates) = --- printf "Ambiguous reference to %s. Possible candidates are:\n%s" --- (showWithKind ty) (unlines $ map ((" " ++) . show) candidates) --- show (UnknownTypeUsageError usage ty) = --- printf "Cannot %s unimported type %s" --- usage (show ty) --- show (AmbiguousNameError qname candidates) = --- printf "Ambiguous reference to function %s. Possible candidates are:\n%s" --- (show qname) candidateList --- where --- candidateList = --- unlines $ map ((" " ++) . showCandidate) candidates --- showCandidate (qn, ty) = show qn ++ " : " ++ show ty --- show (UnknownNamespaceError maybeNs) = --- printf "Unknown namespace %s" --- (maybe "" show maybeNs) --- show (UnknownNameError ns name) = --- printf "Module %s has no function or type called '%s'" --- (show ns) (show name) --- show (ShadowedImportError i) = --- printf "Introduction of module alias '%s' shadows existing import" --- (show $ itarget i) --- show (WrongModuleNameError modname expected) = --- printf "Module name '%s' and file name '%s' must match" --- (show modname) expected --- show PolymorphicConstructorError = --- printf "Constructors (a.k.a. 'init methods') cannot use parametric methods" --- show ClosureReturnError = --- "Closures must declare their type to use return" --- show ClosureForwardError = --- "Closures must declare their type to use forward" --- show MatchMethodNonMaybeReturnError = --- "Match methods must return a Maybe type" --- show MatchMethodNonEmptyParameterListError = --- "Match methods cannot have parameters" --- show (ImpureMatchMethodError e) = --- printf "Match methods must be pure%s" --- pointer --- where --- pointer --- | While{} <- e = ". Consider using a for loop" --- | otherwise = "" --- show (ForwardTypeError retType ty) = --- printf ("Returned type %s of forward should match with " ++ --- "the result type of the containing method %s") --- (show retType) (show ty) --- show (ForwardTypeClosError retType ty) = --- printf ("Result type %s of the closure should match with " ++ --- "the return type %s of the forward") --- (show retType) (show ty) --- show (ForwardInPassiveContext cname) = --- printf "Forward can not be used in passive class '%s'" --- (show cname) --- show (ForwardInFunction) = "Forward cannot be used in functions" --- show (CannotHaveModeError ty) = --- if isClassType ty --- then printf "Cannot give mode to unmoded %s" (refTypeName ty) --- else printf "Cannot give mode to %s" (Types.showWithKind ty) --- show (ModelessError ty) = --- printf "No mode given to %s" (refTypeName ty) --- show (ModeOverrideError ty) = --- printf "Cannot override declared mode '%s' of %s" --- (showModeOf ty) (refTypeName ty) --- show (CannotConsumeError expr) = --- printf "Cannot consume '%s'" (show (ppSugared expr)) --- show (CannotConsumeTypeError expr) = --- printf ("Cannot consume '%s' of type '%s'. " ++ --- "Consider using a Maybe-type") --- (show (ppSugared expr)) (show (getType expr)) --- show (ImmutableConsumeError expr) --- | VarAccess{} <- expr = --- printf "Cannot consume immutable variable '%s'" --- (show (ppSugared expr)) --- | FieldAccess{} <- expr = --- printf "Cannot consume immutable field '%s'" --- (show (ppSugared expr)) --- | otherwise = --- printf "Cannot consume immutable target '%s'" --- (show (ppSugared expr)) --- show (CannotGiveReadModeError trait) = --- printf ("Cannot give read mode to trait '%s'. " ++ --- "It must be declared as read at its declaration site") --- (getId trait) --- show (CannotGiveSharableModeError ty) = --- printf ("Cannot give sharable mode to %s. " ++ --- "It can only be used for type parameters") --- (refTypeName ty) --- show (NonValInReadContextError ctx) = --- printf "Read %s can only have val fields" --- (if isTraitType ctx then "traits" else "classes") --- show (NonSafeInReadContextError ctx ty) = --- printf "Read %s can not have field of non-safe type '%s'. \n%s" --- (if isTraitType ctx then "trait" else "class") (show ty) --- enumerateSafeTypes --- show (NonSafeInExtendedReadTraitError t f ty) = --- printf "Read trait '%s' cannot be extended with field '%s' of non-safe type '%s'. \n%s" --- (getId t) (show f) (show ty) --- enumerateSafeTypes --- show (ProvidingToReadTraitError provider requirer mname) = --- printf "Non-read trait '%s' cannot provide method '%s' to read trait '%s'" --- (getId provider) (show mname) (getId requirer) --- show (SubordinateReturnError name ty) = --- printf ("Method '%s' returns a %s and cannot " ++ --- "be called from outside of its aggregate") --- (show name) (if isArrowType ty --- then "closure that captures subordinate state" --- else "subordinate capability") --- show (SubordinateArgumentError arg) = --- if isArrowType (getType arg) --- then printf ("Closure '%s' captures subordinate state " ++ --- "and cannot be passed outside of its aggregate") --- (show (ppSugared arg)) --- else printf ("Cannot pass subordinate argument '%s' " ++ --- "outside of its aggregate") --- (show (ppSugared arg)) --- show (SubordinateFieldError name) = --- printf ("Field '%s' is subordinate and cannot be accessed " ++ --- "from outside of its aggregate") --- (show name) --- show (ThreadLocalFieldError ty) = --- printf "%s must have declared 'local' or 'active' mode to have actor local fields" --- (if isTraitType ty then "Traits" else "Classes") --- show (ThreadLocalFieldExtensionError trait field) = --- printf ("Trait '%s' must have local mode to be extended " ++ --- "with field '%s' of actor local type '%s'") --- (show trait) (show $ fname field) --- (showWithoutMode $ ftype field) --- show (ThreadLocalArgumentError arg) = --- if isArrowType (getType arg) --- then printf ("Closure '%s' captures actor local variables " ++ --- "and cannot be passed to another active object") --- (show (ppSugared arg)) --- else printf ("Cannot pass actor local argument '%s' " ++ --- "to another active object") --- (show (ppSugared arg)) --- show (ThreadLocalReturnError name ty) = --- printf ("Method '%s' returns a %s and cannot " ++ --- "be called by a different active object") --- (show name) (if isArrowType ty --- then "closure that captures local state" --- else "local capability") --- show (PolymorphicArgumentSendError arg ty) = --- printf ("Cannot pass value of '%s' between active objects. " ++ --- "Its type is polymorphic so it may not be safe to share.\n" ++ --- "Consider marking the type variable '%s' as 'sharable'") --- (show (ppSugared arg)) (getId ty) --- show (PolymorphicReturnError name ty) = --- printf ("Method '%s' returns a value of polymorphic type, and sharing " ++ --- "it between active objects may not be safe. \n" ++ --- "Consider marking the type variable '%s' as 'sharable'.") --- (show name) (getId ty) --- show (MalformedConjunctionError ty nonDisjoint source) = --- printf "Type '%s' does not form a conjunction with '%s' in %s" --- (show ty) (show nonDisjoint) (Types.showWithKind source) --- show (CannotUnpackError source) = --- printf "Cannot unpack empty capability of class '%s'" --- (show source) --- show (CannotInferUnpackingError cap) = --- printf ("Unpacking of %s cannot be inferred. " ++ --- "Try adding type annotations") --- (Types.showWithKind cap) --- show (UnsplittableTypeError ty) = --- printf "Cannot unpack %s" --- (Types.showWithKind ty) --- show (DuplicatingSplitError ty) = --- printf "Cannot duplicate linear trait '%s'" --- (showWithoutMode ty) --- show (StackboundArrayTypeError ty) = --- printf "Arrays cannot store borrowed values of type '%s'" --- (show ty) --- show (ManifestConflictError formal conflicting) = --- printf ("Trait '%s' with declared mode '%s' can only be " ++ --- "composed with traits of the same mode. Found '%s'") --- (showWithoutMode formal) (showModeOf formal) (show conflicting) --- show (ManifestClassConflictError cls conflicting) = --- printf "Trait '%s' cannot be included by class '%s' of declared mode '%s'" --- (show conflicting) (showWithoutMode cls) (showModeOf cls) --- show (UnmodedMethodExtensionError cls name) = --- printf ("Unmoded class '%s' cannot declare new method '%s'. " ++ --- "Possible fixes: \n" ++ --- " - Add a mode to the class (e.g. %s)\n" ++ --- " - Assign the method to an included trait: T(%s())") --- (show cls) (show name) --- "active, local, read, linear or subord" (show name) --- show (ActiveTraitError active nonActive) = --- printf ("Active trait '%s' can only be included together with " ++ --- "other active traits. Found '%s'") --- (showWithoutMode active) (show nonActive) --- show (UnsafeTypeArgumentError formal ty) = --- if isModeless ty then --- -- TODO: Could be more precise (e.g. distinguish between linear/subord) --- printf ("Cannot use non-aliasable type '%s' as type argument. " ++ --- "Type parameter '%s' requires the type to have %s mode") --- (show ty) (getId formal) (if isModeless formal --- then "an aliasable" --- else showModeOf formal) --- else --- printf ("Cannot use %s type '%s' as type argument. " ++ --- "Type parameter '%s' requires the type to have %s mode") --- (showModeOf ty) (showWithoutMode ty) --- (getId formal) (if isModeless formal --- then "an aliasable" --- else showModeOf formal) --- show OverlapWithBuiltins = --- printf ("Types Maybe, Fut, Stream, and Par are built-in and cannot be redefined.") --- show (SimpleError msg) = msg --- ---------------------------- --- -- Capturechecking errors -- --- ---------------------------- --- show ReverseBorrowingError = --- "Reverse borrowing (returning borrowed values) " ++ --- "is currently not supported" --- show (BorrowedFieldError ftype) = --- printf "Cannot have field of borrowed type '%s'" --- (show ftype) --- show (LinearClosureError name ty) = --- printf "Cannot capture variable '%s' of linear type '%s' in a closure" --- (show name) (show ty) --- show (BorrowedLeakError e) = --- printf "Cannot pass borrowed expression '%s' as non-borrowed parameter" --- (show (ppSugared e)) --- show (NonBorrowableError FieldAccess{target, name}) = --- printf "Cannot borrow linear field '%s' from non-linear path '%s'" --- (show name) (show (ppSugared target)) --- show (NonBorrowableError ArrayAccess{target}) = --- printf "Cannot borrow linear array value from non-linear path '%s'" --- (show (ppSugared target)) --- show (NonBorrowableError e) = --- printf "Expression '%s' cannot be borrowed." --- (show (ppSugared e)) --- show (ActiveBorrowError arg targetType) = --- printf ("Expression '%s' cannot be borrowed " ++ --- "by active object of type '%s'") --- (show (ppSugared arg)) (show targetType) --- show (ActiveBorrowSendError arg targetType) = --- printf ("Cannot send borrowed expression '%s' to active object " ++ --- "of type '%s'") --- (show (ppSugared arg)) (show targetType) --- show (DuplicateBorrowError root) = --- printf ("Borrowed variable '%s' cannot be used more than once " ++ --- "in an argument list") --- (show (ppSugared root)) --- show (StackboundednessMismatchError ty expected) = --- printf "%s does not match %s" (kindOf ty) (kindOf' expected) --- where --- kindOf ty --- | isStackboundType ty = "Borrowed type '" ++ show ty ++ "'" --- | otherwise = "Non-borrowed type '" ++ show ty ++ "'" --- kindOf' ty = --- let c:s = kindOf ty --- in toLower c:s --- show (LinearCaptureError e ty) = --- printf "Cannot capture expression '%s' of linear type '%s'" --- (show (ppSugared e)) (show ty) +instance Show Error where + show (DistinctTypeParametersError ty) = + printf "Type parameters of '%s' must be distinct" (show ty) + show (WrongNumberOfMethodArgumentsError name targetType expected actual) = + let nameWithKind = + (if name == constructorName + then "Constructor" + else "Method '" ++ show name ++ "'") ++ + " in " ++ refTypeName targetType + in printf "%s expects %d %s. Got %d" + nameWithKind expected (arguments expected) actual + show (WrongNumberOfFunctionArgumentsError name expected actual) = + printf "Function %s expects %d %s. Got %d" + (show name) expected (arguments expected) actual + show (WrongNumberOfFunctionTypeArgumentsError name expected actual) = + printf "Function %s expects %d %s. Got %d" + (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 + show (MissingFieldRequirementError field trait) = + printf "Cannot find field '%s' required by included %s" + (show field) (refTypeName trait) + show (CovarianceViolationError field expected trait) = + printf ("Field '%s' must have a subtype of '%s' to meet " ++ + "the requirements of included %s") + (show field) (show expected) (refTypeName trait) + show (RequiredFieldMismatchError field expected trait isSub) = + printf ("Field '%s' must exactly match type '%s' " ++ + "to meet the requirements of included %s%s") + (show field) (show expected) (refTypeName trait) + (if isSub + then ". Consider turning '" ++ show (fname field) ++ + "' into a val-field in " ++ refTypeName trait + else "") + show (NonDisjointConjunctionError left right field) = + printf + "Conjunctive traits '%s' and '%s' cannot share mutable field '%s'" + (show left) (show right) (show field) + show (OverriddenMethodTypeError name expected trait actual) = + printf ("Overridden method '%s' does not " ++ + "have the expected type '%s' required by %s.\n" ++ + "Actual type is '%s'") + (show name) (show expected) (refTypeName trait) (show actual) + show (OverriddenMethodError name trait err) = + case err of + FieldNotFoundError f _ -> + printf ("Overridden method '%s' requires access to field '%s' " ++ + "which is not in requiring %s.\n" ++ + "Consider extending the trait on inclusion: %s(%s)") + (show name) (show f) (refTypeName trait) (show trait) (show f) + MethodNotFoundError m _ -> + printf ("Overridden method '%s' calls method '%s' " ++ + "which is not in requiring %s.\n" ++ + "Consider extending the trait on inclusion: %s(%s())") + (show name) (show m) (refTypeName trait) (show trait) (show m) + TypeMismatchError actual expected -> + if actual == abstractTraitFromTraitType trait + then printf ("Overridden method '%s' uses 'this' as %s " ++ + "and cannot be typechecked in requiring %s") + (show name) (show expected) (refTypeName trait) + else defaultMessage + ValFieldAssignmentError f targetType -> + if targetType == abstractTraitFromTraitType trait + then printf ("Overridden method '%s' writes field '%s' " ++ + "which is marked as immutable in requiring %s.") + (show name) (show f) (refTypeName trait) + else defaultMessage + err -> defaultMessage + where + defaultMessage = + printf ("Overridden method '%s' cannot be typechecked in " ++ + "requiring %s:\n%s") + (show name) (refTypeName trait) (show err) + show (IncludedMethodConflictError name left right) = + printf "Conflicting inclusion of method '%s' from %s and %s" + (show name) (refTypeName left) (refTypeName right) + show (MissingMethodRequirementError header trait) = + printf "Cannot find method '%s' required by included %s" + (show $ ppFunctionHeader header) (refTypeName trait) + show (UnknownTraitError ty) = + printf "Couldn't find trait '%s'" (getId ty) + show MissingMainClass = "Couldn't find active class 'Main'" + show SyncStreamCall = "A stream method can not be called synchronously since it will invariably deadlock" + show (IdComparisonNotSupportedError ty) = + printf "Type '%s' does not support identity comparison%s" (show ty) + (if isRefType ty + then " (must include Id trait)" + else "") + show (IdComparisonTypeMismatchError lty rty) + | isTupleType lty && isTupleType rty && + length (getArgTypes lty) /= length (getArgTypes rty) = + printf "Cannot compare tuples of different sizes: %s and %s" + (show lty) (show rty) + | otherwise = + printf "Cannot compare values across types %s and %s" + (show lty) (show rty) + show BadSyncCallError = "Synchronous method calls on actors are not allowed (except on the current this)" + show (PrivateAccessModifierTargetError name) = + printf "Cannot call private %s" kind + where + kind = if name == constructorName + then "constructor" + else "method '" ++ show name ++ "'" + show (UnknownRefTypeError ty) = + printf "Couldn't find class, trait or typedef '%s'" (show ty) + show (MalformedCapabilityError ty) = + printf "Cannot form capability with %s" (showWithKind ty) + show (MalformedBoundError bound) = + printf "Cannot use %s as bound (must have trait)" (showWithKind bound) + show (RecursiveTypesynonymError ty) = + printf "Type synonyms cannot be recursive. One of the culprits is %s" + (getId ty) + show (DuplicateThingError kind thing) = + printf "Duplicate %s of %s" kind thing + show PassiveStreamingMethodError = + "Cannot have streaming methods in a passive class" + show StreamingConstructorError = + "Constructor cannot be streaming" + show MainMethodArgumentsError = + "Main method must have argument type () or ([String])" + show MainConstructorError = + "Main class cannot have a constructor" + show (FieldNotFoundError name ty) = + printf "No field '%s' in %s" + (show name) (refTypeName ty) + show (MethodNotFoundError name ty) = + let nameWithKind = if name == constructorName + then "constructor" + else "method '" ++ show name ++ "'" + targetType = if isRefType ty + then refTypeName ty + else showWithKind ty + in printf "No %s in %s" + nameWithKind targetType + show BreakUsedAsExpressionError = + "Break is a statement and cannot be used as a value or expression" + show BreakOutsideOfLoopError = + "Break can only be used inside loops" + show ContinueUsedAsExpressionError = + "Continue is a statement and cannot be used as a value or expression" + show ContinueOutsideOfLoopError = + "Continue can only be used inside while, do/while, and repeat loops" + show (NonCallableTargetError targetType) = + printf "Cannot call method on expression of type '%s'" + (show targetType) + show (NonSendableTargetError targetType) = + printf "Cannot send message to expression of type '%s'" + (show targetType) + show MainMethodCallError = "Cannot call the main method" + show ConstructorCallError = + "Constructor method 'init' can only be called during object creation" + show (ExpectingOtherTypeError something ty) = + printf "Expected %s but found expression of type '%s'" + something (show ty) + show (NonStreamingContextError e) = + printf "Cannot have '%s' outside of a streaming method" + (show $ ppSugared e) + show (UnboundFunctionError name) = + printf "Unbound function variable '%s'" (show name) + show (NonFunctionTypeError ty) = + printf "Cannot use value of type '%s' as a function" (show ty) + show BottomTypeInferenceError = "Not enough information to infer the type.\n" ++ + "Try adding more type information." + show IfInferenceError = "Cannot infer result type of if-statement" + show (IfBranchMismatchError ty1 ty2) = + "Type mismatch in different branches of if-statement:\n" ++ + " then: " ++ show ty1 ++ "\n" ++ + " else: " ++ show ty2 + show EmptyMatchClauseError = "Match statement must have at least one clause" + show ActiveMatchError = "Cannot match on an active object" + show MatchInferenceError = "Cannot infer result type of match expression" + show ThisReassignmentError = "Cannot rebind variable 'this'" + show (ImmutableVariableError qname) = + printf "Variable '%s' is immutable and cannot be re-assigned" + (show qname) + show (PatternArityMismatchError name expected actual) = + printf "Extractor '%s' returns %s. Pattern has %s" + (show name) + (if expected == 1 + then "1 value" + else show expected ++ " values") + (show actual) + show (PatternTypeMismatchError pattern ty) = + printf "Pattern '%s' does not match expected type '%s'" + (show $ ppSugared pattern) (show ty) + show (NonMaybeExtractorPatternError pattern) = + printf "Extractor '%s' must return a Maybe type to be used as a pattern" + (show $ ppSugared pattern) + show (InvalidPatternError pattern) = + printf "'%s' is not a valid pattern" + (show $ ppSugared pattern) + show (InvalidTupleTargetError target compartment ty) = + printf "Compartment access %s.%d expects a tuple target, found %s" + (show $ ppSugared target) + compartment + (show ty) + show (InvalidTupleAccessError target compartment) = + printf "No .%d compartment in tuple %s" + compartment + (show $ ppSugared target) + show (CannotReadFieldError target) = + let targetType = getType target in + if isClassType targetType && isModeless targetType then + printf "Cannot access field of expression '%s' of unmoded class '%s'" + (show $ ppSugared target) (show targetType) + else + printf "Cannot read field of expression '%s' of %s" + (show $ ppSugared target) (showWithKind targetType) + show NonAssignableLHSError = + "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) + show (UnboundVariableError name) = + printf "Unbound variable '%s'" (show name) + show (BuriedVariableError name) = + printf "Variable '%s' cannot be accessed during borrowing" (show name) + show (ObjectCreationError ty) + | isMainType ty = "Cannot create additional Main objects" + | isCapabilityType ty = + printf "Cannot create instance of %s (type must be a class)" + (refTypeName ty) + | otherwise = printf "Cannot create object of type '%s'" (show ty) + show (NonIterableError ty) = + printf "Type '%s' is not iterable" (show ty) + show EmptyArrayLiteralError = "Array literal must have at least one element" + show (NonIndexableError ty) = + printf "Type '%s' is not indexable" (show ty) + show (NonSizeableError ty) = + printf "Type '%s' has no size" (show ty) + show FormatStringLiteralError = + "Formatted printing expects first argument to be a string literal" + show (UnprintableExpressionError ty) = + printf "Expression of type '%s' is not printable" (show ty) + show (WrongNumberOfPrintArgumentsError expected actual) = + printf ("Wrong number of arguments to print. Format string " ++ + "expects %d %s. Found %d") expected (arguments expected) actual + 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 (UndefinedBinaryOperatorError op) = + printf "Undefined binary operator '%s'" (show op) + show NullTypeInferenceError = + "Cannot infer type of null valued expression. " ++ + "Try adding type annotations" + show (CannotBeNullError ty) = + printf ("Null valued expression cannot have type '%s' " ++ + "(must have reference type)") (show ty) + show (TypeMismatchError actual expected) + | isTypeVar actual && isJust (getBound actual) = + printf "Type '%s' with bound '%s' does not match expected type '%s'" + (show actual) (show . fromJust $ getBound actual) (show expected) + | isArrowType actual + , isArrowType expected + , actual `withModeOf` expected == expected = + printf ("Closure of type '%s' captures %s state and cannot " ++ + "be used as type '%s'") + (show actual) (showModeOf actual) (show expected) + | otherwise = printf "Type '%s' does not match expected type '%s'" + (show actual) (show expected) + show (TypeWithCapabilityMismatchError actual cap expected) = + printf "Type '%s' with capability '%s' does not match expected type '%s'%s" + (show actual) (show cap) (show expected) pointer + where + pointer = + let actualTraits = typesFromCapability cap + expectedTraits = typesFromCapability expected + remainders = actualTraits \\ expectedTraits + nonDroppables = filter (not . isReadSingleType) remainders + nonDroppable = head nonDroppables + in if isCapabilityType expected && + all (\te -> any (\ta -> ta == te && + ta `modeSubtypeOf` te) actualTraits) + expectedTraits + then ". Cannot drop mode '" ++ showModeOf nonDroppable ++ "'" + else "" + show (TypeVariableAmbiguityError expected ty1 ty2) = + printf "Type variable '%s' cannot be bound to both '%s' and '%s'" + (getId expected) (show ty1) (show ty2) + show (FreeTypeVariableError ty) = + if getId ty == "void" + then printf "Type 'void' is deprecated. Use 'unit' instead" + else printf "Type variable '%s' is unbound" (show ty) + show (TypeVariableAndVariableCommonNameError [name]) = + printf "Type variable '%s' clashes with existing variable name." + (show name) + show (TypeVariableAndVariableCommonNameError names) = + printf "Type variables %s clash with existing variable names." + formattingName + where + formattingName = + let ns = map (\n -> "'" ++ show n ++ "', ") (init names) + lastName = "'" ++ show (last names) ++ "'" + in show ns ++ "and " ++ lastName + show (UnionMethodAmbiguityError ty name) = + printf "Cannot disambiguate method '%s' in %s" + (show name) (showWithKind ty) + show (MalformedUnionTypeError ty union) = + printf "Type '%s' is not compatible with %s" + (show ty) (showWithKind union) + show (TypeArgumentInferenceError call param) = + printf "Cannot infer the type of parameter '%s' of %s '%s'" + (show param) kind calledName + where + mname = name call + kind | isFunctionCall call = "function" + | isMethodCallOrMessageSend call = + if mname == constructorName + then "class" + else "method" + | otherwise = error msg + calledName | isFunctionCall call = show $ qname call + | isMethodCallOrMessageSend call = + if mname == constructorName + then show $ getType (target call) + else show mname + | otherwise = error msg + msg = "TypeError.hs: " ++ show call ++ + " is not a function or method call" + show (RequiredFieldMutabilityError requirer field) = + printf "Trait '%s' requires field '%s' to be mutable" + (getId requirer) (show field) + show (ProvidingTraitFootprintError provider requirer mname fields) = + printf ("Trait '%s' cannot provide method '%s' to %s.\n" ++ + "'%s' can mutate fields that are marked immutable in '%s':\n%s") + (getId provider) (show mname) (refTypeName requirer) + (getId provider) (getId requirer) + (unlines (map ((" " ++) . show) fields)) + show (AmbiguousTypeError ty candidates) = + printf "Ambiguous reference to %s. Possible candidates are:\n%s" + (showWithKind ty) (unlines $ map ((" " ++) . show) candidates) + show (UnknownTypeUsageError usage ty) = + printf "Cannot %s unimported type %s" + usage (show ty) + show (AmbiguousNameError qname candidates) = + printf "Ambiguous reference to function %s. Possible candidates are:\n%s" + (show qname) candidateList + where + candidateList = + unlines $ map ((" " ++) . showCandidate) candidates + showCandidate (qn, ty) = show qn ++ " : " ++ show ty + show (UnknownNamespaceError maybeNs) = + printf "Unknown namespace %s" + (maybe "" show maybeNs) + show (UnknownNameError ns name) = + printf "Module %s has no function or type called '%s'" + (show ns) (show name) + show (ShadowedImportError i) = + printf "Introduction of module alias '%s' shadows existing import" + (show $ itarget i) + show (WrongModuleNameError modname expected) = + printf "Module name '%s' and file name '%s' must match" + (show modname) expected + show PolymorphicConstructorError = + printf "Constructors (a.k.a. 'init methods') cannot use parametric methods" + show ClosureReturnError = + "Closures must declare their type to use return" + show ClosureForwardError = + "Closures must declare their type to use forward" + show MatchMethodNonMaybeReturnError = + "Match methods must return a Maybe type" + show MatchMethodNonEmptyParameterListError = + "Match methods cannot have parameters" + show (ImpureMatchMethodError e) = + printf "Match methods must be pure%s" + pointer + where + pointer + | While{} <- e = ". Consider using a for loop" + | otherwise = "" + show (ForwardTypeError retType ty) = + printf ("Returned type %s of forward should match with " ++ + "the result type of the containing method %s") + (show retType) (show ty) + show (ForwardTypeClosError retType ty) = + printf ("Result type %s of the closure should match with " ++ + "the return type %s of the forward") + (show retType) (show ty) + show (ForwardInPassiveContext cname) = + printf "Forward can not be used in passive class '%s'" + (show cname) + show (ForwardInFunction) = "Forward cannot be used in functions" + show (CannotHaveModeError ty) = + if isClassType ty + then printf "Cannot give mode to unmoded %s" (refTypeName ty) + else printf "Cannot give mode to %s" (Types.showWithKind ty) + show (ModelessError ty) = + printf "No mode given to %s" (refTypeName ty) + show (ModeOverrideError ty) = + printf "Cannot override declared mode '%s' of %s" + (showModeOf ty) (refTypeName ty) + show (CannotConsumeError expr) = + printf "Cannot consume '%s'" (show (ppSugared expr)) + show (CannotConsumeTypeError expr) = + printf ("Cannot consume '%s' of type '%s'. " ++ + "Consider using a Maybe-type") + (show (ppSugared expr)) (show (getType expr)) + show (ImmutableConsumeError expr) + | VarAccess{} <- expr = + printf "Cannot consume immutable variable '%s'" + (show (ppSugared expr)) + | FieldAccess{} <- expr = + printf "Cannot consume immutable field '%s'" + (show (ppSugared expr)) + | otherwise = + printf "Cannot consume immutable target '%s'" + (show (ppSugared expr)) + show (CannotGiveReadModeError trait) = + printf ("Cannot give read mode to trait '%s'. " ++ + "It must be declared as read at its declaration site") + (getId trait) + show (CannotGiveSharableModeError ty) = + printf ("Cannot give sharable mode to %s. " ++ + "It can only be used for type parameters") + (refTypeName ty) + show (NonValInReadContextError ctx) = + printf "Read %s can only have val fields" + (if isTraitType ctx then "traits" else "classes") + show (NonSafeInReadContextError ctx ty) = + printf "Read %s can not have field of non-safe type '%s'. \n%s" + (if isTraitType ctx then "trait" else "class") (show ty) + enumerateSafeTypes + show (NonSafeInExtendedReadTraitError t f ty) = + printf "Read trait '%s' cannot be extended with field '%s' of non-safe type '%s'. \n%s" + (getId t) (show f) (show ty) + enumerateSafeTypes + show (ProvidingToReadTraitError provider requirer mname) = + printf "Non-read trait '%s' cannot provide method '%s' to read trait '%s'" + (getId provider) (show mname) (getId requirer) + show (SubordinateReturnError name ty) = + printf ("Method '%s' returns a %s and cannot " ++ + "be called from outside of its aggregate") + (show name) (if isArrowType ty + then "closure that captures subordinate state" + else "subordinate capability") + show (SubordinateArgumentError arg) = + if isArrowType (getType arg) + then printf ("Closure '%s' captures subordinate state " ++ + "and cannot be passed outside of its aggregate") + (show (ppSugared arg)) + else printf ("Cannot pass subordinate argument '%s' " ++ + "outside of its aggregate") + (show (ppSugared arg)) + show (SubordinateFieldError name) = + printf ("Field '%s' is subordinate and cannot be accessed " ++ + "from outside of its aggregate") + (show name) + show (ThreadLocalFieldError ty) = + printf "%s must have declared 'local' or 'active' mode to have actor local fields" + (if isTraitType ty then "Traits" else "Classes") + show (ThreadLocalFieldExtensionError trait field) = + printf ("Trait '%s' must have local mode to be extended " ++ + "with field '%s' of actor local type '%s'") + (show trait) (show $ fname field) + (showWithoutMode $ ftype field) + show (ThreadLocalArgumentError arg) = + if isArrowType (getType arg) + then printf ("Closure '%s' captures actor local variables " ++ + "and cannot be passed to another active object") + (show (ppSugared arg)) + else printf ("Cannot pass actor local argument '%s' " ++ + "to another active object") + (show (ppSugared arg)) + show (ThreadLocalReturnError name ty) = + printf ("Method '%s' returns a %s and cannot " ++ + "be called by a different active object") + (show name) (if isArrowType ty + then "closure that captures local state" + else "local capability") + show (PolymorphicArgumentSendError arg ty) = + printf ("Cannot pass value of '%s' between active objects. " ++ + "Its type is polymorphic so it may not be safe to share.\n" ++ + "Consider marking the type variable '%s' as 'sharable'") + (show (ppSugared arg)) (getId ty) + show (PolymorphicReturnError name ty) = + printf ("Method '%s' returns a value of polymorphic type, and sharing " ++ + "it between active objects may not be safe. \n" ++ + "Consider marking the type variable '%s' as 'sharable'.") + (show name) (getId ty) + show (MalformedConjunctionError ty nonDisjoint source) = + printf "Type '%s' does not form a conjunction with '%s' in %s" + (show ty) (show nonDisjoint) (Types.showWithKind source) + show (CannotUnpackError source) = + printf "Cannot unpack empty capability of class '%s'" + (show source) + show (CannotInferUnpackingError cap) = + printf ("Unpacking of %s cannot be inferred. " ++ + "Try adding type annotations") + (Types.showWithKind cap) + show (UnsplittableTypeError ty) = + printf "Cannot unpack %s" + (Types.showWithKind ty) + show (DuplicatingSplitError ty) = + printf "Cannot duplicate linear trait '%s'" + (showWithoutMode ty) + show (StackboundArrayTypeError ty) = + printf "Arrays cannot store borrowed values of type '%s'" + (show ty) + show (ManifestConflictError formal conflicting) = + printf ("Trait '%s' with declared mode '%s' can only be " ++ + "composed with traits of the same mode. Found '%s'") + (showWithoutMode formal) (showModeOf formal) (show conflicting) + show (ManifestClassConflictError cls conflicting) = + printf "Trait '%s' cannot be included by class '%s' of declared mode '%s'" + (show conflicting) (showWithoutMode cls) (showModeOf cls) + show (UnmodedMethodExtensionError cls name) = + printf ("Unmoded class '%s' cannot declare new method '%s'. " ++ + "Possible fixes: \n" ++ + " - Add a mode to the class (e.g. %s)\n" ++ + " - Assign the method to an included trait: T(%s())") + (show cls) (show name) + "active, local, read, linear or subord" (show name) + show (ActiveTraitError active nonActive) = + printf ("Active trait '%s' can only be included together with " ++ + "other active traits. Found '%s'") + (showWithoutMode active) (show nonActive) + show (UnsafeTypeArgumentError formal ty) = + if isModeless ty then + -- TODO: Could be more precise (e.g. distinguish between linear/subord) + printf ("Cannot use non-aliasable type '%s' as type argument. " ++ + "Type parameter '%s' requires the type to have %s mode") + (show ty) (getId formal) (if isModeless formal + then "an aliasable" + else showModeOf formal) + else + printf ("Cannot use %s type '%s' as type argument. " ++ + "Type parameter '%s' requires the type to have %s mode") + (showModeOf ty) (showWithoutMode ty) + (getId formal) (if isModeless formal + then "an aliasable" + else showModeOf formal) + show OverlapWithBuiltins = + printf ("Types Maybe, Fut, Stream, and Par are built-in and cannot be redefined.") + show (SimpleError msg) = msg + ---------------------------- + -- Capturechecking errors -- + ---------------------------- + show ReverseBorrowingError = + "Reverse borrowing (returning borrowed values) " ++ + "is currently not supported" + show (BorrowedFieldError ftype) = + printf "Cannot have field of borrowed type '%s'" + (show ftype) + show (LinearClosureError name ty) = + printf "Cannot capture variable '%s' of linear type '%s' in a closure" + (show name) (show ty) + show (BorrowedLeakError e) = + printf "Cannot pass borrowed expression '%s' as non-borrowed parameter" + (show (ppSugared e)) + show (NonBorrowableError FieldAccess{target, name}) = + printf "Cannot borrow linear field '%s' from non-linear path '%s'" + (show name) (show (ppSugared target)) + show (NonBorrowableError ArrayAccess{target}) = + printf "Cannot borrow linear array value from non-linear path '%s'" + (show (ppSugared target)) + show (NonBorrowableError e) = + printf "Expression '%s' cannot be borrowed." + (show (ppSugared e)) + show (ActiveBorrowError arg targetType) = + printf ("Expression '%s' cannot be borrowed " ++ + "by active object of type '%s'") + (show (ppSugared arg)) (show targetType) + show (ActiveBorrowSendError arg targetType) = + printf ("Cannot send borrowed expression '%s' to active object " ++ + "of type '%s'") + (show (ppSugared arg)) (show targetType) + show (DuplicateBorrowError root) = + printf ("Borrowed variable '%s' cannot be used more than once " ++ + "in an argument list") + (show (ppSugared root)) + show (StackboundednessMismatchError ty expected) = + printf "%s does not match %s" (kindOf ty) (kindOf' expected) + where + kindOf ty + | isStackboundType ty = "Borrowed type '" ++ show ty ++ "'" + | otherwise = "Non-borrowed type '" ++ show ty ++ "'" + kindOf' ty = + let c:s = kindOf ty + in toLower c:s + show (LinearCaptureError e ty) = + printf "Cannot capture expression '%s' of linear type '%s'" + (show (ppSugared e)) (show ty) data TCWarning = TCWarning Warning Environment instance Show TCWarning where From cbbea76f60be49f4c642b502b47d94b60d01876d Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Tue, 24 Jul 2018 15:37:04 +0200 Subject: [PATCH 21/31] Added TypeMismatchError and explanation --- src/types/Typechecker/ExplainTable.hs | 20 ++++++++++++++++++++ src/types/Typechecker/Suggestable.hs | 16 ++++++++++++---- 2 files changed, 32 insertions(+), 4 deletions(-) diff --git a/src/types/Typechecker/ExplainTable.hs b/src/types/Typechecker/ExplainTable.hs index 50256522c..48f6065e2 100644 --- a/src/types/Typechecker/ExplainTable.hs +++ b/src/types/Typechecker/ExplainTable.hs @@ -49,6 +49,26 @@ table = "Welcome to the Encore Compiler!" $$ "Here you will meet many wonderful methods and functions and whatnot!" ) + ,( + "TypeMismatchError", + "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: i32 = \"I am not a number!\";" $+$ + "// ~~~ ~~~~~~~~~~~~~~~~~~~~" $+$ + "// | |" $+$ + "// | initializing expression;" $+$ + "// | compiler infers type `&str`" $+$ + "// |" $+$ + "// type `i32` assigned to variable `x`" $+$ + "```" + ) ] diff --git a/src/types/Typechecker/Suggestable.hs b/src/types/Typechecker/Suggestable.hs index fd52a6cec..4d57b4e39 100644 --- a/src/types/Typechecker/Suggestable.hs +++ b/src/types/Typechecker/Suggestable.hs @@ -25,8 +25,8 @@ pipe = char '|' highlightPretty :: String -> Doc TCStyle highlightPretty s = highlight $ text s -makeNotation :: Doc TCStyle -makeNotation = logistic (pipe $+$ equals) <+> desc (text "note:") +codeViewerNote :: Doc TCStyle +codeViewerNote = logistic (pipe $+$ equals) <+> desc (text "note:") -- How to determine if to use a smallSuggest or longSuggest: -- If a problem justifies it, you could use both, @@ -44,20 +44,28 @@ instance Suggestable TCError where smallSuggest (TCError (NonAssignableLHSError) _) = highlightPretty "Can only be used on var or fields" smallSuggest (TCError (MethodNotFoundError name ty) env) | isMethodNameAFunction name ty env = highlightPretty $ printf "Did you mean function `%s`?" (show name) + smallSuggest (TCError (TypeMismatchError actual expected) _) = + highlightPretty $ printf "expected %s" (show expected) smallSuggest _ = empty + longSuggest (TCError (TypeMismatchError actual expected) _) = + let + expect = text "expected type" <+> desc (text $ show expected) + found = text " found type" <+> desc (text $ show actual) + in + codeViewerNote <+> vcat [expect, found] longSuggest (TCError (TypeWithCapabilityMismatchError actual cap expected) _) = let expect = text "expected type" <+> desc (text $ show expected) found = text " found type" <+> desc (text $ show actual) in - makeNotation <+> vcat [expect, found] + codeViewerNote <+> vcat [expect, found] 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 + codeViewerNote <+> hang ("Method" <+> quotes (text $ show name) <+> "is declared:") 0 (desc (ppFunctionHeader header)) longSuggest _ = empty From 959717fa25d8969d22ab815ee14b5b4600d6e62f Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Thu, 26 Jul 2018 20:55:56 +0200 Subject: [PATCH 22/31] Expose default function modules in visibleFunctions --- src/types/Typechecker/Environment.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/types/Typechecker/Environment.hs b/src/types/Typechecker/Environment.hs index 079dc9861..29faf38a8 100644 --- a/src/types/Typechecker/Environment.hs +++ b/src/types/Typechecker/Environment.hs @@ -512,11 +512,12 @@ varLookup qname@QName{qnspace, qnlocal = x} visibleFunctions :: Environment -> [(Name, Type)] visibleFunctions Env{locals, lookupTables} = let - ftable = extractTables filterFunctionTable lookupTables - selfMadeFunc = filter (not . (`elem` ["Std", "String"]) . show . fst) ftable + fTable = extractTables filterFunctionTable lookupTables + -- Ability to filter lobal functions included by default + --selfMadeFunc = filter (not . (`elem` ["Std", "String"]) . show . fst) fTable localFunc = map (\(x,(_,z)) -> (x,z)) $ filter (isArrowType . snd . snd) locals in - localFunc ++ concatMap (Map.assocs . snd) selfMadeFunc + localFunc ++ concatMap (Map.assocs . snd) fTable where filterFunctionTable LookupTable{functionTable From 3d9d3ffafcfc9eca133c5058c1658b3b5713362a Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Fri, 27 Jul 2018 14:50:37 +0200 Subject: [PATCH 23/31] Test using external file and pager for explanations --- encore.cabal | 2 ++ modules/explanations/testFile.txt | 17 +++++++++++++++ src/front/TopLevel.hs | 10 ++++++++- src/types/Typechecker/ExplainTable.hs | 31 ++++++++++++++------------- 4 files changed, 44 insertions(+), 16 deletions(-) create mode 100644 modules/explanations/testFile.txt diff --git a/encore.cabal b/encore.cabal index 34604f35d..ab36db911 100644 --- a/encore.cabal +++ b/encore.cabal @@ -48,6 +48,8 @@ executable encorec , boxes , filepath , ansi-terminal + , pager + , bytestring hs-source-dirs: src/back src/front src/ir src/opt src/parser src/types ghc-options: -Werror default-language: Haskell2010 diff --git a/modules/explanations/testFile.txt b/modules/explanations/testFile.txt new file mode 100644 index 000000000..585e456dc --- /dev/null +++ b/modules/explanations/testFile.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: i32 = \"I am not a number!\"; +// ~~~ ~~~~~~~~~~~~~~~~~~~~ +// | | +// | initializing expression; +// | compiler infers type `&str` +// | +// type `i32` assigned to variable `x` +``` diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index bc50162d9..584801e42 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -14,6 +14,9 @@ import System.Directory import System.IO import System.Exit import System.Process +import System.Posix.Process +import qualified Data.ByteString.Lazy as B +import System.Pager import System.Posix.Directory import Data.List import Data.List.Utils(split) @@ -430,7 +433,12 @@ main = noExplanation errCode exit "" Just explain -> do - resetScreen >> exit (Pretty.render $ explain Pretty.<> Pretty.text "\n") + let fnom = standardLibLocation ++ "/explanations/testFile.txt" + B.readFile fnom >>= sendToPager + exitSuccess + --executeFile "less" True [standardLibLocation ++ "/explanations/testFile.txt"] Nothing + + --resetScreen >> exit (Pretty.render $ explain Pretty.<> Pretty.text "\n") where resetScreen :: IO () resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0 diff --git a/src/types/Typechecker/ExplainTable.hs b/src/types/Typechecker/ExplainTable.hs index 48f6065e2..d905aa7ba 100644 --- a/src/types/Typechecker/ExplainTable.hs +++ b/src/types/Typechecker/ExplainTable.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Typechecker.ExplainTable ( Table @@ -208,18 +209,18 @@ toKey (ManifestConflictError _ _) = Just "ManifestConflictEr toKey (ManifestClassConflictError _ _) = Just "ManifestClassConflictError" toKey (UnmodedMethodExtensionError _ _) = Just "UnmodedMethodExtensionError" toKey (ActiveTraitError _ _) = Just "ActiveTraitError" -toKey (NewWithModeError) = Just "NewWithModeError" -toKey (UnsafeTypeArgumentError _ _) = Just "UnsafeTypeArgumentError" -toKey (OverlapWithBuiltins) = Just "OverlapWithBuiltins" -toKey (SimpleError _) = Just "SimpleError" -toKey (ReverseBorrowingError) = Just "ReverseBorrowingError" -toKey (BorrowedFieldError _) = Just "BorrowedFieldError" -toKey (LinearClosureError _ _) = Just "LinearClosureError" -toKey (BorrowedLeakError _) = Just "BorrowedLeakError" -toKey (NonBorrowableError _) = Just "NonBorrowableError" -toKey (ActiveBorrowError _ _) = Just "ActiveBorrowError" -toKey (ActiveBorrowSendError _ _) = Just "ActiveBorrowSendError" -toKey (DuplicateBorrowError _) = Just "DuplicateBorrowError" -toKey (StackboundednessMismatchError _ _) = Just "StackboundednessMismatchError" -toKey (LinearCaptureError _ _) = Just "LinearCaptureError" ---toKey _ = Nothing \ No newline at end of file +--toKey (NewWithModeError) = Just "NewWithModeError" +--toKey (UnsafeTypeArgumentError _ _) = Just "UnsafeTypeArgumentError" +--toKey (OverlapWithBuiltins) = Just "OverlapWithBuiltins" +--toKey (SimpleError _) = Just "SimpleError" +--toKey (ReverseBorrowingError) = Just "ReverseBorrowingError" +--toKey (BorrowedFieldError _) = Just "BorrowedFieldError" +--toKey (LinearClosureError _ _) = Just "LinearClosureError" +--toKey (BorrowedLeakError _) = Just "BorrowedLeakError" +--toKey (NonBorrowableError _) = Just "NonBorrowableError" +--toKey (ActiveBorrowError _ _) = Just "ActiveBorrowError" +--toKey (ActiveBorrowSendError _ _) = Just "ActiveBorrowSendError" +--toKey (DuplicateBorrowError _) = Just "DuplicateBorrowError" +--toKey (StackboundednessMismatchError _ _) = Just "StackboundednessMismatchError" +--toKey (LinearCaptureError _ _) = Just "LinearCaptureError" +toKey _ = Nothing \ No newline at end of file From 0d76dfec3d3b51fbe37b89444776fed389e8a491 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Fri, 27 Jul 2018 16:26:30 +0200 Subject: [PATCH 24/31] Code cleanup --- src/front/TopLevel.hs | 2 +- src/types/Typechecker/Errorprinter.hs | 77 ++++++++++++++------------- src/types/Typechecker/Suggestable.hs | 16 +++--- src/types/Typechecker/TypeError.hs | 27 ++++------ 4 files changed, 60 insertions(+), 62 deletions(-) diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index acae43f34..c63574521 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -244,7 +244,7 @@ compileProgram prog sourcePath options = customFlags = case find isCustomFlags options of Just (CustomFlags str) -> str Nothing -> "" - flags = "-std=gnu11 -Wall -fms-extensions -Wno-format -Wno-microsoft -Wno-parentheses-equality -Wno-unused-variable -Wno-unused-value" <+> customFlags <+> "-lpthread -latomic -ldl -lm -Wno-attributes" + flags = "-std=gnu11 -Wall -fms-extensions -Wno-format -Wno-microsoft -Wno-parentheses-equality -Wno-unused-variable -Wno-unused-value" <+> customFlags <+> "-lpthread -ldl -lm -Wno-attributes" oFlag = "-o" <+> execName defines = getDefines options incs = "-I" <+> incPath <+> "-I ." diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs index c128e6001..db4ec19f7 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -65,8 +65,9 @@ toWarningStyle Code = return () -- prettyError will need all lines of code it will print beforehand in its second argument prettyError :: TCError -> [String] -> Doc TCStyle -prettyError tcErr@(TCError err@(UnknownRefTypeError _) _) _ = - declareError err <+> description err $+$ nest 2 (showPosition $ currentPos tcErr) +-- 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 $ currentPos tcErr) -- Default errors prettyError (TCError err Env{bt = []}) _ = @@ -80,29 +81,15 @@ prettyError tcErr@(TCError err _) code = pipe = char '|' declareError :: Error -> Doc TCStyle -declareError _ = classify $ text "Error:" +declareError _ = styleClassify $ text "Error:" description :: Error -> Doc TCStyle -description err = desc $ text $ show err +description err = styleDesc $ text $ show err -codeLine ::Int -> String -> String -> Int -> Doc TCStyle -codeLine digitSpace insertStr codeLine lineNo = - let - pad = digitSpace - (length $ show lineNo) - in - logistic (nest pad $ (int lineNo) <+> pipe) <> - highlight (text insertStr) <> - code (text codeLine) showPosition :: Position -> Doc TCStyle -showPosition pos = logistic (text "-->") <+> (text $ show $ pos) - -lineHighlighter :: Int -> Int -> Char -> Doc ann -lineHighlighter s e c = text $ replicate (s-1) ' ' ++ replicate (e-s) c +showPosition pos = styleLogistic (text "-->") <+> (text $ show $ pos) -multilineHighlighter :: Int -> Bool -> Char -> Doc ann -multilineHighlighter col True c = space <> space <> text (replicate (col-1) '_') <> char c -multilineHighlighter col False c = space <> pipe <> text (replicate (col-2) '_') <> char c codeViewer :: TCError -> [String] -> Doc TCStyle codeViewer _ [] = error "TypeError.hs: No code to view" @@ -110,31 +97,49 @@ codeViewer err (cHead:cTail) = let pos = currentPos err ((sL, sC), (eL, eC)) = getPositions pos - digitLen = length $ show eL - tailCode = zipWith (codeLine digitLen " |") cTail (range (sL+1, eL)) + digitLen = 1 + (length $ show eL) --One additional for the space between line-number and pipe + tailCode = zipWith (codeLine " |") cTail (range (sL+1, eL)) in if sL == eL then - nest (digitLen+1) $ showPosition pos $+$ - logistic pipe $+$ - nest (-(digitLen+1)) (codeLine digitLen "" cHead sL) $+$ - logistic pipe <> - highlight (lineHighlighter sC eC '^') <+> - smallSuggest err $+$ + nest (digitLen) $ showPosition pos $+$ + styleLogistic pipe $+$ + codeLine "" cHead sL $+$ + styleLogistic pipe <> + styleHighlight (lineHighlighter sC eC '^') <+> + styleHighlight (smallSuggest err) $+$ longSuggest err else - nest (digitLen+1) $ showPosition pos $+$ - logistic pipe $+$ - nest (-(digitLen+1)) (codeLine digitLen " " cHead sL) $+$ - logistic pipe <> - highlight (multilineHighlighter sC True '^') $+$ - nest (-(digitLen+1)) (vcat tailCode) $+$ - logistic pipe <> - highlight (multilineHighlighter eC False '^') <+> - smallSuggest err $+$ + nest (digitLen) $ showPosition pos $+$ + styleLogistic pipe $+$ + codeLine " " cHead sL $+$ + styleLogistic pipe <> + styleHighlight (multilineHighlighter sC FirstLine '^') $+$ + vcat tailCode $+$ + styleLogistic pipe <> + styleHighlight (multilineHighlighter eC LastLine '^') <+> + styleHighlight (smallSuggest err) $+$ longSuggest err +lineHighlighter :: Int -> Int -> Char -> Doc ann +lineHighlighter s e c = 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) + getCodeLines :: Position -> IO [String] getCodeLines pos = do let ((sL, _), (eL, _)) = getPositions pos diff --git a/src/types/Typechecker/Suggestable.hs b/src/types/Typechecker/Suggestable.hs index fd52a6cec..292d2cd03 100644 --- a/src/types/Typechecker/Suggestable.hs +++ b/src/types/Typechecker/Suggestable.hs @@ -22,11 +22,9 @@ import Types pipe = char '|' -highlightPretty :: String -> Doc TCStyle -highlightPretty s = highlight $ text s makeNotation :: Doc TCStyle -makeNotation = logistic (pipe $+$ equals) <+> desc (text "note:") +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, @@ -37,19 +35,19 @@ makeNotation = logistic (pipe $+$ equals) <+> desc (text "note:") -- 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 TCStyle + smallSuggest :: a -> Doc ann longSuggest :: a -> Doc TCStyle instance Suggestable TCError where - smallSuggest (TCError (NonAssignableLHSError) _) = highlightPretty "Can only be used on var or fields" + smallSuggest (TCError (NonAssignableLHSError) _) = "Can only be used on var or fields" smallSuggest (TCError (MethodNotFoundError name ty) env) - | isMethodNameAFunction name ty env = highlightPretty $ printf "Did you mean function `%s`?" (show name) + | isMethodNameAFunction name ty env = text $ printf "Did you mean function `%s`?" (show name) smallSuggest _ = empty longSuggest (TCError (TypeWithCapabilityMismatchError actual cap expected) _) = let - expect = text "expected type" <+> desc (text $ show expected) - found = text " found type" <+> desc (text $ show actual) + expect = text "expected type" <+> styleDesc (text $ show expected) + found = text " found type" <+> styleDesc (text $ show actual) in makeNotation <+> vcat [expect, found] longSuggest (TCError (WrongNumberOfMethodArgumentsError name targetType _ _) env) = @@ -58,7 +56,7 @@ instance Suggestable TCError where types = hparams header in makeNotation <+> hang ("Method" <+> quotes (text $ show name) <+> "is declared:") 0 - (desc (ppFunctionHeader header)) + (styleDesc (ppFunctionHeader header)) longSuggest _ = empty diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 1c55b6c36..a019ff125 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -13,11 +13,11 @@ module Typechecker.TypeError ( ,TCWarning(TCWarning) ,Warning(..) ,TCStyle(..) - ,classify - ,desc - ,logistic - ,highlight - ,code + ,styleClassify + ,styleDesc + ,styleLogistic + ,styleHighlight + ,styleCode ) where import Text.PrettyPrint.Annotated.HughesPJ @@ -859,14 +859,9 @@ pipe = char '|' data TCStyle = Classification | Desc | Logistic | Highlight | Code -classify, desc, logistic, highlight, code :: Doc TCStyle -> Doc TCStyle -classify = annotate Classification -desc = annotate Desc -logistic = annotate Logistic -highlight = annotate Highlight -code = annotate Code - - - --hash (UnionMethodAmbiguityError _ _) = 3 - - --explain 3 = "stuff" \ No newline at end of file +styleClassify, styleDesc, styleLogistic, styleHighlight, styleCode :: Doc TCStyle -> Doc TCStyle +styleClassify = annotate Classification +styleDesc = annotate Desc +styleLogistic = annotate Logistic +styleHighlight = annotate Highlight +styleCode = annotate Code From 390d593ee03efbefa78644a486a5d7c81a1af779 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Sun, 25 Nov 2018 19:53:16 +0100 Subject: [PATCH 25/31] Alternative codeviewer with new multiline renderer --- src/types/Typechecker/Errorprinter.hs | 54 +++++++++++++++++++++++++-- 1 file changed, 51 insertions(+), 3 deletions(-) diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs index db4ec19f7..676df8c29 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -90,10 +90,53 @@ description err = styleDesc $ text $ show err showPosition :: Position -> Doc TCStyle showPosition pos = styleLogistic (text "-->") <+> (text $ show $ pos) +codeViewer_ver1 :: TCError -> [String] -> Doc TCStyle +codeViewer_ver1 _ [] = error "TypeError.hs: No code to view" +codeViewer_ver1 err (cHead:cTail) = + nest (digitLen) $ showPosition pos $+$ + styleLogistic pipe $+$ + showCodeHead + showTailCode <+> + styleHighlight (smallSuggest err) $+$ + longSuggest err -codeViewer :: TCError -> [String] -> Doc TCStyle -codeViewer _ [] = error "TypeError.hs: No code to view" -codeViewer err (cHead:cTail) = + where + pos = currentPos 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] + + showCodeHead :: Doc TCStyle -> Doc TCStyle + showCodeHead tail + | sL == eL = + codeLine " " cHead sL $+$ + styleLogistic pipe <> + styleHighlight (singleLineHighlighter sC eC '^') <+> tail + | errorIsWholeLine cHead sC = codeLine " /" cHead sL $+$ tail + | otherwise = + codeLine " " cHead sL $+$ + styleLogistic pipe <> + styleHighlight (multilineHighlighter sC FirstLine '^') $+$ tail + + showTailCode :: Doc TCStyle + showTailCode + | null tailCode = empty + | otherwise = + vcat tailCode $+$ + styleLogistic pipe <> + styleHighlight (multilineHighlighter eC LastLine '^') + + errorIsWholeLine _ 0 = True + errorIsWholeLine _ 1 = True + errorIsWholeLine (x:xs) n + | x == ' ' = errorIsWholeLine xs (n-1) + | otherwise = False + + + +codeViewer_ver2 :: TCError -> [String] -> Doc TCStyle +codeViewer_ver2 _ [] = error "TypeError.hs: No code to view" +codeViewer_ver2 err (cHead:cTail) = let pos = currentPos err ((sL, sC), (eL, eC)) = getPositions pos @@ -122,9 +165,14 @@ codeViewer err (cHead:cTail) = longSuggest err +-- Remove if version 2 is not to be used lineHighlighter :: Int -> Int -> Char -> Doc ann lineHighlighter s e c = text $ replicate (s-1) ' ' ++ replicate (e-s) c +-- Remove if version 1 is not to be used +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 From 6c07c054c2dc42a3125c40b11bfc6e1e43d09837 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Mon, 26 Nov 2018 00:25:50 +0100 Subject: [PATCH 26/31] Added pretty rendering of warnings --- src/front/TopLevel.hs | 4 +- src/types/Typechecker/Errorprinter.hs | 57 +++++++++++++++++++-------- src/types/Typechecker/Suggestable.hs | 5 ++- src/types/Typechecker/TypeError.hs | 23 ++++++----- 4 files changed, 58 insertions(+), 31 deletions(-) diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index c63574521..f46ab6276 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -410,7 +410,7 @@ main = verbose options str = when (Verbose `elem` options) (putStrLn str) - showWarnings = mapM print + showWarnings = mapM printWarning . reverse helpMessage = "Welcome to the Encore compiler!\n" <> usage <> "\n\n" <> @@ -434,4 +434,4 @@ main = errorAbort e = do printf "*** Error during typechecking *** \n\n" printError e - abort $ "\nAborting due to previous error" \ No newline at end of file + abort $ "Aborting due to previous error" \ No newline at end of file diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs index 676df8c29..40f01e07f 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -1,5 +1,5 @@ -module Typechecker.Errorprinter (printError) where +module Typechecker.Errorprinter (printError, printWarning) where -- Library dependencies @@ -18,21 +18,34 @@ import Typechecker.Environment import Typechecker.TypeError import Typechecker.Util import Typechecker.Suggestable +import System.IO -currentPos (TCError _ Env{bt = ((pos, _):_)}) = pos printError :: TCError -> IO () printError err@(TCError _ Env{bt = []}) = - renderError $ prettyError err [] $+$ text "" -printError error = do - code <- getCodeLines $ currentPos error - renderError $ prettyError error code $+$ text "" + renderTCType toErrorStyle $ prettyError err [] $+$ text "\n" +printError err@(TCError _ env) = do + code <- getCodeLines $ currentBTPos err + renderTCType toErrorStyle $ prettyError err code $+$ text "\n" -renderError :: Doc TCStyle -> IO () -renderError doc = - renderDecoratedM toErrorStyle endAnn textprinter endDoc doc +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] @@ -67,30 +80,40 @@ toWarningStyle Code = return () 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 $ currentPos tcErr) + | 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 + declareError err <+> description err $+$ codeViewer_ver1 tcErr code -- Possible extensions: -- Duplicate Class -> print positions (File + line) of the two classes -- Type error in func call -> print a version of codeViewer that also shows the function head +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_ver1 tcWarn code + pipe = char '|' declareError :: Error -> Doc TCStyle declareError _ = styleClassify $ text "Error:" -description :: Error -> Doc TCStyle -description err = styleDesc $ text $ show err +declareWarning :: Warning -> Doc TCStyle +declareWarning _ = styleClassify $ text "Warning:" + +description :: Show a => a -> Doc TCStyle +description ty = styleDesc $ text $ show ty showPosition :: Position -> Doc TCStyle showPosition pos = styleLogistic (text "-->") <+> (text $ show $ pos) -codeViewer_ver1 :: TCError -> [String] -> Doc TCStyle +codeViewer_ver1 :: (TCType a, Suggestable a) => a -> [String] -> Doc TCStyle codeViewer_ver1 _ [] = error "TypeError.hs: No code to view" codeViewer_ver1 err (cHead:cTail) = nest (digitLen) $ showPosition pos $+$ @@ -101,7 +124,7 @@ codeViewer_ver1 err (cHead:cTail) = longSuggest err where - pos = currentPos err + 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] @@ -134,11 +157,11 @@ codeViewer_ver1 err (cHead:cTail) = -codeViewer_ver2 :: TCError -> [String] -> Doc TCStyle +codeViewer_ver2 :: (TCType a, Suggestable a) => a -> [String] -> Doc TCStyle codeViewer_ver2 _ [] = error "TypeError.hs: No code to view" codeViewer_ver2 err (cHead:cTail) = let - pos = currentPos err + 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 (range (sL+1, eL)) diff --git a/src/types/Typechecker/Suggestable.hs b/src/types/Typechecker/Suggestable.hs index 292d2cd03..b88a557d8 100644 --- a/src/types/Typechecker/Suggestable.hs +++ b/src/types/Typechecker/Suggestable.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Typechecker.Suggestable ( - smallSuggest + Suggestable + ,smallSuggest ,longSuggest )where @@ -61,7 +62,7 @@ instance Suggestable TCError where longSuggest _ = empty -instance Suggestable Warning where +instance Suggestable TCWarning where smallSuggest _ = empty longSuggest _ = empty diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 331805b4d..68fdb3c57 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -8,7 +8,9 @@ The machinery used by "Typechecker.Typechecker" and -} module Typechecker.TypeError ( - TCError(TCError) + TCType + ,currentBTPos + ,TCError(TCError) ,Error(..) ,TCWarning(TCWarning) ,Warning(..) @@ -50,10 +52,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 Environment +instance TCType TCError where + currentBTPos (TCError _ Env{bt = ((pos, _):_)}) = pos + data Error = DistinctTypeParametersError Type @@ -812,13 +820,10 @@ instance Show Error where (show (ppSugared e)) (show ty) data TCWarning = TCWarning Warning Environment -instance Show TCWarning where - show (TCWarning w Env{bt = []}) = - "Warning:\n" ++ - show w - show (TCWarning w Env{bt = ((pos, _):_)}) = - "Warning at " ++ show pos ++ ":\n" ++ - show w + +instance TCType TCWarning where + currentBTPos (TCWarning _ Env{bt = ((pos, _):_)}) = pos + data Warning = StringDeprecatedWarning | StringIdentityWarning @@ -861,8 +866,6 @@ instance Show Warning where -pipe = char '|' - data TCStyle = Classification | Desc | Logistic | Highlight | Code styleClassify, styleDesc, styleLogistic, styleHighlight, styleCode :: Doc TCStyle -> Doc TCStyle From 02874a5489e65006642251cd80473da3d8725a1e Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Mon, 26 Nov 2018 01:25:33 +0100 Subject: [PATCH 27/31] Uses now pager for every explanation --- modules/explanations/E0014.txt | 2 + .../explanations/{testFile.txt => E0073.txt} | 0 src/front/TopLevel.hs | 45 ++- src/types/Typechecker/ExplainTable.hs | 360 ++++++++---------- 4 files changed, 175 insertions(+), 232 deletions(-) create mode 100644 modules/explanations/E0014.txt rename modules/explanations/{testFile.txt => E0073.txt} (100%) diff --git a/modules/explanations/E0014.txt b/modules/explanations/E0014.txt new file mode 100644 index 000000000..ef8073268 --- /dev/null +++ b/modules/explanations/E0014.txt @@ -0,0 +1,2 @@ +Welcome to the Encore Compiler! +Here you will meet many wonderful methods and functions and whatnot! diff --git a/modules/explanations/testFile.txt b/modules/explanations/E0073.txt similarity index 100% rename from modules/explanations/testFile.txt rename to modules/explanations/E0073.txt diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index 584801e42..6d9b4b6bf 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -47,7 +47,6 @@ import Typechecker.Environment(buildLookupTable) import Typechecker.Prechecker(precheckProgram) import Typechecker.Typechecker(typecheckProgram, checkForMainClass) import Typechecker.Errorprinter -import Typechecker.ExplainTable(getErrorExplanation) import Typechecker.Capturechecker(capturecheckProgram) import Optimizer.Optimizer import CodeGen.Main @@ -424,25 +423,6 @@ main = showWarnings = mapM print - isExplain (Explain _) = True - isExplain _ = False - - explainError errCode = - case getErrorExplanation errCode of - Nothing -> do - noExplanation errCode - exit "" - Just explain -> do - let fnom = standardLibLocation ++ "/explanations/testFile.txt" - B.readFile fnom >>= sendToPager - exitSuccess - --executeFile "less" True [standardLibLocation ++ "/explanations/testFile.txt"] Nothing - - --resetScreen >> exit (Pretty.render $ explain Pretty.<> Pretty.text "\n") - where - resetScreen :: IO () - resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0 - helpMessage = "Welcome to the Encore compiler!\n" <> usage <> "\n\n" <> @@ -466,4 +446,27 @@ main = errorAbort e = do printf "*** Error during typechecking *** \n\n" printError e - abort $ "\nAborting due to previous error" \ No newline at end of file + abort $ "\nAborting due to previous error" + + + 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 + + where + resetScreen :: IO () + resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0 + + isExplanationHash :: String -> IO Bool + isExplanationHash str@('E':_:_:_:_:[]) = doesFileExist $ standardLibLocation ++ "/explanations/" ++ str ++ ".txt" + isExplanationHash _ = return False \ No newline at end of file diff --git a/src/types/Typechecker/ExplainTable.hs b/src/types/Typechecker/ExplainTable.hs index d905aa7ba..5d1b66213 100644 --- a/src/types/Typechecker/ExplainTable.hs +++ b/src/types/Typechecker/ExplainTable.hs @@ -1,226 +1,164 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Typechecker.ExplainTable ( Table ,lookupHash - ,getErrorExplanation ) where import Typechecker.TypeError -import Text.PrettyPrint.Annotated -import Text.Read (readMaybe) -import Text.Printf (printf) - lookupHash :: Error -> Maybe Int -lookupHash err - | Just k <- toKey err = let T t = table in lookup' t k 1 - | otherwise = Nothing - where - lookup' [] k _ = Nothing - lookup' ((k', v):as) k x - | k == k'= Just x - | otherwise = lookup' as k (x+1) - - -getErrorExplanation :: String -> Maybe (Doc a) -getErrorExplanation ('E':err) = - case readMaybe err :: Maybe Int of - Just num - | num > 0 -> let T t = table in lookupExplain (num-1) t - | otherwise -> Nothing - Nothing -> Nothing -getErrorExplanation _ = Nothing - - -lookupExplain _ [] = Nothing -lookupExplain 0 ((_, v):_) = Just v -lookupExplain x (_:ls) = lookupExplain (x-1) ls - - -newtype Table k v = T [(k, v)] +lookupHash err = toKey err -table :: Table String (Doc a) -table = - T [ - ( - "MissingMainClass", - "Welcome to the Encore Compiler!" $$ - "Here you will meet many wonderful methods and functions and whatnot!" - ) - ,( - "TypeMismatchError", - "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: i32 = \"I am not a number!\";" $+$ - "// ~~~ ~~~~~~~~~~~~~~~~~~~~" $+$ - "// | |" $+$ - "// | initializing expression;" $+$ - "// | compiler infers type `&str`" $+$ - "// |" $+$ - "// type `i32` assigned to variable `x`" $+$ - "```" - ) - ] --- I want to have a guarding Nothing in case if an error is introdused, --- but the compiler gives me an overlapped-error.... -toKey :: Error -> Maybe String -toKey (DistinctTypeParametersError _) = Just "DistinctTypeParametersError" -toKey (WrongNumberOfMethodArgumentsError _ _ _ _) = Just "WrongNumberOfMethodArgumentsError" -toKey (WrongNumberOfFunctionArgumentsError _ _ _) = Just "WrongNumberOfFunctionArgumentsError" -toKey (WrongNumberOfFunctionTypeArgumentsError _ _ _) = Just "WrongNumberOfFunctionTypeArgumentsError" -toKey (WrongNumberOfTypeParametersError _ _ _ _) = Just "WrongNumberOfTypeParametersError" -toKey (MissingFieldRequirementError _ _) = Just "MissingFieldRequirementError" -toKey (CovarianceViolationError _ _ _) = Just "CovarianceViolationError" -toKey (RequiredFieldMismatchError _ _ _ _) = Just "RequiredFieldMismatchError" -toKey (NonDisjointConjunctionError _ _ _) = Just "NonDisjointConjunctionError" -toKey (OverriddenMethodTypeError _ _ _ _) = Just "OverriddenMethodTypeError" -toKey (OverriddenMethodError _ _ _) = Just "OverriddenMethodError" -toKey (IncludedMethodConflictError _ _ _) = Just "IncludedMethodConflictError" -toKey (MissingMethodRequirementError _ _) = Just "MissingMethodRequirementError" -toKey (MissingMainClass) = Just "MissingMainClass" -toKey (SyncStreamCall) = Just "SyncStreamCall" -toKey (UnknownTraitError _) = Just "UnknownTraitError" -toKey (UnknownRefTypeError _) = Just "UnknownRefTypeError" -toKey (MalformedCapabilityError _) = Just "MalformedCapabilityError" -toKey (MalformedBoundError _) = Just "MalformedBoundError" -toKey (RecursiveTypesynonymError _) = Just "RecursiveTypesynonymError" -toKey (DuplicateThingError _ _) = Just "DuplicateThingError" -toKey (PassiveStreamingMethodError) = Just "PassiveStreamingMethodError" -toKey (PolymorphicConstructorError) = Just "PolymorphicConstructorError" -toKey (StreamingConstructorError) = Just "StreamingConstructorError" -toKey (MainMethodArgumentsError) = Just "MainMethodArgumentsError" -toKey (MainConstructorError) = Just "MainConstructorError" -toKey (FieldNotFoundError _ _) = Just "FieldNotFoundError" -toKey (MethodNotFoundError _ _) = Just "MethodNotFoundError" -toKey (BreakOutsideOfLoopError) = Just "BreakOutsideOfLoopError" -toKey (BreakUsedAsExpressionError) = Just "BreakUsedAsExpressionError" -toKey (ContinueOutsideOfLoopError) = Just "ContinueOutsideOfLoopError" -toKey (ContinueUsedAsExpressionError) = Just "ContinueUsedAsExpressionError" -toKey (NonCallableTargetError _) = Just "NonCallableTargetError" -toKey (NonSendableTargetError _) = Just "NonSendableTargetError" -toKey (MainMethodCallError) = Just "MainMethodCallError" -toKey (ConstructorCallError) = Just "ConstructorCallError" -toKey (ExpectingOtherTypeError _ _) = Just "ExpectingOtherTypeError" -toKey (NonStreamingContextError _) = Just "NonStreamingContextError" -toKey (UnboundFunctionError _) = Just "UnboundFunctionError" -toKey (NonFunctionTypeError _) = Just "NonFunctionTypeError" -toKey (BottomTypeInferenceError) = Just "BottomTypeInferenceError" -toKey (IfInferenceError) = Just "IfInferenceError" -toKey (IfBranchMismatchError _ _) = Just "IfBranchMismatchError" -toKey (EmptyMatchClauseError) = Just "EmptyMatchClauseError" -toKey (ActiveMatchError) = Just "ActiveMatchError" -toKey (MatchInferenceError) = Just "MatchInferenceError" -toKey (ThisReassignmentError) = Just "ThisReassignmentError" -toKey (ImmutableVariableError _) = Just "ImmutableVariableError" -toKey (PatternArityMismatchError _ _ _) = Just "PatternArityMismatchError" -toKey (PatternTypeMismatchError _ _) = Just "PatternTypeMismatchError" -toKey (NonMaybeExtractorPatternError _) = Just "NonMaybeExtractorPatternError" -toKey (InvalidPatternError _) = Just "InvalidPatternError" -toKey (InvalidTupleTargetError _ _ _) = Just "InvalidTupleTargetError" -toKey (InvalidTupleAccessError _ _) = Just "InvalidTupleAccessError" -toKey (CannotReadFieldError _) = Just "CannotReadFieldError" -toKey (NonAssignableLHSError) = Just "NonAssignableLHSError" -toKey (ValFieldAssignmentError _ _) = Just "ValFieldAssignmentError" -toKey (UnboundVariableError _) = Just "UnboundVariableError" -toKey (BuriedVariableError _) = Just "BuriedVariableError" -toKey (ObjectCreationError _) = Just "ObjectCreationError" -toKey (NonIterableError _) = Just "NonIterableError" -toKey (EmptyArrayLiteralError) = Just "EmptyArrayLiteralError" -toKey (NonIndexableError _) = Just "NonIndexableError" -toKey (NonSizeableError _) = Just "NonSizeableError" -toKey (FormatStringLiteralError) = Just "FormatStringLiteralError" -toKey (UnprintableExpressionError _) = Just "UnprintableExpressionError" -toKey (WrongNumberOfPrintArgumentsError _ _) = Just "WrongNumberOfPrintArgumentsError" -toKey (UnaryOperandMismatchError _ _) = Just "UnaryOperandMismatchError" -toKey (BinaryOperandMismatchError _ _ _ _) = Just "BinaryOperandMismatchError" -toKey (UndefinedBinaryOperatorError _) = Just "UndefinedBinaryOperatorError" -toKey (NullTypeInferenceError) = Just "NullTypeInferenceError" -toKey (CannotBeNullError _) = Just "CannotBeNullError" -toKey (TypeMismatchError _ _) = Just "TypeMismatchError" -toKey (TypeWithCapabilityMismatchError _ _ _) = Just "TypeWithCapabilityMismatchError" -toKey (TypeVariableAmbiguityError _ _ _) = Just "TypeVariableAmbiguityError" -toKey (FreeTypeVariableError _) = Just "FreeTypeVariableError" -toKey (TypeVariableAndVariableCommonNameError _) = Just "TypeVariableAndVariableCommonNameError" -toKey (UnionMethodAmbiguityError _ _) = Just "UnionMethodAmbiguityError" -toKey (MalformedUnionTypeError _ _) = Just "MalformedUnionTypeError" -toKey (RequiredFieldMutabilityError _ _) = Just "RequiredFieldMutabilityError" -toKey (ProvidingTraitFootprintError _ _ _ _) = Just "ProvidingTraitFootprintError" -toKey (TypeArgumentInferenceError _ _) = Just "TypeArgumentInferenceError" -toKey (AmbiguousTypeError _ _) = Just "AmbiguousTypeError" -toKey (UnknownTypeUsageError _ _) = Just "UnknownTypeUsageError" -toKey (AmbiguousNameError _ _) = Just "AmbiguousNameError" -toKey (UnknownNamespaceError _) = Just "UnknownNamespaceError" -toKey (UnknownNameError _ _) = Just "UnknownNameError" -toKey (ShadowedImportError _) = Just "ShadowedImportError" -toKey (WrongModuleNameError _ _) = Just "WrongModuleNameError" -toKey (BadSyncCallError) = Just "BadSyncCallError" -toKey (PrivateAccessModifierTargetError _) = Just "PrivateAccessModifierTargetError" -toKey (ClosureReturnError) = Just "ClosureReturnError" -toKey (ClosureForwardError) = Just "ClosureForwardError" -toKey (MatchMethodNonMaybeReturnError) = Just "MatchMethodNonMaybeReturnError" -toKey (MatchMethodNonEmptyParameterListError) = Just "MatchMethodNonEmptyParameterListError" -toKey (ImpureMatchMethodError _) = Just "ImpureMatchMethodError" -toKey (IdComparisonNotSupportedError _) = Just "IdComparisonNotSupportedError" -toKey (IdComparisonTypeMismatchError _ _) = Just "IdComparisonTypeMismatchError" -toKey (ForwardInPassiveContext _) = Just "ForwardInPassiveContext" -toKey (ForwardInFunction) = Just "ForwardInFunction" -toKey (ForwardTypeError _ _) = Just "ForwardTypeError" -toKey (ForwardTypeClosError _ _) = Just "ForwardTypeClosError" -toKey (CannotHaveModeError _) = Just "CannotHaveModeError" -toKey (ModelessError _) = Just "ModelessError" -toKey (ModeOverrideError _) = Just "ModeOverrideError" -toKey (CannotConsumeError _) = Just "CannotConsumeError" -toKey (CannotConsumeTypeError _) = Just "CannotConsumeTypeError" -toKey (ImmutableConsumeError _) = Just "ImmutableConsumeError" -toKey (CannotGiveReadModeError _) = Just "CannotGiveReadModeError" -toKey (CannotGiveSharableModeError _) = Just "CannotGiveSharableModeError" -toKey (NonValInReadContextError _) = Just "NonValInReadContextError" -toKey (NonSafeInReadContextError _ _) = Just "NonSafeInReadContextError" -toKey (NonSafeInExtendedReadTraitError _ _ _) = Just "NonSafeInExtendedReadTraitError" -toKey (ProvidingToReadTraitError _ _ _) = Just "ProvidingToReadTraitError" -toKey (SubordinateReturnError _ _) = Just "SubordinateReturnError" -toKey (SubordinateArgumentError _) = Just "SubordinateArgumentError" -toKey (SubordinateFieldError _) = Just "SubordinateFieldError" -toKey (ThreadLocalFieldError _) = Just "ThreadLocalFieldError" -toKey (ThreadLocalFieldExtensionError _ _) = Just "ThreadLocalFieldExtensionError" -toKey (ThreadLocalArgumentError _) = Just "ThreadLocalArgumentError" -toKey (PolymorphicArgumentSendError _ _) = Just "PolymorphicArgumentSendError" -toKey (PolymorphicReturnError _ _) = Just "PolymorphicReturnError" -toKey (ThreadLocalReturnError _ _) = Just "ThreadLocalReturnError" -toKey (MalformedConjunctionError _ _ _) = Just "MalformedConjunctionError" -toKey (CannotUnpackError _) = Just "CannotUnpackError" -toKey (CannotInferUnpackingError _) = Just "CannotInferUnpackingError" -toKey (UnsplittableTypeError _) = Just "UnsplittableTypeError" -toKey (DuplicatingSplitError _) = Just "DuplicatingSplitError" -toKey (StackboundArrayTypeError _) = Just "StackboundArrayTypeError" -toKey (ManifestConflictError _ _) = Just "ManifestConflictError" -toKey (ManifestClassConflictError _ _) = Just "ManifestClassConflictError" -toKey (UnmodedMethodExtensionError _ _) = Just "UnmodedMethodExtensionError" -toKey (ActiveTraitError _ _) = Just "ActiveTraitError" ---toKey (NewWithModeError) = Just "NewWithModeError" ---toKey (UnsafeTypeArgumentError _ _) = Just "UnsafeTypeArgumentError" ---toKey (OverlapWithBuiltins) = Just "OverlapWithBuiltins" ---toKey (SimpleError _) = Just "SimpleError" ---toKey (ReverseBorrowingError) = Just "ReverseBorrowingError" ---toKey (BorrowedFieldError _) = Just "BorrowedFieldError" ---toKey (LinearClosureError _ _) = Just "LinearClosureError" ---toKey (BorrowedLeakError _) = Just "BorrowedLeakError" ---toKey (NonBorrowableError _) = Just "NonBorrowableError" ---toKey (ActiveBorrowError _ _) = Just "ActiveBorrowError" ---toKey (ActiveBorrowSendError _ _) = Just "ActiveBorrowSendError" ---toKey (DuplicateBorrowError _) = Just "DuplicateBorrowError" ---toKey (StackboundednessMismatchError _ _) = Just "StackboundednessMismatchError" ---toKey (LinearCaptureError _ _) = Just "LinearCaptureError" +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 \ No newline at end of file From ddad6e8ce459825352a32b946428ef0525c8e091 Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Mon, 26 Nov 2018 13:35:17 +0100 Subject: [PATCH 28/31] Added graphical tests suite --- src/tests/encore/ui/errorHash.enc | 12 ++++++++++++ src/tests/encore/ui/errorHash.fail | 1 + src/tests/encore/ui/errorNoHash.enc | 17 +++++++++++++++++ src/tests/encore/ui/errorNoHash.fail | 1 + src/tests/encore/ui/multifullscopeError.enc | 12 ++++++++++++ src/tests/encore/ui/multifullscopeError.fail | 4 ++++ src/tests/encore/ui/multipartialscopeError.enc | 17 +++++++++++++++++ src/tests/encore/ui/multipartialscopeError.fail | 4 ++++ src/tests/encore/ui/showPosition.enc | 6 ++++++ src/tests/encore/ui/showPosition.fail | 1 + src/tests/encore/ui/singleLineError.enc | 6 ++++++ src/tests/encore/ui/singleLineError.fail | 2 ++ src/tests/encore/ui/warning.enc | 9 +++++++++ src/tests/encore/ui/warning.fail | 3 +++ 14 files changed, 95 insertions(+) create mode 100644 src/tests/encore/ui/errorHash.enc create mode 100644 src/tests/encore/ui/errorHash.fail create mode 100644 src/tests/encore/ui/errorNoHash.enc create mode 100644 src/tests/encore/ui/errorNoHash.fail create mode 100644 src/tests/encore/ui/multifullscopeError.enc create mode 100644 src/tests/encore/ui/multifullscopeError.fail create mode 100644 src/tests/encore/ui/multipartialscopeError.enc create mode 100644 src/tests/encore/ui/multipartialscopeError.fail create mode 100644 src/tests/encore/ui/showPosition.enc create mode 100644 src/tests/encore/ui/showPosition.fail create mode 100644 src/tests/encore/ui/singleLineError.enc create mode 100644 src/tests/encore/ui/singleLineError.fail create mode 100644 src/tests/encore/ui/warning.enc create mode 100644 src/tests/encore/ui/warning.fail 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 + | ^^^^^^^^^^ From 475b8956d3b9037cc1790f60ac16593bb33f78dd Mon Sep 17 00:00:00 2001 From: Thizizmyname Date: Sat, 16 Mar 2019 21:32:07 +0100 Subject: [PATCH 29/31] Moved auxiliary info to long suggest --- src/types/Typechecker/Suggestable.hs | 7 +++++++ src/types/Typechecker/TypeError.hs | 8 +++----- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/types/Typechecker/Suggestable.hs b/src/types/Typechecker/Suggestable.hs index 12a887ae9..cad8efb78 100644 --- a/src/types/Typechecker/Suggestable.hs +++ b/src/types/Typechecker/Suggestable.hs @@ -64,6 +64,13 @@ instance Suggestable TCError where 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 diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index 2c0fee1b4..241fbf41d 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -471,11 +471,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 = From 6f9b25bdcea852860603bb51399a38ffcccb3cbd Mon Sep 17 00:00:00 2001 From: Alexis Date: Wed, 27 Mar 2019 20:11:49 +0100 Subject: [PATCH 30/31] Update from feedback --- src/front/TopLevel.hs | 8 ++-- src/types/Typechecker/Errorprinter.hs | 64 +++++---------------------- src/types/Typechecker/ExplainTable.hs | 15 ++++--- src/types/Typechecker/Suggestable.hs | 18 +++----- src/types/Typechecker/Typechecker.hs | 1 - 5 files changed, 33 insertions(+), 73 deletions(-) diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index 208a904c4..c599fb930 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -14,9 +14,8 @@ import System.Directory import System.IO import System.Exit import System.Process -import System.Posix.Process -import qualified Data.ByteString.Lazy as B -import System.Pager +import qualified Data.ByteString.Lazy as B (readFile) +import System.Pager (sendToPager) import System.Posix.Directory import Data.List import Data.List.Utils(split) @@ -421,7 +420,6 @@ main = verbose options str = when (Verbose `elem` options) (putStrLn str) - showWarnings = mapM printWarning . reverse helpMessage = "Welcome to the Encore compiler!\n" <> @@ -448,6 +446,8 @@ main = printError e abort $ "Aborting due to previous error" + showWarnings = mapM printWarning . reverse + isExplain (Explain _) = True isExplain _ = False diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs index 96c30bf59..f1a6de952 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -87,7 +87,7 @@ prettyError tcErr@(TCError err@(UnknownRefTypeError ty) _) _ prettyError (TCError err Env{bt = []}) _ = declareError err <+> description err prettyError tcErr@(TCError err _) code = - declareError err <+> description err $+$ codeViewer_ver1 tcErr code + declareError err <+> description err $+$ codeViewer tcErr code -- Possible extensions: -- Duplicate Class -> print positions (File + line) of the two classes -- Type error in func call -> print a version of codeViewer that also shows the function head @@ -97,28 +97,23 @@ prettyWarning :: TCWarning -> [String] -> Doc TCStyle prettyWarning (TCWarning w Env{bt = []}) _ = declareWarning w <+> description w prettyWarning tcWarn@(TCWarning w _) code = - declareWarning w <+> description w $+$ codeViewer_ver1 tcWarn code + declareWarning w <+> description w $+$ codeViewer tcWarn code pipe = char '|' declareError :: Error -> Doc TCStyle -declareError err = - let - hash = case lookupHash err of - Nothing -> empty - Just num -> text $ printf "[E%04d]" num - in - styleClassify $ text "Error" <> hash <> char ':' - +declareError = styleDeclaration "[E%04d]" "Error" . explain declareWarning :: Warning -> Doc TCStyle -declareWarning w = +declareWarning = styleDeclaration "[W%04d]" "Warning" . explain + +styleDeclaration format msg explanation = let - hash = case lookupHashW w of + hash = case explanation of Nothing -> empty - Just num -> text $ printf "[W%04d]" num + Just num -> text $ printf format num in - styleClassify $ text "Warning" <> hash <> char ':' + styleClassify $ text msg <> hash <> char ':' description :: Show a => a -> Doc TCStyle description ty = styleDesc $ text $ show ty @@ -127,9 +122,9 @@ description ty = styleDesc $ text $ show ty showPosition :: Position -> Doc TCStyle showPosition pos = styleLogistic (text "-->") <+> (text $ show $ pos) -codeViewer_ver1 :: (TCType a, Suggestable a) => a -> [String] -> Doc TCStyle -codeViewer_ver1 _ [] = error "TypeError.hs: No code to view" -codeViewer_ver1 err (cHead:cTail) = +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 @@ -171,41 +166,6 @@ codeViewer_ver1 err (cHead:cTail) = -codeViewer_ver2 :: (TCType a, Suggestable a) => a -> [String] -> Doc TCStyle -codeViewer_ver2 _ [] = error "TypeError.hs: No code to view" -codeViewer_ver2 err (cHead:cTail) = - let - 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 (range (sL+1, eL)) - in - if sL == eL - then - nest (digitLen) $ showPosition pos $+$ - styleLogistic pipe $+$ - codeLine "" cHead sL $+$ - styleLogistic pipe <> - styleHighlight (lineHighlighter sC eC '^') <+> - styleHighlight (smallSuggest err) $+$ - longSuggest err - else - nest (digitLen) $ showPosition pos $+$ - styleLogistic pipe $+$ - codeLine " " cHead sL $+$ - styleLogistic pipe <> - styleHighlight (multilineHighlighter sC FirstLine '^') $+$ - vcat tailCode $+$ - styleLogistic pipe <> - styleHighlight (multilineHighlighter eC LastLine '^') <+> - styleHighlight (smallSuggest err) $+$ - longSuggest err - - --- Remove if version 2 is not to be used -lineHighlighter :: Int -> Int -> Char -> Doc ann -lineHighlighter s e c = text $ replicate (s-1) ' ' ++ replicate (e-s) c - -- Remove if version 1 is not to be used singleLineHighlighter :: Int -> Int -> Char -> Doc ann singleLineHighlighter s e c = space <+> text (replicate (s-1) ' ' ++ replicate (e-s) c) diff --git a/src/types/Typechecker/ExplainTable.hs b/src/types/Typechecker/ExplainTable.hs index 6bf58cb55..004209237 100644 --- a/src/types/Typechecker/ExplainTable.hs +++ b/src/types/Typechecker/ExplainTable.hs @@ -1,15 +1,20 @@ {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -module Typechecker.ExplainTable (lookupHash, lookupHashW) where +module Typechecker.ExplainTable (explain) where import Typechecker.TypeError (Error(..), Warning(..)) -lookupHash :: Error -> Maybe Int -lookupHash err = toKey err +class Explanainable a where + explain :: a -> Maybe Int + +instance Explanainable Error where + explain err = toKey err + +instance Explanainable Warning where + explain warn = toKeyW warn + -lookupHashW :: Warning -> Maybe Int -lookupHashW w = toKeyW w diff --git a/src/types/Typechecker/Suggestable.hs b/src/types/Typechecker/Suggestable.hs index cad8efb78..a7dbe0ac8 100644 --- a/src/types/Typechecker/Suggestable.hs +++ b/src/types/Typechecker/Suggestable.hs @@ -45,18 +45,14 @@ instance Suggestable TCError where | isMethodNameAFunction name ty env = text $ printf "Did you mean function `%s`?" (show name) smallSuggest _ = empty + + longSuggest (TCError (TypeMismatchError actual expected) _) = - let - expect = text "expected type" <+> styleDesc (text $ show expected) - found = text " found type" <+> styleDesc (text $ show actual) - in - makeNotation <+> vcat [expect, found] - longSuggest (TCError (TypeWithCapabilityMismatchError actual cap expected) _) = - let - expect = text "expected type" <+> styleDesc (text $ show expected) - found = text " found type" <+> styleDesc (text $ show actual) - in - makeNotation <+> vcat [expect, found] + 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 diff --git a/src/types/Typechecker/Typechecker.hs b/src/types/Typechecker/Typechecker.hs index 523921e5e..1033f5018 100644 --- a/src/types/Typechecker/Typechecker.hs +++ b/src/types/Typechecker/Typechecker.hs @@ -35,7 +35,6 @@ 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 -> From 53ef4a6910ed5829a4ac988d4ff819542dc6cc1b Mon Sep 17 00:00:00 2001 From: Alexis Date: Wed, 29 Jan 2020 21:12:00 +0100 Subject: [PATCH 31/31] feedback resolved and workarounds to solve stupidity --- modules/explanations/E0014.txt | 17 ++++++++ modules/explanations/E0073.txt | 14 +++--- src/front/TopLevel.hs | 5 --- src/ir/AST/PrettyPrinter.hs | 3 ++ src/types/Typechecker/Environment.hs | 8 ++-- src/types/Typechecker/Errorprinter.hs | 62 ++++++++++++++++----------- src/types/Typechecker/Suggestable.hs | 4 +- 7 files changed, 70 insertions(+), 43 deletions(-) diff --git a/modules/explanations/E0014.txt b/modules/explanations/E0014.txt index ef8073268..a7b17dad7 100644 --- a/modules/explanations/E0014.txt +++ b/modules/explanations/E0014.txt @@ -1,2 +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 index 585e456dc..ae53ec861 100644 --- a/modules/explanations/E0073.txt +++ b/modules/explanations/E0073.txt @@ -7,11 +7,11 @@ variable. For example: ``` -let x: i32 = \"I am not a number!\"; -// ~~~ ~~~~~~~~~~~~~~~~~~~~ -// | | -// | initializing expression; -// | compiler infers type `&str` -// | -// type `i32` assigned to variable `x` +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 c599fb930..6fbf075b4 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -27,7 +27,6 @@ import qualified Data.Map.Strict as Map import SystemUtils import Language.Haskell.TH -- for Template Haskell hackery import Text.Printf -import System.Console.ANSI import qualified Text.PrettyPrint.Annotated as Pretty import qualified Text.PrettyPrint.Boxes as Box import System.FilePath (splitPath, joinPath) @@ -463,10 +462,6 @@ main = B.readFile fnom >>= sendToPager exitSuccess - where - resetScreen :: IO () - resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0 - isExplanationHash :: String -> IO Bool isExplanationHash str@('E':_:_:_:_:[]) = doesFileExist $ standardLibLocation ++ "/explanations/" ++ str ++ ".txt" isExplanationHash _ = return False diff --git a/src/ir/AST/PrettyPrinter.hs b/src/ir/AST/PrettyPrinter.hs index 0908cac54..ed1e3db7c 100644 --- a/src/ir/AST/PrettyPrinter.hs +++ b/src/ir/AST/PrettyPrinter.hs @@ -16,6 +16,7 @@ module AST.PrettyPrinter (ppExpr ,indent ,ppSugared ,ppFunctionHeader + ,pipe ) where -- Library dependencies @@ -28,6 +29,8 @@ import AST.AST indent = nest 2 +pipe = char '|' + commaSep l = hcat $ punctuate ", " l brackets s = hcat ["[", s, "]"] diff --git a/src/types/Typechecker/Environment.hs b/src/types/Typechecker/Environment.hs index 29faf38a8..9375b8108 100644 --- a/src/types/Typechecker/Environment.hs +++ b/src/types/Typechecker/Environment.hs @@ -512,12 +512,12 @@ varLookup qname@QName{qnspace, qnlocal = x} visibleFunctions :: Environment -> [(Name, Type)] visibleFunctions Env{locals, lookupTables} = let - fTable = extractTables filterFunctionTable lookupTables - -- Ability to filter lobal functions included by default - --selfMadeFunc = filter (not . (`elem` ["Std", "String"]) . show . fst) fTable + 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) fTable + localFunc ++ concatMap (Map.assocs . snd) exposedTable where filterFunctionTable LookupTable{functionTable diff --git a/src/types/Typechecker/Errorprinter.hs b/src/types/Typechecker/Errorprinter.hs index f1a6de952..274129423 100644 --- a/src/types/Typechecker/Errorprinter.hs +++ b/src/types/Typechecker/Errorprinter.hs @@ -9,6 +9,8 @@ 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) @@ -88,9 +90,6 @@ prettyError (TCError err Env{bt = []}) _ = declareError err <+> description err prettyError tcErr@(TCError err _) code = declareError err <+> description err $+$ codeViewer tcErr code --- Possible extensions: --- Duplicate Class -> print positions (File + line) of the two classes --- Type error in func call -> print a version of codeViewer that also shows the function head prettyWarning :: TCWarning -> [String] -> Doc TCStyle -- Default warnings @@ -99,21 +98,18 @@ prettyWarning (TCWarning w Env{bt = []}) _ = prettyWarning tcWarn@(TCWarning w _) code = declareWarning w <+> description w $+$ codeViewer tcWarn code -pipe = char '|' - declareError :: Error -> Doc TCStyle -declareError = styleDeclaration "[E%04d]" "Error" . explain +declareError = formatDeclaration "[E%04d]" "Error" . explain declareWarning :: Warning -> Doc TCStyle -declareWarning = styleDeclaration "[W%04d]" "Warning" . explain +declareWarning = formatDeclaration "[W%04d]" "Warning" . explain -styleDeclaration format msg explanation = - let - hash = case explanation of - Nothing -> empty +-- 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 - in - styleClassify $ text msg <> hash <> char ':' description :: Show a => a -> Doc TCStyle description ty = styleDesc $ text $ show ty @@ -135,8 +131,11 @@ codeViewer err (cHead:cTail) = 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 + 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 @@ -144,7 +143,8 @@ codeViewer err (cHead:cTail) = codeLine " " cHead sL $+$ styleLogistic pipe <> styleHighlight (singleLineHighlighter sC eC '^') <+> tail - | errorIsWholeLine cHead sC = codeLine " /" cHead sL $+$ tail + | secondLineMergable = + codeLine " " cHead sL $+$ tail | otherwise = codeLine " " cHead sL $+$ styleLogistic pipe <> @@ -153,20 +153,21 @@ codeViewer err (cHead:cTail) = 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 '^') - errorIsWholeLine _ 0 = True - errorIsWholeLine _ 1 = True - errorIsWholeLine (x:xs) n - | x == ' ' = errorIsWholeLine xs (n-1) - | otherwise = False - - +emptyBeforePosition _ 0 = True +emptyBeforePosition (x:xs) n + | x == ' ' = emptyBeforePosition xs (n-1) + | otherwise = False --- Remove if version 1 is not to be used singleLineHighlighter :: Int -> Int -> Char -> Doc ann singleLineHighlighter s e c = space <+> text (replicate (s-1) ' ' ++ replicate (e-s) c) @@ -185,6 +186,16 @@ codeLine insertStr code lineNo = 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 @@ -193,7 +204,10 @@ getCodeLines pos = do contents <- readFile $ getPositionFile pos case take end $ drop start $ lines contents of [] -> error "\nFile has been edited between parsing and type checking" - l -> return l + 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 = diff --git a/src/types/Typechecker/Suggestable.hs b/src/types/Typechecker/Suggestable.hs index a7dbe0ac8..b18556d18 100644 --- a/src/types/Typechecker/Suggestable.hs +++ b/src/types/Typechecker/Suggestable.hs @@ -4,6 +4,7 @@ module Typechecker.Suggestable ( Suggestable ,smallSuggest ,longSuggest + ,pipe -- from AST.PrettyPrinter )where -- Library dependencies @@ -21,9 +22,6 @@ import Identifiers import Types -pipe = char '|' - - makeNotation :: Doc TCStyle makeNotation = styleLogistic (pipe $+$ equals) <+> styleDesc (text "note:")