[add bange-patterns extension, add individual flags for various extensions
John Meacham <john@repetae.net>**20120201110217
 Ignore-this: 45f6e1befab3cb368ca4e000118159f2
] hunk ./regress/tests/0_parse/2_pass/data.hs 1
-{-# OPTIONS_JHC -funboxed-tuples #-}
+{-# OPTIONS_JHC -funboxed-tuples -fforall #-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/T2478.hs 2
+{-# LANGUAGE RankNTypes #-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/faxen.hs 2
+{-# LANGUAGE ExistentialQuantification #-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc065.hs 1
-module ShouldSucceed where
-
--- import TheUtils
-import qualified Data.Set as Set
-import Data.Set (Set)
-import Data.List (partition )
-
-data Digraph vertex = MkDigraph [vertex]
-
-type Edge  vertex = (vertex, vertex)
-type Cycle vertex = [vertex]
-
-mkDigraph = MkDigraph
-
-stronglyConnComp :: Eq vertex => [Edge vertex] -> [vertex] -> [[vertex]]
-stronglyConnComp es vs
-  = snd (span_tree (new_range reversed_edges)
-		    ([],[])
-                   ( snd (dfs (new_range es) ([],[]) vs) )
-	 )
- where
-   reversed_edges = map swap es
-
-   swap :: Edge v -> Edge v
-   swap (x,y) = (y, x)
-
-   new_range    []       w = []
-   new_range ((x,y):xys) w
-	= if x==w
-	  then (y : (new_range xys w))
-	  else (new_range xys w)
-
-   span_tree r (vs,ns) []   = (vs,ns)
-   span_tree r (vs,ns) (x:xs)
-	| x `elem` vs = span_tree r (vs,ns) xs
-	| otherwise = span_tree r (vs',(x:ns'):ns) xs
-	  where
-	    (vs',ns') = dfs r (x:vs,[]) (r x)
-
-dfs r (vs,ns)   []   = (vs,ns)
-dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs
-                     | otherwise = dfs r (vs',(x:ns')++ns) xs
-                                   where
-                                     (vs',ns') = dfs r (x:vs,[]) (r x)
-
-
-isCyclic :: Eq vertex => [Edge vertex] -> [vertex] -> Bool
-isCyclic edges [v] = (v,v) `elem` edges
-isCyclic edges vs = True
-
-
-topSort :: (Eq vertex) => [Edge vertex] -> [vertex]
-              -> MaybeErr [vertex] [[vertex]]
-
-
-topSort edges vertices
- = case cycles of
-	[] -> Succeeded [v | [v] <- singletons]
-	_  -> Failed cycles
-   where
-   sccs = stronglyConnComp edges vertices
-   (cycles, singletons) = partition (isCyclic edges) sccs
-
-
-type FlattenedDependencyInfo vertex name code
-   = [(vertex, Set name, Set name, code)]
-
-mkVertices :: FlattenedDependencyInfo vertex name code -> [vertex]
-mkVertices info = [ vertex | (vertex,_,_,_) <- info]
-
-mkEdges :: (Eq vertex, Ord name) =>
-	    [vertex]
-	 -> FlattenedDependencyInfo vertex name code
-	 -> [Edge vertex]
-
-mkEdges vertices flat_info
- = [ (source_vertex, target_vertex)
-   | (source_vertex, _, used_names, _) <- flat_info,
-     target_name   <- Set.toList used_names,
-     target_vertex <- vertices_defining target_name flat_info
-   ]
- where
-   vertices_defining name flat_info
-    = [ vertex |  (vertex, names_defined, _, _) <- flat_info,
-   		name `Set.member` names_defined
-      ]
-
-lookupVertex :: (Eq vertex, Ord name) =>
-	    	 FlattenedDependencyInfo vertex name code
-	      -> vertex
-	      -> code
-
-lookupVertex flat_info vertex
- = head code_list
- where
-   code_list = [ code | (vertex',_,_,code) <- flat_info, vertex == vertex']
-
-
-isRecursiveCycle :: (Eq vertex) => Cycle vertex -> [Edge vertex] -> Bool
-isRecursiveCycle [vertex] edges = (vertex, vertex) `elem` edges
-isRecursiveCycle cycle    edges = True
-
-
-
--- may go to TheUtils
-
-data MaybeErr a b = Succeeded a | Failed b
-
rmfile ./regress/tests/1_typecheck/2_pass/ghc/tc065.hs
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc087.hs 1
+{-# LANGUAGE raNK2TYpes #-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc097.hs 1
+{-# OPTIONS -fforall #-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc124.hs 2
+{-# OPTIONS -fforall #-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc140.hs 1
-{-# OPTIONS -fglasgow-exts #-}
+{-# OPTIONS -fglasgow-exts -fforall #-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc146.hs 2
+{-# OPTIONS -fforall #-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc149.hs 1
-{-# OPTIONS -fglasgow-exts #-}
+{-# OPTIONS -fglasgow-exts -fforall #-}
hunk ./src/FlagOpts.flags 9
-
hunk ./src/FlagOpts.flags 16
+type-families type/data family support
+user-kinds user defined kinds
+forall - forall keyword for rank-n types and explicit quantification
+exists - exists keyword for existential types recognized
+bang-patterns - bang patterns
hunk ./src/FlagOpts.flags 47
+@glasgow-exts forall ffi unboxed-tuples
hunk ./src/FrontEnd/HsParser.y 101
+      'bang!' { BangExclamation }
hunk ./src/FrontEnd/HsParser.y 140
+      'family'        { KW_Family }
hunk ./src/FrontEnd/HsParser.y 235
-
hunk ./src/FrontEnd/HsParser.y 297
+mkind :: { Maybe HsKind }
+    : '::' kind                       { Just $2 }
+    |                                 { Nothing }
+
hunk ./src/FrontEnd/HsParser.y 308
+      | 'data' 'family' simpletype srcloc mkind
+                      { HsTypeFamilyDecl $4 True (fst $3) (snd $3) $5 }
+      | 'type' 'family' simpletype srcloc mkind
+                      { HsTypeFamilyDecl $4 False (fst $3) (snd $3) $5 }
hunk ./src/FrontEnd/HsParser.y 353
-
hunk ./src/FrontEnd/HsParser.y 385
-      | pragmainline                  { $1 }
hunk ./src/FrontEnd/HsParser.y 387
-
-
hunk ./src/FrontEnd/HsParser.y 455
+       |  'bang!'               { hsKindBang }
hunk ./src/FrontEnd/HsParser.y 487
-
hunk ./src/FrontEnd/HsParser.y 511
-
hunk ./src/FrontEnd/HsParser.y 551
+      | btype 'bang!' atype               {% splitTyConApp $1 `thenP` \(c,ts) ->
+                                         returnP (c,map HsUnBangedTy ts++
+                                                      [HsBangedTy $3]) }
hunk ./src/FrontEnd/HsParser.y 559
+      | 'bang!' atype                 { HsBangedTy   $2 }
hunk ./src/FrontEnd/HsParser.y 564
+      | 'bang!' atype                 { HsBangedTy   $2 }
hunk ./src/FrontEnd/HsParser.y 576
+      | 'bang!' atype                 { HsBangedTy   $2 }
hunk ./src/FrontEnd/HsParser.y 637
+--      | 'data' simpletype srcloc
+--                      { HsTypeFamilyDecl $3 True (fst $2) (snd $2) Nothing }
+--      | 'data' simpletype srcloc '::' kind
+--                      { HsTypeFamilyDecl $3 True (fst $2) (snd $2) (Just $5) }
hunk ./src/FrontEnd/HsParser.y 642
-                      { HsTypeDecl $3 (fst $2) (snd $2) HsTyAssoc }
+                      { HsTypeFamilyDecl $3 False (fst $2) (snd $2) Nothing }
+      | 'type' simpletype srcloc '::' kind
+                      { HsTypeFamilyDecl $3 False (fst $2) (snd $2) (Just $5) }
hunk ./src/FrontEnd/HsParser.y 730
---      | '!' srcloc aexp1 srcloc       { HsBangPat $ located ($2,$4) $3 }
+      | 'bang!' srcloc aexp1 srcloc   { HsBangPat $ located ($2,$4) $3 }
hunk ./src/FrontEnd/HsParser.y 778
-paexps :: { [HsExp] }
-      : paexps paexp                    { $2 : $1 }
-      | paexp                          { [$1] }
-
hunk ./src/FrontEnd/HsParser.y 810
---      | '!' srcloc paexp1 srcloc      { HsBangPat $ located ($2,$4) $3 }
-
+      | 'bang!' srcloc paexp1 srcloc  { HsBangPat $ located ($2,$4) $3 }
hunk ./src/FrontEnd/HsParser.y 849
-
hunk ./src/FrontEnd/HsParser.y 971
+      | 'family'              { toName UnknownType "family" }
hunk ./src/FrontEnd/HsParser.y 1003
+      | 'bang!'               { pling_name }
hunk ./src/FrontEnd/HsParser.y 1014
+      | 'bang!'               { pling_name }
hunk ./src/FrontEnd/HsParser.y 1098
-
hunk ./src/FrontEnd/HsSyn.hs 127
-    = HsTypeDecl	 {
+    = HsTypeFamilyDecl {
+        hsDeclSrcLoc :: SrcLoc,
+        hsDeclData :: Bool,
+        hsDeclName :: HsName,
+        hsDeclTArgs :: [HsType],
+        hsDeclHasKind :: Maybe HsKind
+        }
+    | HsTypeDecl	 {
hunk ./src/FrontEnd/Lexer.hs 33
+import Options
hunk ./src/FrontEnd/Lexer.hs 35
+import qualified FlagOpts as FO
hunk ./src/FrontEnd/Lexer.hs 90
+    | BangExclamation
hunk ./src/FrontEnd/Lexer.hs 124
+    | KW_Family
hunk ./src/FrontEnd/Lexer.hs 189
- ( "foreign",   KW_Foreign ),
- ( "forall",    KW_Forall ),
hunk ./src/FrontEnd/Lexer.hs 190
- ( "exists",    KW_Exists ),
hunk ./src/FrontEnd/Lexer.hs 197
- ( "kind", 	KW_Kind ),
hunk ./src/FrontEnd/Lexer.hs 202
+-- these become keywords when the cooresponding extensions are enabled.
+optional_ids = procOpt [
+ ( "kind", KW_Kind, FO.UserKinds ),
+ ( "foreign", KW_Foreign, FO.Ffi ),
+ ( "family", KW_Family, FO.TypeFamilies ),
+ ( "forall", KW_Forall, FO.Forall ),
+ ( "exists", KW_Exists, FO.Exists),
+ ( "!"     , BangExclamation, FO.BangPatterns )
+ ]
+
+procOpt xs = Map.fromList [ (toUnqualName w,(o,k)) | (w,k,o) <- xs ]
+
hunk ./src/FrontEnd/Lexer.hs 356
-    ParseMode { parseUnboxedValues = uval, parseUnboxedTuples = utup, parseFFI = doFFI } <- lexParseMode
+    ParseMode { parseUnboxedValues = uval, parseUnboxedTuples = utup, parseOpt = opt } <- lexParseMode
+    let opt_ids = Map.mapMaybe f optional_ids where
+            f (fo,k) = if fo `Set.member` optFOptsSet opt
+                then Just k else Nothing
hunk ./src/FrontEnd/Lexer.hs 397
-		case Map.lookup ident (reserved_ids `Map.union` special_varids) of
-                        Just KW_Foreign
-                            | doFFI -> return KW_Foreign
-                            | otherwise -> return $ VarId ident
+		case Map.lookup ident (opt_ids `Map.union` reserved_ids `Map.union` special_varids) of
hunk ./src/FrontEnd/Lexer.hs 405
-		return $ case Map.lookup nsym (reserved_ops `Map.union` special_varops) of
+		return $ case Map.lookup nsym (opt_ids `Map.union` reserved_ops `Map.union` special_varops) of
hunk ./src/FrontEnd/ParseMonad.hs 95
-		parseFilename      :: String,
+		parseFilename      :: FilePath,
+                parseOpt           :: Opt,
hunk ./src/FrontEnd/ParseMonad.hs 108
+                parseOpt = options,
hunk ./src/FrontEnd/ParseMonad.hs 117
-    parseFFI = FO.Ffi `Set.member` optFOptsSet options
+    parseFFI = FO.Ffi `Set.member` optFOptsSet options,
+    parseOpt = options
hunk ./src/FrontEnd/Warning.hs 110
-ignore = ["h98-emptydata"]
+ignore = ["h98-emptydata", "h98-forall"]
hunk ./src/Ho/ReadSource.hs 71
-    f (l:ls) pfs nfs us | Just lo <- Map.lookup ll langmap =  f ls (Set.insert lo pfs) nfs us
-                        | 'n':'o':ll <- ll, Just lo <- Map.lookup ll langmap = f ls pfs (Set.insert lo nfs) us
+    f (l:ls) pfs nfs us | Just lo <- Map.lookup ll langmap =  f ls (Set.union lo pfs) nfs us
+                        | 'n':'o':ll <- ll, Just lo <- Map.lookup ll langmap = f ls pfs (nfs Set.\\ lo) us
hunk ./src/Ho/ReadSource.hs 84
+    "explicitforall" ==> FO.Forall,
+    "existentialquantification" =+> [FO.Forall,FO.Exists],
+    "scopedtypevariables" ==> FO.Forall,
+    "rankntypes" ==> FO.Forall,
+    "rank2types" ==> FO.Forall,
+    "polymorphiccomponents" ==> FO.Forall,
+    "TypeFamilies" ==> FO.TypeFamilies,
hunk ./src/Ho/ReadSource.hs 92
-    ] where x ==> y = (x,y)
+    ] where x ==> y = (x,Set.singleton y)
+            x =+> y = (x,Set.fromList y)