Commit 5edf58c1 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Deal correctly with infix type constructors in GADT decls

parent 3afa01b9
......@@ -630,30 +630,22 @@ checkValSig (L l (HsVar v)) ty
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.
......
......@@ -593,18 +593,22 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty)
; 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 ->
......
......@@ -543,23 +543,26 @@ GADT constructor signatures
\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:"))
......
......@@ -301,7 +301,7 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
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)
......
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