Mon Sep 18 14:31:59 EDT 2006 Manuel M T Chakravarty <chak@cse.unsw.edu.au>
* newtype deriving still not working
Sat Aug 5 21:25:43 EDT 2006 Manuel M T Chakravarty <chak@cse.unsw.edu.au>
* newtype deriving still not working
Mon Jul 10 10:27:20 EDT 2006 kevind@bu.edu
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConStupidTheta, dataConName,
dataConWrapId, dataConUnivTyVars )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConStupidTheta, dataConName,
dataConWrapId, dataConUnivTyVars )
-import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
+import Id ( Id, idName, idType, mkUserLocal, mkLocalId, isId )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
isInternalName, setNameUnique )
import NameSet ( addOneToNameSet )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
isInternalName, setNameUnique )
import NameSet ( addOneToNameSet )
instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
(+) = ((+)@a)
...etc...
instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
(+) = ((+)@a)
...etc...
-There's no 'corece' needed because after the type checker newtypes
-are transparent.
+There may be a coercion needed which we get from the tycon for the newtype
+when the dict is constructed in TcInstDcls.tcInstDecl2
+
\begin{code}
makeDerivEqns :: OverlapFlag
\begin{code}
makeDerivEqns :: OverlapFlag
; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
; dicts <- newDicts origin theta
; uniqs <- newUniqueSupply
; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
; dicts <- newDicts origin theta
; uniqs <- newUniqueSupply
- ; let (rep_dict_id:sc_dict_ids) = map instToId dicts
+ ; let (cls, op_tys) = tcSplitDFunHead inst_head
+ ; [this_dict] <- newDicts origin [mkClassPred cls op_tys]
+ ; let (rep_dict_id:sc_dict_ids) =
+ if null dicts then
+ [instToId this_dict]
+ else
+ map instToId dicts
+
-- (Here, we are relying on the order of dictionary
-- arguments built by NewTypeDerived in TcDeriv.)
-- (Here, we are relying on the order of dictionary
-- arguments built by NewTypeDerived in TcDeriv.)
- wrap_fn = CoTyLams tvs <.> CoLams sc_dict_ids
+ wrap_fn | null dicts = idCoercion
+ | otherwise = CoTyLams tvs <.> CoLams sc_dict_ids
- coerced_rep_dict = mkHsCoerce (co_fn tvs cls_tycon) (HsVar rep_dict_id)
- mk_located a = L noSrcSpan a
- body | null sc_dict_ids = coerced_rep_dict
- | otherwise = HsCase (mk_located coerced_rep_dict) $
+ coerced_rep_dict = mkHsCoerce (co_fn tvs cls_tycon) (HsVar rep_dict_id)
+
+ body | null dicts || null sc_dict_ids = coerced_rep_dict
+ | otherwise = HsCase (noLoc coerced_rep_dict) $
MatchGroup [the_match] inst_head
the_match = mkSimpleMatch [the_pat] the_rhs
op_ids = zipWith (mkSysLocal FSLIT("op"))
(uniqsFromSupply uniqs) op_tys
MatchGroup [the_match] inst_head
the_match = mkSimpleMatch [the_pat] the_rhs
op_ids = zipWith (mkSysLocal FSLIT("op"))
(uniqsFromSupply uniqs) op_tys
- the_pat = mk_located $ ConPatOut { pat_con = mk_located cls_data_con, pat_tvs = [],
+ the_pat = noLoc $ ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
pat_dicts = sc_dict_ids,
pat_binds = emptyLHsBinds,
pat_args = PrefixCon (map nlVarPat op_ids),
pat_ty = inst_head }
pat_dicts = sc_dict_ids,
pat_binds = emptyLHsBinds,
pat_args = PrefixCon (map nlVarPat op_ids),
pat_ty = inst_head }
- (cls, op_tys) = tcSplitDFunHead inst_head
cls_data_con = classDataCon cls
cls_tycon = dataConTyCon cls_data_con
the_rhs = mkHsConApp (cls_data_con) (mkTyVarTys tvs) (map HsVar (sc_dict_ids ++ op_ids))
cls_data_con = classDataCon cls
cls_tycon = dataConTyCon cls_data_con
the_rhs = mkHsConApp (cls_data_con) (mkTyVarTys tvs) (map HsVar (sc_dict_ids ++ op_ids))
-
- ; return (unitBag (mk_located $ VarBind (dfun_id) (mk_located (mkHsCoerce wrap_fn body)))) }
+ dict = (mkHsCoerce wrap_fn body)
+ ; pprTrace "built dict:" (ppr dict) $ return (unitBag (noLoc $ VarBind (dfun_id) (noLoc dict))) }
where
co_fn :: [TyVar] -> TyCon -> ExprCoFn
co_fn tvs cls_tycon | Just co_con <- newTyConCo tycon
where
co_fn :: [TyVar] -> TyCon -> ExprCoFn
co_fn tvs cls_tycon | Just co_con <- newTyConCo tycon
- = ExprCoFn (mkAppCoercion (mkAppsCoercion (mkTyConApp cls_tycon []) rep_tys)
+ = ExprCoFn (mkAppCoercion (mkTyConApp cls_tycon [])
(mkTyConApp co_con (map mkTyVarTy tvs)))
| otherwise
= idCoercion
(mkTyConApp co_con (map mkTyVarTy tvs)))
| otherwise
= idCoercion