X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=62868f680a90581ab3f7545756374086ed9d954d;hb=9dfbc2dadf268996963feeb8667eb2d0b0f30634;hp=e31af01511404a60f343ec31c7282fe35e474a74;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index e31af01..62868f6 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -1,50 +1,53 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[CoreLint]{A ``lint'' pass to check for Core correctness} \begin{code} -#include "HsVersions.h" - module CoreLint ( lintCoreBindings, lintUnfolding ) where -import Ubiq +#include "HsVersions.h" +import IO ( hPutStr, stderr ) + +import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting ) import CoreSyn import Bag -import Kind ( Kind{-instance-} ) +import Kind ( hasMoreBoxityInfo, Kind{-instance-} ) import Literal ( literalType, Literal{-instance-} ) -import Id ( idType, isBottomingId, - getInstantiatedDataConSig, GenId{-instances-} +import Id ( idType, isBottomingId, dataConRepType, isDataCon, isAlgCon, + dataConArgTys, GenId{-instances-}, + emptyIdSet, mkIdSet, + unionIdSets, elementOfIdSet, IdSet, + Id ) import Maybes ( catMaybes ) -import Outputable ( Outputable(..) ) +import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-}, + NamedThing(..) + ) import PprCore -import PprStyle ( PprStyle(..) ) -import PprType ( GenType, GenTyVar, TyCon ) -import Pretty -import PrimOp ( primOpType, PrimOp(..) ) +import ErrUtils ( doIfSet, ghcExit ) +import PrimOp ( primOpType ) import PrimRep ( PrimRep(..) ) +import Specialise ( idSpecVars ) import SrcLoc ( SrcLoc ) -import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe, - isPrimType,getTypeKind,instantiateTy, - mkForAllUsageTy,getForAllUsageTy,instantiateUsage, - maybeAppDataTyCon, eqTy - ) -import TyCon ( isPrimTyCon, tyConFamilySize ) -import TyVar ( getTyVarKind, GenTyVar{-instances-} ) -import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets, - unionUniqSets, elementOfUniqSet, UniqSet(..) +import Type ( mkFunTy, splitFunTy_maybe, mkForAllTy, + splitForAllTy_maybe, + isUnpointedType, typeKind, instantiateTy, + splitAlgTyConApp_maybe, Type ) +import TyCon ( TyCon, isPrimTyCon, isDataTyCon ) +import TyVar ( TyVar, tyVarKind, mkTyVarEnv ) +import ErrUtils ( ErrMsg ) import Unique ( Unique ) -import Usage ( GenUsage ) -import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic ) +import Util ( zipEqual ) +import Outputable -infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL` +infixr 9 `thenL`, `seqL`, `thenMaybeL` \end{code} %************************************************************************ @@ -81,25 +84,33 @@ Outstanding issues: -- \begin{code} -lintCoreBindings - :: PprStyle -> String -> Bool -> [CoreBinding] -> [CoreBinding] +lintCoreBindings :: String -> Bool -> [CoreBinding] -> IO () + +lintCoreBindings whoDunnit spec_done binds + | not opt_DoCoreLinting + = return () -lintCoreBindings sty whoDunnit spec_done binds +lintCoreBindings whoDunnit spec_done binds = case (initL (lint_binds binds) spec_done) of - Nothing -> binds - Just msg -> - pprPanic "" (ppAboves [ - ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"), - msg sty, - ppStr "*** Offending Program ***", - ppAboves (map (pprCoreBinding sty) binds), - ppStr "*** End of Offense ***" - ]) + Nothing -> doIfSet opt_D_show_passes + (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n")) + + Just bad_news -> printDump (display bad_news) >> + ghcExit 1 where lint_binds [] = returnL () lint_binds (bind:binds) = lintCoreBinding bind `thenL` \binders -> addInScopeVars binders (lint_binds binds) + + display bad_news + = vcat [ + text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), + bad_news, + ptext SLIT("*** Offending Program ***"), + pprCoreBindings binds, + ptext SLIT("*** End of Offense ***") + ] \end{code} %************************************************************************ @@ -122,10 +133,10 @@ lintUnfolding locn expr Nothing -> Just expr Just msg -> pprTrace "WARNING: Discarded bad unfolding from interface:\n" - (ppAboves [msg PprForUser, - ppStr "*** Bad unfolding ***", - ppr PprDebug expr, - ppStr "*** End unfolding ***"]) + (vcat [msg, + ptext SLIT("*** Bad unfolding ***"), + ppr expr, + ptext SLIT("*** End unfolding ***")]) Nothing \end{code} @@ -162,13 +173,19 @@ lintSingleBinding (binder,rhs) Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty)) `seqL` - -- Check (not isPrimType) - checkIfSpecDoneL (not (isPrimType (idType binder))) - (mkRhsPrimMsg binder rhs) + -- Check (not isUnpointedType) + checkIfSpecDoneL (not (isUnpointedType (idType binder))) + (mkRhsPrimMsg binder rhs) `seqL` + -- Check whether binder's specialisations contain any out-of-scope variables + ifSpecDoneL (mapL (checkSpecIdInScope binder) spec_vars `seqL` returnL ()) + -- We should check the unfolding, if any, but this is tricky because -- the unfolding is a SimplifiableCoreExpr. Give up for now. ) + where + spec_vars = idSpecVars binder + \end{code} %************************************************************************ @@ -180,9 +197,31 @@ lintSingleBinding (binder,rhs) \begin{code} lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found -lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var)) +lintCoreExpr (Var var) + | isAlgCon var = returnL (Just (idType var)) + -- Micro-hack here... Class decls generate applications of their + -- dictionary constructor, but don't generate a binding for the + -- constructor (since it would never be used). After a single round + -- of simplification, these dictionary constructors have been + -- inlined (from their UnfoldInfo) to CoCons. Just between + -- desugaring and simplfication, though, they appear as naked, unbound + -- variables as the function in an application. + -- The hack here simply doesn't check for out-of-scope-ness for + -- data constructors (at least, in a function position). + + | otherwise = checkIdInScope var `seqL` returnL (Just (idType var)) + lintCoreExpr (Lit lit) = returnL (Just (literalType lit)) -lintCoreExpr (SCC _ expr) = lintCoreExpr expr + +lintCoreExpr (Note (Coerce to_ty from_ty) expr) + = lintCoreExpr expr `thenMaybeL` \ expr_ty -> + lintTy to_ty `seqL` + lintTy from_ty `seqL` + checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL` + returnL (Just to_ty) + +lintCoreExpr (Note other_note expr) + = lintCoreExpr expr lintCoreExpr (Let binds body) = lintCoreBinding binds `thenL` \binders -> @@ -193,19 +232,20 @@ lintCoreExpr (Let binds body) (addInScopeVars binders (lintCoreExpr body)) lintCoreExpr e@(Con con args) - = lintCoreArgs False e (idType con) args + = checkL (isDataCon con) (mkConErrMsg e) `seqL` + lintCoreArgs {-False-} e (dataConRepType con) args -- Note: we don't check for primitive types in these arguments lintCoreExpr e@(Prim op args) - = lintCoreArgs True e (primOpType op) args + = lintCoreArgs {-True-} e (primOpType op) args -- Note: we do check for primitive types in these arguments lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v - = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg False e ty arg + = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg -- Note: we don't check for primitive types in argument to 'error' lintCoreExpr e@(App fun arg) - = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg True e ty arg + = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg -- Note: we do check for primitive types in this argument lintCoreExpr (Lam (ValBinder var) expr) @@ -217,14 +257,11 @@ lintCoreExpr (Lam (ValBinder var) expr) lintCoreExpr (Lam (TyBinder tyvar) expr) = lintCoreExpr expr `thenMaybeL` \ty -> returnL (Just(mkForAllTy tyvar ty)) - -- TODO: Should add in-scope type variable at this point + -- ToDo: Should add in-scope type variable at this point lintCoreExpr e@(Case scrut alts) = lintCoreExpr scrut `thenMaybeL` \ty -> - -- Check that it is a data type - case maybeAppDataTyCon ty of - Nothing -> addErrL (mkCaseDataConMsg e) `seqL` returnL Nothing - Just(tycon, _, _) -> lintCoreAlts alts ty tycon + lintCoreAlts alts ty \end{code} %************************************************************************ @@ -237,12 +274,12 @@ The boolean argument indicates whether we should flag type applications to primitive types as being errors. \begin{code} -lintCoreArgs :: Bool -> CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type) +lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type) -lintCoreArgs _ _ ty [] = returnL (Just ty) -lintCoreArgs checkTyApp e ty (a : args) - = lintCoreArg checkTyApp e ty a `thenMaybeL` \ res -> - lintCoreArgs checkTyApp e res args +lintCoreArgs _ ty [] = returnL (Just ty) +lintCoreArgs e ty (a : args) + = lintCoreArg e ty a `thenMaybeL` \ res -> + lintCoreArgs e res args \end{code} %************************************************************************ @@ -252,38 +289,47 @@ lintCoreArgs checkTyApp e ty (a : args) %************************************************************************ \begin{code} -lintCoreArg :: Bool -> CoreExpr -> Type -> CoreArg -> LintM (Maybe Type) +lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type) -lintCoreArg _ e ty (LitArg lit) +lintCoreArg e ty (LitArg lit) = -- Make sure function type matches argument - case (getFunTy_maybe ty) of - Just (arg,res) | (literalType lit `eqTy` arg) -> returnL(Just res) - _ -> addErrL (mkAppMsg ty (literalType lit) e) `seqL` returnL Nothing + case (splitFunTy_maybe ty) of + Just (arg,res) | (lit_ty == arg) -> returnL(Just res) + _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing + where + lit_ty = literalType lit -lintCoreArg _ e ty (VarArg v) +lintCoreArg e ty (VarArg v) = -- Make sure variable is bound - checkInScope v `seqL` + checkIdInScope v `seqL` -- Make sure function type matches argument - case (getFunTy_maybe ty) of - Just (arg,res) | (idType v `eqTy` arg) -> returnL(Just res) - _ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing - -lintCoreArg checkTyApp e ty a@(TyArg arg_ty) - = -- TODO: Check that ty is well-kinded and has no unbound tyvars - checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a) - `seqL` - case (getForAllTy_maybe ty) of - Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) -> - returnL(Just(instantiateTy [(tyvar,arg_ty)] body)) - _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing - -lintCoreArg _ e ty (UsageArg u) - = -- TODO: Check that usage has no unbound usage variables - case (getForAllUsageTy ty) of - Just (uvar,bounds,body) -> - -- TODO Check argument satisfies bounds - returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body")) - _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing + case (splitFunTy_maybe ty) of + Just (arg,res) | (var_ty == arg) -> returnL(Just res) + _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing + where + var_ty = idType v + +lintCoreArg e ty a@(TyArg arg_ty) + = lintTy arg_ty `seqL` + + case (splitForAllTy_maybe ty) of + Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing + + Just (tyvar,body) -> + let + tyvar_kind = tyVarKind tyvar + argty_kind = typeKind arg_ty + in + if argty_kind `hasMoreBoxityInfo` tyvar_kind + -- Arg type might be boxed for a function with an uncommitted + -- tyvar; notably this is used so that we can give + -- error :: forall a:*. String -> a + -- and then apply it to both boxed and unboxed types. + then + returnL(Just(instantiateTy (mkTyVarEnv [(tyvar,arg_ty)]) body)) + else + pprTrace "lintCoreArg:kinds:" (hsep [ppr tyvar_kind, ppr argty_kind]) $ + addErrL (mkKindErrMsg tyvar arg_ty e) `seqL` returnL Nothing \end{code} %************************************************************************ @@ -295,20 +341,20 @@ lintCoreArg _ e ty (UsageArg u) \begin{code} lintCoreAlts :: CoreCaseAlts -> Type -- Type of scrutinee - -> TyCon -- TyCon pinned on the case +-- -> TyCon -- TyCon pinned on the case -> LintM (Maybe Type) -- Type of alternatives -lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon +lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon = -- Check tycon is not a primitive tycon - addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon) - `seqL` +-- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon) +-- `seqL` -- Check we are scrutinising a proper datatype -- (ToDo: robustify) - addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon) - `seqL` +-- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon) +-- `seqL` lintDeflt deflt ty `thenL` \maybe_deflt_ty -> - mapL (lintAlgAlt ty tycon) alts + mapL (lintAlgAlt ty {-tycon-}) alts `thenL` \maybe_alt_tys -> -- Check the result types case catMaybes (maybe_deflt_ty : maybe_alt_tys) of @@ -319,10 +365,10 @@ lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon where check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts) -lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon +lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon = -- Check tycon is a primitive tycon - addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon) - `seqL` +-- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon) +-- `seqL` mapL (lintPrimAlt ty) alts `thenL` \maybe_alt_tys -> lintDeflt deflt ty @@ -336,19 +382,19 @@ lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon where check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts) -lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs) - = (case maybeAppDataTyCon scrut_ty of - Nothing -> - addErrL (mkAlgAltMsg1 scrut_ty) - Just (tycon, tys_applied, cons) -> +lintAlgAlt scrut_ty (con,args,rhs) + = (case splitAlgTyConApp_maybe scrut_ty of + Just (tycon, tys_applied, cons) | isDataTyCon tycon -> let - (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied + arg_tys = dataConArgTys con tys_applied in checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL` checkL (length arg_tys == length args) (mkAlgAltMsg3 con args) `seqL` - mapL check (arg_tys `zipEqual` args) `seqL` + mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL` returnL () + + other -> addErrL (mkAlgAltMsg1 scrut_ty) ) `seqL` addInScopeVars args ( lintCoreExpr rhs @@ -374,6 +420,19 @@ lintDeflt deflt@(BindDefault binder rhs) ty %************************************************************************ %* * +\subsection[lint-types]{Types} +%* * +%************************************************************************ + +\begin{code} +lintTy :: Type -> LintM () +lintTy ty = returnL () +-- ToDo: Check that ty is well-kinded and has no unbound tyvars +\end{code} + + +%************************************************************************ +%* * \subsection[lint-monad]{The Lint monad} %* * %************************************************************************ @@ -381,12 +440,10 @@ lintDeflt deflt@(BindDefault binder rhs) ty \begin{code} type LintM a = Bool -- True <=> specialisation has been done -> [LintLocInfo] -- Locations - -> UniqSet Id -- Local vars in scope + -> IdSet -- Local vars in scope -> Bag ErrMsg -- Error messages so far -> (a, Bag ErrMsg) -- Result and error messages (if any) -type ErrMsg = PprStyle -> Pretty - data LintLocInfo = RhsOf Id -- The variable bound | LambdaBodyOf Id -- The lambda-binder @@ -394,37 +451,37 @@ data LintLocInfo | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) instance Outputable LintLocInfo where - ppr sty (RhsOf v) - = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"] + ppr (RhsOf v) + = ppr (getSrcLoc v) <> colon <+> + brackets (ptext SLIT("RHS of") <+> pp_binders [v]) - ppr sty (LambdaBodyOf b) - = ppBesides [ppr sty (getSrcLoc b), - ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"] + ppr (LambdaBodyOf b) + = ppr (getSrcLoc b) <> colon <+> + brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b) - ppr sty (BodyOfLetRec bs) - = ppBesides [ppr sty (getSrcLoc (head bs)), - ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"] + ppr (BodyOfLetRec bs) + = ppr (getSrcLoc (head bs)) <> colon <+> + brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs) - ppr sty (ImportedUnfolding locn) - = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]") + ppr (ImportedUnfolding locn) + = ppr locn <> colon <+> + brackets (ptext SLIT("in an imported unfolding")) -pp_binders :: PprStyle -> [Id] -> Pretty -pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs) +pp_binders :: [Id] -> SDoc +pp_binders bs = sep (punctuate comma (map pp_binder bs)) -pp_binder :: PprStyle -> Id -> Pretty -pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)] +pp_binder :: Id -> SDoc +pp_binder b = hsep [ppr b, text "::", ppr (idType b)] \end{code} \begin{code} initL :: LintM a -> Bool -> Maybe ErrMsg initL m spec_done - = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) -> + = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) -> if isEmptyBag errs then Nothing else - Just ( \ sty -> - ppAboves [ msg sty | msg <- bagToList errs ] - ) + Just (vcat (bagToList errs)) } returnL :: a -> LintM a @@ -446,12 +503,6 @@ thenMaybeL m k spec loc scope errs (Nothing, errs2) -> (Nothing, errs2) (Just r, errs2) -> k r spec loc scope errs2 -seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b) -seqMaybeL m k spec loc scope errs - = case m spec loc scope errs of - (Nothing, errs2) -> (Nothing, errs2) - (Just _, errs2) -> k spec loc scope errs2 - mapL :: (a -> LintM b) -> [a] -> LintM [b] mapL f [] = returnL [] mapL f (x:xs) @@ -478,8 +529,9 @@ checkIfSpecDoneL True msg spec loc scope errs = ((), errs) checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc) checkIfSpecDoneL False msg False loc scope errs = ((), errs) -addErrIfL pred spec - = if pred then addErrL spec else returnL () +ifSpecDoneL :: LintM () -> LintM () +ifSpecDoneL m False loc scope errs = ((), errs) +ifSpecDoneL m True loc scope errs = m True loc scope errs addErrL :: ErrMsg -> LintM () addErrL msg spec loc scope errs = ((), addErr errs msg loc) @@ -488,9 +540,7 @@ addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg addErr errs_so_far msg locs = ASSERT (not (null locs)) - errs_so_far `snocBag` ( \ sty -> - ppHang (ppr sty (head locs)) 4 (msg sty) - ) + errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg) addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m spec loc scope errs @@ -503,144 +553,145 @@ addInScopeVars ids m spec loc scope errs -- For now, it's just a "trace"; we may make -- a real error out of it... let - new_set = mkUniqSet ids + new_set = mkIdSet ids - shadowed = scope `intersectUniqSets` new_set +-- shadowed = scope `intersectIdSets` new_set in -- After adding -fliberate-case, Simon decided he likes shadowed -- names after all. WDP 94/07 -- (if isEmptyUniqSet shadowed -- then id --- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) ( - m spec loc (scope `unionUniqSets` new_set) errs +-- else pprTrace "Shadowed vars:" (ppr (uniqSetToList shadowed))) ( + m spec loc (scope `unionIdSets` new_set) errs -- ) \end{code} \begin{code} -checkInScope :: Id -> LintM () -checkInScope id spec loc scope errs - = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then - ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc) +checkIdInScope :: Id -> LintM () +checkIdInScope id + = checkInScope (ptext SLIT("is out of scope")) id + +checkSpecIdInScope :: Id -> Id -> LintM () +checkSpecIdInScope binder id + = checkInScope msg id + where + msg = ptext SLIT("is out of scope inside specialisation info for") <+> + ppr binder + +checkInScope :: SDoc -> Id -> LintM () +checkInScope loc_msg id spec loc scope errs + = let + id_name = getName id + in + if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then + ((), addErr errs (hsep [ppr id, loc_msg]) loc) else ((),errs) checkTys :: Type -> Type -> ErrMsg -> LintM () checkTys ty1 ty2 msg spec loc scope errs - = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc) + = if ty1 == ty2 then ((), errs) else ((), addErr errs msg loc) \end{code} \begin{code} -mkCaseAltMsg :: CoreCaseAlts -> ErrMsg -mkCaseAltMsg alts sty - = ppAbove (ppStr "Type of case alternatives not the same:") - (ppr sty alts) +mkConErrMsg e + = ($$) (ptext SLIT("Application of newtype constructor:")) + (ppr e) -mkCaseDataConMsg :: CoreExpr -> ErrMsg -mkCaseDataConMsg expr sty - = ppAbove (ppStr "A case scrutinee not of data constructor type:") - (pp_expr sty expr) -mkCaseNotPrimMsg :: TyCon -> ErrMsg -mkCaseNotPrimMsg tycon sty - = ppAbove (ppStr "A primitive case on a non-primitive type:") - (ppr sty tycon) - -mkCasePrimMsg :: TyCon -> ErrMsg -mkCasePrimMsg tycon sty - = ppAbove (ppStr "An algebraic case on a primitive type:") - (ppr sty tycon) +mkCaseAltMsg :: CoreCaseAlts -> ErrMsg +mkCaseAltMsg alts + = ($$) (ptext SLIT("Type of case alternatives not the same:")) + (ppr alts) mkCaseAbstractMsg :: TyCon -> ErrMsg -mkCaseAbstractMsg tycon sty - = ppAbove (ppStr "An algebraic case on some weird type:") - (ppr sty tycon) +mkCaseAbstractMsg tycon + = ($$) (ptext SLIT("An algebraic case on some weird type:")) + (ppr tycon) mkDefltMsg :: CoreCaseDefault -> ErrMsg -mkDefltMsg deflt sty - = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:") - (ppr sty deflt) +mkDefltMsg deflt + = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:")) + (ppr deflt) mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg -mkAppMsg fun arg expr sty - = ppAboves [ppStr "Argument values doesn't match argument type:", - ppHang (ppStr "Fun type:") 4 (ppr sty fun), - ppHang (ppStr "Arg type:") 4 (ppr sty arg), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] - -mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg -mkTyAppMsg ty arg expr sty - = panic "mkTyAppMsg" -{- - = ppAboves [ppStr "Illegal type application:", - ppHang (ppStr "Exp type:") 4 (ppr sty exp), - ppHang (ppStr "Arg type:") 4 (ppr sty arg), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] --} - -mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg -mkUsageAppMsg ty u expr sty - = ppAboves [ppStr "Illegal usage application:", - ppHang (ppStr "Exp type:") 4 (ppr sty ty), - ppHang (ppStr "Usage exp:") 4 (ppr sty u), - ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] +mkAppMsg fun arg expr + = vcat [ptext SLIT("Argument value doesn't match argument type:"), + hang (ptext SLIT("Fun type:")) 4 (ppr fun), + hang (ptext SLIT("Arg type:")) 4 (ppr arg), + hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)] + +mkKindErrMsg :: TyVar -> Type -> CoreExpr -> ErrMsg +mkKindErrMsg tyvar arg_ty expr + = vcat [ptext SLIT("Kinds don't match in type application:"), + hang (ptext SLIT("Type variable:")) + 4 (ppr tyvar <+> ptext SLIT("::") <+> ppr (tyVarKind tyvar)), + hang (ptext SLIT("Arg type:")) + 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty)), + hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)] + +mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg +mkTyAppMsg msg ty arg expr + = vcat [hsep [ptext msg, ptext SLIT("type application:")], + hang (ptext SLIT("Exp type:")) + 4 (ppr ty <+> ptext SLIT("::") <+> ppr (typeKind ty)), + hang (ptext SLIT("Arg type:")) + 4 (ppr arg <+> ptext SLIT("::") <+> ppr (typeKind arg)), + hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)] mkAlgAltMsg1 :: Type -> ErrMsg -mkAlgAltMsg1 ty sty - = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:") - (ppr sty ty) +mkAlgAltMsg1 ty + = ($$) (text "In some case statement, type of scrutinee is not a data type:") + (ppr ty) mkAlgAltMsg2 :: Type -> Id -> ErrMsg -mkAlgAltMsg2 ty con sty - = ppAboves [ - ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", - ppr sty ty, - ppr sty con +mkAlgAltMsg2 ty con + = vcat [ + text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", + ppr ty, + ppr con ] mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg -mkAlgAltMsg3 con alts sty - = ppAboves [ - ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:", - ppr sty con, - ppr sty alts +mkAlgAltMsg3 con alts + = vcat [ + text "In some algebraic case alternative, number of arguments doesn't match constructor:", + ppr con, + ppr alts ] mkAlgAltMsg4 :: Type -> Id -> ErrMsg -mkAlgAltMsg4 ty arg sty - = ppAboves [ - ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:", - ppr sty ty, - ppr sty arg +mkAlgAltMsg4 ty arg + = vcat [ + text "In some algebraic case alternative, type of argument doesn't match data constructor:", + ppr ty, + ppr arg ] mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg -mkPrimAltMsg alt sty - = ppAbove - (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:") - (ppr sty alt) +mkPrimAltMsg alt + = ($$) + (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:") + (ppr alt) mkRhsMsg :: Id -> Type -> ErrMsg -mkRhsMsg binder ty sty - = ppAboves - [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:", - ppr sty binder], - ppCat [ppStr "Binder's type:", ppr sty (idType binder)], - ppCat [ppStr "Rhs type:", ppr sty ty]] +mkRhsMsg binder ty + = vcat + [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"), + ppr binder], + hsep [ptext SLIT("Binder's type:"), ppr (idType binder)], + hsep [ptext SLIT("Rhs type:"), ppr ty]] mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg -mkRhsPrimMsg binder rhs sty - = ppAboves [ppCat [ppStr "The type of this binder is primitive:", - ppr sty binder], - ppCat [ppStr "Binder's type:", ppr sty (idType binder)] +mkRhsPrimMsg binder rhs + = vcat [hsep [ptext SLIT("The type of this binder is primitive:"), + ppr binder], + hsep [ptext SLIT("Binder's type:"), ppr (idType binder)] ] -mkSpecTyAppMsg :: CoreArg -> ErrMsg -mkSpecTyAppMsg arg sty - = ppAbove - (ppStr "Unboxed types in a type application (after specialisation):") - (ppr sty arg) - -pp_expr :: PprStyle -> CoreExpr -> Pretty -pp_expr sty expr - = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr +mkCoerceErr from_ty expr_ty + = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"), + ptext SLIT("From-type:") <+> ppr from_ty, + ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty + ] \end{code}