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

[git at git.haskell.org]

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

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

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

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

    Stage1 compiles now.


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

5f8b07fd86f6d414c0a78301d2ade25eebcf97f7
 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 252e579..634c6ed 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -504,7 +504,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 () }
@@ -1281,7 +1281,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
@@ -1312,7 +1312,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
@@ -1345,7 +1345,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)
@@ -1362,7 +1362,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]
@@ -1374,7 +1374,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
@@ -1457,15 +1457,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