Implement -XPolymorphicComponents

compiler/main/DynFlags.hs

@@ -188,6 +188,7 @@ data DynFlag
    | Opt_MultiParamTypeClasses
    | Opt_FunctionalDependencies
    | Opt_UnicodeSyntax
+   | Opt_PolymorphicComponents
    | Opt_MagicHash
    | Opt_EmptyDataDecls
    | Opt_KindSignatures
@@ -1110,6 +1111,7 @@ xFlags = [
   ( "PatternGuards",                    Opt_PatternGuards ),
   ( "UnicodeSyntax",                    Opt_UnicodeSyntax ),
   ( "MagicHash",                        Opt_MagicHash ),
+  ( "PolymorphicComponents",            Opt_PolymorphicComponents ),
   ( "KindSignatures",                   Opt_KindSignatures ),
   ( "EmptyDataDecls",                   Opt_EmptyDataDecls ),
   ( "ParallelListComp",                 Opt_ParallelListComp ),
@@ -1169,6 +1171,7 @@ glasgowExtsFlags = [ Opt_GlasgowExts
            , Opt_MultiParamTypeClasses
            , Opt_FunctionalDependencies
 		   , Opt_MagicHash
+           , Opt_PolymorphicComponents
            , Opt_UnicodeSyntax
            , Opt_PatternGuards
            , Opt_RankNTypes

compiler/parser/Lexer.x

@@ -1590,6 +1590,7 @@ mkPState buf loc flags  =
 	       .|. thBit        `setBitIf` dopt Opt_TH           flags
 	       .|. ipBit        `setBitIf` dopt Opt_ImplicitParams flags
 	       .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
+	       .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
 	       .|. bangPatBit   `setBitIf` dopt Opt_BangPatterns flags
 	       .|. tyFamBit     `setBitIf` dopt Opt_TypeFamilies flags
 	       .|. haddockBit   `setBitIf` dopt Opt_Haddock      flags

compiler/typecheck/TcMType.lhs

@@ -697,6 +697,7 @@ checkValidType ctxt ty
     doptM Opt_GlasgowExts	`thenM` \ gla_exts ->
     doptM Opt_Rank2Types	`thenM` \ rank2 ->
     doptM Opt_RankNTypes	`thenM` \ rankn ->
+    doptM Opt_PolymorphicComponents	`thenM` \ polycomp ->
     let 
 	rank | rankn = Arbitrary
 	     | rank2 = Rank 2
@@ -710,8 +711,11 @@ checkValidType ctxt ty
 		 TySynCtxt _    -> Rank 0
 		 ExprSigCtxt 	-> Rank 1
 		 FunSigCtxt _   -> Rank 1
-		 ConArgCtxt _   -> Rank 1	-- We are given the type of the entire
-						-- constructor, hence rank 1
+		 ConArgCtxt _   -> if polycomp
+                           then Rank 2
+                                -- We are given the type of the entire
+                                -- constructor, hence rank 1
+                           else Rank 1
 		 ForSigCtxt _	-> Rank 1
 		 SpecInstCtxt   -> Rank 1