Refactor ConDecl: Trac #14529
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 28 Nov 2017 11:33:37 +0000 (11:33 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 7 Dec 2017 14:40:35 +0000 (14:40 +0000)
This patch refactors HsDecls.ConDecl.  Specifically

* ConDeclGADT was horrible, with all the information hidden
  inside con_res_ty.  Now it's kept separate, as it should be.

* ConDeclH98: use [LHsTyVarBndr] instead of LHsQTyVars for the
  existentials. There is no implicit binding here.

* Add a field con_forall to both ConDeclGADT and ConDeclH98
  which says if there is an explicit user-written forall.

* Field renamings in ConDecl
     con_cxt     to con_mb_cxt
     con_details to con_args

There is an accompanying submodule update to Haddock.

Also the following change turned out to remove a lot of clutter:

* add a smart constructor for HsAppsTy, namely mkHsAppsTy,
  and use it consistently. This avoids a lot of painful pattern
  matching for the common singleton case.

Two api-annotation tests (T10278, and T10399) are broken, hence marking
them as expect_broken(14529).  Alan is going to fix them, probably by
changing the con_forall field to
   con_forall :: Maybe SrcSpan
instead of Bool

24 files changed:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnNames.hs
compiler/rename/RnSource.hs
compiler/rename/RnTypes.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/utils/ListSetOps.hs
testsuite/tests/ghc-api/annotations/all.T
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
testsuite/tests/parser/should_compile/T14189.stderr
testsuite/tests/patsyn/should_fail/T11039.stderr
testsuite/tests/patsyn/should_fail/T11667.stderr
testsuite/tests/rename/should_compile/T5331.stderr
testsuite/tests/th/T13123.hs
testsuite/tests/typecheck/should_compile/T2494.stderr
utils/haddock
utils/hsc2hs

index 2a181e8..f77d23e 100644 (file)
@@ -630,51 +630,45 @@ repAnnProv ModuleAnnProvenance
 
 repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
 repC (L _ (ConDeclH98 { con_name = con
-                      , con_qvars = Nothing, con_cxt = Nothing
-                      , con_details = details }))
-  = repDataCon con details
+                      , con_forall = False
+                      , con_mb_cxt = Nothing
+                      , con_args = args }))
+  = repDataCon con args
 
 repC (L _ (ConDeclH98 { con_name = con
-                      , con_qvars = mcon_tvs, con_cxt = mcxt
-                      , con_details = details }))
-  = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs
-             ctxt    = unLoc $ fromMaybe (noLoc []) mcxt
-       ; addTyVarBinds con_tvs $ \ ex_bndrs ->
-         do { c'    <- repDataCon con details
-            ; ctxt' <- repContext ctxt
-            ; if isEmptyLHsQTvs con_tvs && null ctxt
+                      , con_forall = is_existential
+                      , con_ex_tvs = con_tvs
+                      , con_mb_cxt = mcxt
+                      , con_args = args }))
+  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
+         do { c'    <- repDataCon con args
+            ; ctxt' <- repMbContext mcxt
+            ; if not is_existential && isNothing mcxt
               then return c'
               else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
             }
        }
 
 repC (L _ (ConDeclGADT { con_names = cons
-                       , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })}))
-  | (details, res_ty', L _ [] , []) <- gadtDetails
-  , [] <- imp_tvs
-    -- no implicit or explicit variables, no context = no need for a forall
-  = do { let doc = text "In the constructor for " <+> ppr (head cons)
-       ; (hs_details, gadt_res_ty) <-
-           updateGadtResult failWithDs doc details res_ty'
-       ; repGadtDataCons cons hs_details gadt_res_ty }
-
-  | (details,res_ty',ctxt, exp_tvs) <- gadtDetails
-  = do { let doc = text "In the constructor for " <+> ppr (head cons)
-             con_tvs = HsQTvs { hsq_implicit  = imp_tvs
-                              , hsq_explicit  = exp_tvs
-                              , hsq_dependent = emptyNameSet }
-             -- NB: Don't put imp_tvs into the hsq_explicit field above
+                       , con_qvars = qtvs, con_mb_cxt = mcxt
+                       , con_args = args, con_res_ty = res_ty }))
+  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables
+  , Nothing <- mcxt      -- No context
+                         -- ==> no need for a forall
+  = repGadtDataCons cons args res_ty
+
+  | otherwise
+  = addTyVarBinds qtvs $ \ ex_bndrs ->
              -- See Note [Don't quantify implicit type variables in quotes]
-       ; addTyVarBinds con_tvs $ \ ex_bndrs -> do
-       { (hs_details, gadt_res_ty) <-
-           updateGadtResult failWithDs doc details res_ty'
-       ; c'    <- repGadtDataCons cons hs_details gadt_res_ty
-       ; ctxt' <- repContext (unLoc ctxt)
-       ; if null exp_tvs && null (unLoc ctxt)
+    do { c'    <- repGadtDataCons cons args res_ty
+       ; ctxt' <- repMbContext mcxt
+       ; if null (hsQTvExplicit qtvs) && isNothing mcxt
          then return c'
-         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } }
-  where
-     gadtDetails = gadtDeclDetails res_ty
+         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
+
+repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
+repMbContext Nothing          = repContext []
+repMbContext (Just (L _ cxt)) = repContext cxt
 
 repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
 repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
@@ -867,24 +861,30 @@ addSimpleTyVarBinds names thing_inside
        ; term <- addBinds fresh_names thing_inside
        ; wrapGenSyms fresh_names term }
 
+addHsTyVarBinds :: [LHsTyVarBndr GhcRn]  -- the binders to be added
+                -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
+                -> DsM (Core (TH.Q a))
+addHsTyVarBinds exp_tvs thing_inside
+  = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
+       ; term <- addBinds fresh_exp_names $
+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
+                                     (exp_tvs `zip` fresh_exp_names)
+                    ; thing_inside kbs }
+       ; wrapGenSyms fresh_exp_names term }
+  where
+    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
+
 addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added
               -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
               -> DsM (Core (TH.Q a))
 -- gensym a list of type variables and enter them into the meta environment;
 -- the computations passed as the second argument is executed in that extended
 -- meta environment and gets the *new* names on Core-level as an argument
-
-addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m
-  = do { fresh_imp_names <- mkGenSyms imp_tvs
-       ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
-       ; let fresh_names = fresh_imp_names ++ fresh_exp_names
-       ; term <- addBinds fresh_names $
-                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
-                                     (exp_tvs `zip` fresh_exp_names)
-                    ; m kbs }
-       ; wrapGenSyms fresh_names term }
-  where
-    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
+addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs })
+              thing_inside
+  = addSimpleTyVarBinds imp_tvs $
+    addHsTyVarBinds exp_tvs $
+    thing_inside
 
 addTyClTyVarBinds :: LHsQTyVars GhcRn
                   -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
@@ -943,12 +943,9 @@ repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
 repHsSigType (HsIB { hsib_vars = implicit_tvs
                    , hsib_body = body })
   | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
