checkValSig (L l other) ty
= parseError l "Invalid type signature"
-mkGadtDecl
- :: Located RdrName
- -> LHsType RdrName -- assuming HsType
- -> ConDecl RdrName
-mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl
- { con_name = name
- , con_explicit = Implicit
- , con_qvars = qvars
- , con_cxt = cxt
- , con_details = PrefixCon args
- , con_res = ResTyGADT res
- }
- where
- (args, res) = splitHsFunType ty
-mkGadtDecl name ty = ConDecl
- { con_name = name
- , con_explicit = Implicit
- , con_qvars = []
- , con_cxt = noLoc []
- , con_details = PrefixCon args
- , con_res = ResTyGADT res
- }
- where
- (args, res) = splitHsFunType ty
+mkGadtDecl :: Located RdrName
+ -> LHsType RdrName -- assuming HsType
+ -> ConDecl RdrName
+mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
+mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
+
+mk_gadt_con name qvars cxt ty
+ = ConDecl { con_name = name
+ , con_explicit = Implicit
+ , con_qvars = qvars
+ , con_cxt = cxt
+ , con_details = PrefixCon []
+ , con_res = ResTyGADT ty }
+ -- NB: we put the whole constr type into the ResTyGADT for now;
+ -- the renamer will unravel it once it has sorted out
+ -- operator fixities
-- A variable binding is parsed as a FunBind.
; bindTyVarsRn doc tvs' $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
; new_details <- rnConDetails doc details
- ; new_res_ty <- rnConResult doc res_ty
- ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
- ; traceRn (text "****** - autrijus" <> ppr rv)
- ; return rv } }
+ ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
+ ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
-rnConResult _ ResTyH98 = return ResTyH98
-rnConResult doc (ResTyGADT ty) = do
+rnConResult _ details ResTyH98 = return (details, ResTyH98)
+
+rnConResult doc details (ResTyGADT ty) = do
ty' <- rnHsSigType doc ty
- return $ ResTyGADT ty'
+ let (arg_tys, res_ty) = splitHsFunType ty'
+ -- We can split it up, now the renamer has dealt with fixities
+ case details of
+ PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
+ RecCon fields -> return (details, ResTyGADT ty')
+ InfixCon {} -> panic "rnConResult"
rnConDetails doc (PrefixCon tys)
= mappM (rnLHsType doc) tys `thenM` \ new_tys ->
\begin{code}
tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])
-tcLHsConResTy ty@(L span _)
- = setSrcSpan span $
- addErrCtxt (gadtResCtxt ty) $
- tc_con_res ty []
-
-tc_con_res (L _ (HsAppTy fun res_ty)) res_tys
- = do { res_ty' <- dsHsType res_ty
- ; tc_con_res fun (res_ty' : res_tys) }
-
-tc_con_res ty@(L _ (HsTyVar name)) res_tys
- = do { thing <- tcLookup name
- ; case thing of
- AGlobal (ATyCon tc) -> return (tc, res_tys)
- other -> failWithTc (badGadtDecl ty)
- }
-
-tc_con_res ty _ = failWithTc (badGadtDecl ty)
+tcLHsConResTy res_ty
+ = addErrCtxt (gadtResCtxt res_ty) $
+ case get_largs res_ty [] of
+ (HsTyVar tc_name, args)
+ -> do { args' <- mapM dsHsType args
+ ; thing <- tcLookup tc_name
+ ; case thing of
+ AGlobal (ATyCon tc) -> return (tc, args')
+ other -> failWithTc (badGadtDecl res_ty) }
+ other -> failWithTc (badGadtDecl res_ty)
+ where
+ -- We can't call dsHsType on res_ty, and then do tcSplitTyConApp_maybe
+ -- because that causes a black hole, and for good reason. Building
+ -- the type means expanding type synonyms, and we can't do that
+ -- inside the "knot". So we have to work by steam.
+ get_largs (L _ ty) args = get_args ty args
+ get_args (HsAppTy fun arg) args = get_largs fun (arg:args)
+ get_args (HsParTy ty) args = get_largs ty args
+ get_args (HsOpTy ty1 (L span tc) ty2) args = get_args (HsTyVar tc) (ty1:ty2:args)
+ get_args ty args = (ty, reverse args)
gadtResCtxt ty
= hang (ptext SLIT("In the result type of a data constructor:"))
details' <- kc_con_details details
res' <- case res of
ResTyH98 -> return ResTyH98
- ResTyGADT ty -> return . ResTyGADT =<< kcHsSigType ty
+ ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
return (ConDecl name expl ex_tvs' ex_ctxt' details' res')
kc_con_details (PrefixCon btys)