diff --git a/src/ir/AST/PrettyPrinter.hs b/src/ir/AST/PrettyPrinter.hs index 184b680bd..8dcf0c135 100644 --- a/src/ir/AST/PrettyPrinter.hs +++ b/src/ir/AST/PrettyPrinter.hs @@ -49,7 +49,7 @@ ppProgram Program{bundle, etl, imports, typedefs, functions, classes} = vcat (map ppClassDecl classes) $+$ "" -- new line at end of file -ppEmbedded EmbedTL{etlheader=header, etlbody=code} = +ppEmbedded EmbedTL{etlheader=header, etlbody=code} = ppHeader header code ppHeader header code = @@ -198,7 +198,7 @@ ppExpr FutureChain {future, chain} = ppExpr future <+> "~~>" <+> ppExpr chain ppExpr Get {val} = "get" <+> ppExpr val ppExpr Yield {val} = "yield" <+> ppExpr val -ppExpr Eos {} = "eos" <> parens empty +ppExpr Eos {} = "eos" ppExpr Await {val} = "await" <+> ppExpr val ppExpr IsEos {target} = ppExpr target <> "." <> "eos" <> parens empty ppExpr StreamNext {target} = ppExpr target <> "." <> "next" <> parens empty diff --git a/src/types/Typechecker/Environment.hs b/src/types/Typechecker/Environment.hs index 184b66ba9..e89580c60 100644 --- a/src/types/Typechecker/Environment.hs +++ b/src/types/Typechecker/Environment.hs @@ -112,7 +112,7 @@ mergeEnvs Env{classTable = classTable, bt = bt'} = Env{classTable = Map.union classTable classTable', traitTable = Map.union traitTable traitTable', - typeSynonymTable = Map.union typeSynonymTable typeSynonymTable', + typeSynonymTable = Map.union typeSynonymTable typeSynonymTable', globals = globs ++ globs', locals = locals ++ locals', bindings = binds ++ binds', @@ -199,7 +199,7 @@ methodLookup ty m env ms = map (\t -> traitMethodLookup t m env) traits ret <- find isJust ms return $ fromJust ret - | otherwise = error "methodLookup in non-ref type" + | otherwise = Nothing capabilityLookup :: Type -> Environment -> Maybe Type capabilityLookup ty env diff --git a/src/types/Typechecker/Prechecker.hs b/src/types/Typechecker/Prechecker.hs index 1c518e591..90ef4a500 100644 --- a/src/types/Typechecker/Prechecker.hs +++ b/src/types/Typechecker/Prechecker.hs @@ -153,13 +153,13 @@ instance Precheckable MethodDecl where (checkMainParams $ hparams mheader') when (isStreamMethod m) $ do unless (isActiveClassType thisType) $ - tcError "Cannot have streaming methods in a passive class" + tcError PassiveStreamingMethodError when (isConstructor m) $ - tcError "Constructor cannot be streaming" + tcError StreamingConstructorError let mtype = htype mheader' return $ setType mtype m{mheader = mheader'} where checkMainParams params = unless (map ptype params `elem` allowedMainArguments) $ - tcError "Main method must have argument type () or ([String])" + tcError MainMethodArgumentsError allowedMainArguments = [[], [arrayType stringObjectType]] diff --git a/src/types/Typechecker/TypeError.hs b/src/types/Typechecker/TypeError.hs index d7c374608..8f4803d81 100644 --- a/src/types/Typechecker/TypeError.hs +++ b/src/types/Typechecker/TypeError.hs @@ -9,6 +9,7 @@ module Typechecker.TypeError (Backtrace ,emptyBT ,Pushable(push) ,TCError(TCError) + ,Error(..) ,TCWarning(TCWarning) ,Warning(..) ,currentMethodFromBacktrace) where @@ -17,6 +18,7 @@ import Text.PrettyPrint import Text.Parsec(SourcePos) import Data.Maybe import Data.List +import Text.Printf (printf) import Identifiers import Types @@ -60,7 +62,7 @@ instance Show BacktraceNode where | otherwise = let str = show $ nest 2 $ ppSugared expr in "In expression: \n" ++ str - show (BTTypedef tl) = + show (BTTypedef tl) = concat ["In typedef '", show tl, "'"] type Backtrace = [(SourcePos, BacktraceNode)] @@ -110,24 +112,273 @@ instance Pushable Expr where instance Pushable Typedef where push t@(Typedef {typedefdef}) = pushMeta t (BTTypedef typedefdef) +refTypeName :: Type -> String +refTypeName ty + | isClassType ty = "class '" ++ getId ty ++ "'" + | isTraitType ty = "trait '" ++ getId ty ++ "'" + | isCapabilityType ty = "capability '" ++ show ty ++ "'" + | otherwise = error $ "Util.hs: No refTypeName for " ++ + Types.showWithKind ty + -- | The data type for a type checking error. Showing it will -- produce an error message and print the backtrace. -newtype TCError = TCError (String, Backtrace) +data TCError = TCError Error Backtrace instance Show TCError where - show (TCError (msg, [])) = + show (TCError err []) = " *** Error during typechecking *** \n" ++ - msg ++ "\n" - show (TCError (msg, bt@((pos, _):_))) = + show err ++ "\n" + show (TCError err bt@((pos, _):_)) = " *** Error during typechecking *** \n" ++ show pos ++ "\n" ++ - msg ++ "\n" ++ + show err ++ "\n" ++ concatMap showBT bt where - showBT (pos, node) = + showBT (_, node) = case show node of "" -> "" s -> s ++ "\n" +data Error = + DistinctTypeParametersError Type + | WrongNumberOfMethodArgumentsError Name Type Int Int + | WrongNumberOfFunctionArgumentsError Name Int Int + | WrongNumberOfTypeParametersError Type Int Type Int + | MissingFieldRequirementError FieldDecl Type + | CovarianceViolationError FieldDecl Type Type + | RequiredFieldMismatchError FieldDecl Type Type Bool + | NonDisjointConjunctionError Type Type FieldDecl + | OverriddenMethodError Name Type + | IncludedMethodConflictError Name Type Type + | MissingMethodRequirementError FunctionHeader Type + | UnknownTraitError Type + | UnknownRefTypeError Type + | MalformedCapabilityError Type + | RecursiveTypesynonymError Type + | DuplicateThingError String String + | PassiveStreamingMethodError + | StreamingConstructorError + | MainMethodArgumentsError + | FieldNotFoundError Name Type + | MethodNotFoundError Name Type + | TraitsInActiveClassError + | NonCallableTargetError Type + | NonSendableTargetError Type + | MainMethodCallError + | ConstructorCallError + | ExpectingOtherTypeError String Type + | NonStreamingContextError Expr + | UnboundFunctionError Name + | NonFunctionTypeError Type + | BottomTypeInferenceError + | IfInferenceError + | IfBranchMismatchError Type Type + | EmptyMatchClauseError + | ActiveMatchError + | MatchInferenceError + | ThisReassignmentError + | PatternTypeMismatchError Expr Type + | NonMaybeExtractorPatternError Expr + | InvalidPatternError Expr + | CannotReadFieldError Expr + | NonAssignableLHSError + | ValFieldAssignmentError Name Type + | UnboundVariableError Name + | ObjectCreationError Type + | NonIterableError Type + | EmptyArrayLiteralError + | NonIndexableError Type + | NonSizeableError Type + | FormatStringLiteralError + | UnprintableExpressionError Type + | WrongNumberOfPrintArgumentsError Int Int + | UnaryOperandMismatchError UnaryOp Type + | BinaryOperandMismatchError BinaryOp String Type Type + | UndefinedBinaryOperatorError BinaryOp + | NullTypeInferenceError + | CannotBeNullError Type + | TypeMismatchError Type Type + | TypeWithCapabilityMismatchError Type Type Type + | TypeVariableAmbiguityError Type Type Type + | FreeTypeVariableError Type + | SimpleError String + +arguments 1 = "argument" +arguments _ = "arguments" + +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 == Name "_init" + 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 (WrongNumberOfTypeParametersError ty1 n1 ty2 n2) = + printf "'%s' expects %d type %s, but '%s' has %d" + (show ty1) n1 (arguments n1) (show 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 (OverriddenMethodError name trait) = + printf "Method '%s' is defined both in current class and %s" + (show name) (refTypeName trait) + 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 (UnknownRefTypeError ty) = + printf "Couldn't find class, trait or typedef '%s'" (show ty) + show (MalformedCapabilityError ty) = + printf "Cannot form capability with %s" (Types.showWithKind ty) + 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 (FieldNotFoundError name ty) = + printf "No field '%s' in %s" + (show name) (refTypeName ty) + show (MethodNotFoundError name ty) = + let nameWithKind = if name == Name "_init" + then "constructor" + else "method '" ++ show name ++ "'" + targetType = if isRefType ty + then refTypeName ty + else Types.showWithKind ty + in printf "No %s in %s" + nameWithKind targetType + show (TraitsInActiveClassError) = + "Traits can only be used for passive classes" + 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 = "Cannot infer type of 'Nothing'" + 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 (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 (CannotReadFieldError target) = + printf "Cannot read field of expression '%s' of %s" + (show $ ppSugared target) (Types.showWithKind $ getType target) + show NonAssignableLHSError = + "Left-hand side cannot be assigned to" + 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 (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) = + 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'" + (show actual) (show cap) (show expected) + show (TypeVariableAmbiguityError expected ty1 ty2) = + printf "Type variable '%s' cannot be bound to both '%s' and '%s'" + (show expected) (show ty1) (show ty2) + show (FreeTypeVariableError ty) = + printf "Type variable '%s' is unbound" (show ty) + show (SimpleError msg) = msg + + data TCWarning = TCWarning Backtrace Warning instance Show TCWarning where show (TCWarning [] w) = diff --git a/src/types/Typechecker/Typechecker.hs b/src/types/Typechecker/Typechecker.hs index ce7875119..e93731996 100644 --- a/src/types/Typechecker/Typechecker.hs +++ b/src/types/Typechecker/Typechecker.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + {-| Typechecks an "AST.AST" and produces the same tree, extended with @@ -80,8 +82,8 @@ instance Checkable Program where instance Checkable Typedef where doTypecheck t@Typedef{typedefdef} = do let (refId, parameters) = typeSynonymLHS typedefdef - unless (distinctParams parameters) $ tcError $ - "Parameters of type synonyms '" ++ show t ++ "' must be distinct." + unless (distinctParams parameters) $ + tcError $ DistinctTypeParametersError typedefdef let rhs = typeSynonymRHS typedefdef let addTypeParams = addTypeParameters $ getTypeParameters typedefdef rhs' <- local addTypeParams $ resolveType rhs @@ -122,15 +124,11 @@ instance Checkable TraitDecl where matchArgumentLength :: Type -> FunctionHeader -> Arguments -> TypecheckM () matchArgumentLength targetType header args = unless (actual == expected) $ - tcError $ - concat [toStr (hname header), " in ", show targetType, " expects ", - show expected, " arguments. Got ", show actual] + tcError $ WrongNumberOfMethodArgumentsError + (hname header) targetType expected actual where actual = length args - expected = length sigTypes - sigTypes = map ptype (hparams header) - toStr (Name "_init") = "Constructor" - toStr n = concat ["Method '", show n, "'"] + expected = length (hparams header) meetRequiredFields :: [FieldDecl] -> Type -> TypecheckM () meetRequiredFields cFields trait = do @@ -144,26 +142,14 @@ meetRequiredFields cFields trait = do cField = fromJust result cFieldType = ftype cField if isNothing result then - tcError $ - "Cannot find field '" ++ show expField ++ - "' required by included " ++ classOrTraitName trait + tcError $ MissingFieldRequirementError expField trait else if isValField expField then unlessM (cFieldType `subtypeOf` expected) $ - tcError $ - "Field '" ++ show cField ++ "' must have a subtype of '" ++ - show expected ++ "' to meet the requirements of " ++ - "included " ++ classOrTraitName trait + tcError $ CovarianceViolationError cField expected trait else do isSub <- cFieldType `subtypeOf` expected unless (cFieldType == expected) $ - tcError $ - "Field '" ++ show cField ++ "' must exactly match type '" ++ - show expected ++ "' to meet the requirements of " ++ - "included " ++ classOrTraitName trait ++ - if isSub - then ". Consider turning '" ++ show (fname expField) ++ - "' into a val-field in " ++ classOrTraitName trait - else "" + tcError $ RequiredFieldMismatchError cField expected trait isSub noOverlapFields :: Type -> TypecheckM () noOverlapFields capability = @@ -201,9 +187,7 @@ noOverlapFields capability = conjunctiveVarErr :: (Type, Type, FieldDecl) -> TypecheckM () conjunctiveVarErr (left, right, field) = - tcError $ printf - "Conjunctive traits '%s' and '%s' cannot share mutable field '%s'" - (show left) (show right) (show field) + tcError $ NonDisjointConjunctionError left right field notVal :: FieldDecl -> Bool notVal = not . isValField @@ -223,15 +207,14 @@ ensureNoMethodConflict methods tdecls = in unless (null diff) $ if dup `elem` methods then - tcError $ "Method '" ++ show (methodName dup) ++ - "' is defined both in current class and " ++ - classOrTraitName (tname $ head overlappingTraits) + tcError $ OverriddenMethodError + (methodName dup) + (tname $ head overlappingTraits) else - tcError $ "Conflicting inclusion of method '" ++ - show (methodName dup) ++ "' from " ++ - classOrTraitName (tname (head overlappingTraits)) ++ - " and " ++ - classOrTraitName (tname (overlappingTraits !! 1)) + tcError $ IncludedMethodConflictError + (methodName dup) + (tname (head overlappingTraits)) + (tname (overlappingTraits !! 1)) meetRequiredMethods :: [MethodDecl] -> Type -> TypecheckM () meetRequiredMethods cMethods trait = do @@ -241,9 +224,7 @@ meetRequiredMethods cMethods trait = do matchMethod reqHeader = do expHeader <- findMethod trait (hname reqHeader) unlessM (anyM (matchesHeader expHeader) cMethods) $ - tcError $ - "Cannot find method '" ++ show (ppFunctionHeader expHeader) ++ - "' required by included " ++ classOrTraitName trait + tcError $ MissingMethodRequirementError expHeader trait matchesHeader header mdecl = let mName = methodName mdecl @@ -264,7 +245,7 @@ instance Checkable ClassDecl where doTypecheck c@(Class {cname, cfields, cmethods, ccapability}) = do let traits = typesFromCapability ccapability unless (isPassiveClassType cname || null traits) $ - tcError "Traits can only be used for passive classes" + tcError TraitsInActiveClassError mapM_ (meetRequiredFields cfields) traits mapM_ (meetRequiredMethods cmethods) traits noOverlapFields ccapability @@ -335,8 +316,8 @@ instance Checkable Expr where doTypecheck l@(Liftf {val}) = do e <- typecheck val let typ = AST.getType e - unless (isFutureType typ) $ tcError $ "expression '" ++ show (ppSugared e) ++ - "' of type '" ++ show typ ++ "' should be of type 'Future'" + unless (isFutureType typ) $ + pushError e $ ExpectingOtherTypeError "a future" typ return $ setType (parType $ getResultType typ) l {val = e} doTypecheck l@(Liftv {val}) = do @@ -347,87 +328,58 @@ instance Checkable Expr where doTypecheck p@(PartyJoin {val}) = do e <- typecheck val let typ = AST.getType e - unless (isParType typ) $ tcError (errorMsg (ppSugared val) typ typ) - unless ((isParType . getResultType) typ) $ - tcError (errorMsg (ppSugared val) (getResultType typ) typ) + unless (isParType typ && isParType (getResultType typ)) $ + pushError e $ ExpectingOtherTypeError "a nested Par" typ return $ setType (getResultType typ) p {val = e} - where - errorMsg expr expectedType foundType = - "Error: expression '" ++ show expr ++ "' as argument in " ++ - "'join' combinator was expecting type 'Par Par " ++ - show expectedType ++ "' but found type '" ++ show foundType ++ "' instead." doTypecheck p@(PartyEach {val}) = do e <- typecheck val let typ = AST.getType e unless (isArrayType typ) $ - tcError $ "Parallel combinator 'each' was expecting an array type " ++ - "from expression '" ++ show (ppExpr e) ++ "' but found " ++ - "type '" ++ show typ ++ "'" + pushError e $ ExpectingOtherTypeError "an array" typ return $ setType ((parType.getResultType) typ) p {val = e} doTypecheck p@(PartyExtract {val}) = do e <- typecheck val let typ = AST.getType e unless (isParType typ) $ - tcError $ "Parallel combinator `extract` was expecting type 'Par' type" ++ - " from expression '" ++ show (ppSugared e) ++ - "' but found type '" ++ show typ + pushError e $ ExpectingOtherTypeError "a Par" typ return $ setType ((arrayType.getResultType) typ) p {val = e} doTypecheck p@(PartyPar {parl, parr}) = do pl <- typecheck parl pr <- hasType parr (AST.getType pl) + let lType = AST.getType pl + rType = AST.getType pr - unless ((isParType . AST.getType) pl) $ - tcError $ "using parallel combinator '||' with non-parallel expression '" - ++ show (ppSugared pl) ++ "'" - unless ((isParType . AST.getType) pr) $ - tcError $ "using parallel combinator '||' with non-parallel expression '" - ++ show (ppSugared pr) ++ "'" - let [plType, prType] = map AST.getType [pl, pr] + unless (isParType lType) $ + pushError pl $ TypeMismatchError lType (parType lType) + unless (isParType rType) $ + pushError pr $ TypeMismatchError rType (parType rType) - sameTypes <- plType `subtypeOf` prType - unless sameTypes $ - tcError $ "at least one of the parallel collections ('" ++ show (ppSugared pl) - ++ "' or '"++ show (ppSugared pr) ++"') is of a non-parallel type" - return $ setType (AST.getType pl) p {parl = pl, parr = pr} + lIsSubtype <- lType `subtypeOf` rType + rIsSubtype <- rType `subtypeOf` lType + if lIsSubtype + then return $ setType rType p {parl = pl, parr = pr} + else return $ setType lType p {parl = pl, parr = pr} doTypecheck s@(PartySeq {par, seqfunc}) = do ePar <- typecheck par eSeqFunc <- typecheck seqfunc + let seqType = AST.getType eSeqFunc + pType = AST.getType ePar unless (isCallable eSeqFunc) $ - tcError $ "Parallel combinator '>>' expected a callable expresion but found '" ++ - show (ppSugared eSeqFunc) ++ "' of type '" ++ - show (AST.getType eSeqFunc) ++ "'instead." - - unless (leftIsPar ePar) $ - tcError $ "Parallel combinator '>>' expected a parallel expression but found " ++ - "expression '" ++show (ppSugared ePar) ++ "' of type '" ++ - show (AST.getType ePar) ++ "'" - - let nargs = numberArgsFun eSeqFunc - unless (nargs == 1) $ - tcError $ "Parallel combinator '"++ show (ppSugared ePar) ++ - "' expects function '"++ show (ppSugared eSeqFunc) ++ - "' to have a single argument " ++ - "but found that the function " ++ show nargs ++ " arguments" - - unless (outputTypeMatchesInput ePar eSeqFunc) $ - tcError $ "Type '"++ (show . AST.getType) ePar ++ - "' of parallel computation '" ++ show (ppSugared ePar) ++ - "' does not match the expected type '"++ - show (getArgType eSeqFunc) ++"' of function '" ++ - show (ppSugared eSeqFunc) ++ "'" - let getParType = parType . getResultType . AST.getType - return $ setType (getParType eSeqFunc) s {par=ePar, seqfunc=eSeqFunc} - where - outputTypeMatchesInput ePar eSeqFunc = - ((getResultType . AST.getType) ePar) == (getArgType eSeqFunc) - leftIsPar = (isParType . AST.getType) - getArgType = head . getArgTypes . AST.getType - numberArgsFun = length . getArgTypes . AST.getType + pushError eSeqFunc $ NonFunctionTypeError seqType + + unless (isParType pType) $ + pushError ePar $ TypeMismatchError pType (parType pType) + + let resultType = getResultType seqType + expectedFunType = arrowType [getResultType pType] resultType + seqType `assertSubtypeOf` expectedFunType + + return $ setType (parType resultType) s {par=ePar, seqfunc=eSeqFunc} -- E |- e : t -- methodLookup(t, m) = (t1 .. tn, t') @@ -459,12 +411,11 @@ instance Checkable Expr where eTarget <- typecheck target let targetType = AST.getType eTarget unless (isRefType targetType || isCapabilityType targetType) $ - tcError $ "Cannot call method on expression '" ++ - show (ppSugared target) ++ - "' of type '" ++ show targetType ++ "'" - when (isMainMethod targetType name) $ tcError "Cannot call the main method" - when (name == Name "init") $ tcError - "Constructor method 'init' can only be called during object creation" + tcError $ NonCallableTargetError targetType + when (isMainMethod targetType name) $ + tcError MainMethodCallError + when (name == Name "init") $ + tcError ConstructorCallError (header, calledType) <- findMethodWithCalledType targetType name let specializedTarget = setType calledType eTarget matchArgumentLength targetType header args @@ -496,9 +447,7 @@ instance Checkable Expr where eTarget <- typecheck target let targetType = AST.getType eTarget unless (isActiveClassType targetType || isSharedClassType targetType) $ - tcError $ "Cannot send message to expression '" ++ - show (ppSugared target) ++ - "' of type '" ++ show targetType ++ "'" + tcError $ NonSendableTargetError targetType header <- findMethod targetType name matchArgumentLength targetType header args let expectedTypes = map ptype (hparams header) @@ -536,14 +485,13 @@ instance Checkable Expr where funType <- asks $ varLookup name ty <- case funType of Just ty -> return ty - Nothing -> tcError $ "Unbound function variable '" ++ show name ++ "'" + Nothing -> tcError $ UnboundFunctionError name unless (isArrowType ty) $ - tcError $ "Cannot use value of type '" ++ show ty ++ "' as a function" + tcError $ NonFunctionTypeError ty let argTypes = getArgTypes ty unless (length args == length argTypes) $ - tcError $ "Function '" ++ show name ++ "' of type '" ++ show ty ++ - "' expects " ++ show (length argTypes) ++ " arguments. Got " ++ - show (length args) + tcError $ WrongNumberOfFunctionArgumentsError + name (length argTypes) (length args) (eArgs, bindings) <- matchArguments args argTypes let resultType = replaceTypeVars bindings (getResultType ty) return $ setType resultType fcall {args = eArgs} @@ -582,7 +530,7 @@ instance Checkable Expr where let declNames = map fst eDecls declTypes = map (AST.getType . snd) eDecls when (any isBottomType (concatMap typeComponents declTypes)) $ - tcError "Cannot infer type of 'Nothing'" + tcError BottomTypeInferenceError eBody <- local (extendEnvironment (zip declNames declTypes)) $ typecheck body return $ setType (AST.getType eBody) let_ {decls = eDecls, body = eBody} where @@ -622,7 +570,7 @@ instance Checkable Expr where where matchBranches ty1 ty2 | isNullType ty1 && isNullType ty2 = - tcError "Cannot infer result type of if-statement" + tcError IfInferenceError | isNullType ty1 && (isRefType ty2 || isCapabilityType ty2) = return ty2 | isNullType ty2 && @@ -632,9 +580,7 @@ instance Checkable Expr where | otherwise = if ty2 == ty1 then return ty1 - else tcError $ "Type mismatch in different branches of if-statement:\n" ++ - " then: " ++ show ty1 ++ "\n" ++ - " else: " ++ show ty2 + else tcError $ IfBranchMismatchError ty1 ty2 -- E |- arg : t' -- clauses = (pattern1, guard1, expr1),..., (patternN, guardN, exprN) @@ -647,11 +593,11 @@ instance Checkable Expr where -- E |- match arg clauses : t doTypecheck match@(Match {arg, clauses}) = do when (null clauses) $ - tcError "Match statement must have at least one clause" + tcError EmptyMatchClauseError eArg <- typecheck arg let argType = AST.getType eArg when (isActiveClassType argType) $ - tcError "Cannot match on an active object" + tcError ActiveMatchError eClauses <- mapM (checkClause argType) clauses resultType <- checkAllHandlersSameType eClauses return $ setType resultType match {arg = eArg, clauses = eClauses} @@ -664,7 +610,7 @@ instance Checkable Expr where mapM_ (`assertSubtypeOf` ty) types return ty Nothing -> - tcError "Cannot infer result type of match expression" + tcError MatchInferenceError hasKnownType = all (not . isBottomType) . typeComponents . AST.getType @@ -674,27 +620,22 @@ instance Checkable Expr where doGetPatternVars pt va@(VarAccess {name}) = do when (isThisAccess va) $ - tcError "Cannot rebind variable 'this'" + tcError ThisReassignmentError return [(name, pt)] doGetPatternVars pt mcp@(MaybeValue{mdt = JustData {e}}) | isMaybeType pt = let innerType = getResultType pt in getPatternVars innerType e - | otherwise = - tcError $ "Pattern '" ++ show (ppSugared mcp) ++ - "' does not match expected type '" ++ - show pt ++ "'" + | otherwise = tcError $ PatternTypeMismatchError mcp pt doGetPatternVars pt fcall@(FunctionCall {name, args = [arg]}) = do unless (isRefType pt || isCapabilityType pt) $ - tcError $ "Cannot match an extractor pattern against " ++ - "non-reference type '" ++ show pt ++ "'" + tcError $ NonCallableTargetError pt header <- findMethod pt name let hType = htype header unless (isMaybeType hType) $ - tcError $ "Pattern '" ++ show (ppSugared fcall) ++ - "' is not a proper extractor pattern" + tcError $ NonMaybeExtractorPatternError fcall let extractedType = getResultType hType getPatternVars extractedType arg @@ -705,7 +646,7 @@ instance Checkable Expr where doGetPatternVars pt tuple@(Tuple {args}) = do unless (isTupleType pt) $ - tcError $ "Cannot match a tuple against non-tuple type " ++ show pt + tcError $ PatternTypeMismatchError tuple pt let elemTypes = getArgTypes pt varLists <- zipWithM getPatternVars elemTypes args @@ -735,8 +676,7 @@ instance Checkable Expr where doCheckPattern pattern@(MaybeValue{mdt = JustData {e}}) argty = do unless (isMaybeType argty) $ - tcError $ "Pattern '" ++ show (ppSugared pattern) ++ - "' does not match expected type '" ++ show argty ++ "'" + tcError $ PatternTypeMismatchError pattern argty let innerType = getResultType argty eExpr <- checkPattern e innerType return $ setType argty (pattern {mdt = JustData {e = eExpr}}) @@ -744,9 +684,7 @@ instance Checkable Expr where doCheckPattern pattern@(Tuple{args}) tupty = do let argTypes = getArgTypes tupty unless (length argTypes == length args) $ - tcError $ "Pattern '" ++ show (ppSugared pattern) ++ - "' does not match expected type " ++ show tupty ++ - ". Wrong tuple size" + tcError $ PatternTypeMismatchError pattern tupty eArgs <- zipWithM checkPattern args argTypes return $ setType tupty (pattern {args=eArgs}) @@ -754,14 +692,12 @@ instance Checkable Expr where eBody <- checkPattern body argty ty' <- resolveType ty unless (ty' == argty) $ - tcError $ "Type '" ++ show ty' ++ - "' does not match expected type '" ++ show argty ++ "'" + tcError $ TypeMismatchError ty' argty return $ setType ty' eBody doCheckPattern pattern argty | isPattern pattern = hasType pattern argty - | otherwise = tcError $ "'" ++ show (ppSugared pattern) ++ - "' is not a valid pattern" + | otherwise = tcError $ InvalidPatternError pattern checkClause pt clause@MatchClause{mcpattern, mchandler, mcguard} = do vars <- getPatternVars pt mcpattern @@ -789,7 +725,8 @@ instance Checkable Expr where do eVal <- typecheck val let ty = AST.getType eVal unless (isFutureType ty || isStreamType ty) $ - tcError $ "Cannot get the value of non-future type '" ++ show ty ++ "'" + pushError eVal $ ExpectingOtherTypeError + "a future or a stream" ty return $ setType (getResultType ty) get {val = eVal} -- E |- val : t @@ -800,16 +737,13 @@ instance Checkable Expr where do eVal <- typecheck val result <- asks currentMethod when (isNothing result) $ - tcError "Can only yield from (streaming) methods" + tcError $ NonStreamingContextError yield let mtd = fromJust result mType = methodType mtd eType = AST.getType eVal unless (isStreamMethod mtd) $ - tcError $ "Cannot yield in non-streaming method '" ++ - show (methodName mtd) ++ "'" - unlessM (eType `subtypeOf` mType) $ - tcError $ "Cannot yield value of type '" ++ show eType ++ - "' in streaming method of type '" ++ show mType ++ "'" + tcError $ NonStreamingContextError yield + eType `assertSubtypeOf` mType return $ setType voidType yield {val = eVal} -- isStreaming(currentMethod) @@ -818,11 +752,10 @@ instance Checkable Expr where doTypecheck eos@(Eos {}) = do result <- asks currentMethod when (isNothing result) $ - tcError "Can only yield from (streaming) methods" + tcError $ NonStreamingContextError eos let mtd = fromJust result unless (isStreamMethod mtd) $ - tcError $ "Cannot have end-of-stream in non-streaming method '" ++ - show (methodName mtd) ++ "'" + tcError $ NonStreamingContextError eos return $ setType voidType eos -- E |- s : Stream t @@ -830,9 +763,10 @@ instance Checkable Expr where -- E |- eos s : bool doTypecheck iseos@(IsEos {target}) = do eTarget <- typecheck target - unless (isStreamType $ AST.getType eTarget) $ - tcError $ "Cannot check end of stream on non-stream target '" - ++ show (ppSugared target) ++ "'" + let targetType = AST.getType eTarget + unless (isStreamType targetType) $ + pushError eTarget $ ExpectingOtherTypeError + "a stream" targetType return $ setType boolType iseos{target = eTarget} -- E |- s : Stream t @@ -840,11 +774,11 @@ instance Checkable Expr where -- E |- s.next() : Stream t doTypecheck next@(StreamNext {target}) = do eTarget <- typecheck target - let eType = AST.getType eTarget - unless (isStreamType eType) $ - tcError $ "Cannot get next value from non-stream target '" ++ - show (ppSugared target) ++ "'" - return $ setType eType next{target = eTarget} + let targetType = AST.getType eTarget + unless (isStreamType targetType) $ + pushError eTarget $ ExpectingOtherTypeError + "a stream" targetType + return $ setType targetType next{target = eTarget} -- -- ------------------ :: suspend @@ -859,7 +793,7 @@ instance Checkable Expr where do eVal <- typecheck val let ty = AST.getType eVal unless (isFutureType ty) $ - tcError $ "Cannot await the value of non-future type '" ++ show ty ++ "'" + pushError eVal $ ExpectingOtherTypeError "a future" ty return $ setType voidType await {val = eVal} -- f : Fut T @@ -871,13 +805,15 @@ instance Checkable Expr where eChain <- typecheck chain let ty = AST.getType eFuture unless (isFutureType ty) $ - tcError $ "Cannot chain with a non-future type '" ++ show ty ++ "'" - let ty' = AST.getType eChain - unless (isArrowType ty') $ - tcError $ "Chaining requires a closure argument '" ++ show ty' ++ "'" - unless ([getResultType ty] == getArgTypes ty') $ - tcError $ "Future value has type '" ++ show (getResultType ty) ++ "' but chained closure expects '" ++ show (head (getArgTypes ty')) ++ "'" - return $ setType (futureType (getResultType ty')) futureChain {future = eFuture, chain = eChain} + pushError eFuture $ ExpectingOtherTypeError "a future" ty + let chainType = AST.getType eChain + returnType = getResultType chainType + expectedFunType = arrowType [getResultType ty] returnType + unless (isArrowType chainType) $ + pushError eChain $ NonFunctionTypeError chainType + chainType `assertSubtypeOf` expectedFunType + return $ setType (futureType returnType) + futureChain {future = eFuture, chain = eChain} -- E |- target : t' -- fieldLookup(t', name) = t @@ -887,8 +823,7 @@ instance Checkable Expr where eTarget <- typecheck target let targetType = AST.getType eTarget unless (isThisAccess target || isPassiveClassType targetType) $ - tcError $ "Cannot read field of expression '" ++ - show (ppSugared target) ++ "' of " ++ Types.showWithKind targetType + tcError $ CannotReadFieldError target fdecl <- findField targetType name let ty = ftype fdecl return $ setType ty fAcc {target = eTarget} @@ -902,16 +837,14 @@ instance Checkable Expr where do eLhs <- typecheck lhs varIsLocal <- asks $ isLocal name unless varIsLocal $ - tcError $ "Left hand side '" ++ show (ppSugared lhs) ++ - "' is a global variable and cannot be assigned to" + pushError eLhs NonAssignableLHSError eRhs <- hasType rhs (AST.getType eLhs) return $ setType voidType assign {lhs = eLhs, rhs = eRhs} doTypecheck assign@(Assign {lhs, rhs}) = - do unless (isLval lhs) $ - tcError $ "Left hand side '" ++ show (ppSugared lhs) ++ - "' cannot be assigned to" - eLhs <- typecheck lhs + do eLhs <- typecheck lhs + unless (isLval eLhs) $ + pushError eLhs NonAssignableLHSError mtd <- asks currentMethod unless (isNothing mtd || isConstructor (fromJust mtd)) $ assertNotValField eLhs @@ -923,9 +856,7 @@ instance Checkable Expr where let targetType = AST.getType target fdecl <- findField targetType name when (isValField fdecl) $ - tcError $ "Cannot assign to val-field '" ++ - show name ++ "' in " ++ - classOrTraitName targetType + tcError $ ValFieldAssignmentError name targetType | otherwise = return () -- name : t \in E @@ -935,7 +866,7 @@ instance Checkable Expr where do varType <- asks $ varLookup name case varType of Just ty -> return $ setType ty var - Nothing -> tcError $ "Unbound variable '" ++ show name ++ "'" + Nothing -> tcError $ UnboundVariableError name -- -- ---------------------- @@ -961,10 +892,8 @@ instance Checkable Expr where -- E |- new ty(args) : ty doTypecheck new@(NewWithInit {ty, args}) = do ty' <- resolveType ty - unless (isClassType ty') $ - tcError $ "Cannot create an object of type '" ++ show ty ++ "'" - when (isMainType ty') $ - tcError "Cannot create additional Main objects" + unless (isClassType ty' && not (isMainType ty')) $ + tcError $ ObjectCreationError ty' header <- findMethod ty' (Name "_init") matchArgumentLength ty header args let expectedTypes = map ptype (hparams header) @@ -978,11 +907,8 @@ instance Checkable Expr where -- E |- peer ty : ty doTypecheck peer@(Peer {ty}) = do ty' <- resolveType ty - unless (isActiveClassType ty') $ - tcError $ "Cannot create an object of type '" ++ - show ty ++ "'" - when (isMainType ty') $ - tcError "Cannot create additional Main objects" + unless (isActiveClassType ty' && not (isMainType ty')) $ + tcError $ ObjectCreationError ty' return $ setType ty' peer{ty = ty'} -- E |- n : int @@ -1013,7 +939,7 @@ instance Checkable Expr where let srcType = AST.getType srcTyped unless (isArrayType srcType || isRangeType srcType) $ - tcError "For loops can only iterate over ranges or arrays" + pushError src $ NonIterableError srcType let elementType = if isRangeType srcType then intType @@ -1040,7 +966,7 @@ instance Checkable Expr where -- E |- [arg1, .., argn] : [ty] doTypecheck arr@(ArrayLiteral {args}) = do when (null args) $ - tcError "Array literal must have at least one element" + tcError EmptyArrayLiteralError eArg1 <- doTypecheck (head args) let ty = AST.getType eArg1 eArgs <- mapM (`hasType` ty) args @@ -1054,9 +980,7 @@ instance Checkable Expr where do eTarget <- typecheck target let targetType = AST.getType eTarget unless (isArrayType targetType) $ - tcError $ "Cannot index non-array '" ++ - show (ppSugared target) ++ - "' of type '" ++ show targetType ++ "'" + pushError eTarget $ NonIndexableError targetType eIndex <- hasType index intType return $ setType (getResultType targetType) arrAcc{target = eTarget, index = eIndex} @@ -1068,9 +992,7 @@ instance Checkable Expr where do eTarget <- typecheck target let targetType = AST.getType eTarget unless (isArrayType targetType) $ - tcError $ "Cannot calculate the size of non-array '" ++ - show (ppSugared target) ++ - "' of type '" ++ show targetType ++ "'" + pushError eTarget $ NonSizeableError targetType return $ setType intType arrSize{target = eTarget} -- count("{}", stringLit) = n @@ -1087,18 +1009,14 @@ instance Checkable Expr where unprintable = filter (not . isPrintable . AST.getType) eArgs unprintableHead = head unprintable unless (isStringLiteral fstString) $ - tcError $ "Formatted printing expects first argument '" ++ - show (ppSugared fst) ++ "' to be a string literal" + pushError fst FormatStringLiteralError unless (null unprintable) $ - tcError $ "Cannot print expression '" ++ - show (ppExpr unprintableHead) ++ "' of type '" ++ - show (AST.getType unprintableHead) ++ "'" + pushError unprintableHead $ + UnprintableExpressionError (AST.getType unprintableHead) let formatString = stringLit fstString noArgs = T.count (T.pack "{}") (T.pack formatString) unless (noArgs == length rest) $ - tcError $ "Wrong number of arguments to format string. " ++ - "Expected " ++ show noArgs ++ ", got " ++ - show (length rest) ++ "." + tcError $ WrongNumberOfPrintArgumentsError (length rest) noArgs let eFormatString = setType stringType $ StringLiteral (emeta fstString) formatString newArgs = eFormatString : rest @@ -1109,8 +1027,11 @@ instance Checkable Expr where -- E |- exit(arg) : void doTypecheck exit@(Exit {args}) = do eArgs <- mapM typecheck args - unless (length eArgs == 1 && isIntType (AST.getType (head eArgs))) $ - tcError "exit expects a single integer argument" + let expectedTypes = [intType] + unless (length args == length expectedTypes) $ + tcError $ WrongNumberOfFunctionArgumentsError + (Name "exit") (length expectedTypes) (length args) + matchArguments args expectedTypes return $ setType voidType exit {args = eArgs} doTypecheck stringLit@(StringLiteral {}) = return $ setType stringType stringLit @@ -1137,8 +1058,7 @@ instance Checkable Expr where eOperand <- typecheck operand let eType = AST.getType eOperand unless (isExpected eType) $ - tcError $ "Operator '" ++ show uop ++ "' is not defined " ++ - "for values of type '" ++ show eType ++ "'" + tcError $ UnaryOperandMismatchError uop eType let resultType | uop == Identifiers.NOT = boolType | uop == Identifiers.NEG = eType return $ setType resultType unary {operand = eOperand} @@ -1165,9 +1085,8 @@ instance Checkable Expr where let lType = AST.getType eLoper rType = AST.getType eRoper unless (isBoolType lType && isBoolType rType) $ - tcError $ "Operator '"++ show binop ++ "' is only defined for boolean types\n" ++ - " Left type: '" ++ show lType ++ "'\n" ++ - " Right type: '" ++ show rType ++ "'" + tcError $ BinaryOperandMismatchError binop "boolean" + lType rType return $ setType boolType bin {loper = eLoper, roper = eRoper} | binop `elem` cmpOps = do eLoper <- typecheck loper @@ -1175,9 +1094,8 @@ instance Checkable Expr where let lType = AST.getType eLoper rType = AST.getType eRoper unless (isNumeric lType && isNumeric rType) $ - tcError $ "Operator '"++ show binop ++ "' is only defined for numeric types\n" ++ - " Left type: '" ++ show lType ++ "'\n" ++ - " Right type: '" ++ show rType ++ "'" + tcError $ BinaryOperandMismatchError binop "numeric" + lType rType return $ setType boolType bin {loper = eLoper, roper = eRoper} | binop `elem` eqOps = do eLoper <- typecheck loper @@ -1191,11 +1109,10 @@ instance Checkable Expr where let lType = AST.getType eLoper rType = AST.getType eRoper unless (isNumeric lType && isNumeric rType) $ - tcError $ "Operator '"++ show binop ++ "' is only defined for numeric types\n" ++ - " Left type: '" ++ show lType ++ "'\n" ++ - " Right type: '" ++ show rType ++ "'" + tcError $ BinaryOperandMismatchError binop "numeric" + lType rType return $ setType (coerceTypes lType rType) bin {loper = eLoper, roper = eRoper} - | otherwise = tcError $ "Undefined binary operator '" ++ show binop ++ "'" + | otherwise = tcError $ UndefinedBinaryOperatorError binop where boolOps = [Identifiers.AND, Identifiers.OR] cmpOps = [Identifiers.LT, Identifiers.GT, Identifiers.LTE, Identifiers.GTE] @@ -1212,13 +1129,10 @@ instance Checkable Expr where -- --------------------- -- null : ty coerceNull null ty - | isNullType ty || - isTypeVar ty = tcError "Cannot infer type of null valued expression" | isRefType ty || isCapabilityType ty = return $ setType ty null - | isMaybeType ty = return $ setType ty null + | isNullType ty = tcError NullTypeInferenceError | otherwise = - tcError $ "Null valued expression cannot have type '" ++ - show ty ++ "' (must have reference type)" + tcError $ CannotBeNullError ty coercedInto :: Type -> Type -> TypecheckM Type coercedInto actual expected @@ -1232,17 +1146,16 @@ coercedInto actual expected return $ setArgTypes actual argTypes | isNullType actual = do when (isNullType expected) $ - tcError "Cannot infer type of null valued expression" + tcError NullTypeInferenceError unless (canBeNull expected) $ - tcError $ "Null valued expression cannot have type '" ++ - show actual ++ "' (must have reference type)" + tcError $ CannotBeNullError expected return expected | isBottomType actual = do when (any isBottomType $ typeComponents expected) $ - tcError "Cannot infer type of 'Nothing'" + tcError BottomTypeInferenceError return expected | isBottomType expected = - tcError "Cannot infer type of 'Nothing'" + tcError BottomTypeInferenceError | otherwise = do actual `assertSubtypeOf` expected return actual @@ -1316,11 +1229,14 @@ matchTypes :: Type -> Type -> TypecheckM [(Type, Type)] matchTypes expected ty | isFutureType expected && isFutureType ty || isParType expected && isParType ty || - isStreamType expected && isStreamType ty = + isStreamType expected && isStreamType ty || + isMaybeType expected && isMaybeType ty = matchTypes (getResultType expected) (getResultType ty) - `catchError` (\_ -> tcError $ "Type '" ++ show ty ++ - "' does not match expected type '" ++ - show expected ++ "'") + `catchError` (\case + TCError (TypeMismatchError _ _) _ -> + tcError $ TypeMismatchError ty expected + TCError err _ -> tcError err + ) | isArrowType expected && isArrowType ty = let expArgTypes = getArgTypes expected argTypes = getArgTypes ty @@ -1339,18 +1255,11 @@ matchTypes expected ty case result of Just boundType -> do unlessM (ty `subtypeOf` boundType) $ - tcError $ "Type variable '" ++ show expected ++ - "' cannot be bound to both '" ++ show ty ++ - "' and '" ++ show boundType ++ "'" + tcError $ TypeVariableAmbiguityError expected ty boundType asks bindings Nothing -> do bindings <- asks bindings return $ (expected, ty) : bindings - | isMaybeType expected && isMaybeType ty = - matchTypes (getResultType expected) (getResultType ty) - `catchError` (\_ -> tcError $ "Type '" ++ show ty ++ - "' does not match expected type '" ++ - show expected ++ "'") | otherwise = assertMatch expected ty where matchArgs [] [] = asks bindings @@ -1359,7 +1268,7 @@ matchTypes expected ty local (bindTypes bindings) $ matchArgs types1 types2 assertMatch expected ty = do - assertSubtypeOf ty expected + ty `assertSubtypeOf` expected asks bindings assertSubtypeOf :: Type -> Type -> TypecheckM () @@ -1372,6 +1281,8 @@ assertSubtypeOf sub super = then return cap else return Nothing else return Nothing - let subMsg = "Type '" ++ show sub ++ "'" ++ - maybe "" ((" with capability " ++) . show) capability - tcError $ subMsg ++ " does not match expected type '" ++ show super ++ "'" + case capability of + Just cap -> + tcError $ TypeWithCapabilityMismatchError sub cap super + Nothing -> + tcError $ TypeMismatchError sub super diff --git a/src/types/Typechecker/Util.hs b/src/types/Typechecker/Util.hs index 5c78436b5..fe0677a61 100644 --- a/src/types/Typechecker/Util.hs +++ b/src/types/Typechecker/Util.hs @@ -7,13 +7,13 @@ module Typechecker.Util(TypecheckM ,anyM ,unlessM ,tcError + ,pushError ,tcWarning ,resolveType ,resolveTypeAndCheckForLoops ,subtypeOf ,assertDistinctThing ,assertDistinct - ,classOrTraitName ,findField ,findMethod ,findMethodWithCalledType @@ -58,11 +58,14 @@ type TypecheckM a = MonadError TCError m, MonadReader Environment m) => m a --- | convenience function for throwing an exception with the +-- | Convenience function for throwing an exception with the -- current backtrace -tcError msg = +tcError err = do bt <- asks backtrace - throwError $ TCError (msg, bt) + throwError $ TCError err bt + +-- | Push the expression @expr@ and throw error err +pushError expr err = local (pushBT expr) $ tcError err tcWarning wrn = do bt <- asks backtrace @@ -75,9 +78,8 @@ matchTypeParameterLength ty1 ty2 = do let params1 = getTypeParameters ty1 params2 = getTypeParameters ty2 unless (length params1 == length params2) $ - tcError $ printf "'%s' expects %d type arguments, but '%s' has %d" - (show ty1) (length params1) - (show ty2) (length params2) + tcError $ WrongNumberOfTypeParametersError + ty1 (length params1) ty2 (length params2) -- | @resolveType ty@ checks all the components of @ty@, resolving -- reference types to traits or classes and making sure that any @@ -90,7 +92,7 @@ resolveSingleType ty | isTypeVar ty = do params <- asks typeParameters unless (ty `elem` params) $ - tcError $ "Free type variables in type '" ++ show ty ++ "'" + tcError $ FreeTypeVariableError ty return ty | isRefType ty = do res <- resolveRefType ty @@ -113,9 +115,9 @@ resolveSingleType ty | isRefType t = do result <- asks $ traitLookup t when (isNothing result) $ - tcError $ "Couldn't find trait '" ++ getId t ++ "'" + tcError $ UnknownTraitError t | otherwise = - tcError $ "Cannot form capability with " ++ Ty.showWithKind t + tcError $ MalformedCapabilityError t resolveTypeAndCheckForLoops ty = evalStateT (typeMapM resolveAndCheck ty) [] @@ -125,8 +127,7 @@ resolveTypeAndCheckForLoops ty = seen <- get let tyid = getId ty when (tyid `elem` seen) $ - lift $ tcError $ "Type synonyms cannot be recursive." ++ - " One of the culprits is " ++ tyid + lift . tcError $ RecursiveTypesynonymError ty res <- lift $ resolveRefType ty when (isTypeSynonym res) $ put (tyid : seen) if isTypeSynonym res @@ -144,7 +145,7 @@ resolveRefType ty let res = formal `setTypeParameters` getTypeParameters ty return res Nothing -> - tcError $ "Couldn't find class, trait or typedef '" ++ show ty ++ "'" + tcError $ UnknownRefTypeError ty | otherwise = error $ "Util.hs: " ++ Ty.showWithKind ty ++ " isn't a ref-type" subtypeOf :: Type -> Type -> TypecheckM Bool @@ -220,7 +221,7 @@ assertDistinctThing something kind l = duplicate = head duplicates in unless (null duplicates) $ - tcError $ printf "Duplicate %s of %s %s" something kind $ show duplicate + tcError $ DuplicateThingError something (kind ++ show duplicate) -- | Convenience function for asserting distinctness of a list of -- things that @HasMeta@ (and thus knows how to print its own @@ -235,23 +236,14 @@ assertDistinct something l = first = head duplicates in unless (null duplicates) $ - tcError $ printf "Duplicate %s of %s" something $ AST.showWithKind first - -classOrTraitName :: Type -> String -classOrTraitName ty - | isClassType ty = "class '" ++ getId ty ++ "'" - | isTraitType ty = "trait '" ++ getId ty ++ "'" - | isCapabilityType ty = "capability '" ++ show ty ++ "'" - | otherwise = error $ "Util.hs: No class or trait name for " ++ - Ty.showWithKind ty + tcError $ DuplicateThingError something (AST.showWithKind first) findField :: Type -> Name -> TypecheckM FieldDecl findField ty f = do result <- asks $ fieldLookup ty f case result of Just fdecl -> return fdecl - Nothing -> tcError $ "No field '" ++ show f ++ "' in " ++ - classOrTraitName ty + Nothing -> tcError $ FieldNotFoundError f ty findMethod :: Type -> Name -> TypecheckM FunctionHeader findMethod ty = liftM fst . findMethodWithCalledType ty @@ -259,19 +251,16 @@ findMethod ty = liftM fst . findMethodWithCalledType ty findMethodWithCalledType :: Type -> Name -> TypecheckM (FunctionHeader, Type) findMethodWithCalledType ty name = do result <- asks $ methodAndCalledTypeLookup ty name - when (isNothing result) $ tcError $ - concat [noMethod name, " in ", classOrTraitName ty] + when (isNothing result) $ + tcError $ MethodNotFoundError name ty return $ fromJust result - where - noMethod (Name "_init") = "No constructor" - noMethod n = concat ["No method '", show n, "'"] findCapability :: Type -> TypecheckM Type findCapability ty = do result <- asks $ capabilityLookup ty return $ fromMaybe err result where - err = error $ "Util.hs: No capability in " ++ classOrTraitName ty + err = error $ "Util.hs: No capability in " ++ Ty.showWithKind ty getImplementedTraits :: Type -> TypecheckM [Type] getImplementedTraits ty diff --git a/src/types/Types.hs b/src/types/Types.hs index 53f34fa92..c278c159b 100644 --- a/src/types/Types.hs +++ b/src/types/Types.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Types( - Type - , Activity (..) + Type + ,Activity (..) ,arrowType ,isArrowType ,futureType @@ -17,11 +17,11 @@ module Types( ,refTypeWithParams ,refType ,traitTypeFromRefType - , classType + ,classType ,isRefType ,isTraitType ,isActiveClassType - , isSharedClassType + ,isSharedClassType ,isPassiveClassType ,isClassType ,isMainType @@ -60,7 +60,7 @@ module Types( ,maybeGetId ,getTypeParameters ,setTypeParameters - , conjunctiveTypesFromCapability + ,conjunctiveTypesFromCapability ,typesFromCapability ,typeComponents ,typeMap