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(..) )
......
This diff is collapsed.
......@@ -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 }
; return (meth_id, L loc bind) }
----------------
mk_op_wrapper :: Id -> EvVar -> HsWrapper
mk_op_wrapper sel_id rep_d
= WpCast (liftTcCoSubstWith sel_tvs (map mkTcReflCo init_inst_tys ++ [co])
local_meth_ty)
<.> WpEvApp (EvId rep_d)
<.> mkWpTyApps (init_inst_tys ++ [rep_ty])
where
(sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
(_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
`orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
------------------
mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
mkGenericDefMethBind clas inst_tys sel_id dm_name
......
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