#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