Implement -XUnicodeSyntax

compiler/main/DynFlags.hs

@@ -187,6 +187,7 @@ data DynFlag
    | Opt_FlexibleInstances
    | Opt_MultiParamTypeClasses
    | Opt_FunctionalDependencies
+   | Opt_UnicodeSyntax
    | Opt_MagicHash
    | Opt_EmptyDataDecls
    | Opt_KindSignatures
@@ -1107,6 +1108,7 @@ xFlags :: [(String, DynFlag)]
 xFlags = [
   ( "CPP",                              Opt_Cpp ),
   ( "PatternGuards",                    Opt_PatternGuards ),
+  ( "UnicodeSyntax",                    Opt_UnicodeSyntax ),
   ( "MagicHash",                        Opt_MagicHash ),
   ( "KindSignatures",                   Opt_KindSignatures ),
   ( "EmptyDataDecls",                   Opt_EmptyDataDecls ),
@@ -1167,6 +1169,7 @@ glasgowExtsFlags = [ Opt_GlasgowExts
            , Opt_MultiParamTypeClasses
            , Opt_FunctionalDependencies
 		   , Opt_MagicHash
+           , Opt_UnicodeSyntax
            , Opt_PatternGuards
            , Opt_RankNTypes
            , Opt_RecursiveDo

compiler/parser/Lexer.x

@@ -632,39 +632,43 @@ reservedWordsFM = listToUFM $
 	( "proc",	ITproc,		 bit arrowsBit)
      ]
 
+reservedSymsFM :: UniqFM (Token, Int -> Bool)
 reservedSymsFM = listToUFM $
-	map (\ (x,y,z) -> (mkFastString x,(y,z)))
-      [ ("..",	ITdotdot,	0)
-       ,(":",	ITcolon,	0)	-- (:) is a reserved op, 
-						-- meaning only list cons
-       ,("::",	ITdcolon, 	0)
-       ,("=",	ITequal, 	0)
-       ,("\\",	ITlam, 		0)
-       ,("|",	ITvbar, 	0)
-       ,("<-",	ITlarrow, 	0)
-       ,("->",	ITrarrow, 	0)
-       ,("@",	ITat, 		0)
-       ,("~",	ITtilde, 	0)
-       ,("=>",	ITdarrow, 	0)
-       ,("-",	ITminus, 	0)
-       ,("!",	ITbang, 	0)
-
-       ,("*",	ITstar,		bit glaExtsBit .|. bit kindSigsBit .|.
-				bit tyFamBit)	    -- For data T (a::*) = MkT
-       ,(".",	ITdot,		bit tvBit)	    -- For 'forall a . t'
-
-       ,("-<",	ITlarrowtail,	bit arrowsBit)
-       ,(">-",	ITrarrowtail,	bit arrowsBit)
-       ,("-<<",	ITLarrowtail,	bit arrowsBit)
-       ,(">>-",	ITRarrowtail,	bit arrowsBit)
+    map (\ (x,y,z) -> (mkFastString x,(y,z)))
+      [ ("..",  ITdotdot,   always)
+        -- (:) is a reserved op, meaning only list cons
+       ,(":",   ITcolon,    always)
+       ,("::",  ITdcolon,   always)
+       ,("=",   ITequal,    always)
+       ,("\\",  ITlam,      always)
+       ,("|",   ITvbar,     always)
+       ,("<-",  ITlarrow,   always)
+       ,("->",  ITrarrow,   always)
+       ,("@",   ITat,       always)
+       ,("~",   ITtilde,    always)
+       ,("=>",  ITdarrow,   always)
+       ,("-",   ITminus,    always)
+       ,("!",   ITbang,     always)
+
+        -- For data T (a::*) = MkT
+       ,("*", ITstar, \i -> glaExtsEnabled i ||
+                            kindSigsEnabled i ||
+                            tyFamEnabled i)
+        -- For 'forall a . t'
+       ,(".", ITdot, tvEnabled)
+
+       ,("-<",  ITlarrowtail, arrowsEnabled)
+       ,(">-",  ITrarrowtail, arrowsEnabled)
+       ,("-<<", ITLarrowtail, arrowsEnabled)
+       ,(">>-", ITRarrowtail, arrowsEnabled)
 
 #if __GLASGOW_HASKELL__ >= 605
-       ,("∷",   ITdcolon,       bit glaExtsBit)
-       ,("⇒",   ITdarrow,	bit glaExtsBit)
-       ,("∀",	ITforall,	bit glaExtsBit)
-       ,("→",   ITrarrow,	bit glaExtsBit)
-       ,("←",   ITlarrow,	bit glaExtsBit)
-       ,("⋯", 	ITdotdot,	bit glaExtsBit)
+       ,("∷",   ITdcolon, unicodeSyntaxEnabled)
+       ,("⇒",   ITdarrow, unicodeSyntaxEnabled)
+       ,("∀",   ITforall, \i -> unicodeSyntaxEnabled i && tvEnabled i)
+       ,("→",   ITrarrow, unicodeSyntaxEnabled)
+       ,("←",   ITlarrow, unicodeSyntaxEnabled)
+       ,("⋯",   ITdotdot, unicodeSyntaxEnabled)
         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
         -- form part of a large operator.  This would let us have a better
         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
@@ -943,9 +947,8 @@ consym = sym ITconsym
 
 sym con span buf len = 
   case lookupUFM reservedSymsFM fs of
-	Just (keyword,0)    -> return (L span keyword)
 	Just (keyword,exts) -> do
-		b <- extension (\i -> exts .&. i /= 0)
+		b <- extension exts
 		if b then return (L span keyword)
 		     else return (L span $! con fs)
 	_other -> return (L span $! con fs)
@@ -1520,8 +1523,10 @@ haddockBit = 10 -- Lex and parse Haddock comments
 magicHashBit = 11 -- # in both functions and operators
 kindSigsBit = 12 -- Kind signatures on type variables
 recursiveDoBit = 13 -- mdo
+unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
 
 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
+always           _     = True
 glaExtsEnabled   flags = testBit flags glaExtsBit
 ffiEnabled       flags = testBit flags ffiBit
 parrEnabled      flags = testBit flags parrBit
@@ -1535,6 +1540,7 @@ haddockEnabled   flags = testBit flags haddockBit
 magicHashEnabled flags = testBit flags magicHashBit
 kindSigsEnabled  flags = testBit flags kindSigsBit
 recursiveDoEnabled flags = testBit flags recursiveDoBit
+unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
 
 -- PState for parsing options pragmas
 --
@@ -1589,6 +1595,7 @@ mkPState buf loc flags  =
 	       .|. magicHashBit `setBitIf` dopt Opt_MagicHash    flags
 	       .|. kindSigsBit  `setBitIf` dopt Opt_KindSignatures flags
 	       .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
+	       .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b