X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=7470294d1c204144efeaee9547cca22f79b32a18;hb=3fe27db88139e65f2a153c91b323cb43fd52185e;hp=2f278b28e87fe7c65298c9401e259301f640b955;hpb=e9e74aa537f61618306aa0285d8426c1d8fcb29d;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 2f278b2..7470294 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -7,71 +7,70 @@ module CoreLint ( lintCoreBindings, lintUnfolding, - beginPass, endPass + showPass, endPass ) where #include "HsVersions.h" -import IO ( hPutStr, stderr ) - -import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting ) import CoreSyn -import CoreUtils ( idFreeVars ) +import CoreFVs ( idFreeVars ) +import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType ) import Bag -import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt ) -import Id ( isConstantId, idMustBeINLINEd ) -import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar ) +import Literal ( literalType ) +import DataCon ( dataConRepType ) +import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding ) import VarSet -import VarEnv ( mkVarEnv ) -import Name ( isLocallyDefined, getSrcLoc ) +import Subst ( substTyWith ) +import Name ( getSrcLoc ) import PprCore -import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message, - ErrMsg, addErrLocHdrLine, pprBagOfErrors ) -import PrimRep ( PrimRep(..) ) -import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc ) -import Type ( Type, Kind, tyVarsOfType, - splitFunTy_maybe, mkPiType, mkTyVarTy, - splitForAllTy_maybe, splitTyConApp_maybe, - isUnLiftedType, typeKind, substTy, - splitAlgTyConApp_maybe, +import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass, + addErrLocHdrLine ) +import SrcLoc ( SrcLoc, noSrcLoc ) +import Type ( Type, tyVarsOfType, eqType, + splitFunTy_maybe, mkTyVarTy, + splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp, + isUnLiftedType, typeKind, isUnboxedTupleType, hasMoreBoxityInfo ) -import TyCon ( TyCon, isPrimTyCon, tyConDataCons ) +import TyCon ( isPrimTyCon ) +import BasicTypes ( RecFlag(..), isNonRec ) +import CmdLineOpts +import Maybe import Outputable +import IO ( hPutStrLn, stderr ) + infixr 9 `thenL`, `seqL` \end{code} %************************************************************************ %* * -\subsection{Start and end pass} +\subsection{End pass} %* * %************************************************************************ -@beginPass@ and @endPass@ don't really belong here, but it makes a convenient +@showPass@ and @endPass@ don't really belong here, but it makes a convenient place for them. They print out stuff before and after core passes, and do Core Lint when necessary. \begin{code} -beginPass :: String -> IO () -beginPass pass_name - | opt_D_show_passes - = hPutStr stderr ("*** " ++ pass_name ++ "\n") - | otherwise - = return () - - -endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind] -endPass pass_name dump_flag binds +endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind] +endPass dflags pass_name dump_flag binds = do + -- Report result size if required + -- This has the side effect of forcing the intermediate to be evaluated + if verbosity dflags >= 2 then + hPutStrLn stderr (" Result size = " ++ show (coreBindsSize binds)) + else + return () + -- Report verbosely, if required - dumpIfSet dump_flag pass_name - (pprCoreBindings binds) + dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds) -- Type check - lintCoreBindings pass_name binds + lintCoreBindings dflags pass_name binds return binds \end{code} @@ -108,28 +107,30 @@ Outstanding issues: -- may well be happening...); \begin{code} -lintCoreBindings :: String -> [CoreBind] -> IO () +lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO () -lintCoreBindings whoDunnit binds - | not opt_DoCoreLinting +lintCoreBindings dflags whoDunnit binds + | not (dopt Opt_DoCoreLinting dflags) = return () -lintCoreBindings whoDunnit binds +lintCoreBindings dflags whoDunnit binds = case (initL (lint_binds binds)) of - Nothing -> doIfSet opt_D_show_passes - (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n")) - + Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit) 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) + -- Put all the top-level binders in scope at the start + -- This is because transformation rules can bring something + -- into use 'unexpectedly' + lint_binds binds = addInScopeVars (bindersOfBinds binds) $ + mapL lint_bind binds + + lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL` + returnL () + lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs) display bad_news - = vcat [ - text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), + = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"), bad_news, ptext SLIT("*** Offending Program ***"), pprCoreBindings binds, @@ -147,20 +148,15 @@ We use this to check all unfoldings that come in from interfaces (it is very painful to catch errors otherwise): \begin{code} -lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr - -lintUnfolding locn expr - = case - initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr)) - of - Nothing -> Just expr - Just msg -> - pprTrace "WARNING: Discarded bad unfolding from interface:\n" - (vcat [msg, - ptext SLIT("*** Bad unfolding ***"), - ppr expr, - ptext SLIT("*** End unfolding ***")]) - Nothing +lintUnfolding :: SrcLoc + -> [Var] -- Treat these as in scope + -> CoreExpr + -> Maybe Message -- Nothing => OK + +lintUnfolding locn vars expr + = initL (addLoc (ImportedUnfolding locn) $ + addInScopeVars vars $ + lintCoreExpr expr) \end{code} %************************************************************************ @@ -172,19 +168,7 @@ lintUnfolding locn expr Check a core binding, returning the list of variables bound. \begin{code} -lintCoreBinding :: CoreBind -> LintM [Id] - -lintCoreBinding (NonRec binder rhs) - = lintSingleBinding (binder,rhs) `seqL` returnL [binder] - -lintCoreBinding (Rec pairs) - = addInScopeVars binders ( - mapL lintSingleBinding pairs `seqL` returnL binders - ) - where - binders = map fst pairs - -lintSingleBinding (binder,rhs) +lintSingleBinding rec_flag (binder,rhs) = addLoc (RhsOf binder) $ -- Check the rhs @@ -195,7 +179,8 @@ lintSingleBinding (binder,rhs) checkTys binder_ty ty (mkRhsMsg binder ty) `seqL` -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples) - checkL (not (isUnLiftedType binder_ty)) + checkL (not (isUnLiftedType binder_ty) + || (isNonRec rec_flag && exprOkForSpeculation rhs)) (mkRhsPrimMsg binder rhs) `seqL` -- Check whether binder's specialisations contain any out-of-scope variables @@ -218,20 +203,8 @@ lintSingleBinding (binder,rhs) \begin{code} lintCoreExpr :: CoreExpr -> LintM Type -lintCoreExpr (Var var) - | isConstantId var = returnL (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). - -- Ditto primitive Ids - - | otherwise = checkIdInScope var `seqL` returnL (idType var) +lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var) +lintCoreExpr (Lit lit) = returnL (literalType lit) lintCoreExpr (Note (Coerce to_ty from_ty) expr) = lintCoreExpr expr `thenL` \ expr_ty -> @@ -243,18 +216,17 @@ lintCoreExpr (Note (Coerce to_ty from_ty) expr) lintCoreExpr (Note other_note expr) = lintCoreExpr expr -lintCoreExpr (Let binds body) - = lintCoreBinding binds `thenL` \binders -> - if (null binders) then - lintCoreExpr body -- Can't add a new source location - else - addLoc (BodyOfLetRec binders) - (addInScopeVars binders (lintCoreExpr body)) +lintCoreExpr (Let (NonRec bndr rhs) body) + = lintSingleBinding NonRecursive (bndr,rhs) `seqL` + addLoc (BodyOfLetRec [bndr]) + (addInScopeVars [bndr] (lintCoreExpr body)) -lintCoreExpr e@(Con con args) - = addLoc (AnExpr e) $ - checkL (conOkForApp con) (mkConAppMsg e) `seqL` - lintCoreArgs (conType con) args +lintCoreExpr (Let (Rec pairs) body) + = addInScopeVars bndrs $ + mapL (lintSingleBinding Recursive) pairs `seqL` + addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) + where + bndrs = map fst pairs lintCoreExpr e@(App fun arg) = lintCoreExpr fun `thenL` \ ty -> @@ -263,10 +235,14 @@ lintCoreExpr e@(App fun arg) lintCoreExpr (Lam var expr) = addLoc (LambdaBodyOf var) $ - checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var) + (if isId var then + checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var) + else + returnL ()) `seqL` (addInScopeVars [var] $ lintCoreExpr expr `thenL` \ ty -> + returnL (mkPiType var ty)) lintCoreExpr e@(Case scrut var alts) @@ -288,7 +264,8 @@ lintCoreExpr e@(Case scrut var alts) addInScopeVars [var] ( -- Check the alternatives - checkAllCasesCovered e scrut_ty alts `seqL` + checkCaseAlts e scrut_ty alts `seqL` + mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) -> mapL (check alt_ty) alt_tys `seqL` returnL alt_ty) @@ -305,31 +282,40 @@ lintCoreExpr e@(Type ty) %* * %************************************************************************ -The boolean argument indicates whether we should flag type -applications to primitive types as being errors. +The basic version of these functions checks that the argument is a +subtype of the required type, as one would expect. \begin{code} lintCoreArgs :: Type -> [CoreArg] -> LintM Type +lintCoreArgs = lintCoreArgs0 checkTys -lintCoreArgs ty [] = returnL ty -lintCoreArgs ty (a : args) - = lintCoreArg ty a `thenL` \ res -> - lintCoreArgs res args +lintCoreArg :: Type -> CoreArg -> LintM Type +lintCoreArg = lintCoreArg0 checkTys \end{code} +The primitive version of these functions takes a check argument, +allowing a different comparison. + \begin{code} -lintCoreArg :: Type -> CoreArg -> LintM Type +lintCoreArgs0 check_tys ty [] = returnL ty +lintCoreArgs0 check_tys ty (a : args) + = lintCoreArg0 check_tys ty a `thenL` \ res -> + lintCoreArgs0 check_tys res args -lintCoreArg ty a@(Type arg_ty) +lintCoreArg0 check_tys ty a@(Type arg_ty) = lintTy arg_ty `seqL` lintTyApp ty arg_ty -lintCoreArg fun_ty arg +lintCoreArg0 check_tys fun_ty arg = -- Make sure function type matches argument lintCoreExpr arg `thenL` \ arg_ty -> - case (splitFunTy_maybe fun_ty) of - Just (arg,res) | (arg_ty == arg) -> returnL res - _ -> addErrL (mkAppMsg fun_ty arg_ty) + let + err = mkAppMsg fun_ty arg_ty + in + case splitFunTy_maybe fun_ty of + Just (arg,res) -> check_tys arg arg_ty err `seqL` + returnL res + _ -> addErrL err \end{code} \begin{code} @@ -338,6 +324,7 @@ lintTyApp ty arg_ty Nothing -> addErrL (mkTyAppMsg ty arg_ty) Just (tyvar,body) -> + if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else let tyvar_kind = tyVarKind tyvar argty_kind = typeKind arg_ty @@ -348,7 +335,7 @@ lintTyApp ty arg_ty -- error :: forall a:*. String -> a -- and then apply it to both boxed and unboxed types. then - returnL (substTy (mkVarEnv [(tyvar,arg_ty)]) body) + returnL (substTyWith [tyvar] [arg_ty] body) else addErrL (mkKindErrMsg tyvar arg_ty) @@ -369,42 +356,30 @@ lintTyApps fun_ty (arg_ty : arg_tys) %************************************************************************ \begin{code} -checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e) - -checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL - -checkAllCasesCovered e scrut_ty alts - = case splitTyConApp_maybe scrut_ty of { - Nothing -> addErrL (badAltsMsg e); - Just (tycon, tycon_arg_tys) -> - - if isPrimTyCon tycon then - checkL (hasDefault alts) (nonExhaustiveAltsMsg e) - else -#ifdef DEBUG - -- Algebraic cases are not necessarily exhaustive, because - -- the simplifer correctly eliminates case that can't - -- possibly match. - -- This code just emits a message to say so - let - missing_cons = filter not_in_alts (tyConDataCons tycon) - not_in_alts con = all (not_in_alt con) alts - not_in_alt con (DataCon con', _, _) = con /= con' - not_in_alt con other = True +checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM () +-- a) Check that the alts are non-empty +-- b) Check that the DEFAULT comes first, if it exists +-- c) Check that there's a default for infinite types +-- NB: Algebraic cases are not necessarily exhaustive, because +-- the simplifer correctly eliminates case that can't +-- possibly match. + +checkCaseAlts e ty [] + = addErrL (mkNullAltsMsg e) + +checkCaseAlts e ty alts + = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL` + checkL (isJust maybe_deflt || not is_infinite_ty) + (nonExhaustiveAltsMsg e) + where + (con_alts, maybe_deflt) = findDefault alts - case_bndr = case e of { Case _ bndr alts -> bndr } - in - if not (hasDefault alts || null missing_cons) then - pprTrace "Exciting (but not a problem)! Non-exhaustive case:" - (ppr case_bndr <+> ppr missing_cons) - nopL - else -#endif - nopL } - -hasDefault [] = False -hasDefault ((DEFAULT,_,_) : alts) = True -hasDefault (alt : alts) = hasDefault alts + non_deflt (DEFAULT, _, _) = False + non_deflt alt = True + + is_infinite_ty = case splitTyConApp_maybe ty of + Nothing -> False + Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon \end{code} \begin{code} @@ -416,12 +391,18 @@ lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs) = checkL (null args) (mkDefaultArgsMsg args) `seqL` lintCoreExpr rhs -lintCoreAlt scrut_ty alt@(con, args, rhs) - = addLoc (CaseAlt alt) ( +lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs) + = checkL (null args) (mkDefaultArgsMsg args) `seqL` + checkTys lit_ty scrut_ty + (mkBadPatMsg lit_ty scrut_ty) `seqL` + lintCoreExpr rhs + where + lit_ty = literalType lit - checkL (conOkForAlt con) (mkConAltMsg con) `seqL` +lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs) + = addLoc (CaseAlt alt) ( - mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg))) + mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg))) (mkUnboxedTupleMsg arg)) args `seqL` addInScopeVars args ( @@ -430,9 +411,10 @@ lintCoreAlt scrut_ty alt@(con, args, rhs) -- Scrutinee type must be a tycon applicn; checked by caller -- This code is remarkably compact considering what it does! -- NB: args must be in scope here so that the lintCoreArgs line works. - case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) -> - lintTyApps (conType con) tycon_arg_tys `thenL` \ con_type -> - lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty -> + -- NB: relies on existential type args coming *after* ordinary type args + case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) -> + lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type -> + lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty -> checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) } `seqL` @@ -441,7 +423,8 @@ lintCoreAlt scrut_ty alt@(con, args, rhs) )) where mk_arg b | isTyVar b = Type (mkTyVarTy b) - | otherwise = Var b + | isId b = Var b + | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b) \end{code} %************************************************************************ @@ -451,9 +434,10 @@ lintCoreAlt scrut_ty alt@(con, args, rhs) %************************************************************************ \begin{code} -lintBinder :: IdOrTyVar -> LintM () +lintBinder :: Var -> LintM () lintBinder v = nopL -- ToDo: lint its type +-- ToDo: lint its rules lintTy :: Type -> LintM () lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL` @@ -471,8 +455,8 @@ lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL` \begin{code} type LintM a = [LintLocInfo] -- Locations -> IdSet -- Local vars in scope - -> Bag ErrMsg -- Error messages so far - -> (Maybe a, Bag ErrMsg) -- Result and error messages (if any) + -> Bag Message -- Error messages so far + -> (Maybe a, Bag Message) -- Result and error messages (if any) data LintLocInfo = RhsOf Id -- The variable bound @@ -484,14 +468,11 @@ data LintLocInfo \end{code} \begin{code} -initL :: LintM a -> Maybe Message +initL :: LintM a -> Maybe Message {- errors -} initL m - = case (m [] emptyVarSet emptyBag) of { (_, errs) -> - if isEmptyBag errs then - Nothing - else - Just (pprBagOfErrors errs) - } + = case m [] emptyVarSet emptyBag of + (_, errs) | isEmptyBag errs -> Nothing + | otherwise -> Just (vcat (punctuate (text "") (bagToList errs))) returnL :: a -> LintM a returnL r loc scope errs = (Just r, errs) @@ -520,60 +501,58 @@ mapL f (x:xs) \begin{code} checkL :: Bool -> Message -> LintM () -checkL True msg loc scope errs = (Nothing, errs) -checkL False msg loc scope errs = (Nothing, addErr errs msg loc) +checkL True msg = nopL +checkL False msg = addErrL msg addErrL :: Message -> LintM a addErrL msg loc scope errs = (Nothing, addErr errs msg loc) -addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg - +addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message addErr errs_so_far msg locs - = ASSERT (not (null locs)) + = ASSERT( notNull locs ) errs_so_far `snocBag` mk_msg msg where - (loc, pref) = dumpLoc (head locs) - - mk_msg msg - | isNoSrcLoc loc = (loc, hang pref 4 msg) - | otherwise = addErrLocHdrLine loc pref msg + (loc, cxt1) = dumpLoc (head locs) + cxts = [snd (dumpLoc loc) | loc <- locs] + context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 + | otherwise = cxt1 + + mk_msg msg = addErrLocHdrLine loc context msg addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m loc scope errs = m (extra_loc:loc) scope errs -addInScopeVars :: [IdOrTyVar] -> LintM a -> LintM a +addInScopeVars :: [Var] -> LintM a -> LintM a addInScopeVars ids m loc scope errs = m loc (scope `unionVarSet` mkVarSet ids) errs \end{code} \begin{code} -checkIdInScope :: IdOrTyVar -> LintM () +checkIdInScope :: Var -> LintM () checkIdInScope id = checkInScope (ptext SLIT("is out of scope")) id -checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM () +checkBndrIdInScope :: Var -> Var -> LintM () checkBndrIdInScope binder id = checkInScope msg id where msg = ptext SLIT("is out of scope inside info for") <+> ppr binder -checkInScope :: SDoc -> IdOrTyVar -> LintM () -checkInScope loc_msg id loc scope errs - | isLocallyDefined id - && not (id `elemVarSet` scope) - && not (idMustBeINLINEd id) -- Constructors and dict selectors - -- don't have bindings, - -- just MustInline prags - = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc) +checkInScope :: SDoc -> Var -> LintM () +checkInScope loc_msg var loc scope errs + | mustHaveLocalBinding var && not (var `elemVarSet` scope) + = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc) | otherwise - = (Nothing,errs) + = nopL loc scope errs checkTys :: Type -> Type -> Message -> LintM () -checkTys ty1 ty2 msg loc scope errs - | ty1 == ty2 = (Nothing, errs) - | otherwise = (Nothing, addErr errs msg loc) +-- check ty2 is subtype of ty1 (ie, has same structure but usage +-- annotations need only be consistent, not equal) +checkTys ty1 ty2 msg + | ty1 `eqType` ty2 = nopL + | otherwise = addErrL msg \end{code} @@ -590,7 +569,10 @@ dumpLoc (RhsOf v) dumpLoc (LambdaBodyOf b) = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)) -dumpLoc (BodyOfLetRec bs) +dumpLoc (BodyOfLetRec []) + = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders"))) + +dumpLoc (BodyOfLetRec bs@(_:_)) = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)) dumpLoc (AnExpr e) @@ -602,32 +584,24 @@ dumpLoc (CaseAlt (con, args, rhs)) dumpLoc (ImportedUnfolding locn) = (locn, brackets (ptext SLIT("in an imported unfolding"))) -pp_binders :: [Id] -> SDoc +pp_binders :: [Var] -> SDoc pp_binders bs = sep (punctuate comma (map pp_binder bs)) -pp_binder :: Id -> SDoc -pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] +pp_binder :: Var -> SDoc +pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] + | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)] \end{code} \begin{code} ------------------------------------------------------ -- Messages for case expressions -mkConAppMsg :: CoreExpr -> Message -mkConAppMsg e - = hang (text "Application of newtype constructor:") - 4 (ppr e) - -mkConAltMsg :: Con -> Message -mkConAltMsg con - = text "PrimOp in case pattern:" <+> ppr con - mkNullAltsMsg :: CoreExpr -> Message mkNullAltsMsg e = hang (text "Case expression with no alternatives:") 4 (ppr e) -mkDefaultArgsMsg :: [IdOrTyVar] -> Message +mkDefaultArgsMsg :: [Var] -> Message mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") 4 (ppr args) @@ -643,15 +617,13 @@ mkScrutMsg var scrut_ty text "Result binder type:" <+> ppr (idType var), text "Scrutinee type:" <+> ppr scrut_ty] -badAltsMsg :: CoreExpr -> Message -badAltsMsg e - = hang (text "Case statement scrutinee is not a data type:") - 4 (ppr e) + +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) nonExhaustiveAltsMsg :: CoreExpr -> Message nonExhaustiveAltsMsg e - = hang (text "Case expression with non-exhaustive alternatives") - 4 (ppr e) + = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) mkBadPatMsg :: Type -> Type -> Message mkBadPatMsg con_result_ty scrut_ty