Commit 171d4582 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fix newtype deriving properly (un-doing Audreys patch)

The newtype-deriving mechanism generates a HsSyn case expression looking
like this
	case (d `cast` co) of { ... }
That is, the case expression scrutinises a dictionary.  This is 
otherwise never seen in HsSyn, and it made the desugarer
(Check.get_unused_cons) crash in tcTyConAppTyCon.

It would really be better to generate Core in TcInstDecls (the newtype
deriving part) but I'm not going to do that today.  Instead, I made
Check.get_unused_cons a bit more robust.

Audrey tried to fix this over the weekend, but her fix was, alas, utterly
bogus, which caused mysterious failures later.  I completely undid this
change.

Anyway it should work now!
parent 57610c7b
......@@ -438,12 +438,12 @@ mb_neg (Just _) v = -v
get_unused_cons :: [Pat Id] -> [DataCon]
get_unused_cons used_cons = unused_cons
where
(ConPatOut { pat_ty = ty }) = head used_cons
ty_con = tcTyConAppTyCon ty -- Newtype observable
all_cons = tyConDataCons ty_con
used_cons_as_id = map (\ (ConPatOut{ pat_con = L _ d}) -> d) used_cons
unused_cons = uniqSetToList
(mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
(ConPatOut { pat_con = l_con, pat_ty = ty }) = head used_cons
ty_con = dataConTyCon (unLoc l_con) -- Newtype observable
all_cons = tyConDataCons ty_con
used_cons_as_id = map (\ (ConPatOut{ pat_con = L _ d}) -> d) used_cons
unused_cons = uniqSetToList
(mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
all_vars :: [Pat Id] -> Bool
all_vars [] = True
......
......@@ -632,6 +632,8 @@ get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
-- f {| a+b |} ... = ...
-- f {| x+y |} ... = ...
-- Then at this point we'll have an InstInfo for each
--
-- The class should be unary, which is why simpleInstInfoTyCon should be ok
let
tc_inst_infos :: [(TyCon, InstInfo)]
tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
......
......@@ -571,6 +571,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
the_rhs = mkHsConApp cls_data_con cls_inst_tys $
map HsVar (sc_dict_ids ++ op_ids)
-- Warning: this HsCase scrutinises a value with a PredTy, which is
-- never otherwise seen in Haskell source code. It'd be
-- nicer to generate Core directly!
; return (HsCase (noLoc coerced_rep_dict) $
MatchGroup [the_match] (mkFunTy inst_head_ty inst_head_ty)) }
where
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcType]{Types used in the typechecker}
......@@ -698,10 +698,14 @@ tcMultiSplitSigmaTy sigma
-----------------------
tcTyConAppTyCon :: Type -> TyCon
tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of
Just (tc, _) -> tc
Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty)
tcTyConAppArgs :: Type -> [Type]
tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of
Just (_, args) -> args
Nothing -> pprPanic "tcTyConAppArgs" (pprType ty)
tcSplitTyConApp :: Type -> (TyCon, [Type])
tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
......@@ -712,17 +716,9 @@ tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
tcSplitTyConApp_maybe (AppTy arg res) = Just (funTyCon, [arg,res])
-- Newtypes are opaque, so they may be split
-- However, predicates are not treated
-- as tycon applications by the type checker
-- XXX - 2006-09-24: This case is hard-coded in (rendering predicates opaque as well)
-- to make the newly reworked newtype-deriving work on the trivial case:
-- newtype T = T () deriving (Eq, Ord)
-- Please remove this if the newtype-deriving scheme no longer produces a PredTy.
tcSplitTyConApp_maybe (PredTy (ClassP _ [ty'])) = tcSplitTyConApp_maybe ty'
tcSplitTyConApp_maybe other = Nothing
-----------------------
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment