- ------------------------------------------------------------------
- derive_these :: [(SrcSpan, InstOrigin, NewOrData, Name, LHsType Name)]
- -- Find the (nd, TyCon, Pred) pairs that must be `derived'
- derive_these = [ (srcLocSpan (getSrcLoc tycon), DerivOrigin, nd, tycon, pred)
- | L _ (TyData { tcdND = nd, tcdLName = L _ tycon,
- tcdDerivs = Just preds }) <- tycl_decls,
- pred <- preds ]
-
- top_level_deriv :: LDerivDecl Name -> TcM (Maybe (SrcSpan, InstOrigin, NewOrData, Name, LHsType Name))
- top_level_deriv d@(L l (DerivDecl inst ty_name)) = recoverM (returnM Nothing) $ setSrcSpan l $
- do tycon <- tcLookupLocatedTyCon ty_name
- let new_or_data = if isNewTyCon tycon then NewType else DataType
- traceTc (text "Stand-alone deriving:" <+> ppr (new_or_data, unLoc ty_name, inst))
- return $ Just (l, StandAloneDerivOrigin, new_or_data, unLoc ty_name, inst)
-
- ------------------------------------------------------------------
- -- takes (whether newtype or data, name of data type, partially applied type class)
- mk_eqn :: (SrcSpan, InstOrigin, NewOrData, Name, LHsType Name) -> TcM (Maybe DerivEqn, Maybe InstInfo)
- -- We swizzle the tyvars and datacons out of the tycon
- -- to make the rest of the equation
- --
- -- The "deriv_ty" is a LHsType to take account of the fact that for newtype derivign
- -- we allow deriving (forall a. C [a]).
-
- mk_eqn (loc, orig, new_or_data, tycon_name, hs_deriv_ty)
- = tcLookupTyCon tycon_name `thenM` \ tycon ->
- setSrcSpan loc $
- addErrCtxt (derivCtxt tycon) $
- tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
- -- the type variables for the type constructor
- tcHsDeriv hs_deriv_ty `thenM` \ (deriv_tvs, clas, tys) ->
- doptM Opt_GlasgowExts `thenM` \ gla_exts ->
- mk_eqn_help loc orig gla_exts new_or_data tycon deriv_tvs clas tys
-
- ------------------------------------------------------------------
- -- data/newtype T a = ... deriving( C t1 t2 )
- -- leads to a call to mk_eqn_help with
- -- tycon = T, deriv_tvs = ftv(t1,t2), clas = C, tys = [t1,t2]
-
- mk_eqn_help loc orig gla_exts DataType tycon deriv_tvs clas tys
- | Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys
- = bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
- | otherwise
- = do { eqn <- mkDataTypeEqn loc orig tycon clas
- ; returnM (Just eqn, Nothing) }
-
- mk_eqn_help loc orig gla_exts NewType tycon deriv_tvs clas tys
- | can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas)
- = do { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
- ; -- Go ahead and use the isomorphism
- dfun_name <- new_dfun_name clas tycon
- ; return (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name,
- iBinds = NewTypeDerived ntd_info })) }
- | std_class gla_exts clas
- = mk_eqn_help loc orig gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route
-
- | otherwise -- Non-standard instance
- = bale_out (if gla_exts then
- cant_derive_err -- Too hard
- else
- non_std_err) -- Just complain about being a non-std instance
- where
- -- Here is the plan for newtype derivings. We see
- -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
- -- where t is a type,
- -- ak+1...an is a suffix of a1..an
- -- ak+1...an do not occur free in t, nor in the s1..sm
- -- (C s1 ... sm) is a *partial applications* of class C
- -- with the last parameter missing
- -- (T a1 .. ak) matches the kind of C's last argument
- -- (and hence so does t)
- --
- -- We generate the instance
- -- instance forall ({a1..ak} u fvs(s1..sm)).
- -- C s1 .. sm t => C s1 .. sm (T a1...ak)
- -- where T a1...ap is the partial application of
- -- the LHS of the correct kind and p >= k
- --
- -- NB: the variables below are:
- -- tc_tvs = [a1, ..., an]
- -- tyvars_to_keep = [a1, ..., ak]
- -- rep_ty = t ak .. an
- -- deriv_tvs = fvs(s1..sm) \ tc_tvs
- -- tys = [s1, ..., sm]
- -- rep_fn' = t
- --
- -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
- -- We generate the instance
- -- instance Monad (ST s) => Monad (T s) where
+ -- Tiresomely we must figure out the "lhs", which is awkward for type families
+ -- E.g. data T a b = .. deriving( Eq )
+ -- Here, the lhs is (T a b)
+ -- data instance TF Int b = ... deriving( Eq )
+ -- Here, the lhs is (TF Int b)
+ -- But if we just look up the tycon_name, we get is the *family*
+ -- tycon, but not pattern types -- they are in the *rep* tycon.
+ get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name
+ ; let tvs = tyConTyVars tc
+ ; return (tvs, tc, mkTyVarTys tvs) }
+ get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
+ ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
+ ; let (tc, tc_args) = tcSplitTyConApp tc_app
+ ; return (tvs, tc, tc_args) }
+
+deriveTyData _other
+ = panic "derivTyData" -- Caller ensures that only TyData can happen
+\end{code}