[commit: ghc] wip/T11028: Stage1 compiles now. (a901d7e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T11028
Link       : http://ghc.haskell.org/trac/ghc/changeset/a901d7e42cb61ab67a30874f275b01055d2ea37f/ghc

>---------------------------------------------------------------

commit a901d7e42cb61ab67a30874f275b01055d2ea37f
Author: Alan Zimmerman <alan.zimm at gmail.com>
Date:   Wed Nov 25 16:10:32 2015 +0200

    Stage1 compiles now.


>---------------------------------------------------------------

a901d7e42cb61ab67a30874f275b01055d2ea37f
 compiler/typecheck/TcTyClsDecls.hs | 23 +++++++++++++----------
 1 file changed, 13 insertions(+), 10 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 0b6a603..592f279 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -510,7 +510,7 @@ kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
          -- concept doesn't really apply here. We just need to bring the variables
          -- into scope!
     do { _ <- kcHsTyVarBndrs False ((fromMaybe (HsQTvs mempty []) ex_tvs) ::LHsQTyVars Name) $
-              do { _ <- tcHsContext (fromMaybe mempty ex_ctxt)
+              do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
                  ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
                  ; return (panic "kcConDecl", ()) }
        ; return () }
@@ -1294,7 +1294,7 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
        ; (ctxt, arg_tys, field_lbls, stricts)
            <- tcHsQTyVars (fromMaybe (HsQTvs [] []) hs_tvs) $ \ _ ->
               do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
-                 ; ctxt <- tcHsContext (fromMaybe mempty hs_ctxt)
+                 ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
                  ; btys <- tcConArgs new_or_data hs_details
                  ; field_lbls <- lookupConstructorFields (unLoc name)
                  ; let (arg_tys, stricts) = unzip btys
@@ -1325,7 +1325,7 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
        ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
        ; let
            buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfix name hs_details ResTyH98
+             { is_infix <- tcConIsInfixH98 name hs_details
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix
@@ -1358,7 +1358,7 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
                  ; ty' <- tcHsLiftedType bty
                  ; field_lbls <- lookupConstructorFields (unLoc $ head names)
                  ; let (arg_tys, stricts) = unzip btys
-                 ; return (ctxt, arg_tys, ty, field_lbls, stricts)
+                 ; return (ctxt, arg_tys, ty', field_lbls, stricts)
                  }
 
              -- Generalise the kind variables (returning quantified TcKindVars)
@@ -1375,7 +1375,7 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
        ; ctxt    <- zonkTcTypeToTypes ze ctxt
        ; res_ty  <- zonkTcTypeToType ze res_ty
 
-       ; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty
+       ; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs (ResTyGADT undefined res_ty)
              -- NB: this is a /lazy/ binding, so we pass four thunks to buildDataCon
              --     without yet forcing the guards in rejigConRes
              -- See Note [Checking GADT return types]
@@ -1387,7 +1387,7 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
        ; let
            buildOneDataCon (L _ name) = do
              { let hs_details = gadtDeclDetails ty
-             ; is_infix <- tcConIsInfix name hs_details res_ty
+             ; is_infix <- tcConIsInfixGADT name hs_details
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix
@@ -1470,15 +1470,18 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl
        }
 -}
 
-tcConIsInfix :: Name
+tcConIsInfixH98 :: Name
              -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-             -> ResType Type
              -> TcM Bool
-tcConIsInfix _   details ResTyH98
+tcConIsInfixH98 _   details
   = case details of
            InfixCon {}  -> return True
            _            -> return False
-tcConIsInfix con details (ResTyGADT _ _)
+
+tcConIsInfixGADT :: Name
+             -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
+             -> TcM Bool
+tcConIsInfixGADT con details
   = case details of
            InfixCon {}  -> return True
            RecCon {}    -> return False