[commit: ghc] master: Wombling around in Trac #14808 (e7653bc)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/e7653bc3c4f57d2282e982b9eb83bd1fcbae6e30/ghc

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

commit e7653bc3c4f57d2282e982b9eb83bd1fcbae6e30
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Mar 2 17:12:03 2018 +0000

    Wombling around in Trac #14808
    
    Comment:4 in Trac #14808 explains why I'm unhappy with the current
    state of affairs -- at least the lack of documentation.
    
    This smallpatch does nothing major:
    
    * adds comments
    * uses existing type synonyms more (notably FreeKiTyVarsWithDups)
    * adds another test case to T14808


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

e7653bc3c4f57d2282e982b9eb83bd1fcbae6e30
 compiler/rename/RnSource.hs    |  9 ++++++---
 compiler/rename/RnTypes.hs     | 35 +++++++++++++++++++++--------------
 testsuite/tests/gadt/T14808.hs |  6 ++++++
 3 files changed, 33 insertions(+), 17 deletions(-)

diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 5c7f538..447871a 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1917,9 +1917,12 @@ rnConDecl decl@(ConDeclGADT { con_names   = names
         ; let explicit_tkvs = hsQTvExplicit qtvs
               theta         = hsConDeclTheta mcxt
               arg_tys       = hsConDeclArgTys args
-                       -- We must ensure that we extract the free tkvs in the
-                       -- order of theta, then arg_tys, then res_ty. Failing to
-                       -- do so resulted in #14808.
+
+          -- We must ensure that we extract the free tkvs in left-to-right
+          -- order of their appearance in the constructor type.
+          -- That order governs the order the implicitly-quantified type
+          -- variable, and hence the order needed for visible type application
+          -- See Trac #14808.
         ; free_tkvs <- extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])
         ; free_tkvs <- extractHsTvBndrs explicit_tkvs free_tkvs
 
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index cdb98fb..2305a04 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -1748,27 +1748,32 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
         extract_mlctxt ctxt =<<
         extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV
 
-extract_mlctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> RnM FreeKiTyVars
+extract_mlctxt :: Maybe (LHsContext GhcPs)
+               -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_mlctxt Nothing     acc = return acc
 extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc
 
 extract_lctxt :: TypeOrKind
-              -> LHsContext GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
+              -> LHsContext GhcPs
+              -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
 
 extract_ltys :: TypeOrKind
-             -> [LHsType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
+             -> [LHsType GhcPs]
+             -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys
 
-extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars)
-           -> Maybe a -> FreeKiTyVars -> RnM FreeKiTyVars
+extract_mb :: (a -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups)
+           -> Maybe a
+           -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_mb _ Nothing  acc = return acc
 extract_mb f (Just x) acc = f x acc
 
 extract_lkind :: LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_lkind = extract_lty KindLevel
 
-extract_lty :: TypeOrKind -> LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
+extract_lty :: TypeOrKind -> LHsType GhcPs
+            -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_lty t_or_k (L _ ty) acc
   = case ty of
       HsTyVar _  ltv            -> extract_tv t_or_k ltv acc
@@ -1813,19 +1818,21 @@ extract_apps :: TypeOrKind
              -> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
 
-extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars
-            -> RnM FreeKiTyVars
+extract_app :: TypeOrKind -> LHsAppType GhcPs
+            -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 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
+                 -> FreeKiTyVarsWithDups           -- Free in body
+                 -> RnM FreeKiTyVarsWithDups       -- 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
+extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
+                    -> FreeKiTyVarsWithDups  -- Accumulator
+                    -> FreeKiTyVarsWithDups  -- Free in body
+                    -> RnM FreeKiTyVarsWithDups
 -- In (forall (a :: Maybe e). a -> b) we have
 --     'a' is bound by the forall
 --     'b' is a free type variable
@@ -1866,8 +1873,8 @@ extract_hs_tv_bndrs_kvs tv_bndrs
        ; return (freeKiTyVarsKindVars fktvs) }
          -- There will /be/ no free tyvars!
 
-extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars
-           -> RnM FreeKiTyVars
+extract_tv :: TypeOrKind -> Located RdrName
+           -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_tv t_or_k ltv@(L _ tv) acc@(FKTV kvs tvs)
   | not (isRdrTyVar tv) = return acc
   | isTypeLevel t_or_k  = return (FKTV kvs (ltv : tvs))
diff --git a/testsuite/tests/gadt/T14808.hs b/testsuite/tests/gadt/T14808.hs
index 726f502..da3d521 100644
--- a/testsuite/tests/gadt/T14808.hs
+++ b/testsuite/tests/gadt/T14808.hs
@@ -10,3 +10,9 @@ data ECC ctx f a where
 
 f :: [()] -> ECC () [] ()
 f = ECC @() @[] @()
+
+data ECC2 f a ctx where
+  ECC2 :: ctx => f a -> ECC2 f a ctx
+
+f2 :: [()] -> ECC2 [] () ()
+f2 = ECC2 @() @[] @()