-  = addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs
-                          , hsq_explicit = explicit_tvs
-                          , hsq_dependent = emptyNameSet })
-    -- NB: Don't pass implicit_tvs to the hsq_explicit field above
-    -- See Note [Don't quantify implicit type variables in quotes]
-                  $ \ th_explicit_tvs ->
+  = addSimpleTyVarBinds implicit_tvs $
+      -- See Note [Don't quantify implicit type variables in quotes]
+    addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
     do { th_ctxt <- repLContext ctxt
        ; th_ty   <- repLTy ty
        ; if null explicit_tvs && null (unLoc ctxt)
@@ -958,20 +955,15 @@ repHsSigType (HsIB { hsib_vars = implicit_tvs
 repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
 repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
                          , hsib_body = body })
-  = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs ->
-      addTyVarBinds (newTvs [] exis) $ \th_exis ->
+  = addSimpleTyVarBinds implicit_tvs $
+         -- See Note [Don't quantify implicit type variables in quotes]
+    addHsTyVarBinds univs            $ \th_univs ->
+    addHsTyVarBinds exis             $ \th_exis ->
     do { th_reqs  <- repLContext reqs
        ; th_provs <- repLContext provs
        ; th_ty    <- repLTy ty
        ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }
   where
-    newTvs impl_tvs expl_tvs = HsQTvs
-      { hsq_implicit  = impl_tvs
-      , hsq_explicit  = expl_tvs
-      , hsq_dependent = emptyNameSet }
-    -- NB: Don't pass impl_tvs to the hsq_explicit field above
-    -- See Note [Don't quantify implicit type variables in quotes]
-
     (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body
 
 repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
@@ -990,8 +982,7 @@ repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)
 -- Arg of repForall is always HsForAllTy or HsQualTy
 repForall ty
  | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
- = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs
-                         , hsq_dependent = emptyNameSet }) $ \bndrs ->
+ = addHsTyVarBinds tvs $ \bndrs ->
    do { ctxt1  <- repLContext ctxt
       ; ty1    <- repLTy tau
       ; repTForall bndrs ctxt1 ty1 }
index 4336243..47c2182 100644 (file)
@@ -42,7 +42,7 @@ import MonadUtils ( foldrM )
 import qualified Data.ByteString as BS
 import Control.Monad( unless, liftM, ap, (<=<) )
 
-import Data.Maybe( catMaybes, fromMaybe, isNothing )
+import Data.Maybe( catMaybes, isNothing )
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
 
@@ -490,59 +490,57 @@ cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
 
 cvtConstr (NormalC c strtys)
   = do  { c'   <- cNameL c
-        ; cxt' <- returnL []
         ; tys' <- mapM cvt_arg strtys
-        ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
+        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }
 
 cvtConstr (RecC c varstrtys)
   = do  { c'    <- cNameL c
-        ; cxt'  <- returnL []
         ; args' <- mapM cvt_id_arg varstrtys
-        ; returnL $ mkConDeclH98 c' Nothing cxt'
+        ; returnL $ mkConDeclH98 c' Nothing Nothing
                                    (RecCon (noLoc args')) }
 
 cvtConstr (InfixC st1 c st2)
   = do  { c'   <- cNameL c
-        ; cxt' <- returnL []
         ; st1' <- cvt_arg st1
         ; st2' <- cvt_arg st2
-        ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
+        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }
 
 cvtConstr (ForallC tvs ctxt con)
-  = do  { tvs'        <- cvtTvs tvs
-        ; L loc ctxt' <- cvtContext ctxt
-        ; L _ con'    <- cvtConstr con
-        ; returnL $ case con' of
-                ConDeclGADT { con_type = conT } ->
-                  let hs_ty  = mkHsForAllTy tvs noSrcSpan tvs' rho_ty
-                      rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt')
-                                                         (hsib_body conT)
-                  in con' { con_type = mkHsImplicitBndrs hs_ty }
-                ConDeclH98  {} ->
-                  let qvars = case (tvs, con_qvars con') of
-                        ([], Nothing) -> Nothing
-                        (_ , m_qvs  ) -> Just $
-                          mkHsQTvs (hsQTvExplicit tvs' ++
-                                    maybe [] hsQTvExplicit m_qvs)
-                  in con' { con_qvars = qvars
-                          , con_cxt = Just $
-                            L loc (ctxt' ++
-                                   unLoc (fromMaybe (noLoc [])
-                                          (con_cxt con'))) } }
+  = do  { tvs'      <- cvtTvs tvs
+        ; ctxt'     <- cvtContext ctxt
+        ; L _ con'  <- cvtConstr con
+        ; returnL $ add_forall tvs' ctxt' con' }
+  where
+    add_cxt lcxt         Nothing           = Just lcxt
+    add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2))
+
+    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
+      = con { con_forall = not (null all_tvs)
+            , con_qvars  = mkHsQTvs all_tvs
+            , con_mb_cxt = add_cxt cxt' cxt }
+      where
+        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars
+
+    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
+      = con { con_forall = not (null all_tvs)
+            , con_ex_tvs = all_tvs
+            , con_mb_cxt = add_cxt cxt' cxt }
+      where
+        all_tvs = hsQTvExplicit tvs' ++ ex_tvs
 
 cvtConstr (GadtC c strtys ty)
   = do  { c'      <- mapM cNameL c
         ; args    <- mapM cvt_arg strtys
         ; L _ ty' <- cvtType ty
         ; c_ty    <- mk_arr_apps args ty'
-        ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
+        ; returnL $ mkGadtDecl c' c_ty}
 
 cvtConstr (RecGadtC c varstrtys ty)
   = do  { c'       <- mapM cNameL c
         ; ty'      <- cvtType ty
         ; rec_flds <- mapM cvt_id_arg varstrtys
         ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
-        ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
+        ; returnL $ mkGadtDecl c' rec_ty }
 
 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
 cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
index 55d43fd..8078582 100644 (file)
@@ -63,10 +63,8 @@ module HsDecls (
   CImportSpec(..),
   -- ** Data-constructor declarations
   ConDecl(..), LConDecl,
-  HsConDeclDetails, hsConDeclArgTys,
-  getConNames,
-  getConDetails,
-  gadtDeclDetails,
+  HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,
+  getConNames, getConArgs,
   -- ** Document comments
   DocDecl(..), LDocDecl, docDeclDoc,
   -- ** Deprecations
@@ -909,7 +907,7 @@ data FamilyDecl pass = FamilyDecl
   { fdInfo           :: FamilyInfo pass              -- type/data, closed/open
   , fdLName          :: Located (IdP pass)           -- type constructor
   , fdTyVars         :: LHsQTyVars pass              -- type variables
-  , fdFixity         :: LexicalFixity         -- Fixity used in the declaration
+  , fdFixity         :: LexicalFixity                -- Fixity used in the declaration
   , fdResultSig      :: LFamilyResultSig pass        -- result signature
   , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann
   }
@@ -1151,8 +1149,19 @@ type LConDecl pass = Located (ConDecl pass)
 data ConDecl pass
   = ConDeclGADT
       { con_names   :: [Located (IdP pass)]
-      , con_type    :: LHsSigType pass
-        -- ^ The type after the ‘::’
+
+      -- The next four fields describe the type after the '::'
+      -- See Note [GADT abstract syntax]
+      , con_forall  :: Bool              -- ^ True <=> explicit forall
+                                         --   False => hsq_explicit is empty
+      , con_qvars   :: LHsQTyVars pass
+                       -- Whether or not there is an /explicit/ forall, we still
+                       -- need to capture the implicitly-bound type/kind variables
+
+      , con_mb_cxt  :: Maybe (LHsContext pass) -- ^ User-written context (if any)
+      , con_args    :: HsConDeclDetails pass   -- ^ Arguments; never InfixCon
+      , con_res_ty  :: LHsType pass            -- ^ Result type
+
       , con_doc     :: Maybe LHsDocString
           -- ^ A possible Haddock comment.
       }
@@ -1160,24 +1169,56 @@ data ConDecl pass
   | ConDeclH98
       { con_name    :: Located (IdP pass)
 
-      , con_qvars     :: Maybe (LHsQTyVars pass)
-        -- User-written forall (if any), and its implicit
-        -- kind variables
-        -- Non-Nothing means an explicit user-written forall
-        --     e.g. data T a = forall b. MkT b (b->a)
-        --     con_qvars = {b}
-
-      , con_cxt       :: Maybe (LHsContext pass)
-        -- ^ User-written context (if any)
-
-      , con_details   :: HsConDeclDetails pass
-          -- ^ Arguments
+      , con_forall  :: Bool   -- ^ True <=> explicit user-written forall
+                              --     e.g. data T a = forall b. MkT b (b->a)
+                              --     con_ex_tvs = {b}
+                              -- False => con_ex_tvs is empty
+      , con_ex_tvs :: [LHsTyVarBndr pass]      -- ^ Existentials only
+      , con_mb_cxt :: Maybe (LHsContext pass)  -- ^ User-written context (if any)
+      , con_args   :: HsConDeclDetails pass    -- ^ Arguments; can be InfixCon
 
       , con_doc       :: Maybe LHsDocString
           -- ^ A possible Haddock comment.
       }
 deriving instance (DataId pass) => Data (ConDecl pass)
 
+{- Note [GADT abstract syntax]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There's a wrinkle in ConDeclGADT
+
+* For record syntax, it's all uniform.  Given:
+      data T a where
+        K :: forall a. Ord a => { x :: [a], ... } -> T a
+    we make the a ConDeclGADT for K with
+       con_qvars  = {a}
+       con_mb_cxt = Just [Ord a]
+       con_args   = RecCon <the record fields>
+       con_res_ty = T a
+
+  We need the RecCon before the reanmer, so we can find the record field
+  binders in HsUtils.hsConDeclsBinders.
+
+* However for a GADT constr declaration which is not a record, it can
+  be hard parse until we know operator fixities. Consider for example
+     C :: a :*: b -> a :*: b -> a :+: b
+  Initially this type will parse as
+      a :*: (b -> (a :*: (b -> (a :+: b))))
+  so it's hard to split up the arguments until we've done the precedence
+  resolution (in the renamer).
+
+  So:  - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr
+         type into the res_ty for a ConDeclGADT for now, and use
+         PrefixCon []
+            con_args   = PrefixCon []
+            con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b))))
+
+       - In the renamer (RnSource.rnConDecl), we unravel it afer
+         operator fixities are sorted. So we generate. So we end
+         up with
+            con_args   = PrefixCon [ a :*: b, a :*: b ]
+            con_res_ty = a :+: b
+-}
+
 -- | Haskell data Constructor Declaration Details
 type HsConDeclDetails pass
    = HsConDetails (LBangType pass) (Located [LConDeclField pass])
@@ -1186,36 +1227,21 @@ getConNames :: ConDecl pass -> [Located (IdP pass)]
 getConNames ConDeclH98  {con_name  = name}  = [name]
 getConNames ConDeclGADT {con_names = names} = names
 
--- don't call with RdrNames, because it can't deal with HsAppsTy
-getConDetails :: ConDecl pass -> HsConDeclDetails pass
-getConDetails ConDeclH98  {con_details  = details} = details
-getConDetails ConDeclGADT {con_type     = ty     } = details
-  where
-    (details,_,_,_) = gadtDeclDetails ty
-
--- don't call with RdrNames, because it can't deal with HsAppsTy
-gadtDeclDetails :: LHsSigType pass
-                -> ( HsConDeclDetails pass
-                   , LHsType pass
-                   , LHsContext pass
-                   , [LHsTyVarBndr pass] )
-gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)
-  where
-    (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
-    (details, res_ty)           -- See Note [Sorting out the result type]
-      = case tau of
-          L _ (HsFunTy (L l (HsRecTy flds)) res_ty')
-                  -> (RecCon (L l flds), res_ty')
-          _other  -> (PrefixCon [], tau)
+getConArgs :: ConDecl pass -> HsConDeclDetails pass
+getConArgs d = con_args d
 
 hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass]
 hsConDeclArgTys (PrefixCon tys)    = tys
 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
 hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) (unLoc flds)
 
-pp_data_defn :: (SourceTextX pass, OutputableBndrId pass)
-                  => (HsContext pass -> SDoc)   -- Printing the header
-                  -> HsDataDefn pass
+hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]
+hsConDeclTheta Nothing            = []
+hsConDeclTheta (Just (L _ theta)) = theta
+
+pp_data_defn :: (SourceTextX p, OutputableBndrId p)
+                  => (HsContext p -> SDoc)   -- Printing the header
+                  -> HsDataDefn p
                   -> SDoc
 pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
                                 , dd_cType = mb_ct
@@ -1258,26 +1284,34 @@ instance (SourceTextX pass, OutputableBndrId pass)
 
 pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc
 pprConDecl (ConDeclH98 { con_name = L _ con
-                       , con_qvars = mtvs
-                       , con_cxt = mcxt
-                       , con_details = details
+                       , con_ex_tvs = ex_tvs
+                       , con_mb_cxt = mcxt
+                       , con_args = args
                        , con_doc = doc })
-  = sep [ppr_mbDoc doc, pprHsForAll tvs cxt,         ppr_details details]
+  = sep [ppr_mbDoc doc, pprHsForAll ex_tvs cxt, ppr_details args]
   where
     ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
     ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con
                                    : map (pprHsType . unLoc) tys)
     ppr_details (RecCon fields)  = pprPrefixOcc con
                                  <+> pprConDeclFields (unLoc fields)
-    tvs = case mtvs of
-      Nothing -> []
-      Just (HsQTvs { hsq_explicit = tvs }) -> tvs
+    cxt = fromMaybe (noLoc []) mcxt
+
+pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
+                        , con_mb_cxt = mcxt, con_args = args
+                        , con_res_ty = res_ty, con_doc = doc })
+  = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
+    <+> (sep [pprHsForAll (hsq_explicit qvars) cxt,
+              ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
+  where
+    get_args (PrefixCon args) = map ppr args
+    get_args (RecCon fields)  = [pprConDeclFields (unLoc fields)]
+    get_args (InfixCon {})    = pprPanic "pprConDecl:GADT" (ppr cons)
 
     cxt = fromMaybe (noLoc []) mcxt
 
-pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc })
-  = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
-         <+> ppr res_ty]
+    ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
+    ppr_arrow_chain []     = empty
 
 ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc
 ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
index f5b4149..10e2d00 100644 (file)
@@ -35,7 +35,7 @@ module HsTypes (
         SrcStrictness(..), SrcUnpackedness(..),
         getBangType, getBangStrictness,
 
-        ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult,
+        ConDeclField(..), LConDeclField, pprConDeclFields,
 
         HsConDetails(..),
 
@@ -50,7 +50,7 @@ module HsTypes (
         mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
         mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
         mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
-        isHsKindedTyVar, hsTvbAllKinded,
+        isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
         hsScopedTvs, hsWcScopedTvs, dropWildCards,
         hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
         hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
@@ -59,7 +59,7 @@ module HsTypes (
         splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
         splitHsFunType, splitHsAppsTy,
         splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe,
-        mkHsOpTy, mkHsAppTy, mkHsAppTys,
+        mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppsTy,
         ignoreParens, hsSigType, hsSigWcType,
         hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
 
@@ -93,7 +93,6 @@ import Maybes( isJust )
 
 import Data.Data hiding ( Fixity, Prefix, Infix )
 import Data.Maybe ( fromMaybe )
-import Control.Monad ( unless )
 
 {-
 ************************************************************************
@@ -785,30 +784,6 @@ instance (Outputable arg, Outputable rec)
   ppr (RecCon rec)     = text "RecCon:" <+> ppr rec
   ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]
 
--- Takes details and result type of a GADT data constructor as created by the
--- parser and rejigs them using information about fixities from the renamer.
--- See Note [Sorting out the result type] in RdrHsSyn
-updateGadtResult
-  :: (Monad m)
-     => (SDoc -> m ())
-     -> SDoc
-     -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-                     -- ^ Original details
-     -> LHsType GhcRn -- ^ Original result type
-     -> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
-           LHsType GhcRn)
-updateGadtResult failWith doc details ty
-  = do { let (arg_tys, res_ty) = splitHsFunType ty
-             badConSig         = text "Malformed constructor signature"
-       ; case details of
-           InfixCon {}  -> pprPanic "updateGadtResult" (ppr ty)
-
-           RecCon {}    -> do { unless (null arg_tys)
-                                       (failWith (doc <+> badConSig))
-                              ; return (details, res_ty) }
-
-           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
-
 {-
 Note [ConDeclField passs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -917,9 +892,12 @@ sameWildCard :: Located (HsWildCardInfo pass)
 sameWildCard (L l1 (AnonWildCard _))   (L l2 (AnonWildCard _))   = l1 == l2
 
 ignoreParens :: LHsType pass -> LHsType pass
-ignoreParens (L _ (HsParTy ty))                      = ignoreParens ty
-ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty
-ignoreParens ty                                      = ty
+ignoreParens (L _ (HsParTy ty)) = ignoreParens ty
+ignoreParens ty                 = ty
+
+isLHsForAllTy :: LHsType p -> Bool
+isLHsForAllTy (L _ (HsForAllTy {})) = True
+isLHsForAllTy _                     = False
 
 {-
 ************************************************************************
@@ -941,6 +919,11 @@ mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
 mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass
 mkHsAppTys = foldl mkHsAppTy
 
+mkHsAppsTy :: [LHsAppType GhcPs] -> HsType GhcPs
+-- In the common case of a singleton non-operator,
+-- avoid the clutter of wrapping in a HsAppsTy
+mkHsAppsTy [L _ (HsAppPrefix (L _ ty))] = ty
+mkHsAppsTy app_tys                      = HsAppsTy app_tys
 
 {-
 ************************************************************************
index 8e17994..67c0c3b 100644 (file)
@@ -84,7 +84,6 @@ module HsUtils(
   hsLTyClDeclBinders, hsTyClForeignBinders,
   hsPatSynSelectors, getPatSynBinds,
   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
-  hsDataDefnBinders,
 
   -- Collecting implicit binders
   lStmtsImplicits, hsValBindsImplicits, lPatImplicits
@@ -1106,55 +1105,48 @@ hsDataDefnBinders (HsDataDefn { dd_cons = cons })
   -- See Note [Binders in family instances]
 
 -------------------
+type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass]
+                 -- Filters out ones that have already been seen
+
 hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
-  -- See hsLTyClDeclBinders for what this does
-  -- The function is boringly complicated because of the records
-  -- And since we only have equality, we have to be a little careful
-hsConDeclsBinders cons = go id cons
-  where go :: ([LFieldOcc pass] -> [LFieldOcc pass])
-           -> [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
-        go _ [] = ([], [])
-        go remSeen (r:rs) =
-          -- don't re-mangle the location of field names, because we don't
-          -- have a record of the full location of the field declaration anyway
-          case r of
-             -- remove only the first occurrence of any seen field in order to
-             -- avoid circumventing detection of duplicate fields (#9156)
-             L loc (ConDeclGADT { con_names = names
-                                , con_type = HsIB { hsib_body = res_ty}}) ->
-               case tau of
-                 L _ (HsFunTy
-                      (L _ (HsAppsTy
-                            [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)
-                         -> record_gadt flds
-                 L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
-                         -> record_gadt flds
-
-                 _other  -> (map (L loc . unLoc) names ++ ns, fs)
-                            where (ns, fs) = go remSeen rs
-               where
-                 (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
-                 record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs)
-                   where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
-                         remSeen' = foldr (.) remSeen
-                                        [deleteBy ((==) `on`
-                                              unLoc . rdrNameFieldOcc . unLoc) v
-                                        | v <- r']
-                         (ns, fs) = go remSeen' rs
-
-             L loc (ConDeclH98 { con_name = name
-                               , con_details = RecCon flds }) ->
-               ([L loc (unLoc name)] ++ ns, r' ++ fs)
-                  where r' = remSeen (concatMap (cd_fld_names . unLoc)
-                                                (unLoc flds))
-                        remSeen'
-                          = foldr (.) remSeen
-                               [deleteBy ((==) `on`
-                                   unLoc . rdrNameFieldOcc . unLoc) v | v <- r']
-                        (ns, fs) = go remSeen' rs
-             L loc (ConDeclH98 { con_name = name }) ->
-                ([L loc (unLoc name)] ++ ns, fs)
-                  where (ns, fs) = go remSeen rs
+   -- See hsLTyClDeclBinders for what this does
+   -- The function is boringly complicated because of the records
+   -- And since we only have equality, we have to be a little careful
+hsConDeclsBinders cons
+  = go id cons
+  where
+    go :: Seen pass -> [LConDecl pass]
+       -> ([Located (IdP pass)], [LFieldOcc pass])
+    go _ [] = ([], [])
+    go remSeen (r:rs)
+      -- Don't re-mangle the location of field names, because we don't
+      -- have a record of the full location of the field declaration anyway
+      = case r of
+           -- remove only the first occurrence of any seen field in order to
+           -- avoid circumventing detection of duplicate fields (#9156)
+           L loc (ConDeclGADT { con_names = names, con_args = args })
+             -> (map (L loc . unLoc) names ++ ns, flds ++ fs)
+             where
+                (remSeen', flds) = get_flds remSeen args
+                (ns, fs) = go remSeen' rs
+
+           L loc (ConDeclH98 { con_name = name, con_args = args })
+             -> ([L loc (unLoc name)] ++ ns, flds ++ fs)
+             where
+                (remSeen', flds) = get_flds remSeen args
+                (ns, fs) = go remSeen' rs
+
+    get_flds :: Seen pass -> HsConDeclDetails pass
+             -> (Seen pass, [LFieldOcc pass])
+    get_flds remSeen (RecCon flds)
+       = (remSeen', fld_names)
+       where
+          fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
+          remSeen' = foldr (.) remSeen
+                               [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v
+                               | v <- fld_names]
+    get_flds remSeen _
+       = (remSeen, [])
 
 {-
 
index c60f517..7ae653f 100644 (file)
@@ -1839,7 +1839,7 @@ typedoc :: { LHsType GhcPs }
 -- See Note [Parsing ~]
 btype :: { LHsType GhcPs }
         : tyapps                      {%  splitTildeApps (reverse (unLoc $1)) >>=
-                                          \ts -> return $ sL1 $1 $ HsAppsTy ts }
+                                          \ts -> return $ sL1 $1 $ mkHsAppsTy ts }
 
 -- Used for parsing Haskell98-style data constructors,
 -- in order to forbid the blasphemous
@@ -2064,7 +2064,7 @@ gadt_constr :: { LConDecl GhcPs }
     -- see Note [Difference in parsing GADT and data constructors]
     -- Returns a list because of:   C,D :: ty
         : con_list '::' sigtype
-                {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3)))
+                {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) $3))
                        [mu AnnDcolon $2] }
 
 {- Note [Difference in parsing GADT and data constructors]
@@ -2093,13 +2093,17 @@ constr :: { LConDecl GhcPs }
         : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev
                 {% ams (let (con,details) = unLoc $5 in
                   addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
-                                                   (snd $ unLoc $2) $3 details))
+                                                       (snd $ unLoc $2)
+                                                       (Just $3)
+                                                       details))
                             ($1 `mplus` $6))
                         (mu AnnDarrow $4:(fst $ unLoc $2)) }
         | maybe_docnext forall constr_stuff maybe_docprev
                 {% ams ( let (con,details) = unLoc $3 in
                   addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
-                                           (snd $ unLoc $2) (noLoc []) details))
+                                                      (snd $ unLoc $2)
+                                                      Nothing   -- No context
+                                                      details))
                             ($1 `mplus` $4))
                        (fst $ unLoc $2) }
 
index 126e92e..0c2b204 100644 (file)
@@ -7,6 +7,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MagicHash #-}
 
 module   RdrHsSyn (
         mkHsOpApp,
@@ -68,7 +69,6 @@ module   RdrHsSyn (
     ) where
 
 import GhcPrelude
-
 import HsSyn            -- Lots of it
 import Class            ( FunDep )
 import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
@@ -552,24 +552,44 @@ recordPatSynErr loc pat =
     ppr pat
 
 mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
-                -> LHsContext GhcPs -> HsConDeclDetails GhcPs
+                -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
                 -> ConDecl GhcPs
 
-mkConDeclH98 name mb_forall cxt details
-  = ConDeclH98 { con_name     = name
-               , con_qvars    = fmap mkHsQTvs mb_forall
-               , con_cxt      = Just cxt
-                             -- AZ:TODO: when can cxt be Nothing?
-                             --          remembering that () is a valid context.
-               , con_details  = details
-               , con_doc      = Nothing }
+mkConDeclH98 name mb_forall mb_cxt args
+  = ConDeclH98 { con_name   = name
+               , con_forall = isJust mb_forall
+               , con_ex_tvs = mb_forall `orElse` []
+               , con_mb_cxt = mb_cxt
+               , con_args   = args
+               , con_doc    = Nothing }
 
 mkGadtDecl :: [Located RdrName]
-           -> LHsSigType GhcPs     -- Always a HsForAllTy
+           -> LHsType GhcPs     -- Always a HsForAllTy
            -> ConDecl GhcPs
-mkGadtDecl names ty = ConDeclGADT { con_names = names
-                                  , con_type  = ty
-                                  , con_doc   = Nothing }
+mkGadtDecl names ty
+  = ConDeclGADT { con_names  = names
+                , con_forall = isLHsForAllTy ty
+                , con_qvars  = mkHsQTvs tvs
+                , con_mb_cxt = mcxt
+                , con_args   = args
+                , con_res_ty = res_ty
+                , con_doc    = Nothing }
+  where
+    (tvs, rho) = splitLHsForAllTy ty
+    (mcxt, tau) = split_rho rho
+
+    split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau }))
+                                 = (Just cxt, tau)
+    split_rho (L _ (HsParTy ty)) = split_rho ty
+    split_rho tau                = (Nothing, tau)
+
+    (args, res_ty) = split_tau tau
+
+    -- See Note [GADT abstract syntax] in HsDecls
+    split_tau (L _ (HsFunTy (L loc (HsRecTy rf)) res_ty))
+                                 = (RecCon (L loc rf), res_ty)
+    split_tau (L _ (HsParTy ty)) = split_tau ty
+    split_tau tau                = (PrefixCon [], tau)
 
 setRdrNameSpace :: RdrName -> NameSpace -> RdrName
 -- ^ This rather gruesome function is used mainly by the parser.
@@ -656,23 +676,6 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It
 really doesn't matter!
 -}
 
--- | Note [Sorting out the result type]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- In a GADT declaration which is not a record, we put the whole constr type
--- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once
--- it has sorted out operator fixities. Consider for example
---      C :: a :*: b -> a :*: b -> a :+: b
--- Initially this type will parse as
---       a :*: (b -> (a :*: (b -> (a :+: b))))
---
--- so it's hard to split up the arguments until we've done the precedence
--- resolution (in the renamer). On the other hand, for a record
---         { x,y :: Int } -> a :*: b
--- there is no doubt.  AND we need to sort records out so that
--- we can bring x,y into scope.  So:
---    * For PrefixCon we keep all the args in the res_ty
---    * For RecCon we do not
-
 checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
              -> P (LHsQTyVars GhcPs)
 -- Same as checkTyVars, but in the P monad
@@ -694,13 +697,10 @@ checkTyVars pp_what equals_or_where tc tparms
   = do { tvs <- mapM chk tparms
        ; return (mkHsQTvs tvs) }
   where
-
     chk (L _ (HsParTy ty)) = chk ty
-    chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty
 
         -- Check that the name space is correct!
-    chk (L l (HsKindSig
-            (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))
+    chk (L l (HsKindSig (L lv (HsTyVar _ (L _ tv))) k))
         | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
     chk (L l (HsTyVar _ (L ltv tv)))
         | isRdrTyVar tv    = return (L l (UserTyVar (L ltv tv)))
index b1dc887..60c8b1b 100644 (file)
@@ -639,24 +639,16 @@ getLocalNonValBinders fixity_env
                -> [(Name, [FieldLabel])]
     mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
       where
-        find_con_flds (L _ (ConDeclH98 { con_name    = L _ rdr
-                                       , con_details = RecCon cdflds }))
+        find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
+                                       , con_args = RecCon cdflds }))
             = [( find_con_name rdr
                , concatMap find_con_decl_flds (unLoc cdflds) )]
-        find_con_flds (L _ (ConDeclGADT
-                              { con_names = rdrs
-                              , con_type = (HsIB { hsib_body = res_ty})}))
-            = map (\ (L _ rdr) -> ( find_con_name rdr
-                                  , concatMap find_con_decl_flds cdflds))
-                  rdrs
-            where
-              (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
-              cdflds = case tau of
-                 L _ (HsFunTy
-                      (L _ (HsAppsTy
-                        [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds
-                 L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
-                 _                                    -> []
+        find_con_flds (L _ (ConDeclGADT { con_names = rdrs
+                                        , con_args = RecCon flds }))
+            = [ ( find_con_name rdr
+                 , concatMap find_con_decl_flds (unLoc flds))
+              | L _ rdr <- rdrs ]
+
         find_con_flds _ = []
 
         find_con_name rdr
@@ -664,6 +656,7 @@ getLocalNonValBinders fixity_env
               find (\ n -> nameOccName n == rdrNameOcc rdr) names
         find_con_decl_flds (L _ x)
           = map find_con_decl_fld (cd_fld_names x)
+
         find_con_decl_fld  (L _ (FieldOcc (L _ rdr) _))
           = expectJust "getLocalNonValBinders/find_con_decl_fld" $
               find (\ fl -> flLabel fl == lbl) flds
index c0347c4..897e660 100644 (file)
@@ -52,7 +52,6 @@ import Avail
 import Outputable
 import Bag
 import BasicTypes       ( DerivStrategy, RuleName, pprRuleName )
-import Maybes           ( orElse )
 import FastString
 import SrcLoc
 import DynFlags
@@ -1536,6 +1535,7 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
        ; typeintype <- xoptM LangExt.TypeInType
        ; let cusk = hsTvbAllKinded tyvars' &&
                     (not typeintype || no_rhs_kvs)
+       ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
        ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
                           , tcdFixity = fixity
                           , tcdDataDefn = defn', tcdDataCusk = cusk
@@ -1872,52 +1872,90 @@ rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
 
 rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
-rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
-                           , con_cxt = mcxt, con_details = details
+rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
+                           , con_mb_cxt = mcxt, con_args = args
                            , con_doc = mb_doc })
-  = do  { _ <- addLocM checkConName name
-        ; new_name     <- lookupLocatedTopBndrRn name
-        ; mb_doc'      <- rnMbLHsDoc mb_doc
-
-        ; let doc      = ConDeclCtx [new_name]
-              qtvs'    = qtvs `orElse` mkHsQTvs []
-              body_kvs = []  -- Consider   data T a = forall (b::k). MkT (...)
-                             -- The 'k' will already be in scope from the
-                             -- bindHsQTyVars for the entire DataDecl
-                             -- So there can be no new body_kvs here
-        ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing body_kvs qtvs' $
-          \new_tyvars _ -> do
-        { (new_context, fvs1) <- case mcxt of
-                             Nothing   -> return (Nothing,emptyFVs)
-                             Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
-                                             ; return (Just lctx',fvs) }
-        ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
-        ; let (new_details',fvs3) = (new_details,emptyFVs)
+  = do  { _        <- addLocM checkConName name
+        ; new_name <- lookupLocatedTopBndrRn name
+        ; mb_doc'  <- rnMbLHsDoc mb_doc
+
+        -- We bind no implicit binders here; this is just like
+        -- a nested HsForAllTy.  E.g. consider
+        --         data T a = forall (b::k). MkT (...)
+        -- The 'k' will already be in scope from the bindHsQTyVars
+        -- for the data decl itself. So we'll get
+        --         data T {k} a = ...
+        -- And indeed we may later discover (a::k).  But that's the
+        -- scoping we get.  So no implicit binders at the existential forall
+
+        ; let ctxt = ConDeclCtx [new_name]
+        ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))
+                            Nothing ex_tvs $ \ new_ex_tvs ->
+    do  { (new_context, fvs1) <- rnMbContext ctxt mcxt
+        ; (new_args,    fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
+        ; let all_fvs  = fvs1 `plusFV` fvs2
         ; traceRn "rnConDecl" (ppr name <+> vcat
-             [ text "qtvs:" <+> ppr qtvs
-             , text "qtvs':" <+> ppr qtvs' ])
-        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
-              new_tyvars' = case qtvs of
-                Nothing -> Nothing
-                Just _ -> Just new_tyvars
-        ; return (decl { con_name = new_name, con_qvars = new_tyvars'
-                       , con_cxt = new_context, con_details = new_details'
+             [ text "ex_tvs:" <+> ppr ex_tvs
+             , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])
+
+        ; return (decl { con_name = new_name, con_ex_tvs = new_ex_tvs
+                       , con_mb_cxt = new_context, con_args = new_args
                        , con_doc = mb_doc' },
                   all_fvs) }}
 
-rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
+rnConDecl decl@(ConDeclGADT { con_names   = names
+                            , con_forall  = explicit_forall
+                            , con_qvars   = qtvs
+                            , con_mb_cxt  = mcxt
+                            , con_args    = args
+                            , con_res_ty  = res_ty
                             , con_doc = mb_doc })
   = do  { mapM_ (addLocM checkConName) names
-        ; new_names    <- mapM lookupLocatedTopBndrRn names
-        ; let doc = ConDeclCtx new_names
-        ; mb_doc'      <- rnMbLHsDoc mb_doc
-
-        ; (ty', fvs) <- rnHsSigType doc ty
-        ; traceRn "rnConDecl" (ppr names <+> vcat
-             [ text "fvs:" <+> ppr fvs ])
-        ; return (decl { con_names = new_names, con_type = ty'
+        ; new_names <- mapM lookupLocatedTopBndrRn names
+        ; mb_doc'   <- rnMbLHsDoc mb_doc
+
+        ; let explicit_tkvs = hsQTvExplicit qtvs
+              theta         = hsConDeclTheta mcxt
+              arg_tys       = hsConDeclArgTys args
+        ; free_tkvs <- extractHsTysRdrTyVarsDups (res_ty : theta ++ arg_tys)
+        ; free_tkvs <- extractHsTvBndrs explicit_tkvs free_tkvs
+
+        ; let ctxt    = ConDeclCtx new_names
+              mb_ctxt = Just (inHsDocContext ctxt)
+
+        ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall )
+        ; rnImplicitBndrs (not explicit_forall) ctxt free_tkvs $ \ implicit_tkvs ->
+          bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->
+    do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt
+        ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args
+        ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
+
+        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+              (args', res_ty')
+                  = case args of
+                      InfixCon {}  -> pprPanic "rnConDecl" (ppr names)
+                      RecCon {}    -> (new_args, new_res_ty)
+                      PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty
+                                   -> ASSERT( null as )
+                                      -- See Note [GADT abstract syntax] in HsDecls
+                                      (PrefixCon arg_tys, final_res_ty)
+
+              new_qtvs =  HsQTvs { hsq_implicit  = implicit_tkvs
+                                 , hsq_explicit  = explicit_tkvs
+                                 , hsq_dependent = emptyNameSet }
+
+        ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
+        ; return (decl { con_names = new_names
+                       , con_qvars = new_qtvs, con_mb_cxt = new_cxt
+                       , con_args = args', con_res_ty = res_ty'
                        , con_doc = mb_doc' },
-                  fvs) }
+                  all_fvs) } }
+
+rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
+            -> RnM (Maybe (LHsContext GhcRn), FreeVars)
+rnMbContext _    Nothing    = return (Nothing, emptyFVs)
+rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt
+                                ; return (Just ctx',fvs) }
 
 rnConDeclDetails
    :: Name
index dd66cd3..727744d 100644 (file)
@@ -23,13 +23,14 @@ module RnTypes (
         checkPrecMatch, checkSectionPrec,
 
         -- Binding related stuff
-        bindLHsTyVarBndr,
+        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
         bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
         extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,
         extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
         extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
         extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
         extractRdrKindSigVars, extractDataDefnKindVars,
+        extractHsTvBndrs,
         freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,
         elemRdr
   ) where
@@ -59,6 +60,7 @@ import NameSet
 import FieldLabel
 
 import Util
+import ListSetOps       ( deleteBys )
 import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
                           Fixity(..), FixityDirection(..), LexicalFixity(..) )
 import Outputable
@@ -66,7 +68,7 @@ import FastString
 import Maybes
 import qualified GHC.LanguageExtensions as LangExt
 
-import Data.List          ( nubBy, partition )
+import Data.List          ( nubBy, partition, (\\) )
 import Control.Monad      ( unless, when )
 
 #include "HsVersions.h"
@@ -85,7 +87,7 @@ to break several loop.
 rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
             -> RnM (LHsSigWcType GhcRn, FreeVars)
 rnHsSigWcType doc sig_ty
-  = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' ->
+  = rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' ->
     return (sig_ty', emptyFVs)
 
 rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
@@ -99,26 +101,31 @@ rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
 rnHsSigWcTypeScoped ctx sig_ty thing_inside
   = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
        ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
-       ; rn_hs_sig_wc_type False ctx sig_ty thing_inside
+       ; rn_hs_sig_wc_type True ctx sig_ty thing_inside
        }
-    -- False: for pattern type sigs and rules we /do/ want
-    --        to bring those type variables into scope
+    -- True: for pattern type sigs and rules we /do/ want
+    --       to bring those type variables into scope, even
+    --       if there's a forall at the top which usually
+    --       stops that happening
     -- e.g  \ (x :: forall a. a-> b) -> e
     -- Here we do bring 'b' into scope
 
-rn_hs_sig_wc_type :: Bool   -- see rnImplicitBndrs
+rn_hs_sig_wc_type :: Bool   -- True <=> always bind any free tyvars of the
+                            --          type, regardless of whether it has
+                            --          a forall at the top
                   -> HsDocContext
                   -> LHsSigWcType GhcPs
                   -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
                   -> RnM (a, FreeVars)
 -- rn_hs_sig_wc_type is used for source-language type signatures
-rn_hs_sig_wc_type no_implicit_if_forall ctxt
+rn_hs_sig_wc_type always_bind_free_tvs ctxt
                   (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
                   thing_inside
   = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
        ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
        ; let nwc_rdrs = nubL nwc_rdrs'
-       ; rnImplicitBndrs no_implicit_if_forall ctxt hs_ty tv_rdrs $ \ vars ->
+             bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty)
+       ; rnImplicitBndrs bind_free_tvs ctxt tv_rdrs $ \ vars ->
     do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
        ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' }
              ib_ty'  = mk_implicit_bndrs vars hs_ty' fvs1
@@ -265,32 +272,31 @@ rnHsSigType :: HsDocContext -> LHsSigType GhcPs
 rnHsSigType ctx (HsIB { hsib_body = hs_ty })
   = do { traceRn "rnHsSigType" (ppr hs_ty)
        ; vars <- extractFilteredRdrTyVarsDups hs_ty
-       ; rnImplicitBndrs True ctx hs_ty vars $ \ vars ->
+       ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) ctx vars $ \ vars ->
     do { (body', fvs) <- rnLHsType ctx hs_ty
        ; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }
 
-rnImplicitBndrs :: Bool    -- True <=> no implicit quantification
-                           --          if type is headed by a forall
+rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables
                            -- E.g.  f :: forall a. a->b
-                           -- Do not quantify over 'b' too.
+                           --  we do not want to bring 'b' into scope, hence False
+                           -- But   f :: a -> b
+                           --  we want to bring both 'a' and 'b' into scope
                 -> HsDocContext
-                -> LHsType GhcPs   -- hs_ty: the type over which the
-                                   -- implicit binders will scope
                 -> FreeKiTyVarsWithDups
                                    -- Free vars of hs_ty (excluding wildcards)
                                    -- May have duplicates, which is
                                    -- checked here
                 -> ([Name] -> RnM (a, FreeVars))
                 -> RnM (a, FreeVars)
-rnImplicitBndrs no_implicit_if_forall doc (L loc hs_ty)
+rnImplicitBndrs bind_free_tvs doc
                 fvs_with_dups@(FKTV { fktv_kis = kvs_with_dups
                                     , fktv_tys = tvs_with_dups })
                 thing_inside
   = do { let FKTV kvs tvs = rmDupsInRdrTyVars fvs_with_dups
-             real_tvs | no_implicit_if_forall
-                      , HsForAllTy {} <- hs_ty = []
-                      | otherwise              = tvs
-             -- Quantify over type variables only if there is no
+             real_tvs | bind_free_tvs = tvs
+                      | otherwise     = []
+             -- We always bind over free /kind/ variables.
+             -- Bind free /type/ variables only if there is no
              -- explicit forall.  E.g.
              --    f :: Proxy (a :: k) -> b
              --         Quantify over {k} and {a,b}
@@ -300,8 +306,9 @@ rnImplicitBndrs no_implicit_if_forall doc (L loc hs_ty)
              -- but, rather arbitrarily, we switch off the type-quantification
              -- if there is an explicit forall
 
-       ; traceRn "rnImplicitBndrs" (vcat [ ppr hs_ty, ppr kvs, ppr tvs, ppr real_tvs ])
+       ; traceRn "rnImplicitBndrs" (vcat [ ppr kvs, ppr tvs, ppr real_tvs ])
 
+       ; loc <- getSrcSpanM
        ; vars <- mapM (newLocalBndrRn . L loc . unLoc) (kvs ++ real_tvs)
 
        ; checkBadKindBndrs doc kvs
@@ -898,23 +905,24 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
 
        ; let -- See Note [bindHsQTyVars examples] for what
              -- all these various things are doing
-             bndrs, kv_occs, implicit_bndr_kvs,
-                    implicit_body_kvs, implicit_kvs :: [Located RdrName]
-             bndrs             = map hsLTyVarLocName hs_tv_bndrs
-             kv_occs           = body_kv_occs ++ bndr_kv_occs
-             implicit_bndr_kvs = filter_occs rdr_env bndrs bndr_kv_occs
-             implicit_body_kvs = filter_occs rdr_env (implicit_bndr_kvs ++ bndrs) body_kv_occs
+             bndrs, kv_occs, implicit_kvs :: [Located RdrName]
+             bndrs        = map hsLTyVarLocName hs_tv_bndrs
+             kv_occs      = nubL (body_kv_occs ++ bndr_kv_occs)
+             implicit_kvs = filter_occs rdr_env bndrs kv_occs
                                  -- Deleting bndrs: See Note [Kind-variable ordering]
-             implicit_kvs      = implicit_bndr_kvs ++ implicit_body_kvs
-
              -- dep_bndrs is the subset of bndrs that are dependent
              --   i.e. appear in bndr/body_kv_occs
              -- Can't use implicit_kvs because we've deleted bndrs from that!
              dep_bndrs = filter (`elemRdr` kv_occs) bndrs
+             del       = deleteBys eqLocated
+             all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)
 
        ; traceRn "checkMixedVars3" $
            vcat [ text "kv_occs" <+> ppr kv_occs
-                , text "bndrs"   <+> ppr bndrs ]
+                , text "bndrs"   <+> ppr hs_tv_bndrs
+                , text "bndr_kv_occs"   <+> ppr bndr_kv_occs
+                , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)
+                ]
        ; checkBadKindBndrs doc implicit_kvs
        ; checkMixedVars kv_occs bndrs
 
@@ -927,7 +935,7 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
        ; thing_inside (HsQTvs { hsq_implicit  = implicit_kv_nms
                               , hsq_explicit  = rn_bndrs
                               , hsq_dependent = mkNameSet dep_bndr_nms })
-                      (null implicit_body_kvs) } }
+                      all_bound_on_lhs } }
 
   where
     filter_occs :: LocalRdrEnv         -- In scope
@@ -957,15 +965,10 @@ Then:
   body_kv_occs = [k2,k1], kind variables free in the
                           result kind signature
 
-  implicit_bndr_kvs = [k1], kind variables free in kind signatures
-                            of hs_tv_bndrs, and not bound by bndrs
-
-  implicit_body_kvs = [k2], kind variables free in the result kind
-                            signature, and not bound either by
-                            bndrs or by implicit_bndr_kvs
+  implicit_kvs = [k1,k2], kind variables free in kind signatures
+                          of hs_tv_bndrs, and not bound by bndrs
 
-* We want to quantify add implicit bindings for
-  implicit_bndr_kvs and implicit_body_kvs
+* We want to quantify add implicit bindings for implicit_kvs
 
 * The "dependent" bndrs (hsq_dependent) are the subset of
   bndrs that are free in bndr_kv_occs or body_kv_occs
@@ -1739,11 +1742,11 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
      foldrM (extract_con . unLoc) emptyFKTV cons)
   where
     extract_con (ConDeclGADT { }) acc = return acc
-    extract_con (ConDeclH98 { con_qvars = qvs
-                            , con_cxt = ctxt, con_details = details }) acc
-      = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<<
+    extract_con (ConDeclH98 { con_ex_tvs = ex_tvs
+                            , con_mb_cxt = ctxt, con_args = args }) acc
+      = extract_hs_tv_bndrs ex_tvs acc =<<
         extract_mlctxt ctxt =<<
-        extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV
+        extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV
 
 extract_mlctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_mlctxt Nothing     acc = return acc
@@ -1815,6 +1818,12 @@ extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars
 extract_app t_or_k (L _ (HsAppInfix tv))  acc = extract_tv t_or_k tv acc
 extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
 
+extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
+                 -> FreeKiTyVars           -- Free in body
+                 -> RnM FreeKiTyVars       -- Free in result
+extractHsTvBndrs tv_bndrs body_fvs
+  = extract_hs_tv_bndrs tv_bndrs emptyFKTV body_fvs
+
 extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars
                     -> FreeKiTyVars -> RnM FreeKiTyVars
 -- In (forall (a :: Maybe e). a -> b) we have
index 10794e2..cc826b9 100644 (file)
@@ -32,7 +32,7 @@ module TcHsType (
         tcHsLiftedType,   tcHsOpenType,
         tcHsLiftedTypeNC, tcHsOpenTypeNC,
         tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,
-        tcHsContext, tcLHsPredType, tcInferApps,
+        tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps,
         solveEqualities, -- useful re-export
 
         typeLevelMode, kindLevelMode,
@@ -983,6 +983,10 @@ instantiateTyUntilN mb_kind_env n ty ki
     instantiateTyN mb_kind_env num_to_inst ty bndrs inner_ki
 
 ---------------------------
+tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
+tcHsMbContext Nothing    = return []
+tcHsMbContext (Just cxt) = tcHsContext cxt
+
 tcHsContext :: LHsContext GhcRn -> TcM [PredType]
 tcHsContext = tc_hs_context typeLevelMode
 
index f77a70b..e3b8b4d 100644 (file)
@@ -619,34 +619,34 @@ kcTyClDecl (FamDecl (FamilyDecl { fdLName  = L _ fam_tc_name
 
 -------------------
 kcConDecl :: ConDecl GhcRn -> TcM ()
-kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
-                      , con_cxt = ex_ctxt, con_details = details })
+kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
+                      , con_mb_cxt = ex_ctxt, con_args = args })
   = addErrCtxt (dataConCtxtName [name]) $
-         -- the 'False' says that the existentials don't have a CUSK, as the
-         -- concept doesn't really apply here. We just need to bring the variables
-         -- into scope. (Similarly, the choice of PromotedDataConFlavour isn't
-         -- particularly important.)
-    do { _ <- kcHsTyVarBndrs (unLoc name) PromotedDataConFlavour
-                             False False
-                             ((fromMaybe emptyLHsQTvs ex_tvs)) $
-              do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
-                 ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
-                 ; return (panic "kcConDecl", ()) }
-              -- We don't need to check the telescope here, because that's
-              -- done in tcConDecl
+    do { _ <- tcExplicitTKBndrs ex_tvs $ \ _ ->
+              do { _ <- tcHsMbContext ex_ctxt
+                 ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)
+                 ; return (panic "kcConDecl", emptyVarSet) }
        ; return () }
 
 kcConDecl (ConDeclGADT { con_names = names
-                       , con_type = ty })
-  = addErrCtxt (dataConCtxtName names) $
-      do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty
-                -- Even though the data constructor's type is closed, we
-                -- must still call tcGadtSigType, because that influences
-                -- the inferred kind of the /type/ constructor.  Example:
-                --    data T f a where
-                --      MkT :: f a -> T f a
-                -- If we don't look at MkT we won't get the correct kind
-                -- for the type constructor T
+                       , con_qvars = qtvs, con_mb_cxt = cxt
+                       , con_args = args, con_res_ty = res_ty })
+  | HsQTvs { hsq_implicit = implicit_tkv_nms
+           , hsq_explicit = explicit_tkv_nms } <- qtvs
+  = -- Even though the data constructor's type is closed, we
+    -- must still kind-check the type, because that may influence
+    -- the inferred kind of the /type/ constructor.  Example:
+    --    data T f a where
+    --      MkT :: f a -> T f a
+    -- If we don't look at MkT we won't get the correct kind
+    -- for the type constructor T
+    addErrCtxt (dataConCtxtName names) $
+    do { _ <- tcImplicitTKBndrs implicit_tkv_nms $
+              tcExplicitTKBndrs explicit_tkv_nms $ \ _ ->
+              do { _ <- tcHsMbContext cxt
+                 ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)
+                 ; _ <- tcHsOpenType res_ty
+                 ; return (panic "kcConDecl", emptyVarSet) }
          ; return () }
 
 {-
@@ -1637,43 +1637,35 @@ tcConDecl :: TyCon             -- Representation tycon. Knot-tied!
 
 tcConDecl rep_tycon tmpl_bndrs res_tmpl
           (ConDeclH98 { con_name = name
-                      , con_qvars = hs_qvars, con_cxt = hs_ctxt
-                      , con_details = hs_details })
+                      , con_ex_tvs = explicit_tkv_nms
+                      , con_mb_cxt = hs_ctxt
+                      , con_args = hs_args })
   = addErrCtxt (dataConCtxtName [name]) $
     do { -- Get hold of the existential type variables
          -- e.g. data T a = forall (b::k) f. MkT a (f b)
          -- Here tmpl_bndrs = {a}
-         --          hs_kvs = {k}
-         --          hs_tvs = {f,b}
-       ; let (hs_kvs, hs_tvs) = case hs_qvars of
-               Nothing -> ([], [])
-               Just (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })
-                       -> (kvs, tvs)
+         --      hs_qvars = HsQTvs { hsq_implicit = {k}
+         --                        , hsq_explicit = {f,b} }
 
-       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr hs_kvs, ppr hs_tvs ])
+       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])
 
-       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, field_lbls, stricts))
+       ; ((exp_tvs, ctxt, arg_tys, field_lbls, stricts), _bound_vars)
            <- solveEqualities $
-              tcImplicitTKBndrs hs_kvs $
-              tcExplicitTKBndrs hs_tvs $ \ exp_tvs ->
-              do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
-                 ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
-                 ; btys <- tcConArgs hs_details
+              tcExplicitTKBndrs explicit_tkv_nms $ \ exp_tvs ->
+              do { ctxt <- tcHsMbContext hs_ctxt
+                 ; btys <- tcConArgs hs_args
                  ; field_lbls <- lookupConstructorFields (unLoc name)
                  ; let (arg_tys, stricts) = unzip btys
-                       bound_vars  = allBoundVariabless ctxt `unionVarSet`
-                                     allBoundVariabless arg_tys
+                       bound_vars  = emptyVarSet  -- Not used
                  ; return ((exp_tvs, ctxt, arg_tys, field_lbls, stricts), bound_vars)
                  }
 
          -- exp_tvs have explicit, user-written binding sites
-         -- imp_tvs are user-written kind variables, without an explicit binding site
          -- the kvs below are those kind variables entirely unmentioned by the user
          --   and discovered only by generalization
 
              -- Kind generalisation
-       ; let all_user_tvs = imp_tvs ++ exp_tvs
-       ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys all_user_tvs $
+       ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys exp_tvs $
                                             mkFunTys ctxt $
                                             mkFunTys arg_tys $
                                             unitTy)
