Commit 2930694d authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu Committed by Joachim Breitner

Implement GeneralizedNewtypeDeriving in terms of `coerce`.

parent 335031f0
......@@ -35,7 +35,7 @@ module MkId (
wiredInIds, ghcPrimIds,
unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
coercionTokenId, magicDictId,
coercionTokenId, magicDictId, coerceId,
-- Re-export error Ids
module PrelRules
......
......@@ -32,7 +32,8 @@ module HsUtils(
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
toHsType, toHsKind,
-- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
......@@ -73,6 +74,8 @@ module HsUtils(
lStmtsImplicits, hsValBindsImplicits, lPatImplicits
) where
#include "HsVersions.h"
import HsDecls
import HsBinds
import HsExpr
......@@ -84,6 +87,8 @@ import TcEvidence
import RdrName
import Var
import TypeRep
import TcType
import Kind
import DataCon
import Name
import NameSet
......@@ -382,6 +387,47 @@ missingTupArg :: HsTupArg a
missingTupArg = Missing placeHolderType
\end{code}
%************************************************************************
%* *
Converting a Type to an HsType RdrName
%* *
%************************************************************************
This is needed to implement GeneralizedNewtypeDeriving.
\begin{code}
toHsType :: Type -> LHsType RdrName
toHsType ty
| [] <- tvs_only
, [] <- theta
= to_hs_type tau
| otherwise
= noLoc $
mkExplicitHsForAllTy (map mk_hs_tvb tvs_only)
(noLoc $ map toHsType theta)
(to_hs_type tau)
where
(tvs, theta, tau) = tcSplitSigmaTy ty
tvs_only = filter isTypeVar tvs
to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv)
to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2)
to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args)
to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) )
nlHsFunTy (toHsType arg) (toHsType res)
to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t)
to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy n)
to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy s)
mk_hs_tvb tv = noLoc $ KindedTyVar (getRdrName tv) (toHsKind (tyVarKind tv))
toHsKind :: Kind -> LHsKind RdrName
toHsKind = toHsType
\end{code}
\begin{code}
--------- HsWrappers: type args, dict args, casts ---------
mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
......
......@@ -12,7 +12,7 @@ module ParserCore ( parseCore ) where
import IfaceSyn
import ForeignCall
import RdrHsSyn
import HsSyn
import HsSyn hiding (toHsType, toHsKind)
import RdrName
import OccName
import TypeRep ( TyThing(..) )
......
......@@ -28,7 +28,6 @@ import FamInstEnv
import TcHsType
import TcMType
import TcSimplify
import TcEvidence
import RnBinds
import RnEnv
......@@ -40,7 +39,6 @@ import Id( idType )
import Class
import Type
import Kind( isKind )
import Coercion ( tvUsedAtNominalRole )
import ErrUtils
import MkId
import DataCon
......@@ -329,12 +327,12 @@ tcDeriving tycl_decls inst_decls deriv_decls
-- the stand-alone derived instances (@insts1@) are used when inferring
-- the contexts for "deriving" clauses' instances (@infer_specs@)
; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
inferInstanceContexts overlap_flag infer_specs
; insts2 <- mapM (genInst False overlap_flag commonAuxs) final_specs
; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2)
; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
; loc <- getSrcSpanM
; let (binds, newTyCons, famInsts, extraInstances) =
genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))
......@@ -352,8 +350,8 @@ tcDeriving tycl_decls inst_decls deriv_decls
tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
tcExtendLocalFamInstEnv (bagToList famInsts) $
tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) }
; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
where
ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
-> Bag TyCon -- ^ Empty data constructors
......@@ -409,6 +407,8 @@ renameDeriv is_boot inst_infos bagBinds
= discardWarnings $ -- Discard warnings about unused bindings etc
setXOptM Opt_EmptyCase $ -- Derived decls (for empty types) can have
-- case x of {}
setXOptM Opt_ScopedTypeVariables $ -- Derived decls (for newtype-deriving) can
setXOptM Opt_KindSignatures $ -- used ScopedTypeVariables & KindSignatures
do {
-- Bring the extra deriving stuff into scope
-- before renaming the instances themselves
......@@ -424,18 +424,19 @@ renameDeriv is_boot inst_infos bagBinds
where
rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
= return ( info { iBinds = NewTypeDerived coi tc }
, mkFVs (map dataConName (tyConDataCons tc)))
-- See Note [Newtype deriving and unused constructors]
rn_inst_info inst_info@(InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
rn_inst_info inst_info@(InstInfo { iSpec = inst
, iBinds = InstBindings
{ ib_binds = binds
, ib_pragmas = sigs
, ib_standalone_deriving = sa } })
= -- Bring the right type variables into
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
bindLocalNames (map Var.varName tyvars) $
do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
; let binds' = VanillaInst rn_binds [] standalone_deriv
; let binds' = InstBindings { ib_binds = rn_binds
, ib_pragmas = []
, ib_standalone_deriving = sa }
; return (inst_info { iBinds = binds' }, fvs) }
where
(tyvars, _) = tcSplitForAllTys (idType (instanceDFunId inst))
......@@ -456,10 +457,9 @@ had written
return x = MkP (return x)
...etc...
So we want to signal a user of the data constructor 'MkP'. That's
what we do in rn_inst_info, and it's the only reason we have the TyCon
stored in NewTypeDerived.
So we want to signal a user of the data constructor 'MkP'.
This is the reason behind the (Maybe Name) part of the return type
of genInst.
%************************************************************************
%* *
......@@ -1340,9 +1340,13 @@ std_class_via_iso clas
non_iso_class :: Class -> Bool
-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1 by isomorphism,
-- even with -XGeneralizedNewtypeDeriving
-- Also, avoid Traversable, as the iso-derived instance and the "normal"-derived
-- instance behave differently if there's a non-lawful Applicative out there.
-- Besides, with roles, iso-deriving Traversable is ill-roled.
non_iso_class cls
= classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
, genClassKey, gen1ClassKey, typeableClassKey]
, genClassKey, gen1ClassKey, typeableClassKey
, traversableClassKey ]
++ oldTypeableClassKeys)
oldTypeableClassKeys :: [Unique]
......@@ -1398,7 +1402,7 @@ mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class
mkNewTypeEqn orig dflags tvs
cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
| can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
| might_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
= do { traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
; dfun_name <- new_dfun_name cls tycon
; loc <- getSrcSpanM
......@@ -1415,12 +1419,12 @@ mkNewTypeEqn orig dflags tvs
= case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of
CanDerive -> go_for_it -- Use the standard H98 method
DerivableClassError msg -- Error with standard class
| can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
| otherwise -> bale_out msg
| might_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
| otherwise -> bale_out msg
NonDerivableClass -- Must use newtype deriving
| newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
| can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
| otherwise -> bale_out non_std
| newtype_deriving -> bale_out cant_derive_err -- Too hard, even with newtype deriving
| might_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
| otherwise -> bale_out non_std
where
newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
......@@ -1504,12 +1508,12 @@ mkNewTypeEqn orig dflags tvs
-------------------------------------------------------------------
-- Figuring out whether we can only do this newtype-deriving thing
can_derive_via_isomorphism
-- See Note [Determining whether newtype-deriving is appropriate]
might_derive_via_isomorphism
= not (non_iso_class cls)
&& arity_ok
&& eta_ok
&& ats_ok
&& roles_ok
-- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
arity_ok = length cls_tys + 1 == classArity cls
......@@ -1530,44 +1534,13 @@ mkNewTypeEqn orig dflags tvs
-- currently generate type 'instance' decls; and cannot do
-- so for 'data' instance decls
-- We must make sure that all of the class's members
-- never pattern-match on the last parameter.
-- See Trac #1496 and Note [Roles] in Coercion.
-- Also see Note [Role checking in GND]
roles_ok = null role_errs
role_errs
= [ (id, substed_ty, is_specialized)
| id <- classMethods cls
, let ty = idType id
(_, [cls_constraint], meth_ty) = tcSplitSigmaTy ty
(_cls_tc, cls_args) = splitTyConApp cls_constraint
ordered_tvs = map (getTyVar "mkNewTypeEqn") cls_args
Just (other_tvs, gnd_tv) = snocView ordered_tvs
subst = zipOpenTvSubst other_tvs cls_tys
substed_ty = substTy subst meth_ty
is_specialized = not (meth_ty `eqType` substed_ty)
, ASSERT( _cls_tc == classTyCon cls )
tvUsedAtNominalRole gnd_tv substed_ty ]
cant_derive_err
= vcat [ ppUnless arity_ok arity_msg
, ppUnless eta_ok eta_msg
, ppUnless ats_ok ats_msg
, ppUnless roles_ok roles_msg ]
, ppUnless ats_ok ats_msg ]
arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
eta_msg = ptext (sLit "cannot eta-reduce the representation type enough")
ats_msg = ptext (sLit "the class has associated types")
roles_msg = ptext (sLit "it is not type-safe to use") <+>
ptext (sLit "GeneralizedNewtypeDeriving on this class;") $$
vcat [ quotes (ppr id) <> comma <+>
specialized_doc <+>
quotes (ppr ty) <> comma <+>
text "cannot be converted safely"
| (id, ty, is_specialized) <- role_errs
, let specialized_doc
| is_specialized = text "specialized to type"
| otherwise = text "at type"
]
\end{code}
......@@ -1615,6 +1588,21 @@ the base type's superclass dictionaries in GND, and we don't need to check
them here. For associated types, GND is impossible anyway, so we don't need
to look. All that is left is methods.
Note [Determining whether newtype-deriving is appropriate]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we see
newtype NT = MkNT Foo
deriving C
we have to decide how to perform the deriving. Do we do newtype deriving,
or do we do normal deriving? In general, we prefer to do newtype deriving
wherever possible. So, we try newtype deriving unless there's a glaring
reason not to.
Note that newtype deriving might fail, even after we commit to it. This
is because the derived instance uses `coerce`, which must satisfy its
`Coercible` constraint. This is different than other deriving scenarios,
where we're sure that the resulting instance will type-check.
%************************************************************************
%* *
\subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
......@@ -1924,15 +1912,22 @@ the renamer. What a great hack!
genInst :: Bool -- True <=> standalone deriving
-> OverlapFlag
-> CommonAuxiliaries
-> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff)
-> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
genInst standalone_deriv oflag comauxs
spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = theta, ds_newtype = is_newtype
, ds_name = name, ds_cls = clas })
, ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
, ds_name = name, ds_cls = clas, ds_loc = loc })
| is_newtype
= do { inst_spec <- mkInstance oflag theta spec
; return (InstInfo { iSpec = inst_spec
, iBinds = NewTypeDerived co rep_tycon }, emptyBag) }
; return ( InstInfo
{ iSpec = inst_spec
, iBinds = InstBindings
{ ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty
, ib_pragmas = []
, ib_standalone_deriving = standalone_deriv } }
, emptyBag
, Just $ getName $ head $ tyConDataCons rep_tycon ) }
-- See Note [Newtype deriving and unused constructors]
| otherwise
= do { fix_env <- getFixityEnv
......@@ -1941,25 +1936,17 @@ genInst standalone_deriv oflag comauxs
(lookup rep_tycon comauxs)
; inst_spec <- mkInstance oflag theta spec
; let inst_info = InstInfo { iSpec = inst_spec
, iBinds = VanillaInst meth_binds []
standalone_deriv }
; return ( inst_info, deriv_stuff) }
, iBinds = InstBindings
{ ib_binds = meth_binds
, ib_pragmas = []
, ib_standalone_deriving = standalone_deriv } }
; return ( inst_info, deriv_stuff, Nothing ) }
where
co1 = case tyConFamilyCoercion_maybe rep_tycon of
Just co_con -> mkTcUnbranchedAxInstCo co_con rep_tc_args
Nothing -> id_co
-- Not a family => rep_tycon = main tycon
co2 = mkTcUnbranchedAxInstCo (newTyConCo rep_tycon) rep_tc_args
co = mkTcForAllCos tvs (co1 `mkTcTransCo` co2)
id_co = mkTcReflCo (mkTyConApp rep_tycon rep_tc_args)
-- Example: newtype instance N [a] = N1 (Tree a)
-- deriving instance Eq b => Eq (N [(b,b)])
-- From the instance, we get an implicit newtype R1:N a = N1 (Tree a)
-- When dealing with the deriving clause
-- co1 : N [(b,b)] ~ R1:N (b,b)
-- co2 : R1:N (b,b) ~ Tree (b,b)
-- co : N [(b,b)] ~ Tree (b,b)
(etad_tvs, etad_rhs) = newTyConEtadRhs rep_tycon
-- it's possible the eta-reduced rhs is overly-reduced.
-- pad as necessary
pad_tys = dropList etad_tvs rep_tc_args
rhs_ty = mkAppTys etad_rhs pad_tys
genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
-> Maybe CommonAuxiliary
......
......@@ -65,7 +65,6 @@ import TcIface
import PrelNames
import TysWiredIn
import Id
import TcEvidence
import Var
import VarSet
import RdrName
......@@ -652,27 +651,15 @@ iDFunId :: InstInfo a -> DFunId
iDFunId info = instanceDFunId (iSpec info)
data InstBindings a
= VanillaInst -- The normal case
(LHsBinds a) -- Bindings for the instance methods
[LSig a] -- User pragmas recorded for generating
-- specialised instances
Bool -- True <=> This code came from a standalone deriving clause
-- Used only to improve error messages
| NewTypeDerived -- Used for deriving instances of newtypes, where the
-- witness dictionary is identical to the argument
-- dictionary. Hence no bindings, no pragmas.
TcCoercion -- The coercion maps from newtype to the representation type
-- (quantified over type variables bound by the forall'd iSpec variables)
-- E.g. newtype instance N [a] = N1 (Tree a)
-- co : forall a. N [a] ~ Tree a
TyCon -- The TyCon is the newtype N. If it's indexed, then it's the
-- representation TyCon, so that tyConDataCons returns [N1],
-- the "data constructor".
-- See Note [Newtype deriving and unused constructors]
-- in TcDeriv
= InstBindings
{ ib_binds :: (LHsBinds a) -- Bindings for the instance methods
, ib_pragmas :: [LSig a] -- User pragmas recorded for generating
-- specialised instances
, ib_standalone_deriving :: Bool
-- True <=> This code came from a standalone deriving clause
-- Used only to improve error messages
}
instance OutputableBndr a => Outputable (InstInfo a) where
ppr = pprInstInfoDetails
......@@ -682,8 +669,7 @@ pprInstInfoDetails info
= hang (pprInstanceHdr (iSpec info) <+> ptext (sLit "where"))
2 (details (iBinds info))
where
details (VanillaInst b _ _) = pprLHsBinds b
details (NewTypeDerived {}) = text "Derived from the representation type"
details (InstBindings { ib_binds = b }) = pprLHsBinds b
simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
......
......@@ -30,6 +30,7 @@ module TcGenDeriv (
deepSubtypesContaining, foldDataConArgs,
gen_Foldable_binds,
gen_Traversable_binds,
gen_Newtype_binds,
genAuxBinds,
ordOpTbl, boxConTbl
) where
......@@ -48,6 +49,7 @@ import PrelInfo
import FamInstEnv( FamInst )
import MkCore ( eRROR_ID )
import PrelNames hiding (error_RDR)
import MkId ( coerceId )
import PrimOp
import SrcLoc
import TyCon
......@@ -55,11 +57,14 @@ import TcType
import TysPrim
import TysWiredIn
import Type
import Class
import TypeRep
import VarSet
import VarEnv
import Module
import State
import Util
import Var
import MonadUtils
import Outputable
import FastString
......@@ -1888,7 +1893,59 @@ gen_Traversable_binds loc tycon
where appAp x y = nlHsApps ap_RDR [x,y]
\end{code}
%************************************************************************
%* *
Newtype-deriving instances
%* *
%************************************************************************
We take every method in the original instance and `coerce` it to fit
into the derived instance. We need a type annotation on the argument
to `coerce` to make it obvious what instantiation of the method we're
coercing from.
See #8503 for more discussion.
\begin{code}
gen_Newtype_binds :: SrcSpan
-> Class -- the class being derived
-> [TyVar] -- the tvs in the instance head
-> [Type] -- instance head parameters (incl. newtype)
-> Type -- the representation type (already eta-reduced)
-> LHsBinds RdrName
gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
= listToBag $ map (L loc . mk_bind) $ classMethods cls
where
cls_tvs = classTyVars cls
in_scope = mkInScopeSet $ mkVarSet inst_tvs
lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
coerce_RDR = getRdrName coerceId
mk_bind :: Id -> HsBind RdrName
mk_bind id
= mkRdrFunBind (L loc meth_RDR)
[mkSimpleMatch [] rhs_expr]
where
meth_RDR = getRdrName id
(_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id)
(_quant_tvs, _quant_constraint, tau_meth_ty) = tcSplitSigmaTy user_meth_ty
rhs_expr
= noLoc $ ExprWithTySig
(nlHsApp
(nlHsVar coerce_RDR)
(noLoc $ ExprWithTySig
(nlHsVar meth_RDR)
(toHsType $ substTy rhs_subst tau_meth_ty)))
(toHsType $ substTy lhs_subst user_meth_ty)
changeLast :: [a] -> a -> [a]
changeLast [] _ = panic "changeLast"
changeLast [_] x = [x]
changeLast (x:xs) x' = x : changeLast xs x'
\end{code}
%************************************************************************
%* *
......
......@@ -139,14 +139,19 @@ metaTyConsToDerivStuff tc metaDts =
-- Datatype
d_metaTycon = metaD metaDts
d_inst = mk_inst dClas d_metaTycon d_dfun_name
d_binds = VanillaInst dBinds [] False
d_binds = InstBindings { ib_binds = dBinds
, ib_pragmas = []
, ib_standalone_deriving = False }
d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
-- Constructor
c_metaTycons = metaC metaDts
c_insts = [ mk_inst cClas c ds
| (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
c_binds = [ VanillaInst c [] False | c <- cBinds ]
c_binds = [ InstBindings { ib_binds = c
, ib_pragmas = []
, ib_standalone_deriving = False }
| c <- cBinds ]
c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
| (is,bs) <- myZip1 c_insts c_binds ]
......@@ -154,7 +159,10 @@ metaTyConsToDerivStuff tc metaDts =
s_metaTycons = metaS metaDts
s_insts = map (map (\(s,ds) -> mk_inst sClas s ds))
(myZip2 s_metaTycons s_dfun_names)
s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
s_binds = [ [ InstBindings { ib_binds = s
, ib_pragmas = []
, ib_standalone_deriving = False }
| s <- ss ] | ss <- sBinds ]
s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is
, iBinds = bs})))
(myZip2 s_insts s_binds)
......
......@@ -21,7 +21,7 @@ import HsSyn
import TcBinds
import TcTyClsDecls
import TcClassDcl( tcClassDecl2,
HsSigFun, lookupHsSig, mkHsSigFun, emptyHsSigs,
HsSigFun, lookupHsSig, mkHsSigFun,
findMethodBind, instantiateMethod, tcInstanceMethodBody )
import TcPat ( addInlinePrags )
import TcRnMonad
......@@ -49,7 +49,6 @@ import Class
import Var
import VarEnv
import VarSet
import Pair
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps )
import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames )
......@@ -70,7 +69,7 @@ import Util
import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
import Control.Monad
import Maybes ( orElse, isNothing, isJust, whenIsJust )
import Maybes ( isNothing, isJust, whenIsJust )
\end{code}
Typechecking instance declarations is done in two passes. The first
......@@ -571,7 +570,11 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys)
-- Be sure to freshen those type variables,
-- so they are sure not to appear in any lookup
inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False }
inst_info = InstInfo { iSpec = ispec
, iBinds = InstBindings
{ ib_binds = binds
, ib_pragmas = uprags
, ib_standalone_deriving = False } }
; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) }
......@@ -1004,9 +1007,7 @@ misplacedInstSig name hs_ty
------------------------------
tcSpecInstPrags :: DFunId -> InstBindings Name
-> TcM ([Located TcSpecPrag], PragFun)
tcSpecInstPrags _ (NewTypeDerived {})
= return ([], \_ -> [])
tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
= do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
filter isSpecInstLSig uprags
-- The filter removes the pragmas for methods
......@@ -1192,7 +1193,10 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
-- forall tvs. theta => ...
tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
(spec_inst_prags, prag_fn)
op_items (VanillaInst binds sigs standalone_deriv)
op_items (InstBindings { ib_binds = binds
, ib_pragmas = sigs
, ib_standalone_deriving
= standalone_deriv })
= do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
; let hs_sig_fn = mkHsSigFun sigs
; checkMinimalDefinition
......@@ -1329,83 +1333,6 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
where
methodExists meth = isJust (findMethodBind meth binds)
tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
_ op_items (NewTypeDerived coi _)
-- Running example:
-- class Show b => Foo a b where
-- op :: a -> b -> b
-- newtype N a = MkN (Tree [a])
-- deriving instance (Show p, Foo Int p) => Foo Int (N p)
-- -- NB: standalone deriving clause means
-- -- that the contex is user-specified
-- Hence op :: forall a b. Foo a b => a -> b -> b
--
-- We're going to make an instance like
-- instance (Show p, Foo Int p) => Foo Int (N p)
-- op = $copT
--
-- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
-- $copT p (d1:Show p) (d2:Foo Int p)
-- = op Int (Tree [p]) rep_d |> op_co
-- where
-- rep_d :: Foo Int (Tree [p]) = ...d1...d2...
-- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
-- We get op_co by substituting [Int/a] and [co/b] in type for op
-- where co : [p] ~ T p
--
-- Notice that the dictionary bindings "..d1..d2.." must be generated
-- by the constraint solver, since the <context> may be
-- user-specified.
--
-- See also Note [Newtype deriving superclasses] in TcDeriv
-- for why we don't just coerce the superclass
= do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
emitWanted ScOrigin rep_pred
; mapAndUnzipM (tc_item rep_d_stuff) op_items }
where
loc = getSrcSpan dfun_id
Just (init_inst_tys, _) = snocView inst_tys
rep_ty = pFst (tcCoercionKind co) -- [p]
rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
-- co : [p] ~ T p
co = mkTcSymCo (mkTcInstCos coi (mkTyVarTys tyvars))
sig_fn = emptyHsSigs
----------------
tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
tc_item (rep_ev_binds, rep_d) (sel_id, _)
= do { (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
inst_tys sel_id
; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
local_meth_id = sig_id local_meth_sig
meth_bind = mkVarBind local_meth_id (L loc meth_rhs)
export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
, abe_mono = local_meth_id, abe_prags = noSpecPrags }
bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
, abs_exports = [export]
, abs_ev_binds = rep_ev_binds
, abs_binds = unitBag $ meth_bind }