+match_pred _ _ _ _ = Nothing
+\end{code}
+
+
+%************************************************************************
+%* *
+ GADTs
+%* *
+%************************************************************************
+
+Note [Pruning dead case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider data T a where
+ T1 :: T Int
+ T2 :: T a
+
+ newtype X = MkX Int
+ newtype Y = MkY Char
+
+ type family F a
+ type instance F Bool = Int
+
+Now consider case x of { T1 -> e1; T2 -> e2 }
+
+The question before the house is this: if I know something about the type
+of x, can I prune away the T1 alternative?
+
+Suppose x::T Char. It's impossible to construct a (T Char) using T1,
+ Answer = YES (clearly)
+
+Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated
+to 'Bool', in which case x::T Int, so
+ ANSWER = NO (clearly)
+
+Suppose x::T X. Then *in Haskell* it's impossible to construct a (non-bottom)
+value of type (T X) using T1. But *in FC* it's quite possible. The newtype
+gives a coercion
+ CoX :: X ~ Int
+So (T CoX) :: T X ~ T Int; hence (T1 `cast` sym (T CoX)) is a non-bottom value
+of type (T X) constructed with T1. Hence
+ ANSWER = NO (surprisingly)
+
+Furthermore, this can even happen; see Trac #1251. GHC's newtype-deriving
+mechanism uses a cast, just as above, to move from one dictionary to another,
+in effect giving the programmer access to CoX.
+
+Finally, suppose x::T Y. Then *even in FC* we can't construct a
+non-bottom value of type (T Y) using T1. That's because we can get
+from Y to Char, but not to Int.
+
+
+Here's a related question. data Eq a b where EQ :: Eq a a
+Consider
+ case x of { EQ -> ... }
+
+Suppose x::Eq Int Char. Is the alternative dead? Clearly yes.
+
+What about x::Eq Int a, in a context where we have evidence that a~Char.
+Then again the alternative is dead.
+
+
+ Summary
+
+We are really doing a test for unsatisfiability of the type
+constraints implied by the match. And that is clearly, in general, a
+hard thing to do.
+
+However, since we are simply dropping dead code, a conservative test
+suffices. There is a continuum of tests, ranging from easy to hard, that
+drop more and more dead code.
+
+For now we implement a very simple test: type variables match
+anything, type functions (incl newtypes) match anything, and only
+distinct data types fail to match. We can elaborate later.
+
+\begin{code}
+dataConCannotMatch :: [Type] -> DataCon -> Bool
+-- Returns True iff the data con *definitely cannot* match a
+-- scrutinee of type (T tys)
+-- where T is the type constructor for the data con
+--
+dataConCannotMatch tys con
+ | null eq_spec = False -- Common
+ | all isTyVarTy tys = False -- Also common
+ | otherwise
+ = cant_match_s (map (substTyVar subst . fst) eq_spec)
+ (map snd eq_spec)
+ where
+ dc_tvs = dataConUnivTyVars con
+ eq_spec = dataConEqSpec con
+ subst = zipTopTvSubst dc_tvs tys
+
+ cant_match_s :: [Type] -> [Type] -> Bool
+ cant_match_s tys1 tys2 = ASSERT( equalLength tys1 tys2 )
+ or (zipWith cant_match tys1 tys2)
+
+ cant_match :: Type -> Type -> Bool
+ cant_match t1 t2
+ | Just t1' <- coreView t1 = cant_match t1' t2
+ | Just t2' <- coreView t2 = cant_match t1 t2'
+
+ cant_match (FunTy a1 r1) (FunTy a2 r2)
+ = cant_match a1 a2 || cant_match r1 r2
+
+ cant_match (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+ | isDataTyCon tc1 && isDataTyCon tc2
+ = tc1 /= tc2 || cant_match_s tys1 tys2
+
+ cant_match (FunTy {}) (TyConApp tc _) = isDataTyCon tc
+ cant_match (TyConApp tc _) (FunTy {}) = isDataTyCon tc
+ -- tc can't be FunTyCon by invariant
+
+ cant_match (AppTy f1 a1) ty2
+ | Just (f2, a2) <- repSplitAppTy_maybe ty2
+ = cant_match f1 f2 || cant_match a1 a2
+ cant_match ty1 (AppTy f2 a2)
+ | Just (f1, a1) <- repSplitAppTy_maybe ty1
+ = cant_match f1 f2 || cant_match a1 a2
+
+ cant_match _ _ = False -- Safe!
+
+-- Things we could add;
+-- foralls
+-- look through newtypes
+-- take account of tyvar bindings (EQ example above)
+\end{code}
+
+
+%************************************************************************
+%* *
+ What a refinement is
+%* *
+%************************************************************************
+
+\begin{code}
+data Refinement = Reft InScopeSet InternalReft
+
+type InternalReft = TyVarEnv (Coercion, Type)
+-- INVARIANT: a->(co,ty) then co :: (a:=:ty)
+-- Not necessarily idemopotent
+
+instance Outputable Refinement where
+ ppr (Reft _in_scope env)
+ = ptext (sLit "Refinement") <+>
+ braces (ppr env)
+
+emptyRefinement :: Refinement
+emptyRefinement = (Reft emptyInScopeSet emptyVarEnv)
+
+isEmptyRefinement :: Refinement -> Bool
+isEmptyRefinement (Reft _ env) = isEmptyVarEnv env
+
+refineType :: Refinement -> Type -> Maybe (Coercion, Type)
+-- Apply the refinement to the type.
+-- If (refineType r ty) = (co, ty')
+-- Then co :: ty:=:ty'
+-- Nothing => the refinement does nothing to this type
+refineType (Reft in_scope env) ty
+ | not (isEmptyVarEnv env), -- Common case
+ any (`elemVarEnv` env) (varSetElems (tyVarsOfType ty))
+ = Just (substTy co_subst ty, substTy tv_subst ty)
+ | otherwise
+ = Nothing -- The type doesn't mention any refined type variables
+ where
+ tv_subst = mkTvSubst in_scope (mapVarEnv snd env)
+ co_subst = mkTvSubst in_scope (mapVarEnv fst env)
+
+refinePred :: Refinement -> PredType -> Maybe (Coercion, PredType)
+refinePred (Reft in_scope env) pred
+ | not (isEmptyVarEnv env), -- Common case
+ any (`elemVarEnv` env) (varSetElems (tyVarsOfPred pred))
+ = Just (mkPredTy (substPred co_subst pred), substPred tv_subst pred)
+ | otherwise
+ = Nothing -- The type doesn't mention any refined type variables
+ where
+ tv_subst = mkTvSubst in_scope (mapVarEnv snd env)
+ co_subst = mkTvSubst in_scope (mapVarEnv fst env)
+
+refineResType :: Refinement -> Type -> Maybe (Coercion, Type)
+-- Like refineType, but returns the 'sym' coercion
+-- If (refineResType r ty) = (co, ty')
+-- Then co :: ty':=:ty
+refineResType reft ty
+ = case refineType reft ty of
+ Just (co, ty1) -> Just (mkSymCoercion co, ty1)
+ Nothing -> Nothing
+\end{code}
+
+
+%************************************************************************
+%* *
+ Simple generation of a type refinement
+%* *
+%************************************************************************
+
+\begin{code}
+matchRefine :: [CoVar] -> Refinement
+\end{code}
+
+Given a list of coercions, where for each coercion c::(ty1~ty2), the type ty2
+is a specialisation of ty1, produce a type refinement that maps the variables
+of ty1 to the corresponding sub-terms of ty2 using appropriate coercions; eg,
+
+ matchRefine (co :: [(a, b)] ~ [(c, Maybe d)])
+ = { right (left (right co)) :: a ~ c
+ , right (right co) :: b ~ Maybe d
+ }
+
+Precondition: The rhs types must indeed be a specialisation of the lhs types;
+ i.e., some free variables of the lhs are replaced with either distinct free
+ variables or proper type terms to obtain the rhs. (We don't perform full
+ unification or type matching here!)
+
+NB: matchRefine does *not* expand the type synonyms.
+
+\begin{code}
+matchRefine co_vars
+ = Reft in_scope (foldr plusVarEnv emptyVarEnv (map refineOne co_vars))
+ where
+ in_scope = foldr extend emptyInScopeSet co_vars
+
+ -- For each co_var, add it *and* the tyvars it mentions, to in_scope
+ extend co_var in_scope
+ = extendInScopeSetSet in_scope $
+ extendVarSet (tyVarsOfType (tyVarKind co_var)) co_var
+
+ refineOne co_var = refine (TyVarTy co_var) ty1 ty2
+ where
+ (ty1, ty2) = splitCoercionKind (tyVarKind co_var)
+
+ refine co (TyVarTy tv) ty = unitVarEnv tv (co, ty)
+ refine co (TyConApp _ tys) (TyConApp _ tys') = refineArgs co tys tys'
+ refine _ (PredTy _) (PredTy _) =
+ error "Unify.matchRefine: PredTy"
+ refine co (FunTy arg res) (FunTy arg' res') =
+ refine (mkRightCoercion (mkLeftCoercion co)) arg arg'
+ `plusVarEnv`
+ refine (mkRightCoercion co) res res'
+ refine co (AppTy fun arg) (AppTy fun' arg') =
+ refine (mkLeftCoercion co) fun fun'
+ `plusVarEnv`
+ refine (mkRightCoercion co) arg arg'
+ refine co (ForAllTy tv ty) (ForAllTy _tv ty') =
+ refine (mkForAllCoercion tv co) ty ty' `delVarEnv` tv
+ refine _ _ _ = error "RcGadt.matchRefine: mismatch"
+
+ refineArgs :: Coercion -> [Type] -> [Type] -> InternalReft
+ refineArgs co tys tys' =
+ fst $ foldr refineArg (emptyVarEnv, id) (zip tys tys')
+ where
+ refineArg (ty, ty') (reft, coWrapper)
+ = (refine (mkRightCoercion (coWrapper co)) ty ty' `plusVarEnv` reft,
+ mkLeftCoercion . coWrapper)