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 (file)
--- 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"
 
 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.
 
 
 -- A variable binding is parsed as a FunBind.
 

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index bd9c549..79721cf 100644 (file)
--- 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
        ; 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))
 
   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
     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  ->
 
 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 (file)
--- 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])
 
 \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:"))
 
 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 (file)
--- 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
         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) 
         return (ConDecl name expl ex_tvs' ex_ctxt' details' res')
 
     kc_con_details (PrefixCon btys)