path: root/ghc/compiler/coreSyn/CoreLint.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[CoreLint]{A ``lint'' pass to check for Core correctness}

\begin{code}
module CoreLint (
	lintCoreBindings,
	lintUnfolding, 
	showPass, endPass
    ) where

#include "HsVersions.h"

import CoreSyn
import CoreFVs		( idFreeVars )
import CoreUtils	( findDefault, exprOkForSpeculation, coreBindsSize )
import Unify      	( coreRefineTys )
import Bag
import Literal		( literalType )
import DataCon		( dataConRepType, isVanillaDataCon, dataConTyCon, dataConWorkId )
import TysWiredIn	( tupleCon )
import Var		( Var, Id, TyVar, idType, tyVarKind, mustHaveLocalBinding )
import VarSet
import Name		( getSrcLoc )
import PprCore
import ErrUtils		( dumpIfSet_core, ghcExit, Message, showPass,
			  mkLocMessage, debugTraceMsg )
import SrcLoc		( SrcLoc, noSrcLoc, mkSrcSpan )
import Type		( Type, tyVarsOfType, coreEqType,
			  splitFunTy_maybe, mkTyVarTys,
			  splitForAllTy_maybe, splitTyConApp_maybe,
			  isUnLiftedType, typeKind, mkForAllTy, mkFunTy,
			  isUnboxedTupleType, isSubKind,
			  substTyWith, emptyTvSubst, extendTvInScope, 
			  TvSubst, TvSubstEnv, mkTvSubst, setTvSubstEnv, substTy,
			  extendTvSubst, composeTvSubst, isInScope,
			  getTvSubstEnv, getTvInScope )
import TyCon		( isPrimTyCon )
import BasicTypes	( RecFlag(..), Boxity(..), isNonRec )
import StaticFlags	( opt_PprStyle_Debug )
import DynFlags		( DynFlags, DynFlag(..), dopt )
import Outputable

#ifdef DEBUG
import Util             ( notNull )
#endif

import Maybe

\end{code}

%************************************************************************
%*									*
\subsection{End pass}
%*									*
%************************************************************************

@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}
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
	debugTraceMsg dflags 2 $
		(text "    Result size =" <+> int (coreBindsSize binds))

	-- Report verbosely, if required
	dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)

	-- Type check
	lintCoreBindings dflags pass_name binds

	return binds
\end{code}


%************************************************************************
%*									*
\subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
%*									*
%************************************************************************

Checks that a set of core bindings is well-formed.  The PprStyle and String
just control what we print in the event of an error.  The Bool value
indicates whether we have done any specialisation yet (in which case we do
some extra checks).

We check for
	(a) type errors
	(b) Out-of-scope type variables
	(c) Out-of-scope local variables
	(d) Ill-kinded types

If we have done specialisation the we check that there are
	(a) No top-level bindings of primitive (unboxed type)

Outstanding issues:

    --
    -- Things are *not* OK if:
    --
    --  * Unsaturated type app before specialisation has been done;
    --
    --  * Oversaturated type app after specialisation (eta reduction
    --   may well be happening...);

\begin{code}
lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()

lintCoreBindings dflags whoDunnit binds
  | not (dopt Opt_DoCoreLinting dflags)
  = return ()

lintCoreBindings dflags whoDunnit binds
  = case (initL (lint_binds binds)) of
      Nothing       -> showPass dflags ("Core Linted result of " ++ whoDunnit)
      Just bad_news -> printDump (display bad_news)	>>
		       ghcExit dflags 1
  where
	-- 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) $
		       mapM lint_bind binds 

    lint_bind (Rec prs)		= mapM_ (lintSingleBinding Recursive) prs
    lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)

    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}

%************************************************************************
%*									*
\subsection[lintUnfolding]{lintUnfolding}
%*									*
%************************************************************************

We use this to check all unfoldings that come in from interfaces
(it is very painful to catch errors otherwise):

\begin{code}
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}

%************************************************************************
%*									*
\subsection[lintCoreBinding]{lintCoreBinding}
%*									*
%************************************************************************

Check a core binding, returning the list of variables bound.

