From: Ian Lynagh <igloo@earth.li>
Date: Mon, 9 Jul 2007 12:04:15 +0000 (+0000)
Subject: Implement -XPolymorphicComponents
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f109a0b2d927a8c7fe5cc9881f0dfdae3e34f399

Implement -XPolymorphicComponents
---

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ecf2ef2..a61994b 100644
--- a/compiler/main/DynFlags.hs
+++ b/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
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index d9c5fc8..753a972 100644
--- a/compiler/parser/Lexer.x
+++ b/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
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 18e58fc..c34387b 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/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