@@ -1688,7 +1680,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
 
              -- Zonk to Types
        ; (ze, qkvs)      <- zonkTyBndrsX emptyZonkEnv kvs
-       ; (ze, user_qtvs) <- zonkTyBndrsX ze all_user_tvs
+       ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs
        ; arg_tys         <- zonkTcTypeToTypes ze arg_tys
        ; ctxt            <- zonkTcTypeToTypes ze ctxt
 
@@ -1707,7 +1699,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
            -- See Note [DataCon user type variable binders] in DataCon.
            user_tvbs = univ_tvbs ++ ex_tvbs
            buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfixH98 name hs_details
+             { is_infix <- tcConIsInfixH98 name hs_args
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix rep_nm
@@ -1724,11 +1716,31 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
        }
 
 tcConDecl rep_tycon tmpl_bndrs res_tmpl
-          (ConDeclGADT { con_names = names, con_type = ty })
+          (ConDeclGADT { con_names = names
+                       , con_qvars = qtvs
+                       , con_mb_cxt = cxt, con_args = hs_args
+                       , con_res_ty = res_ty })
+  | HsQTvs { hsq_implicit = implicit_tkv_nms
+           , hsq_explicit = explicit_tkv_nms } <- qtvs
   = addErrCtxt (dataConCtxtName names) $
     do { traceTc "tcConDecl 1" (ppr names)
-       ; (user_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)
-           <- tcGadtSigType (ppr names) (unLoc $ head names) ty
+       ; let (L _ name : _) = names
+
+       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts))
+           <- solveEqualities $
+              tcImplicitTKBndrs implicit_tkv_nms $
+              tcExplicitTKBndrs explicit_tkv_nms $ \ exp_tvs ->
+              do { ctxt <- tcHsMbContext cxt
+                 ; btys <- tcConArgs hs_args
+                 ; res_ty' <- tcHsLiftedType res_ty
+                 ; field_lbls <- lookupConstructorFields name
+                 ; let (arg_tys, stricts) = unzip btys
+                       bound_vars = allBoundVariabless ctxt `unionVarSet`
+                                    allBoundVariabless arg_tys
+
+                 ; return ((exp_tvs, ctxt, arg_tys, res_ty', field_lbls, stricts), bound_vars)
+                 }
+       ; let user_tvs = imp_tvs ++ exp_tvs
 
        ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys user_tvs $
                                             mkFunTys ctxt $
@@ -1767,7 +1779,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
        ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
        ; let
            buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfixGADT name hs_details
+             { is_infix <- tcConIsInfixGADT name hs_args
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix
@@ -1783,31 +1795,6 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
        ; mapM buildOneDataCon names
        }
 
-
-tcGadtSigType :: SDoc -> Name -> LHsSigType GhcRn
-              -> TcM ( [TcTyVar], [PredType],[HsSrcBang], [FieldLabel], [Type], Type
-                     , HsConDetails (LHsType GhcRn)
-                                    (Located [LConDeclField GhcRn]) )
-tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
-  = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty
-       ; (hs_details, res_ty) <- updateGadtResult failWithTc doc hs_details' res_ty'
-       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts))
-           <- solveEqualities $
-              tcImplicitTKBndrs vars $
-              tcExplicitTKBndrs gtvs $ \ exp_tvs ->
-              do { ctxt <- tcHsContext cxt
-                 ; btys <- tcConArgs hs_details
-                 ; ty' <- tcHsLiftedType res_ty
-                 ; field_lbls <- lookupConstructorFields name
-                 ; let (arg_tys, stricts) = unzip btys
-                       bound_vars = allBoundVariabless ctxt `unionVarSet`
-                                    allBoundVariabless arg_tys
-
-                 ; return ((exp_tvs, ctxt, arg_tys, ty', field_lbls, stricts), bound_vars)
-                 }
-       ; return (imp_tvs ++ exp_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty, hs_details)
-       }
-
 tcConIsInfixH98 :: Name
              -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
              -> TcM Bool
index c311ac9..a0fd987 100644 (file)
@@ -8,7 +8,7 @@
 {-# LANGUAGE CPP #-}
 
 module ListSetOps (
-        unionLists, minusList,
+        unionLists, minusList, deleteBys,
 
         -- Association lists
         Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
@@ -37,6 +37,11 @@ getNth :: Outputable a => [a] -> Int -> a
 getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
              xs !! n
 
+deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+-- (deleteBys eq xs ys) returns xs-ys, using the given equality function
+-- Just like 'Data.List.delete' but with an equality function
+deleteBys eq xs ys = foldl (flip (deleteBy eq)) xs ys
+
 {-
 ************************************************************************
 *                                                                      *
index adc0d14..a0c0b24 100644 (file)
@@ -28,13 +28,15 @@ test('T10357',      [extra_files(['Test10357.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10357'])
 test('T10358',      [extra_files(['Test10358.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10358'])
-test('T10278',      [extra_files(['Test10278.hs']),
+test('T10278',      [expect_broken(14529),
+                     extra_files(['Test10278.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10278'])
 test('T10354',      [extra_files(['Test10354.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10354'])
 test('T10396',      [extra_files(['Test10396.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10396'])
-test('T10399',      [extra_files(['Test10399.hs']),
+test('T10399',      [expect_broken(14529),
+                     extra_files(['Test10399.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10399'])
 test('T10313',      [extra_files(['Test10313.hs', 'stringSource.hs']),
                      ignore_stderr], run_command, ['$MAKE -s --no-print-directory T10313'])
index 46ab214..127f28a 100644 (file)
           ({ DumpParsedAst.hs:5:14-17 }
            (Unqual
             {OccName: Zero}))
+          (False)
+          []
           (Nothing)
-          (Just
-           ({ <no location info> }
-            []))
           (PrefixCon
            [])
           (Nothing)))
           ({ DumpParsedAst.hs:5:21-24 }
            (Unqual
             {OccName: Succ}))
+          (False)
+          []
           (Nothing)
-          (Just
-           ({ <no location info> }
-            []))
           (PrefixCon
            [({ DumpParsedAst.hs:5:26-30 }
              (HsTyVar
                 []))]
              (Prefix)
              ({ DumpParsedAst.hs:9:21-24 }
-              (HsAppsTy
-               [({ DumpParsedAst.hs:9:21-24 }
-                 (HsAppPrefix
-                  ({ DumpParsedAst.hs:9:21-24 }
-                   (HsTyVar
-                    (NotPromoted)
-                    ({ DumpParsedAst.hs:9:21-24 }
-                     (Unqual
-                      {OccName: Zero}))))))])))
+              (HsTyVar
+               (NotPromoted)
+               ({ DumpParsedAst.hs:9:21-24 }
+                (Unqual
+                 {OccName: Zero})))))
             (PlaceHolder)))]))
        ({ DumpParsedAst.hs:7:13-18 }
         (Unqual
             (Unqual
              {OccName: as}))
            ({ DumpParsedAst.hs:7:27-29 }
-            (HsAppsTy
-             [({ DumpParsedAst.hs:7:27-29 }
-               (HsAppPrefix
-                ({ DumpParsedAst.hs:7:27-29 }
-                 (HsListTy
-                  ({ DumpParsedAst.hs:7:28 }
-                   (HsAppsTy
-                    [({ DumpParsedAst.hs:7:28 }
-                      (HsAppPrefix
-                       ({ DumpParsedAst.hs:7:28 }
-                        (HsTyVar
-                         (NotPromoted)
-                         ({ DumpParsedAst.hs:7:28 }
-                          (Unqual
-                           {OccName: k}))))))]))))))]))))]
+            (HsListTy
+             ({ DumpParsedAst.hs:7:28 }
+              (HsTyVar
+               (NotPromoted)
+               ({ DumpParsedAst.hs:7:28 }
+                (Unqual
+                 {OccName: k}))))))))]
         (PlaceHolder))
        (Prefix)
        ({ DumpParsedAst.hs:7:32-39 }
         (KindSig
          ({ DumpParsedAst.hs:7:35-39 }
-          (HsAppsTy
-           [({ DumpParsedAst.hs:7:35-39 }
-             (HsAppPrefix
-              ({ DumpParsedAst.hs:7:35-39 }
-               (HsTyVar
-                (NotPromoted)
-                ({ DumpParsedAst.hs:7:35-39 }
-                 (Unqual
-                  {OccName: Peano}))))))]))))
+          (HsTyVar
+           (NotPromoted)
+           ({ DumpParsedAst.hs:7:35-39 }
+            (Unqual
+             {OccName: Peano}))))))
        (Nothing)))))
   ,({ DumpParsedAst.hs:11:1-23 }
     (ValD
index c7daf90..3ddb5ed 100644 (file)
            (ConDeclH98
             ({ DumpRenamedAst.hs:6:14-17 }
              {Name: DumpRenamedAst.Zero})
+            (False)
+            []
             (Nothing)
-            (Just
-             ({ <no location info> }
-              []))
             (PrefixCon
              [])
             (Nothing)))
            (ConDeclH98
             ({ DumpRenamedAst.hs:6:21-24 }
              {Name: DumpRenamedAst.Succ})
+            (False)
+            []
             (Nothing)
-            (Just
-             ({ <no location info> }
-              []))
             (PrefixCon
              [({ DumpRenamedAst.hs:6:26-30 }
                (HsTyVar
               (ConDeclGADT
                [({ DumpRenamedAst.hs:16:3-5 }
                  {Name: DumpRenamedAst.Nat})]
-               (HsIB
+               (False)
+               (HsQTvs
                 [{Name: f}
                 ,{Name: g}]
-                ({ DumpRenamedAst.hs:16:10-45 }
-                 (HsFunTy
-                  ({ DumpRenamedAst.hs:16:10-34 }
-                   (HsParTy
-                    ({ DumpRenamedAst.hs:16:11-33 }
-                     (HsForAllTy
-                      [({ DumpRenamedAst.hs:16:18-19 }
-                        (UserTyVar
-                         ({ DumpRenamedAst.hs:16:18-19 }
-                          {Name: xx})))]
-                      ({ DumpRenamedAst.hs:16:22-33 }
-                       (HsFunTy
-                        ({ DumpRenamedAst.hs:16:22-25 }
-                         (HsAppTy
-                          ({ DumpRenamedAst.hs:16:22 }
-                           (HsTyVar
-                            (NotPromoted)
-                            ({ DumpRenamedAst.hs:16:22 }
-                             {Name: f})))
-                          ({ DumpRenamedAst.hs:16:24-25 }
-                           (HsTyVar
-                            (NotPromoted)
-                            ({ DumpRenamedAst.hs:16:24-25 }
-                             {Name: xx})))))
-                        ({ DumpRenamedAst.hs:16:30-33 }
-                         (HsAppTy
-                          ({ DumpRenamedAst.hs:16:30 }
-                           (HsTyVar
-                            (NotPromoted)
-                            ({ DumpRenamedAst.hs:16:30 }
-                             {Name: g})))
-                          ({ DumpRenamedAst.hs:16:32-33 }
-                           (HsTyVar
-                            (NotPromoted)
-                            ({ DumpRenamedAst.hs:16:32-33 }
-                             {Name: xx})))))))))))
-                  ({ DumpRenamedAst.hs:16:39-45 }
-                   (HsAppTy
-                    ({ DumpRenamedAst.hs:16:39-43 }
-                     (HsAppTy
-                      ({ DumpRenamedAst.hs:16:39-41 }
-                       (HsTyVar
-                        (NotPromoted)
-                        ({ DumpRenamedAst.hs:16:39-41 }
-                         {Name: DumpRenamedAst.Nat})))
-                      ({ DumpRenamedAst.hs:16:43 }
-                       (HsTyVar
-                        (NotPromoted)
-                        ({ DumpRenamedAst.hs:16:43 }
-                         {Name: f})))))
-                    ({ DumpRenamedAst.hs:16:45 }
-                     (HsTyVar
-                      (NotPromoted)
-                      ({ DumpRenamedAst.hs:16:45 }
-                       {Name: g})))))))
-                (True))
+                []
+                {NameSet:
+                 []})
+               (Nothing)
+               (PrefixCon
+                [({ DumpRenamedAst.hs:16:10-34 }
+                  (HsParTy
+                   ({ DumpRenamedAst.hs:16:11-33 }
+                    (HsForAllTy
+                     [({ DumpRenamedAst.hs:16:18-19 }
+                       (UserTyVar
+                        ({ DumpRenamedAst.hs:16:18-19 }
+                         {Name: xx})))]
+                     ({ DumpRenamedAst.hs:16:22-33 }
+                      (HsFunTy
+                       ({ DumpRenamedAst.hs:16:22-25 }
+                        (HsAppTy
+                         ({ DumpRenamedAst.hs:16:22 }
+                          (HsTyVar
+                           (NotPromoted)
+                           ({ DumpRenamedAst.hs:16:22 }
+                            {Name: f})))
+                         ({ DumpRenamedAst.hs:16:24-25 }
+                          (HsTyVar
+                           (NotPromoted)
+                           ({ DumpRenamedAst.hs:16:24-25 }
+                            {Name: xx})))))
+                       ({ DumpRenamedAst.hs:16:30-33 }
+                        (HsAppTy
+                         ({ DumpRenamedAst.hs:16:30 }
+                          (HsTyVar
+                           (NotPromoted)
+                           ({ DumpRenamedAst.hs:16:30 }
+                            {Name: g})))
+                         ({ DumpRenamedAst.hs:16:32-33 }
+                          (HsTyVar
+                           (NotPromoted)
+                           ({ DumpRenamedAst.hs:16:32-33 }
+                            {Name: xx})))))))))))])
+               ({ DumpRenamedAst.hs:16:39-45 }
+                (HsAppTy
+                 ({ DumpRenamedAst.hs:16:39-43 }
+                  (HsAppTy
+                   ({ DumpRenamedAst.hs:16:39-41 }
+                    (HsTyVar
+                     (NotPromoted)
+                     ({ DumpRenamedAst.hs:16:39-41 }
+                      {Name: DumpRenamedAst.Nat})))
+                   ({ DumpRenamedAst.hs:16:43 }
+                    (HsTyVar
+                     (NotPromoted)
+                     ({ DumpRenamedAst.hs:16:43 }
+                      {Name: f})))))
+                 ({ DumpRenamedAst.hs:16:45 }
+                  (HsTyVar
+                   (NotPromoted)
+                   ({ DumpRenamedAst.hs:16:45 }
+                    {Name: g})))))
                (Nothing)))]
             ({ <no location info> }
              [])))
index 53e4a6f..439c5ff 100644 (file)
            (ConDeclH98
             ({ T14189.hs:6:15-16 }
              {Name: T14189.MT})
+            (False)
+            []
             (Nothing)
-            (Just
-             ({ <no location info> }
-              []))
             (PrefixCon
              [({ T14189.hs:6:18-20 }
                (HsTyVar
            (ConDeclH98
             ({ T14189.hs:6:24-25 }
              {Name: T14189.NT})
+            (False)
+            []
             (Nothing)
-            (Just
-             ({ <no location info> }
-              []))
             (PrefixCon
              [])
             (Nothing)))
            (ConDeclH98
             ({ T14189.hs:6:29 }
              {Name: T14189.F})
+            (False)
+            []
             (Nothing)
-            (Just
-             ({ <no location info> }
-              []))
             (RecCon
              ({ T14189.hs:6:31-42 }
               [({ T14189.hs:6:33-40 }
index 4783bc9..14d67a2 100644 (file)
@@ -2,7 +2,8 @@
 T11039.hs:8:15: error:
     • Couldn't match type ‘f’ with ‘A’
       ‘f’ is a rigid type variable bound by
-        the signature for pattern synonym ‘Q’ at T11039.hs:7:14-38
+        the signature for pattern synonym ‘Q’
+        at T11039.hs:7:1-38
       Expected type: f a
         Actual type: A a
     • In the pattern: A a
index fdd4477..c9c00c9 100644 (file)
@@ -16,7 +16,8 @@ T11667.hs:18:28: error:
         arising from the "provided" constraints claimed by
           the signature of ‘Pat2’
       ‘b’ is a rigid type variable bound by
-        the signature for pattern synonym ‘Pat2’ at T11667.hs:17:17-50
+        the signature for pattern synonym ‘Pat2’
+        at T11667.hs:17:1-50
     • In the declaration for pattern synonym ‘Pat2’
     • Relevant bindings include y :: b (bound at T11667.hs:18:21)
 
index 9bc0b10..fb27e64 100644 (file)
@@ -5,7 +5,7 @@ T5331.hs:8:17: warning: [-Wunused-foralls (in -Wextra)]
 
 T5331.hs:11:16: warning: [-Wunused-foralls (in -Wextra)]
     Unused quantified type variable ‘a’
-    In the type ‘forall a. W
+    In the definition of data constructor ‘W1
 
 T5331.hs:13:13: warning: [-Wunused-foralls (in -Wextra)]
     Unused quantified type variable ‘a’
index d7e1006..dbc071c 100644 (file)
@@ -8,6 +8,7 @@ module T13123 where
 
 import GHC.Exts (Constraint)
 
+{-
 $([d| idProxy :: forall proxy (a :: k). proxy a -> proxy a
       idProxy x = x
     |])
@@ -31,6 +32,7 @@ $([d| class Foo b where
 $([d| data GADT where
         MkGADT :: forall proxy (a :: k). proxy a -> GADT
     |])
+-}
 
 $([d| data Dec13 :: (* -> Constraint) -> * where
         MkDec13 :: c a => a -> Dec13 c
index 48b2221..5cf4fde 100644 (file)
@@ -2,9 +2,11 @@
 T2494.hs:15:14: error:
     • Couldn't match type ‘b’ with ‘a’
       ‘b’ is a rigid type variable bound by
-        the RULE "foo/foo" at T2494.hs:14:16-62
+        the RULE "foo/foo"
+        at T2494.hs:(12,1)-(15,33)
       ‘a’ is a rigid type variable bound by
-        the RULE "foo/foo" at T2494.hs:13:16-62
+        the RULE "foo/foo"
+        at T2494.hs:(12,1)-(15,33)
       Expected type: Maybe (m a) -> Maybe (m a)
         Actual type: Maybe (m b) -> Maybe (m b)
     • In the first argument of ‘foo’, namely ‘g’
@@ -20,9 +22,11 @@ T2494.hs:15:14: error:
 T2494.hs:15:30: error:
     • Couldn't match type ‘b’ with ‘a’
       ‘b’ is a rigid type variable bound by
-        the RULE "foo/foo" at T2494.hs:14:16-62
+        the RULE "foo/foo"
+        at T2494.hs:(12,1)-(15,33)
       ‘a’ is a rigid type variable bound by
-        the RULE "foo/foo" at T2494.hs:13:16-62
+        the RULE "foo/foo"
+        at T2494.hs:(12,1)-(15,33)
       Expected type: Maybe (m b) -> Maybe (m a)
         Actual type: Maybe (m b) -> Maybe (m b)
     • In the second argument of ‘(.)’, namely ‘g’
index aaf0733..2484138 160000 (submodule)
@@ -1 +1 @@
-Subproject commit aaf07338cbfec7df69532a4d1e8a0f21c9a1cfde
+Subproject commit 24841386cff6fdccc11accf9daa815c2c7444d65
index 738f366..9483ad1 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 738f3666c878ee9e79c3d5e819ef8b3460288edf
+Subproject commit 9483ad10064fbbb97ab525280623826b1ef63959