\begin{code}
lintSingleBinding rec_flag (binder,rhs)
  = addLoc (RhsOf binder) $
         -- Check the rhs 
    do { ty <- lintCoreExpr rhs	
       ; lintBinder binder -- Check match to RHS type
       ; binder_ty <- applySubst binder_ty
       ; checkTys binder_ty ty (mkRhsMsg binder ty)
        -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
       ; checkL (not (isUnLiftedType binder_ty)
            || (isNonRec rec_flag && exprOkForSpeculation rhs))
 	   (mkRhsPrimMsg binder rhs)
        -- Check whether binder's specialisations contain any out-of-scope variables
       ; mapM_ (checkBndrIdInScope binder) bndr_vars }
	  
	-- We should check the unfolding, if any, but this is tricky because
	-- the unfolding is a SimplifiableCoreExpr. Give up for now.
  where
    binder_ty = idType binder
    bndr_vars = varSetElems (idFreeVars binder)
\end{code}

%************************************************************************
%*									*
\subsection[lintCoreExpr]{lintCoreExpr}
%*									*
%************************************************************************

\begin{code}
type InType  = Type	-- Substitution not yet applied
type OutType = Type	-- Substitution has been applied to this

lintCoreExpr :: CoreExpr -> LintM OutType
-- The returned type has the substitution from the monad 
-- already applied to it:
--	lintCoreExpr e subst = exprType (subst e)

lintCoreExpr (Var var)
  = do	{ checkIdInScope var 
 	; applySubst (idType var) }

lintCoreExpr (Lit lit)
  = return (literalType lit)

lintCoreExpr (Note (Coerce to_ty from_ty) expr)
  = do	{ expr_ty <- lintCoreExpr expr
	; to_ty <- lintTy to_ty
	; from_ty <- lintTy from_ty	
	; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
	; return to_ty }

lintCoreExpr (Note other_note expr)
  = lintCoreExpr expr

lintCoreExpr (Let (NonRec bndr rhs) body)
  = do	{ lintSingleBinding NonRecursive (bndr,rhs)
	; addLoc (BodyOfLetRec [bndr])
		 (addInScopeVars [bndr] (lintCoreExpr body)) }

