From: simonpj@microsoft.com <unknown>
Date: Wed, 26 Jul 2006 22:53:04 +0000 (+0000)
Subject: Deal correctly with infix type constructors in GADT decls
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=5edf58c10a0144fa8b328e18d0b7fffec2319424

Deal correctly with infix type constructors in GADT decls
---

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 15aa859..d338b7c 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -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.
 
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index bd9c549..79721cf 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -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  ->
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 968ccfb..e4b1267 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -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:"))
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 9e0b6cc..1a9d4c0 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -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)