; return (Lam id expr) }
dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside
; return (Lam tv expr) }
-dsCoercion (WpApp id) thing_inside = do { expr <- thing_inside
- ; return (App expr (Var id)) }
+dsCoercion (WpApp v) thing_inside
+ | isTyVar v = do { expr <- thing_inside
+ {- Probably a coercion var -} ; return (App expr (Type (mkTyVarTy v))) }
+ | otherwise = do { expr <- thing_inside
+ {- An Id -} ; return (App expr (Var v)) }
dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside
; return (App expr (Type ty)) }
dsCoercion WpInline thing_inside = do { expr <- thing_inside
| WpCast Coercion -- A cast: [] `cast` co
-- Guaranteed not the identity coercion
- | WpApp Var -- [] d the 'd' is a type-class dictionary
+ | WpApp Var -- [] d the 'd' is a type-class dictionary or coercion variable
| WpTyApp Type -- [] t the 't' is a type or corecion
| WpLam Var -- \d. [] the 'd' is a type-class dictionary or coercion variable
| WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var)
tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
= addErrCtxt (cmdCtxt in_cmd) $ do
- (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut) $
- tcInferRho scrut
+ (scrut', scrut_ty) <- tcInferRho scrut
matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
return (HsCase scrut' matches')
where
cmdCtxt :: HsExpr Name -> SDoc
cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd
-caseScrutCtxt :: LHsExpr Name -> SDoc
-caseScrutCtxt cmd
- = hang (ptext (sLit "In the scrutinee of a case command:")) 4 (ppr cmd)
-
nonEmptyCmdStkErr :: HsExpr Name -> SDoc
nonEmptyCmdStkErr cmd
= hang (ptext (sLit "Non-empty command stack at command:"))
\begin{code}
module TcBinds ( tcLocalBinds, tcTopBinds,
- tcHsBootSigs, tcMonoBinds,
+ tcHsBootSigs, tcMonoBinds, tcPolyBinds,
TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
TcSigInfo(..), TcSigFun, mkTcSigFun,
badBootDeclErr ) where
-- the Ids declared with type signatures
; poly_rec <- doptM Opt_RelaxedPolyRec
; (binds', thing) <- tcExtendIdEnv poly_ids $
- tc_val_binds poly_rec top_lvl sig_fn prag_fn
+ tcBindGroups poly_rec top_lvl sig_fn prag_fn
binds thing_inside
; return (ValBindsOut binds' sigs, thing) }
------------------------
-tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
+tcBindGroups :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
-> [(RecFlag, LHsBinds Name)] -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
+-- Here a "strongly connected component" has the strightforward
+-- meaning of a group of bindings that mention each other,
+-- ignoring type signatures (that part comes later)
-tc_val_binds _ _ _ _ [] thing_inside
+tcBindGroups _ _ _ _ [] thing_inside
= do { thing <- thing_inside
; return ([], thing) }
-tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
+tcBindGroups poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
= do { (group', (groups', thing))
<- tc_group poly_rec top_lvl sig_fn prag_fn group $
- tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside
+ tcBindGroups poly_rec top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', thing) }
------------------------
; return ([(Recursive, unionManyBags binds1)], thing) }
| otherwise -- Recursive group, with gla-exts
- = -- To maximise polymorphism (with -fglasgow-exts), we do a new
+ = -- To maximise polymorphism (with -XRelaxedPolyRec), we do a new
-- strongly-connected-component analysis, this time omitting
-- any references to variables with type signatures.
--
- -- Notice that the bindInsts thing covers *all* the bindings in the original
- -- group at once; an earlier one may use a later one!
+ -- Notice that the bindInsts thing covers *all* the bindings in
+ -- the original group at once; an earlier one may use a later one!
do { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
; (binds1,thing) <- bindLocalInsts top_lvl $
go (stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds))
-- Note that the scoped_tvs and the (sig_tvs sig)
-- may have different Names. That's quite ok.
+ ; traceTc (text "tcMoonBinds" <+> ppr scoped_tvs $$ ppr tc_sig)
; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $
tcMatchesFun mono_name inf matches mono_ty
+ -- Note that "mono_ty" might actually be a polymorphic type,
+ -- if the original function had a signature like
+ -- forall a. Eq a => forall b. Ord b => ....
+ -- But that's ok: tcMatchesFun can deal with that
+ -- It happens, too! See Note [Polymorphic methods] in TcClassDcl.
; let fun_bind' = FunBind { fun_id = L nm_loc mono_id,
fun_infix = inf, fun_matches = matches',
tcInstSig use_skols name
= do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into
-- scope when starting the binding group
- ; let skol_info = SigSkol (FunSigCtxt name)
- inst_tyvars = tcInstSigTyVars use_skols skol_info
- ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id)
+ ; let skol_info = SigSkol (FunSigCtxt name)
+ ; (tvs, theta, tau) <- tcInstSigType use_skols skol_info (idType poly_id)
; loc <- getInstLoc (SigOrigin skol_info)
; return (TcSigInfo { sig_id = poly_id,
sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
\begin{code}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
- getGenericInstances,
- MethodSpec, tcMethodBind, mkMethId,
+ findMethodBind, tcMethodBind,
+ mkGenericDefMethBind, getGenericInstances, mkDefMethRdrName,
tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
import TcEnv
import TcBinds
import TcHsType
-import TcSimplify
-import TcUnify
import TcMType
import TcType
import TcRnMonad
let
(tyvars, _, _, op_items) = classBigSig clas
rigid_info = ClsSkol clas
- origin = SigOrigin rigid_info
prag_fn = mkPragFun sigs
sig_fn = mkTcSigFun sigs
clas_tyvars = tcSkolSigTyVars rigid_info tyvars
- tc_dm = tcDefMeth origin clas clas_tyvars
- default_binds sig_fn prag_fn
+ tc_dm = tcDefMeth clas_tyvars default_binds
+ sig_fn prag_fn
+ -- tc_dm is called only for a sel_id
+ -- that has a binding in default_binds
dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
-- Generate code for polymorphic default methods only
-- the programmer supplied an explicit default decl for the class.
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
- (defm_binds, dm_ids_s) <- mapAndUnzipM tc_dm dm_sel_ids
- return (listToBag defm_binds, concat dm_ids_s)
+ (defm_binds, dm_ids) <- mapAndUnzipM tc_dm dm_sel_ids
+ return (unionManyBags defm_binds, dm_ids)
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
-tcDefMeth :: InstOrigin -> Class -> [TyVar] -> LHsBinds Name
+tcDefMeth :: [TyVar] -> LHsBinds Name
-> TcSigFun -> TcPragFun -> Id
- -> TcM (LHsBindLR Id Var, [Id])
-tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
- = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
- ; let inst_tys = mkTyVarTys tyvars
- dm_ty = idType sel_id -- Same as dict selector!
- cls_pred = mkClassPred clas inst_tys
- local_dm_id = mkDefaultMethodId dm_name dm_ty
-
- ; loc <- getInstLoc origin
- ; this_dict <- newDictBndr loc cls_pred
- ; (_, meth_id) <- mkMethId origin clas sel_id inst_tys
- ; (defm_bind, insts_needed) <- getLIE $
- tcMethodBind origin tyvars [cls_pred] this_dict []
- sig_fn prag_fn binds_in
- (sel_id, DefMeth) meth_id
-
- ; addErrCtxt (defltMethCtxt clas) $ do
-
- -- Check the context
- { dict_binds <- tcSimplifyCheck
- loc
- tyvars
- [this_dict]
- insts_needed
-
- -- Simplification can do unification
- ; checkSigTyVars tyvars
-
- -- Inline pragmas
- -- We'll have an inline pragma on the local binding, made by tcMethodBind
- -- but that's not enough; we want one on the global default method too
- -- Specialisations, on the other hand, belong on the thing inside only, I think
- ; let sel_name = idName sel_id
- inline_prags = filter isInlineLSig (prag_fn sel_name)
- ; prags <- tcPrags meth_id inline_prags
-
- ; let full_bind = AbsBinds tyvars
- [instToId this_dict]
- [(tyvars, local_dm_id, meth_id, prags)]
- (dict_binds `unionBags` defm_bind)
- ; return (noLoc full_bind, [local_dm_id]) }}
-
-mkDefMethRdrName :: Id -> RdrName
-mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
-\end{code}
+ -> TcM (LHsBinds Id, Id)
+tcDefMeth tyvars binds_in sig_fn prag_fn sel_id
+ = do { let sel_name = idName sel_id
+ ; dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name)
+ ; uniq <- newUnique
+ ; let dm_ty = idType sel_id -- Same as dict selector!
+ local_dm_name = setNameUnique sel_name uniq
+ local_dm_id = mkLocalId local_dm_name dm_ty
+ top_dm_id = mkDefaultMethodId dm_name dm_ty
+ all_tvs = map tyVarName tyvars ++ (sig_fn sel_name `orElse` [])
+ -- Tyvars in scope are *both* the ones from the
+ -- class decl *and* ones from the method sig
+
+ ; let meth_bind = findMethodBind sel_name local_dm_name binds_in
+ `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+ -- We only call tcDefMeth on selectors for which
+ -- there is a binding in binds_in
+
+ ; tc_meth_bind <- tcMethodBind all_tvs (prag_fn sel_name)
+ local_dm_id meth_bind
+
+ -- See Note [Silly default-method bind]
+ ; let loc = getLoc meth_bind
+ top_bind = L loc $ VarBind top_dm_id $
+ L loc $ HsWrap (WpLet tc_meth_bind) $
+ HsVar local_dm_id
+
+ ; return (unitBag top_bind, top_dm_id) }
+
+mkDefMethRdrName :: Name -> RdrName
+mkDefMethRdrName sel_name = mkDerivedRdrName sel_name mkDefaultMethodOcc
+---------------------------
+-- The renamer just puts the selector ID as the binder in the method binding
+-- but we must use the method name; so we substitute it here. Crude but simple.
+findMethodBind :: Name -> Name -- Selector and method name
+ -> LHsBinds Name -- A group of bindings
+ -> Maybe (LHsBind Name) -- The binding, with meth_name replacing sel_name
+findMethodBind sel_name meth_name binds
+ = foldlBag mplus Nothing (mapBag f binds)
+ where
+ f (L loc1 bind@(FunBind { fun_id = L loc2 op_name }))
+ | op_name == sel_name
+ = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
+ f _other = Nothing
-%************************************************************************
-%* *
-\subsection{Typechecking a method}
-%* *
-%************************************************************************
-
-@tcMethodBind@ is used to type-check both default-method and
-instance-decl method declarations. We must type-check methods one at a
-time, because their signatures may have different contexts and
-tyvar sets.
-
-\begin{code}
-type MethodSpec = (Id, -- Global selector Id
- Id, -- Local Id (class tyvars instantiated)
- LHsBind Name) -- Binding for the method
-
-tcMethodBind
- :: InstOrigin
- -> [TcTyVar] -- Skolemised type variables for the
- -- enclosing class/instance decl.
- -- They'll be signature tyvars, and we
- -- want to check that they don't get bound
- -- Also they are scoped, so we bring them into scope
- -- Always equal the range of the type envt
- -> TcThetaType -- Available theta; it's just used for the error message
- -> Inst -- Current dictionary (this_dict)
- -> [Inst] -- Other stuff available from context, used to simplify
- -- constraints from the method body (exclude this_dict)
- -> TcSigFun -- For scoped tyvars, indexed by sel_name
- -> TcPragFun -- Pragmas (e.g. inline pragmas), indexed by sel_name
- -> LHsBinds Name -- Method binding (pick the right one from in here)
- -> ClassOpItem
- -> TcId -- The method Id
- -> TcM (LHsBinds Id)
-
-tcMethodBind origin inst_tyvars inst_theta
- this_dict extra_insts
- sig_fn prag_fn meth_binds
- (sel_id, dm_info) meth_id
- | Just user_bind <- find_bind sel_name meth_name meth_binds
- = -- If there is a user-supplied method binding, typecheck it
- tc_method_bind inst_tyvars inst_theta (this_dict:extra_insts)
- sig_fn prag_fn
- sel_id meth_id user_bind
-
- | otherwise -- The user didn't supply a method binding, so we have to make
- -- up a default binding, in a way depending on the default-method info
- = case dm_info of
- NoDefMeth -> do { warn <- doptM Opt_WarnMissingMethods
- ; warnTc (isInstDecl origin
- && warn -- Warn only if -fwarn-missing-methods
- && reportIfUnused (getOccName sel_id))
- -- Don't warn about _foo methods
- (omittedMethodWarn sel_id)
- ; return (unitBag $ L loc (VarBind meth_id error_rhs)) }
-
- DefMeth -> do { -- An polymorphic default method
- -- Might not be imported, but will be an OrigName
- dm_name <- lookupImportedName (mkDefMethRdrName sel_id)
- ; dm_id <- tcLookupId dm_name
- -- Note [Default methods in instances]
- ; return (unitBag $ L loc (VarBind meth_id (mk_dm_app dm_id))) }
-
- GenDefMeth -> ASSERT( isInstDecl origin ) -- We never get here from a class decl
- do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name
- ; tc_method_bind inst_tyvars inst_theta (this_dict:extra_insts)
- sig_fn prag_fn
- sel_id meth_id meth_bind }
-
- where
- meth_name = idName meth_id
- sel_name = idName sel_id
- loc = getSrcSpan meth_id
- (clas, inst_tys) = getDictClassTys this_dict
+---------------------------
+tcMethodBind :: [Name] -> [LSig Name] -> Id
+ -> LHsBind Name -> TcM (LHsBinds Id)
+tcMethodBind tyvars prags meth_id bind
+ = do { let sig_fn _ = Just tyvars
+ prag_fn _ = prags
+
+ -- Typecheck the binding, first extending the envt
+ -- so that when tcInstSig looks up the meth_id to find
+ -- its signature, we'll find it in the environment
+ --
+ -- If scoped type variables is on, they are brought
+ -- into scope by tcPolyBinds (via sig_fn)
+ --
+ -- See Note [Polymorphic methods]
+ ; traceTc (text "tcMethodBind" <+> ppr meth_id <+> ppr tyvars)
+ ; (tc_binds, ids) <- tcExtendIdEnv [meth_id] $
+ tcPolyBinds TopLevel sig_fn prag_fn
+ NonRecursive NonRecursive
+ (unitBag bind)
+
+ ; ASSERT( ids == [meth_id] ) -- Binding for ONE method
+ return (unionManyBags tc_binds) }
+\end{code}
- this_dict_id = instToId this_dict
- error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID)
- error_id_app = mkLHsWrap (WpTyApp (idType meth_id)) error_id
- error_rhs = mkHsApp error_id_app $ L loc $
- HsLit (HsStringPrim (mkFastString error_msg))
- error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+Note [Polymorphic methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ class Foo a where
+ op :: forall b. Ord b => a -> b -> b -> b
+ instance Foo c => Foo [c] where
+ op = e
- mk_dm_app dm_id -- dm tys inst_dict
- = mkLHsWrap (WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys)
- (L loc (HsVar dm_id))
+When typechecking the binding 'op = e', we'll have a meth_id for op
+whose type is
+ op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
+So tcPolyBinds must be capable of dealing with nested polytypes;
+and so it is. See TcBinds.tcMonoBinds (with type-sig case).
----------------------------
-tc_method_bind :: [TyVar] -> TcThetaType -> [Inst] -> (Name -> Maybe [Name])
- -> (Name -> [LSig Name]) -> Id -> Id -> LHsBind Name
- -> TcRn (LHsBindsLR Id Var)
-tc_method_bind inst_tyvars inst_theta avail_insts sig_fn prag_fn
- sel_id meth_id meth_bind
- = recoverM (return emptyLHsBinds) $
- -- If anything fails, recover returning no bindings.
- -- This is particularly useful when checking the default-method binding of
- -- a class decl. If we don't recover, we don't add the default method to
- -- the type enviroment, and we get a tcLookup failure on $dmeth later.
-
- -- Check the bindings; first adding inst_tyvars to the envt
- -- so that we don't quantify over them in nested places
-
- do { let sel_name = idName sel_id
- meth_name = idName meth_id
- meth_sig_fn name = ASSERT( name == meth_name ) sig_fn sel_name
- -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name
-
- ; ((meth_bind, mono_bind_infos), meth_lie)
- <- tcExtendTyVarEnv inst_tyvars $
- tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig
- addErrCtxt (methodCtxt sel_id) $
- getLIE $
- tcMonoBinds [meth_bind] meth_sig_fn Recursive
-
- -- Now do context reduction. We simplify wrt both the local tyvars
- -- and the ones of the class/instance decl, so that there is
- -- no problem with
- -- class C a where
- -- op :: Eq a => a -> b -> a
- --
- -- We do this for each method independently to localise error messages
+Note [Silly default-method bind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we pass the default method binding to the type checker, it must
+look like op2 = e
+not $dmop2 = e
+otherwise the "$dm" stuff comes out in the interface file. So we
+typecheck the former, and wrap it in a let, thus
+ $dmop2 = let op2 = e in op2
+This makes the error messages right.
- ; let [(_, Just sig, local_meth_id)] = mono_bind_infos
- loc = sig_loc sig
- ; addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $ do
- { meth_dicts <- newDictBndrs loc (sig_theta sig)
- ; let meth_tvs = sig_tvs sig
- all_tyvars = meth_tvs ++ inst_tyvars
- all_insts = avail_insts ++ meth_dicts
+%************************************************************************
+%* *
+ Extracting generic instance declaration from class declarations
+%* *
+%************************************************************************
- ; lie_binds <- tcSimplifyCheck loc all_tyvars all_insts meth_lie
+@getGenericInstances@ extracts the generic instance declarations from a class
+declaration. For exmaple
- ; checkSigTyVars all_tyvars
+ class C a where
+ op :: a -> a
- ; prags <- tcPrags meth_id (prag_fn sel_name)
- ; let poly_meth_bind = noLoc $ AbsBinds meth_tvs
- (map instToId meth_dicts)
- [(meth_tvs, meth_id, local_meth_id, prags)]
- (lie_binds `unionBags` meth_bind)
+ op{ x+y } (Inl v) = ...
+ op{ x+y } (Inr v) = ...
+ op{ x*y } (v :*: w) = ...
+ op{ 1 } Unit = ...
- ; return (unitBag poly_meth_bind) }}
+gives rise to the instance declarations
+ instance C (x+y) where
+ op (Inl v) = ...
+ op (Inr v) = ...
+
+ instance C (x*y) where
+ op (v :*: w) = ...
----------------------------
-mkMethId :: InstOrigin -> Class
- -> Id -> [TcType] -- Selector, and instance types
- -> TcM (Maybe Inst, Id)
-
--- mkMethId instantiates the selector Id at the specified types
-mkMethId origin clas sel_id inst_tys
- = let
- (tyvars,rho) = tcSplitForAllTys (idType sel_id)
- rho_ty = ASSERT( length tyvars == length inst_tys )
- substTyWith tyvars inst_tys rho
- (preds,tau) = tcSplitPhiTy rho_ty
- first_pred = ASSERT( not (null preds)) head preds
- in
- -- The first predicate should be of form (C a b)
- -- where C is the class in question
- ASSERT( not (null preds) &&
- case getClassPredTys_maybe first_pred of
- { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False }
- )
- if isSingleton preds then do
- -- If it's the only one, make a 'method'
- inst_loc <- getInstLoc origin
- meth_inst <- newMethod inst_loc sel_id inst_tys
- return (Just meth_inst, instToId meth_inst)
- else do
- -- If it's not the only one we need to be careful
- -- For example, given 'op' defined thus:
- -- class Foo a where
- -- op :: (?x :: String) => a -> a
- -- (mkMethId op T) should return an Inst with type
- -- (?x :: String) => T -> T
- -- That is, the class-op's context is still there.
- -- BUT: it can't be a Method any more, because it breaks
- -- INVARIANT 2 of methods. (See the data decl for Inst.)
- uniq <- newUnique
- loc <- getSrcSpanM
- let
- real_tau = mkPhiTy (tail preds) tau
- meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc
-
- return (Nothing, meth_id)
+ instance C 1 where
+ op Unit = ...
----------------------------
--- The renamer just puts the selector ID as the binder in the method binding
--- but we must use the method name; so we substitute it here. Crude but simple.
-find_bind :: Name -> Name -- Selector and method name
- -> LHsBinds Name -- A group of bindings
- -> Maybe (LHsBind Name) -- The binding, with meth_name replacing sel_name
-find_bind sel_name meth_name binds
- = foldlBag mplus Nothing (mapBag f binds)
- where
- f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
- = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
- f _other = Nothing
----------------------------
+\begin{code}
mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
mkGenericDefMethBind clas inst_tys sel_id meth_name
= -- A generic default method
_ -> Nothing
_ -> Nothing
-isInstDecl :: InstOrigin -> Bool
-isInstDecl (SigOrigin InstSkol) = True
-isInstDecl (SigOrigin (ClsSkol _)) = False
-isInstDecl o = pprPanic "isInstDecl" (ppr o)
-\end{code}
-
-
-Note [Default methods]
-~~~~~~~~~~~~~~~~~~~~~~~
-The default methods for a class are each passed a dictionary for the
-class, so that they get access to the other methods at the same type.
-So, given the class decl
-
- class Foo a where
- op1 :: a -> Bool
- op2 :: forall b. Ord b => a -> b -> b -> b
-
- op1 x = True
- op2 x y z = if (op1 x) && (y < z) then y else z
-
-we get the default methods:
-
- $dmop1 :: forall a. Foo a => a -> Bool
- $dmop1 = /\a -> \dfoo -> \x -> True
-
- $dmop2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
- $dmop2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
- if (op1 a dfoo x) && (< b dord y z) then y else z
-
-When we come across an instance decl, we may need to use the default methods:
-
- instance Foo Int where {}
-
- $dFooInt :: Foo Int
- $dFooInt = MkFoo ($dmop1 Int $dFooInt)
- ($dmop2 Int $dFooInt)
-
-Notice that, as with method selectors above, we assume that dictionary
-application is curried, so there's no need to mention the Ord dictionary
-in the application of $dmop2.
-
- instance Foo a => Foo [a] where {}
-
- $dFooList :: forall a. Foo a -> Foo [a]
- $dFooList = /\ a -> \ dfoo_a ->
- let rec
- op1 = defm.Foo.op1 [a] dfoo_list
- op2 = defm.Foo.op2 [a] dfoo_list
- dfoo_list = MkFoo ($dmop1 [a] dfoo_list)
- ($dmop2 [a] dfoo_list)
- in
- dfoo_list
-
-Note [Default methods in instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this
-
- class Baz v x where
- foo :: x -> x
- foo y = y
-
- instance Baz Int Int
-
-From the class decl we get
-
- $dmfoo :: forall v x. Baz v x => x -> x
-
-Notice that the type is ambiguous. That's fine, though. The instance decl generates
-
- $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
-
-BUT this does mean we must generate the dictionary translation directly, rather
-than generating source-code and type-checking it. That was the bug ing
-Trac #1061. In any case it's less work to generate the translated version!
-
-
-%************************************************************************
-%* *
-\subsection{Extracting generic instance declaration from class declarations}
-%* *
-%************************************************************************
-@getGenericInstances@ extracts the generic instance declarations from a class
-declaration. For exmaple
-
- class C a where
- op :: a -> a
-
- op{ x+y } (Inl v) = ...
- op{ x+y } (Inr v) = ...
- op{ x*y } (v :*: w) = ...
- op{ 1 } Unit = ...
-
-gives rise to the instance declarations
-
- instance C (x+y) where
- op (Inl v) = ...
- op (Inr v) = ...
-
- instance C (x*y) where
- op (v :*: w) = ...
-
- instance C 1 where
- op Unit = ...
-
-
-\begin{code}
+---------------------------
getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name]
getGenericInstances class_decls
= do { gen_inst_infos <- mapM (addLocM get_generics) class_decls
ctxt = hsep [ptext (sLit "In the"), text thing,
ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
-defltMethCtxt :: Class -> SDoc
-defltMethCtxt clas
- = ptext (sLit "When checking the default methods for class") <+> quotes (ppr clas)
-
-methodCtxt :: Var -> SDoc
-methodCtxt sel_id
- = ptext (sLit "In the definition for method") <+> quotes (ppr sel_id)
-
badMethodErr :: Outputable a => a -> Name -> SDoc
badMethodErr clas op
= hsep [ptext (sLit "Class"), quotes (ppr clas),
= hsep [ptext (sLit "Class"), quotes (ppr clas),
ptext (sLit "does not have an associated type"), quotes (ppr at)]
-omittedMethodWarn :: Id -> SDoc
-omittedMethodWarn sel_id
- = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)
-
omittedATWarn :: Name -> SDoc
omittedATWarn at
= ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp ) where
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcInferRhoNC, tcSyntaxOp ) where
#include "HsVersions.h"
-- to do so himself.
tcPolyExpr expr res_ty
- = addErrCtxt (exprCtxt (unLoc expr)) $
+ = addErrCtxt (exprCtxt expr) $
(do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
tcPolyExprNC expr res_ty
| isSigmaTy res_ty
= do { traceTc (text "tcPolyExprNC" <+> ppr res_ty)
- ; (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
+ ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing (tcPolyExprNC expr)
-- Note the recursive call to tcPolyExpr, because the
-- type may have multiple layers of for-alls
-- E.g. forall a. Eq a => forall b. Ord b => ....
; return (mkLHsWrap gen_fn expr') }
| otherwise
- = tcMonoExpr expr res_ty
+ = tcMonoExprNC expr res_ty
---------------
tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
---------------
-tcMonoExpr :: LHsExpr Name -- Expression to type check
- -> BoxyRhoType -- Expected type (could be a type variable)
- -- Definitely no foralls at the top
- -- Can contain boxes, which will be filled in
- -> TcM (LHsExpr TcId)
-
-tcMonoExpr (L loc expr) res_ty
+tcMonoExpr, tcMonoExprNC
+ :: LHsExpr Name -- Expression to type check
+ -> BoxyRhoType -- Expected type (could be a type variable)
+ -- Definitely no foralls at the top
+ -- Can contain boxes, which will be filled in
+ -> TcM (LHsExpr TcId)
+
+tcMonoExpr expr res_ty
+ = addErrCtxt (exprCtxt expr) $
+ tcMonoExprNC expr res_ty
+
+tcMonoExprNC (L loc expr) res_ty
= ASSERT( not (isSigmaTy res_ty) )
setSrcSpan loc $
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
---------------
-tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
-tcInferRho expr = tcInfer (tcMonoExpr expr)
+tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
+tcInferRho expr = tcInfer (tcMonoExpr expr)
+tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
\end{code}
\begin{code}
tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
+tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
+ = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
+
tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty
tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
; return $ mkHsWrapCoI coi (HsLit lit)
}
-tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
+tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
; return (HsPar expr') }
tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
= do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
-- Remember to extend the lexical type-variable environment
- ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
- tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
- tcPolyExprNC expr res_ty)
+ ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $
+ tcMonoExprNC expr
; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
return (SectionL arg1' (L loc op'))
else do (co_fn, (op', arg1'))
- <- subFunTys doc 1 res_ty
+ <- subFunTys doc 1 res_ty Nothing
$ \ [arg2_ty'] res_ty' ->
tcApp op 2 (tc_args arg2_ty') res_ty'
return (mkHsWrap co_fn (SectionL arg1' (L loc op')))
-- \ x -> op x expr
tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
- = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
+ = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
tcApp op 2 (tc_args arg1_ty') res_ty'
; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
where
--
-- But now, in the GADT world, we need to typecheck the scrutinee
-- first, to get type info that may be refined in the case alternatives
- (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut)
- (tcInferRho scrut)
+ (scrut', scrut_ty) <- tcInferRho scrut
; traceTc (text "HsCase" <+> ppr scrut_ty)
; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
mc_body = tcBody }
tcExpr (HsIf pred b1 b2) res_ty
- = do { pred' <- addErrCtxt (predCtxt pred) $
- tcMonoExpr pred boolTy
+ = do { pred' <- tcMonoExpr pred boolTy
; b1' <- tcMonoExpr b1 res_ty
; b2' <- tcMonoExpr b2 res_ty
; return (HsIf pred' b1' b2') }
Boring and alphabetical:
\begin{code}
-caseScrutCtxt expr
- = hang (ptext (sLit "In the scrutinee of a case expression:")) 4 (ppr expr)
-
-exprCtxt expr
+exprCtxt (L _ expr)
= hang (ptext (sLit "In the expression:")) 4 (ppr expr)
fieldCtxt field_name
quotes (ppr fun) <> text ", namely"])
4 (quotes (ppr arg))
-predCtxt expr
- = hang (ptext (sLit "In the predicate expression:")) 4 (ppr expr)
-
nonVanillaUpd tycon
= vcat [ptext (sLit "Record update for the non-Haskell-98 data type")
<+> quotes (pprSourceTyCon tycon)
-> BoxyRhoType
-> TcM (LHsExpr TcId)
-tcInferRho ::
+tcInferRho, tcInferRhoNC ::
LHsExpr Name
-> TcM (LHsExpr TcId, TcRhoType)
import FamInstEnv
import TcDeriv
import TcEnv
+import RnEnv ( lookupImportedName )
import TcHsType
import TcUnify
import TcSimplify
import NameSet
import DynFlags
import SrcLoc
-import ListSetOps
import Util
import Outputable
+import Maybes
import Bag
import BasicTypes
import HscTypes
import Data.Maybe
import Control.Monad
import Data.List
+
+#include "HsVersions.h"
\end{code}
Typechecking instance declarations is done in two passes. The first
all the instance and value decls. Indeed that's the reason we need
two passes over the instance decls.
-Here is the overall algorithm.
-Assume that we have an instance declaration
-
- instance c => k (t tvs) where b
-
-\begin{enumerate}
-\item
-$LIE_c$ is the LIE for the context of class $c$
-\item
-$betas_bar$ is the free variables in the class method type, excluding the
- class variable
-\item
-$LIE_cop$ is the LIE constraining a particular class method
-\item
-$tau_cop$ is the tau type of a class method
-\item
-$LIE_i$ is the LIE for the context of instance $i$
-\item
-$X$ is the instance constructor tycon
-\item
-$gammas_bar$ is the set of type variables of the instance
-\item
-$LIE_iop$ is the LIE for a particular class method instance
-\item
-$tau_iop$ is the tau type for this instance of a class method
-\item
-$alpha$ is the class variable
-\item
-$LIE_cop' = LIE_cop [X gammas_bar \/ alpha, fresh betas_bar]$
-\item
-$tau_cop' = tau_cop [X gammas_bar \/ alpha, fresh betas_bar]$
-\end{enumerate}
-
-ToDo: Update the list above with names actually in the code.
-
-\begin{enumerate}
-\item
-First, make the LIEs for the class and instance contexts, which means
-instantiate $thetaC [X inst_tyvars \/ alpha ]$, yielding LIElistC' and LIEC',
-and make LIElistI and LIEI.
-\item
-Then process each method in turn.
-\item
-order the instance methods according to the ordering of the class methods
-\item
-express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
-\item
-Create final dictionary function from bindings generated already
-\begin{pseudocode}
-df = lambda inst_tyvars
- lambda LIEI
- let Bop1
- Bop2
- ...
- Bopn
- and dbinds_super
- in <op1,op2,...,opn,sd1,...,sdm>
-\end{pseudocode}
-Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
-and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
-\end{enumerate}
+
+Note [How instance declarations are translated]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is how we translation instance declarations into Core
+
+Running example:
+ class C a where
+ op1, op2 :: Ix b => a -> b -> b
+ op2 = <dm-rhs>
+
+ instance C a => C [a]
+ {-# INLINE [2] op1 #-}
+ op1 = <rhs>
+===>
+ -- Method selectors
+ op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
+ op1 = ...
+ op2 = ...
+
+ -- Default methods get the 'self' dictionary as argument
+ -- so they can call other methods at the same type
+ -- Default methods get the same type as their method selector
+ $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
+ $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
+ -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
+ -- Note [Tricky type variable scoping]
+
+ -- A top-level definition for each instance method
+ -- Here op1_i, op2_i are the "instance method Ids"
+ {-# INLINE [2] op1_i #-} -- From the instance decl bindings
+ op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
+ op1_i = <rhs> -- Source code; run the type checker on this
+ -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
+ -- Note [Tricky type variable scoping]
+
+ op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
+
+ -- The dictionary function itself
+ {-# INLINE df_i #-} -- Always inline dictionary functions
+ df_i :: forall a. C a -> C [a]
+ df_i = /\a. \d:C a. MkC (op1_i a d) ($dmop2 a d)
+ -- But see Note [Default methods in instances]
+ -- We can't apply the type checker to the default-nmethod call
+
+* The dictionary function itself is inlined as vigorously as we
+ possibly can, so that we expose that dictionary constructor to
+ selectors as much as poss. That is why the op_i stuff is in
+ *separate* bindings, so that the df_i binding is small enough
+ to inline. See Note [Inline dfuns unconditionally].
+
+* Note that df_i may be mutually recursive with both op1_i and op2_i.
+ It's crucial that df_i is not chosen as the loop breaker, even
+ though op1_i has a (user-specified) INLINE pragma.
+ Not even once! Else op1_i, op2_i may be inlined into df_i.
+
+* Instead the idea is to inline df_i into op1_i, which may then select
+ methods from the MkC record, and thereby break the recursion with
+ df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
+ the same type, it won't mention df_i, so there won't be recursion in
+ the first place.)
+
+* If op1_i is marked INLINE by the user there's a danger that we won't
+ inline df_i in it, and that in turn means that (since it'll be a
+ loop-breaker because df_i isn't), op1_i will ironically never be
+ inlined. We need to fix this somehow -- perhaps allowing inlining
+ of INLINE funcitons inside other INLINE functions.
+
+Note [Tricky type variable scoping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In our example
+ class C a where
+ op1, op2 :: Ix b => a -> b -> b
+ op2 = <dm-rhs>
+
+ instance C a => C [a]
+ {-# INLINE [2] op1 #-}
+ op1 = <rhs>
+
+note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
+in scope in <rhs>. In particular, we must make sure that 'b' is in
+scope when typechecking <dm-rhs>. This is achieved by subFunTys,
+which brings appropriate tyvars into scope. This happens for both
+<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
+complained if 'b' is mentioned in <rhs>.
+
+Note [Inline dfuns unconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The code above unconditionally inlines dict funs. Here's why.
+Consider this program:
+
+ test :: Int -> Int -> Bool
+ test x y = (x,y) == (y,x) || test y x
+ -- Recursive to avoid making it inline.
+
+This needs the (Eq (Int,Int)) instance. If we inline that dfun
+the code we end up with is good:
+
+ Test.$wtest =
+ \r -> case ==# [ww ww1] of wild {
+ PrelBase.False -> Test.$wtest ww1 ww;
+ PrelBase.True ->
+ case ==# [ww1 ww] of wild1 {
+ PrelBase.False -> Test.$wtest ww1 ww;
+ PrelBase.True -> PrelBase.True [];
+ };
+ };
+ Test.test = \r [w w1]
+ case w of w2 {
+ PrelBase.I# ww ->
+ case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
+ };
+
+If we don't inline the dfun, the code is not nearly as good:
+
+ (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
+ PrelBase.:DEq tpl1 tpl2 -> tpl2;
+ };
+
+ Test.$wtest =
+ \r [ww ww1]
+ let { y = PrelBase.I#! [ww1]; } in
+ let { x = PrelBase.I#! [ww]; } in
+ let { sat_slx = PrelTup.(,)! [y x]; } in
+ let { sat_sly = PrelTup.(,)! [x y];
+ } in
+ case == sat_sly sat_slx of wild {
+ PrelBase.False -> Test.$wtest ww1 ww;
+ PrelBase.True -> PrelBase.True [];
+ };
+
+ Test.test =
+ \r [w w1]
+ case w of w2 {
+ PrelBase.I# ww ->
+ case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
+ };
+
+Why didn't GHC inline $fEq in those days? Because it looked big:
+
+ PrelTup.zdfEqZ1T{-rcX-}
+ = \ @ a{-reT-} :: * @ b{-reS-} :: *
+ zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
+ zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
+ let {
+ zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
+ zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
+ let {
+ zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
+ zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
+ let {
+ zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
+ zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
+ ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
+ case ds{-rf5-}
+ of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
+ case ds1{-rf4-}
+ of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
+ PrelBase.zaza{-r4e-}
+ (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
+ (zeze{-rf0-} a2{-reZ-} b2{-reY-})
+ }
+ } } in
+ let {
+ a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
+ a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
+ b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
+ PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
+ } in
+ PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
+
+and it's not as bad as it seems, because it's further dramatically
+simplified: only zeze2 is extracted and its body is simplified.
%************************************************************************
; return (binds, tcl_env) }
\end{code}
-======= New documentation starts here (Sept 92) ==============
-
-The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
-the dictionary function for this instance declaration. For example
-
- instance Foo a => Foo [a] where
- op1 x = ...
- op2 y = ...
-
-might generate something like
-
- dfun.Foo.List dFoo_a = let op1 x = ...
- op2 y = ...
- in
- Dict [op1, op2]
-
-HOWEVER, if the instance decl has no context, then it returns a
-bigger @HsBinds@ with declarations for each method. For example
-
- instance Foo [a] where
- op1 x = ...
- op2 y = ...
-
-might produce
-
- dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
- const.Foo.op1.List a x = ...
- const.Foo.op2.List a y = ...
-
-This group may be mutually recursive, because (for example) there may
-be no method supplied for op2 in which case we'll get
-
- const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
-
-that is, the default method applied to the dictionary at this type.
-What we actually produce in either case is:
-
- AbsBinds [a] [dfun_theta_dicts]
- [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
- { d = (sd1,sd2, ..., op1, op2, ...)
- op1 = ...
- op2 = ...
- }
-
-The "maybe" says that we only ask AbsBinds to make global constant methods
-if the dfun_theta is empty.
-
-For an instance declaration, say,
-
- instance (C1 a, C2 b) => C (T a b) where
- ...
-
-where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
-function whose type is
-
- (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
-
-Notice that we pass it the superclass dictionaries at the instance type; this
-is the ``Mark Jones optimisation''. The stuff before the "=>" here
-is the @dfun_theta@ below.
-
\begin{code}
tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
-- Typecheck the methods
let -- These insts are in scope; quite a few, eh?
- dfun_insts = dfun_eqs ++ dfun_dicts
- wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
- given_sc_eqs = map (updateEqInstCoercion (mkGivenCo . TyVarTy . fromWantedCo "tcInstDecl2") ) wanted_sc_eqs
- given_sc_insts = given_sc_eqs ++ sc_dicts
- avail_insts = dfun_insts ++ given_sc_insts
-
- (meth_ids, meth_binds) <- tcMethods origin clas inst_tyvars'
- dfun_theta' inst_tys' this_dict avail_insts
- op_items monobinds uprags
+ dfun_insts = dfun_eqs ++ dfun_dicts
+ wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
+ this_dict_id = instToId this_dict
+ sc_dict_ids = map instToId sc_dicts
+ dfun_dict_ids = map instToId dfun_dicts
+ prag_fn = mkPragFun uprags
+ tc_meth = tcInstanceMethod loc clas inst_tyvars'
+ (dfun_covars ++ dfun_dict_ids)
+ dfun_theta' inst_tys'
+ this_dict_id
+ monobinds prag_fn
+ (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items
-- Figure out bindings for the superclass context
-- Don't include this_dict in the 'givens', else
-- Create the result bindings
let
dict_constr = classDataCon clas
- scs_and_meths = map instToId sc_dicts ++ meth_ids
- this_dict_id = instToId this_dict
inline_prag | null dfun_insts = []
| otherwise = [L loc (InlinePrag (Inline AlwaysActive True))]
-- Always inline the dfun; this is an experimental decision
-- See Note [Inline dfuns] below
dict_rhs = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars)
- (map HsVar scs_and_meths)
+ (map HsVar sc_dict_ids ++ meth_exprs)
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
-- We do this rather than generate an HsCon directly, because
-- than needing to be repeated here.
dict_bind = noLoc (VarBind this_dict_id dict_rhs)
- all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
main_bind = noLoc $ AbsBinds
(inst_tyvars' ++ dfun_covars)
- (map instToId dfun_dicts)
+ dfun_dict_ids
[(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
- all_binds
+ (dict_bind `consBag` sc_binds)
showLIE (text "instance")
- return (unitBag main_bind)
+ return (main_bind `consBag` unionManyBags meth_binds)
mkCoVars :: [PredType] -> TcM [TyVar]
mkCoVars = newCoVars . map unEqPred
where
eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars"
+\end{code}
-tcMethods :: InstOrigin -> Class -> [TcTyVar] -> TcThetaType -> [TcType]
- -> Inst -> [Inst] -> [(Id, DefMeth)] -> LHsBindsLR Name Name
- -> [LSig Name]
- -> TcM ([Id], Bag (LHsBind Id))
-tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
- this_dict extra_insts op_items monobinds uprags = do
- -- Check that all the method bindings come from this class
- let
- sel_names = [idName sel_id | (sel_id, _) <- op_items]
- bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
- mapM (addErrTc . badMethodErr clas) bad_bndrs
- -- Make the method bindings
- let
- mk_method_id (sel_id, _) = mkMethId origin clas sel_id inst_tys'
-
- (meth_insts, meth_ids) <- mapAndUnzipM mk_method_id op_items
-
- -- And type check them
- -- It's really worth making meth_insts available to the tcMethodBind
- -- Consider instance Monad (ST s) where
- -- {-# INLINE (>>) #-}
- -- (>>) = ...(>>=)...
- -- If we don't include meth_insts, we end up with bindings like this:
- -- rec { dict = MkD then bind ...
- -- then = inline_me (... (GHC.Base.>>= dict) ...)
- -- bind = ... }
- -- The trouble is that (a) 'then' and 'dict' are mutually recursive,
- -- and (b) the inline_me prevents us inlining the >>= selector, which
- -- would unravel the loop. Result: (>>) ends up as a loop breaker, and
- -- is not inlined across modules. Rather ironic since this does not
- -- happen without the INLINE pragma!
- --
- -- Solution: make meth_insts available, so that 'then' refers directly
- -- to the local 'bind' rather than going via the dictionary.
- --
- -- BUT WATCH OUT! If the method type mentions the class variable, then
- -- this optimisation is not right. Consider
- -- class C a where
- -- op :: Eq a => a
- --
- -- instance C Int where
- -- op = op
- -- The occurrence of 'op' on the rhs gives rise to a constraint
- -- op at Int
- -- The trouble is that the 'meth_inst' for op, which is 'available', also
- -- looks like 'op at Int'. But they are not the same.
- let
- prag_fn = mkPragFun uprags
- all_insts = extra_insts ++ catMaybes meth_insts
- sig_fn _ = Just [] -- No scoped type variables, but every method has
- -- a type signature, in effect, so that we check
- -- the method has the right type
- tc_method_bind = tcMethodBind origin inst_tyvars' dfun_theta' this_dict
- all_insts sig_fn prag_fn monobinds
-
- meth_binds_s <- zipWithM tc_method_bind op_items meth_ids
+tcInstanceMethod
+- Make the method bindings, as a [(NonRec, HsBinds)], one per method
+- Remembering to use fresh Name (the instance method Name) as the binder
+- Bring the instance method Ids into scope, for the benefit of tcInstSig
+- Use sig_fn mapping instance method Name -> instance tyvars
+- Ditto prag_fn
+- Use tcValBinds to do the checking
- return (meth_ids, unionManyBags meth_binds_s)
+\begin{code}
+tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var]
+ -> TcThetaType -> [TcType] -> Id
+ -> LHsBinds Name -> TcPragFun
+ -> (Id, DefMeth)
+ -> TcM (HsExpr Id, LHsBinds Id)
+ -- The returned inst_meth_ids all have types starting
+ -- forall tvs. theta => ...
+
+tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys this_dict_id
+ binds_in prag_fn (sel_id, dm_info)
+ = do { uniq <- newUnique
+ ; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
+ rho_ty = ASSERT( length sel_tyvars == length inst_tys )
+ substTyWith sel_tyvars inst_tys sel_rho
+ (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty
+ `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
+
+ -- The first predicate should be of form (C a b)
+ -- where C is the class in question
+ meth_ty = mkSigmaTy tyvars theta meth_tau
+ meth_name = mkInternalName uniq sel_occ loc -- Same OccName
+ meth_id = mkLocalId meth_name meth_ty
+
+ ; MASSERT( case getClassPredTys_maybe first_pred of
+ { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
+
+
+ ; case (findMethodBind sel_name meth_name binds_in, dm_info) of
+ -- There is a user-supplied method binding, so use it
+ (Just user_bind, _) -> typecheck_meth meth_id user_bind
+
+ -- The user didn't supply a method binding, so we have to make
+ -- up a default binding, in a way depending on the default-method info
+
+ (Nothing, GenDefMeth) -> do -- Derivable type classes stuff
+ { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name
+ ; typecheck_meth meth_id meth_bind }
+
+ (Nothing, NoDefMeth) -> do -- No default method in the class
+ { warn <- doptM Opt_WarnMissingMethods
+ ; warnTc (warn -- Warn only if -fwarn-missing-methods
+ && reportIfUnused (getOccName sel_id))
+ -- Don't warn about _foo methods
+ (omittedMethodWarn sel_id)
+ ; return (mk_error_rhs meth_tau, emptyBag) }
+
+ (Nothing, DefMeth) -> do -- An polymorphic default method
+ { -- Build the typechecked version directly,
+ -- without calling typecheck_method;
+ -- see Note [Default methods in instances]
+ dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
+ -- Might not be imported, but will be an OrigName
+ ; dm_id <- tcLookupId dm_name
+ ; return (wrap dm_wrapper dm_id, emptyBag) } }
+ where
+ sel_name = idName sel_id
+ sel_occ = nameOccName sel_name
+ tv_names = map tyVarName tyvars
+ prags = prag_fn sel_name
+
+ typecheck_meth :: Id -> LHsBind Name -> TcM (HsExpr Id, LHsBinds Id)
+ typecheck_meth meth_id bind
+ = do { tc_binds <- tcMethodBind tv_names prags meth_id bind
+ ; return (wrap meth_wrapper meth_id, tc_binds) }
+
+ mk_error_rhs tau = HsApp (mkLHsWrap (WpTyApp tau) error_id) error_msg
+ error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID)
+ error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
+ error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+
+ wrap wrapper id = mkHsWrap wrapper (HsVar id)
+ meth_wrapper = mkWpApps dfun_lam_vars `WpCompose` mkWpTyApps (mkTyVarTys tyvars)
+ dm_wrapper = WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys
+
+omittedMethodWarn :: Id -> SDoc
+omittedMethodWarn sel_id
+ = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)
\end{code}
+Note [Default methods in instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
- ------------------------------
- [Inline dfuns] Inlining dfuns unconditionally
- ------------------------------
+ class Baz v x where
+ foo :: x -> x
+ foo y = y
-The code above unconditionally inlines dict funs. Here's why.
-Consider this program:
+ instance Baz Int Int
- test :: Int -> Int -> Bool
- test x y = (x,y) == (y,x) || test y x
- -- Recursive to avoid making it inline.
+From the class decl we get
-This needs the (Eq (Int,Int)) instance. If we inline that dfun
-the code we end up with is good:
+ $dmfoo :: forall v x. Baz v x => x -> x
- Test.$wtest =
- \r -> case ==# [ww ww1] of wild {
- PrelBase.False -> Test.$wtest ww1 ww;
- PrelBase.True ->
- case ==# [ww1 ww] of wild1 {
- PrelBase.False -> Test.$wtest ww1 ww;
- PrelBase.True -> PrelBase.True [];
- };
- };
- Test.test = \r [w w1]
- case w of w2 {
- PrelBase.I# ww ->
- case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
- };
-
-If we don't inline the dfun, the code is not nearly as good:
+Notice that the type is ambiguous. That's fine, though. The instance decl generates
- (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
- PrelBase.:DEq tpl1 tpl2 -> tpl2;
- };
+ $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
- Test.$wtest =
- \r [ww ww1]
- let { y = PrelBase.I#! [ww1]; } in
- let { x = PrelBase.I#! [ww]; } in
- let { sat_slx = PrelTup.(,)! [y x]; } in
- let { sat_sly = PrelTup.(,)! [x y];
- } in
- case == sat_sly sat_slx of wild {
- PrelBase.False -> Test.$wtest ww1 ww;
- PrelBase.True -> PrelBase.True [];
- };
-
- Test.test =
- \r [w w1]
- case w of w2 {
- PrelBase.I# ww ->
- case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
- };
-
-Why doesn't GHC inline $fEq? Because it looks big:
-
- PrelTup.zdfEqZ1T{-rcX-}
- = \ @ a{-reT-} :: * @ b{-reS-} :: *
- zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
- zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
- let {
- zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
- zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
- let {
- zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
- zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
- let {
- zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
- zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
- ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
- case ds{-rf5-}
- of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
- case ds1{-rf4-}
- of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
- PrelBase.zaza{-r4e-}
- (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
- (zeze{-rf0-} a2{-reZ-} b2{-reY-})
- }
- } } in
- let {
- a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
- a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
- b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
- PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
- } in
- PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
-
-and it's not as bad as it seems, because it's further dramatically
-simplified: only zeze2 is extracted and its body is simplified.
+BUT this does mean we must generate the dictionary translation directly, rather
+than generating source-code and type-checking it. That was the bug ing
+Trac #1061. In any case it's less work to generate the translated version!
%************************************************************************
--------------------------------
-- Instantiation
tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
- tcInstSigTyVars,
- tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType,
+ tcInstSigType,
+ tcInstSkolTyVars, tcInstSkolType,
tcSkolSigType, tcSkolSigTyVars, occurCheckErr,
--------------------------------
tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info
| tv <- tyvars ]
-tcInstSkolTyVar :: SkolemInfo -> Maybe SrcSpan -> TyVar -> TcM TcTyVar
+tcInstSkolTyVar :: SkolemInfo -> (Name -> SrcSpan) -> TyVar -> TcM TcTyVar
-- Instantiate the tyvar, using
-- * the occ-name and kind of the supplied tyvar,
-- * the unique from the monad,
-- * the location either from the tyvar (mb_loc = Nothing)
-- or from mb_loc (Just loc)
-tcInstSkolTyVar info mb_loc tyvar
+tcInstSkolTyVar info get_loc tyvar
= do { uniq <- newUnique
; let old_name = tyVarName tyvar
kind = tyVarKind tyvar
- loc = mb_loc `orElse` getSrcSpan old_name
+ loc = get_loc old_name
new_name = mkInternalName uniq (nameOccName old_name) loc
; return (mkSkolTyVar new_name kind info) }
-- Get the location from the monad
tcInstSkolTyVars info tyvars
= do { span <- getSrcSpanM
- ; mapM (tcInstSkolTyVar info (Just span)) tyvars }
+ ; mapM (tcInstSkolTyVar info (const span)) tyvars }
tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
-- Instantiate a type with fresh skolem constants
-- Binding location comes from the monad
tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty
+
+tcInstSigType :: Bool -> SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcRhoType)
+-- Instantiate with skolems or meta SigTvs; depending on use_skols
+-- Always take location info from the supplied tyvars
+tcInstSigType use_skols skol_info ty
+ = tcInstType (mapM inst_tyvar) ty
+ where
+ inst_tyvar | use_skols = tcInstSkolTyVar skol_info getSrcSpan
+ | otherwise = instMetaTyVar (SigTv skol_info)
\end{code}
%************************************************************************
\begin{code}
-tcInstSigTyVars :: Bool -> SkolemInfo -> [TyVar] -> TcM [TcTyVar]
--- Instantiate with skolems or meta SigTvs; depending on use_skols
--- Always take location info from the supplied tyvars
-tcInstSigTyVars use_skols skol_info tyvars
- | use_skols
- = mapM (tcInstSkolTyVar skol_info Nothing) tyvars
-
- | otherwise
- = mapM (instMetaTyVar (SigTv skol_info)) tyvars
-
zonkSigTyVar :: TcTyVar -> TcM TcTyVar
zonkSigTyVar sig_tv
| isSkolemTyVar sig_tv
tcDoStmt, tcMDoStmt, tcGuardStmt
) where
-import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcMonoExpr, tcPolyExpr )
import HsSyn
import TcRnMonad
-- This is one of two places places we call subFunTys
-- The point is that if expected_y is a "hole", we want
-- to make pat_tys and rhs_ty as "holes" too.
- ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
+ ; subFunTys doc n_pats exp_ty (Just (FunSigCtxt fun_name)) $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty matches
}
where
tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
tcMatchLambda match res_ty
- = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
+ = subFunTys doc n_pats res_ty Nothing $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty match
where
n_pats = matchGroupArity match
tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
tcBody body res_ty
= do { traceTc (text "tcBody" <+> ppr res_ty)
- ; body' <- tcPolyExpr body res_ty
+ ; body' <- tcMonoExpr body res_ty
; return body'
}
\end{code}
; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRho rhs
+ = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
return (usingExpr', Nothing)
Just byExpr -> do
-- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
- (byExpr', tTy) <- tcInferRho byExpr
+ (byExpr', tTy) <- tcInferRhoNC byExpr
usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
return (usingExpr', Just byExpr')
tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
GroupBySomething eitherUsingExpr byExpr -> do
-- We must infer a type such that byExpr :: t
- (byExpr', tTy) <- tcInferRho byExpr
+ (byExpr', tTy) <- tcInferRhoNC byExpr
-- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
tcDoStmt :: TcStmtChecker
tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRho rhs
+ = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
-- We should use type *inference* for the RHS computations,
-- becuase of GADTs.
-- do { pat <- rhs; <rest> }
tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRho rhs
+ = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
-- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
; (then_op', new_res_ty) <-
-- Splitters
-- These are important because they do not look through newtypes
tcView,
- tcSplitForAllTys, tcSplitPhiTy,
+ tcSplitForAllTys, tcSplitPhiTy, tcSplitPredFunTy_maybe,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv)
tcIsForAllTy _ = False
+tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
+-- Split off the first predicate argument from a type
+tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
+tcSplitPredFunTy_maybe (ForAllTy tv ty)
+ | isCoVar tv = Just (coVarPred tv, ty)
+tcSplitPredFunTy_maybe (FunTy arg res)
+ | Just p <- tcSplitPredTy_maybe arg = Just (p, res)
+tcSplitPredFunTy_maybe _
+ = Nothing
+
tcSplitPhiTy :: Type -> (ThetaType, Type)
-tcSplitPhiTy ty = split ty ty []
- where
- split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
-
- split _ (ForAllTy tv ty) ts
- | isCoVar tv = split ty ty (coVarPred tv : ts)
- split _ (FunTy arg res) ts
- | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
- split orig_ty _ ts = (reverse ts, orig_ty)
+tcSplitPhiTy ty
+ = split ty []
+ where
+ split ty ts
+ = case tcSplitPredFunTy_maybe ty of
+ Just (pred, ty) -> split ty (pred:ts)
+ Nothing -> (reverse ts, ty)
tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy ty = case tcSplitForAllTys ty of
subFunTys :: SDoc -- Something like "The function f has 3 arguments"
-- or "The abstraction (\x.e) takes 1 argument"
-> Arity -- Expected # of args
- -> BoxyRhoType -- res_ty
+ -> BoxySigmaType -- res_ty
+ -> Maybe UserTypeCtxt -- Whether res_ty arises from a user signature
+ -- Only relevant if we encounter a sigma-type
-> ([BoxySigmaType] -> BoxyRhoType -> TcM a)
-> TcM (HsWrapper, a)
-- Attempt to decompse res_ty to have enough top-level arrows to
-}
-subFunTys error_herald n_pats res_ty thing_inside
+subFunTys error_herald n_pats res_ty mb_ctxt thing_inside
= loop n_pats [] res_ty
where
-- In 'loop', the parameter 'arg_tys' accumulates
| isSigmaTy res_ty -- Do this before checking n==0, because we
-- guarantee to return a BoxyRhoType, not a
-- BoxySigmaType
- = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet $ \ _ res_ty' ->
- loop n args_so_far res_ty'
+ = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet mb_ctxt $
+ loop n args_so_far
; return (gen_fn <.> co_fn, res) }
loop 0 args_so_far res_ty
if exp_ib then -- SKOL does not apply if exp_ty is inside a box
defer_to_boxy_matching orig act_sty act_ty exp_ib exp_sty exp_ty
else do
- { (gen_fn, co_fn) <- tcGen exp_ty act_tvs $ \ _ body_exp_ty ->
+ { (gen_fn, co_fn) <- tcGen exp_ty act_tvs Nothing $ \ body_exp_ty ->
tc_sub orig act_sty act_ty False body_exp_ty body_exp_ty
; return (gen_fn <.> co_fn) }
}
-> TcTyVarSet -- Extra tyvars that the universally
-- quantified tyvars of expected_ty
-- must not be unified
- -> ([TcTyVar] -> BoxyRhoType -> TcM result)
+ -> Maybe UserTypeCtxt -- Just ctxt => this polytype arose directly from
+ -- a user type sig; bring tyvars into scope
+ -- Nothing => a higher order situation
+ -> (BoxyRhoType -> TcM result)
-> TcM (HsWrapper, result)
-- The expression has type: spec_ty -> expected_ty
-tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall-type
- -- If not, the call is a no-op
+tcGen expected_ty extra_tvs mb_ctxt thing_inside -- We expect expected_ty to be a forall-type
+ -- If not, the call is a no-op
= do { traceTc (text "tcGen")
- -- We want the GenSkol info in the skolemised type variables to
- -- mention the *instantiated* tyvar names, so that we get a
- -- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
- -- Hence the tiresome but innocuous fixM
- ; ((tvs', theta', rho'), skol_info) <- fixM (\ ~(_, skol_info) ->
- do { (forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
- -- Get loation from monad, not from expected_ty
- ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty)
- ; return ((forall_tvs, theta, rho_ty), skol_info) })
+ ; ((tvs', theta', rho'), skol_info, scoped_tvs) <- instantiate expected_ty
; when debugIsOn $
traceTc (text "tcGen" <+> vcat [
text "free_tvs" <+> ppr free_tvs])
-- Type-check the arg and unify with poly type
- ; (result, lie) <- getLIE (thing_inside tvs' rho')
+ ; (result, lie) <- getLIE $
+ tcExtendTyVarEnv2 (scoped_tvs `zip` mkTyVarTys tvs') $
+ -- Extend the lexical type-variable environment
+ -- if we're in a user-type context
+ thing_inside rho'
-- Check that the "forall_tvs" havn't been constrained
-- The interesting bit here is that we must include the free variables
; return (co_fn, result) }
where
free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
+
+ instantiate :: TcType -> TcM (([TcTyVar],ThetaType,TcRhoType), SkolemInfo, [Name])
+ instantiate expected_ty
+ | Just ctxt <- mb_ctxt
+ = do { let skol_info = SigSkol ctxt
+ tv_names = map tyVarName (fst (tcSplitForAllTys expected_ty))
+ ; stuff <- tcInstSigType True skol_info expected_ty
+ ; return (stuff, skol_info, tv_names) }
+
+ | otherwise -- We want the GenSkol info in the skolemised type variables to
+ -- mention the *instantiated* tyvar names, so that we get a
+ -- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
+ -- Hence the tiresome but innocuous fixM
+ = fixM $ \ ~(_, skol_info, _) ->
+ do { stuff@(forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
+ -- Get loation from *monad*, not from expected_ty
+ ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty)
+ ; return (stuff, skol_info, []) }
\end{code}
projects / ghc-hetmet.git / commitdiff