lintCoreExpr (Let (Rec pairs) body) 
  = addInScopeVars bndrs	$
    do	{ mapM (lintSingleBinding Recursive) pairs	
	; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
  where
    bndrs = map fst pairs

lintCoreExpr e@(App fun (Type ty))
-- This is like 'let' for types
-- It's needed when dealing with desugarer output for GADTs. Consider
--   data T = forall a. T a (a->Int) Bool
--    f :: T -> ... -> 
--    f (T x f True)  = <e1>
--    f (T y g False) = <e2>
-- After desugaring we get
--	f t b = case t of 
--		  T a (x::a) (f::a->Int) (b:Bool) ->
--		    case b of 
--			True -> <e1>
--			False -> (/\b. let y=x; g=f in <e2>) a
-- And for a reason I now forget, the ...<e2>... can mention a; so 
-- we want Lint to know that b=a.  Ugh.
--
-- I tried quite hard to make the necessity for this go away, by changing the 
-- desugarer, but the fundamental problem is this:
--	
--	T a (x::a) (y::Int) -> let fail::a = ...
--			       in (/\b. ...(case ... of       
--						True  -> x::b
--					 	False -> fail)
--				  ) a
-- Now the inner case look as though it has incompatible branches.
  = addLoc (AnExpr e) $
    go fun [ty]
  where
    go (App fun (Type ty)) tys
	= do { go fun (ty:tys) }
    go (Lam tv body) (ty:tys)
	= do  { checkL (isTyVar tv) (mkKindErrMsg tv ty)	-- Not quite accurate
	      ; ty' <- lintTy ty; 
	      ; checkKinds tv ty'
		-- Now extend the substitution so we 
		-- take advantage of it in the body
	      ; addInScopeVars [tv] $
	        extendSubstL tv ty' $
		go body tys }
    go fun tys
	= do  { fun_ty <- lintCoreExpr fun
	      ; lintCoreArgs fun_ty (map Type tys) }

lintCoreExpr e@(App fun arg)
  = do	{ fun_ty <- lintCoreExpr fun
	; addLoc (AnExpr e) $
          lintCoreArg fun_ty arg }

lintCoreExpr (Lam var expr)
  = addLoc (LambdaBodyOf var) $
    do	{ body_ty <- addInScopeVars [var] $
                     lintCoreExpr expr
	; if isId var then do
		{ var_ty <- lintId var 	
		; return (mkFunTy var_ty body_ty) }
	  else
		return (mkForAllTy var body_ty)
	}
	-- The applySubst is needed to apply the subst to var

lintCoreExpr e@(Case scrut var alt_ty alts) =
       -- Check the scrutinee
  do { scrut_ty <- lintCoreExpr scrut
     ; alt_ty   <- lintTy alt_ty  
     ; var_ty   <- lintTy (idType var)	
	-- Don't use lintId on var, because unboxed tuple is legitimate

     ; checkTys var_ty scrut_ty (mkScrutMsg var scrut_ty)

     -- If the binder is an unboxed tuple type, don't put it in scope
     ; let vars = if (isUnboxedTupleType (idType var)) then [] else [var]
     ; addInScopeVars vars $
       do { -- Check the alternatives
            checkCaseAlts e scrut_ty alts
          ; mapM (lintCoreAlt scrut_ty alt_ty) alts
          ; return alt_ty } }

lintCoreExpr e@(Type ty)
  = addErrL (mkStrangeTyMsg e)
\end{code}

%************************************************************************
%*									*
\subsection[lintCoreArgs]{lintCoreArgs}
%*									*
%************************************************************************

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
lintCoreArg  :: Type -> CoreArg   -> LintM Type
-- First argument has already had substitution applied to it
\end{code}

\begin{code}
lintCoreArgs ty [] = return ty
lintCoreArgs ty (a : args) = 
  do { res <- lintCoreArg ty a
     ; lintCoreArgs res args }

lintCoreArg fun_ty a@(Type arg_ty) = 
  do { arg_ty <- lintTy arg_ty	
     ; lintTyApp fun_ty arg_ty }

lintCoreArg fun_ty arg = 
       -- Make sure function type matches argument
  do { arg_ty <- lintCoreExpr arg
     ; let err = mkAppMsg fun_ty arg_ty arg
     ; case splitFunTy_maybe fun_ty of
        Just (arg,res) -> 
          do { checkTys arg arg_ty err 
             ; return res }
        _ -> addErrL err }
\end{code}

\begin{code}
-- Both args have had substitution applied
lintTyApp ty arg_ty 
  = case splitForAllTy_maybe ty of
      Nothing -> addErrL (mkTyAppMsg ty arg_ty)

      Just (tyvar,body)
        -> do	{ checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
		; checkKinds tyvar arg_ty
		; return (substTyWith [tyvar] [arg_ty] body) }

lintTyApps fun_ty [] = return fun_ty

lintTyApps fun_ty (arg_ty : arg_tys) = 
  do { fun_ty' <- lintTyApp fun_ty arg_ty
     ; lintTyApps fun_ty' arg_tys }

checkKinds tyvar arg_ty
	-- 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.
  = checkL (argty_kind `isSubKind` tyvar_kind)
	   (mkKindErrMsg tyvar arg_ty)
  where
    tyvar_kind = tyVarKind tyvar
    argty_kind = typeKind arg_ty
\end{code}


%************************************************************************
%*									*
\subsection[lintCoreAlts]{lintCoreAlts}
%*									*
%************************************************************************

\begin{code}
checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
-- a) Check that the alts are non-empty
-- b1) Check that the DEFAULT comes first, if it exists
-- b2) Check that the others are in increasing order
-- 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 = 
  do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
     ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
     ; checkL (isJust maybe_deflt || not is_infinite_ty)
	   (nonExhaustiveAltsMsg e) }
  where
    (con_alts, maybe_deflt) = findDefault alts

	-- Check that successive alternatives have increasing tags 
    increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
    increasing_tag other 		     = True

    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}
checkAltExpr :: CoreExpr -> OutType -> LintM ()
checkAltExpr expr ann_ty
  = do { actual_ty <- lintCoreExpr expr 
       ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }

lintCoreAlt :: OutType 		-- Type of scrutinee
            -> OutType          -- Type of the alternative
	    -> CoreAlt
	    -> LintM ()

lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) = 
  do { checkL (null args) (mkDefaultArgsMsg args)
     ; checkAltExpr rhs alt_ty }

lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) = 
  do { checkL (null args) (mkDefaultArgsMsg args)
     ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)	
     ; checkAltExpr rhs alt_ty } 
  where
    lit_ty = literalType lit

lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
  | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty,
    tycon == dataConTyCon con
  = addLoc (CaseAlt alt) $
    addInScopeVars args $	-- Put the args in scope before lintBinder,
				-- because the Ids mention the type variables
    if isVanillaDataCon con then
    do	{ addLoc (CasePat alt) $ do
	  { mapM lintBinder args 
         	-- FIX! Add check that all args are Ids.
		 -- Check the pattern
		 -- 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.
	         -- NB: relies on existential type args coming *after* ordinary type args

	  ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
                 -- Can just map Var as we know that this is a vanilla datacon
	  ; con_result_ty <- lintCoreArgs con_type (map Var args)
	  ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) 
 	  }
	       -- Check the RHS
	; checkAltExpr rhs alt_ty }

    else 	-- GADT
    do	{ let (tvs,ids) = span isTyVar args
        ; subst <- getTvSubst 
	; let in_scope  = getTvInScope subst
	      subst_env = getTvSubstEnv subst
        ; case coreRefineTys con tvs scrut_ty of {
             Nothing          -> return () ;	-- Alternative is dead code
             Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
    do 	{ addLoc (CasePat alt) $ do
	  { tvs'     <- mapM lintTy (mkTyVarTys tvs)
	  ; con_type <- lintTyApps (dataConRepType con) tvs'
	  ; mapM lintBinder ids	-- Lint Ids in the refined world
	  ; lintCoreArgs con_type (map Var ids)
	  }

	; let refined_alt_ty = substTy (mkTvSubst in_scope refine) alt_ty
		-- alt_ty is already an OutType, so don't re-apply 
		-- the current substitution.  But we must apply the
		-- refinement so that the check in checkAltExpr is ok
	; checkAltExpr rhs refined_alt_ty
    } } }

  | otherwise	-- Scrut-ty is wrong shape
  = addErrL (mkBadAltMsg scrut_ty alt)
\end{code}

%************************************************************************
%*									*
\subsection[lint-types]{Types}
%*									*
%************************************************************************

\begin{code}
lintBinder :: Var -> LintM ()
lintBinder var | isId var  = lintId var >> return ()
	       | otherwise = return ()

lintId :: Var -> LintM OutType
-- ToDo: lint its rules
lintId id
  = do 	{ checkL (not (isUnboxedTupleType (idType id))) 
		 (mkUnboxedTupleMsg id)
		-- No variable can be bound to an unboxed tuple.
	; lintTy (idType id) }

lintTy :: InType -> LintM OutType
-- Check the type, and apply the substitution to it
-- ToDo: check the kind structure of the type
lintTy ty 
  = do	{ ty' <- applySubst ty
	; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty'))
	; return ty' }
\end{code}

    
%************************************************************************
%*									*
\subsection[lint-monad]{The Lint monad}
%*									*
%************************************************************************

\begin{code}
newtype LintM a = 
   LintM { unLintM :: 
            [LintLocInfo] ->         -- Locations
            TvSubst ->               -- Current type substitution; we also use this
				     -- to keep track of all the variables in scope,
				     -- both Ids and TyVars
	    Bag Message ->           -- Error messages so far
	    (Maybe a, Bag Message) } -- Result and error messages (if any)

instance Monad LintM where
  return x = LintM (\ loc subst errs -> (Just x, errs))
  fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
  m >>= k  = LintM (\ loc subst errs -> 
                       let (res, errs') = unLintM m loc subst errs in
                         case res of
                           Just r -> unLintM (k r) loc subst errs'
                           Nothing -> (Nothing, errs'))

data LintLocInfo
  = RhsOf Id		-- The variable bound
  | LambdaBodyOf Id	-- The lambda-binder
  | BodyOfLetRec [Id]	-- One of the binders
  | CaseAlt CoreAlt	-- Case alternative
  | CasePat CoreAlt	-- *Pattern* of the case alternative
  | AnExpr CoreExpr	-- Some expression
  | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
\end{code}

                 
\begin{code}
initL :: LintM a -> Maybe Message {- errors -}
initL m
  = case unLintM m [] emptyTvSubst emptyBag of
      (_, errs) | isEmptyBag errs -> Nothing
		| otherwise	  -> Just (vcat (punctuate (text "") (bagToList errs)))
\end{code}

\begin{code}
checkL :: Bool -> Message -> LintM ()
checkL True  msg = return ()
checkL False msg = addErrL msg

addErrL :: Message -> LintM a
addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))

addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
addErr subst errs_so_far msg locs
  = ASSERT( notNull locs )
    errs_so_far `snocBag` mk_msg msg
  where
   (loc, cxt1) = dumpLoc (head locs)
   cxts        = [snd (dumpLoc loc) | loc <- locs]   
   context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
				      ptext SLIT("Substitution:") <+> ppr subst
	       | otherwise	    = cxt1
 
   mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)

addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m =
  LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)

addInScopeVars :: [Var] -> LintM a -> LintM a
addInScopeVars vars m = 
  LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)

updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
updateTvSubstEnv substenv m = 
  LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)

getTvSubst :: LintM TvSubst
getTvSubst = LintM (\ loc subst errs -> (Just subst, errs))

applySubst :: Type -> LintM Type
applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }

extendSubstL :: TyVar -> Type -> LintM a -> LintM a
extendSubstL tv ty m
  = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
\end{code}

\begin{code}
checkIdInScope :: Var -> LintM ()
checkIdInScope id 
  = do { checkL (not (id == oneTupleDataConId))
		(ptext SLIT("Illegal one-tuple"))
       ; checkInScope (ptext SLIT("is out of scope")) id }

oneTupleDataConId :: Id	-- Should not happen
oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)

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 -> Var -> LintM ()
checkInScope loc_msg var =
 do { subst <- getTvSubst
    ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
             (hsep [ppr var, loc_msg]) }

checkTys :: Type -> Type -> Message -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied
checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
\end{code}

%************************************************************************
%*									*
\subsection{Error messages}
%*									*
%************************************************************************

\begin{code}
dumpLoc (RhsOf v)
  = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))

dumpLoc (LambdaBodyOf b)
  = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))

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)
  = (noSrcLoc, text "In the expression:" <+> ppr e)

dumpLoc (CaseAlt (con, args, rhs))
  = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))

dumpLoc (CasePat (con, args, rhs))
  = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))

dumpLoc (ImportedUnfolding locn)
  = (locn, brackets (ptext SLIT("in an imported unfolding")))

pp_binders :: [Var] -> SDoc
pp_binders bs = sep (punctuate comma (map pp_binder bs))

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

mkNullAltsMsg :: CoreExpr -> Message
mkNullAltsMsg e 
  = hang (text "Case expression with no alternatives:")
	 4 (ppr e)

mkDefaultArgsMsg :: [Var] -> Message
mkDefaultArgsMsg args 
  = hang (text "DEFAULT case with binders")
	 4 (ppr args)

mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
mkCaseAltMsg e ty1 ty2
  = hang (text "Type of case alternatives not the same as the annotation on case:")
	 4 (vcat [ppr ty1, ppr ty2, ppr e])

mkScrutMsg :: Id -> Type -> Message
mkScrutMsg var scrut_ty
  = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
	  text "Result binder type:" <+> ppr (idType var),
	  text "Scrutinee type:" <+> ppr scrut_ty]


mkNonDefltMsg e
  = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
mkNonIncreasingAltsMsg e
  = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)

nonExhaustiveAltsMsg :: CoreExpr -> Message
nonExhaustiveAltsMsg e
  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)

mkBadPatMsg :: Type -> Type -> Message
mkBadPatMsg con_result_ty scrut_ty
  = vcat [
	text "In a case alternative, pattern result type doesn't match scrutinee type:",
	text "Pattern result type:" <+> ppr con_result_ty,
	text "Scrutinee type:" <+> ppr scrut_ty
    ]

mkBadAltMsg :: Type -> CoreAlt -> Message
mkBadAltMsg scrut_ty alt
  = vcat [ text "Data alternative when scrutinee is not a tycon application",
	   text "Scrutinee type:" <+> ppr scrut_ty,
	   text "Alternative:" <+> pprCoreAlt alt ]

------------------------------------------------------
--	Other error messages

mkAppMsg :: Type -> Type -> CoreExpr -> Message
mkAppMsg fun_ty arg_ty arg
  = vcat [ptext SLIT("Argument value doesn't match argument type:"),
	      hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
	      hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
	      hang (ptext SLIT("Arg:")) 4 (ppr arg)]

mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg tyvar arg_ty
  = vcat [ptext SLIT("Kinds don't match in type application:"),
	  hang (ptext SLIT("Type variable:"))
		 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
	  hang (ptext SLIT("Arg type:"))   
	         4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]

mkTyAppMsg :: Type -> Type -> Message
mkTyAppMsg ty arg_ty
  = vcat [text "Illegal type application:",
	      hang (ptext SLIT("Exp type:"))
		 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
	      hang (ptext SLIT("Arg type:"))   
	         4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]

mkRhsMsg :: Id -> Type -> Message
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 -> Message
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)]
	     ]

mkUnboxedTupleMsg :: Id -> Message
mkUnboxedTupleMsg binder
  = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
	  hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]

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
    ]

mkStrangeTyMsg e
  = ptext SLIT("Type where expression expected:") <+> ppr e
\end{code}