- ; repConstr con1 details
- }
-repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 }))
- = addTyVarBinds tvs $ \bndrs ->
- do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] }))
- ; ctxt' <- repContext ctxt
- ; bndrs' <- coreList tyVarBndrTyConName bndrs
- ; rep2 forallCName [unC bndrs', unC ctxt', unC c']
- }
-repC (L loc con_decl) -- GADTs
- = putSrcSpanDs loc $
- notHandled "GADT declaration" (ppr con_decl)
-
+ ; repConstr con1 details }
+repC tvs (L _ (ConDecl { con_name = con
+ , con_qvars = con_tvs, con_cxt = L _ ctxt
+ , con_details = details
+ , con_res = res_ty }))
+ = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
+ ; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
+ ; binds <- mapM dupBinder con_tv_subst
+ ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
+ addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs
+ do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
+ ; c' <- repConstr con1 details
+ ; ctxt' <- repContext (eq_ctxt ++ ctxt)
+ ; ex_bndrs' <- coreList tyVarBndrTyConName ex_bndrs
+ ; rep2 forallCName [unC ex_bndrs', unC ctxt', unC c'] } }
+
+in_subst :: Name -> [(Name,Name)] -> Bool
+in_subst _ [] = False
+in_subst n ((n',_):ns) = n==n' || in_subst n ns
+
+mkGadtCtxt :: [Name] -- Tyvars of the data type
+ -> ResType Name
+ -> DsM (HsContext Name, [(Name,Name)])
+-- Given a data type in GADT syntax, figure out the equality
+-- context, so that we can represent it with an explicit
+-- equality context, because that is the only way to express
+-- the GADT in TH syntax
+--
+-- Example:
+-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
+-- mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
+-- returns
+-- (b~[e], c~e), [d->a]
+--
+-- This function is fiddly, but not really hard
+mkGadtCtxt _ ResTyH98
+ = return ([], [])
+mkGadtCtxt data_tvs (ResTyGADT res_ty)
+ | let (head_ty, tys) = splitHsAppTys res_ty []
+ , Just _ <- is_hs_tyvar head_ty
+ , data_tvs `equalLength` tys
+ = return (go [] [] (data_tvs `zip` tys))
+
+ | otherwise
+ = failWithDs (ptext (sLit "Malformed constructor result type") <+> ppr res_ty)
+ where
+ go cxt subst [] = (cxt, subst)
+ go cxt subst ((data_tv, ty) : rest)
+ | Just con_tv <- is_hs_tyvar ty
+ , isTyVarName con_tv
+ , not (in_subst con_tv subst)
+ = go cxt ((con_tv, data_tv) : subst) rest
+ | otherwise
+ = go (eq_pred : cxt) subst rest
+ where
+ loc = getLoc ty
+ eq_pred = L loc (HsEqualP (L loc (HsTyVar data_tv)) ty)
+
+ is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons
+ is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
+ is_hs_tyvar _ = Nothing
+
+