[GHC] #14288: ScopedTypeVariables with nested foralls broken since 8.0.2
GHC
ghc-devs at haskell.org
Wed Sep 27 19:32:29 UTC 2017
#14288: ScopedTypeVariables with nested foralls broken since 8.0.2
-------------------------------------+-------------------------------------
Reporter: MikolajKonarski | Owner: (none)
Type: bug | Status: new
Priority: normal | Milestone:
Component: Compiler (Type | Version: 8.2.1
checker) |
Resolution: | Keywords:
Operating System: Linux | Architecture: x86_64
Type of failure: GHC rejects | (amd64)
valid program | Test Case:
Blocked By: | Blocking:
Related Tickets: | Differential Rev(s):
Wiki Page: |
-------------------------------------+-------------------------------------
Comment (by RyanGlScott):
For what it's worth, it's quite simple to change the behavior to make it
work the way you desire:
{{{#!diff
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index b9cd946..5e0f885 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -54,7 +54,8 @@ module HsTypes (
hsScopedTvs, hsWcScopedTvs, dropWildCards,
hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
- splitLHsInstDeclTy, getLHsInstDeclHead,
getLHsInstDeclClass_maybe,
+ splitLHsInstDeclTy, splitNestedLHsSigmaTys,
+ getLHsInstDeclHead, getLHsInstDeclClass_maybe,
splitLHsPatSynTy,
splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
splitHsFunType, splitHsAppsTy,
@@ -76,7 +77,7 @@ import PlaceHolder ( PlaceHolder(..) )
import HsExtension
import Id ( Id )
-import Name( Name )
+import Name( Name, NamedThing(..) )
import RdrName ( RdrName )
import NameSet ( NameSet, emptyNameSet )
import DataCon( HsSrcBang(..), HsImplBang(..),
@@ -843,17 +844,19 @@ hsWcScopedTvs sig_ty
| HsWC { hswc_wcs = nwcs, hswc_body = sig_ty1 } <- sig_ty
, HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty1
= case sig_ty2 of
- L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++
- map hsLTyVarName tvs
+ fa_ty@(L _ (HsForAllTy {}))
+ | (tvs, _, _) <- splitNestedLHsSigmaTys fa_ty
+ -> vars ++ nwcs ++ map hsLTyVarName tvs
-- include kind variables only if the type is headed by
forall
-- (this is consistent with GHC 7 behaviour)
- _ -> nwcs
+ _ -> nwcs
hsScopedTvs :: LHsSigType GhcRn -> [Name]
-- Same as hsWcScopedTvs, but for a LHsSigType
hsScopedTvs sig_ty
| HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty
- , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2
+ , fa_ty@(L _ (HsForAllTy {})) <- sig_ty2
+ , (tvs, _, _) <- splitNestedLHsSigmaTys fa_ty
= vars ++ map hsLTyVarName tvs
| otherwise
= []
@@ -953,9 +956,10 @@ mkHsAppTys = foldl mkHsAppTy
-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
-- Breaks up any parens in the result type:
-- splitHsFunType (a -> (b -> c)) = ([a,b], c)
--- Also deals with (->) t1 t2; that is why it only works on LHsType Name
+-- Also deals with (->) t1 t2; that is why it only works on NamedThings.
-- (see Trac #9096)
-splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn)
+splitHsFunType :: NamedThing (IdP pass)
+ => LHsType pass -> ([LHsType pass], LHsType pass)
splitHsFunType (L _ (HsParTy ty))
= splitHsFunType ty
@@ -966,7 +970,7 @@ splitHsFunType (L _ (HsFunTy x y))
splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
= go t1 [t2]
where -- Look for (->) t1 t2, possibly with parenthesisation
- go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName
+ go (L _ (HsTyVar _ (L _ fn))) tys | getName fn == funTyConName
, [t1,t2] <- tys
, (args, res) <- splitHsFunType t2
= (t1:args, res)
@@ -1044,6 +1048,7 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs,
ty4)
(exis, ty3) = splitLHsForAllTy ty2
(provs, ty4) = splitLHsQualTy ty3
+-- | Split a sigma type into its parts.
splitLHsSigmaTy :: LHsType pass
-> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
splitLHsSigmaTy ty
@@ -1051,6 +1056,50 @@ splitLHsSigmaTy ty
, (ctxt, ty2) <- splitLHsQualTy ty1
= (tvs, ctxt, ty2)
+-- | Split a sigma type into its parts, going underneath as many
'HsForAllTy's
+-- and 'HsQualTy's as possible.
+--
+-- 'splitNestedLHsSigmaTys' is to 'splitLHsSigmaTy' as
'tcSplitNestedSigmaTys'
+-- is to 'tcSplitSigmaTy' (from "TcType").
+splitNestedLHsSigmaTys
+ :: NamedThing (IdP pass)
+ => LHsType pass
+ -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
+splitNestedLHsSigmaTys ty
+ -- If there's a forall or context, split it apart and try splitting
the
+ -- rho type underneath it.
+ | Just (arg_tys, tvs1, L src1 theta1, rho1) <-
deepSplitLHsSigmaTy_maybe ty
+ = let (tvs2, L src2 theta2, rho2) = splitNestedLHsSigmaTys rho1
+ in ( tvs1 ++ tvs2, L (combineSrcSpans src1 src2) (theta1 ++ theta2)
+ , nlHsFunTys arg_tys rho2 )
+ -- If there's no forall or context, we're done.
+ | otherwise = ([], L noSrcSpan [], ty)
+ where
+ -- These really should be imported from HsUtils, but that would lead
+ -- to import cycles.
+ nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
+ nlHsFunTy a b = noLoc (HsFunTy a b)
+
+ nlHsFunTys :: [LHsType name] -> LHsType name -> LHsType name
+ nlHsFunTys args res = foldr nlHsFunTy res args
+
+deepSplitLHsSigmaTy_maybe
+ :: NamedThing (IdP pass)
+ => LHsType pass
+ -> Maybe ( [LHsType pass], [LHsTyVarBndr pass], LHsContext pass
+ , LHsType pass )
+deepSplitLHsSigmaTy_maybe ty
+ | (arg_tys1, res_ty) <- splitHsFunType ty
+ , not (null arg_tys1) -- If not, splitHsFunType didn't find any arrow
types
+ , Just (arg_tys2, tvs, theta, rho) <- deepSplitLHsSigmaTy_maybe res_ty
+ = Just (arg_tys1 ++ arg_tys2, tvs, theta, rho)
+
+ | (tvs, hs_theta@(L _ theta), rho) <- splitLHsSigmaTy ty
+ , not (null tvs && null theta)
+ = Just ([], tvs, hs_theta, rho)
+
+ | otherwise = Nothing
+
splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body }))
= (tvs, body)
splitLHsForAllTy body
= ([], body)
}}}
Applying this patch makes that test case compile successfully. The only
question is if we //should// apply the patch at all.
--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/14288#comment:3>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler
More information about the ghc-tickets
mailing list