From dff3e914fbc8cff76b0475e4431fa831c804209a Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Mon, 9 Jul 2007 09:34:15 +0000 Subject: [PATCH] Implement -XUnicodeSyntax --- compiler/main/DynFlags.hs | 3 ++ compiler/parser/Lexer.x | 71 +++++++++++++++++++++++++-------------------- 2 files changed, 42 insertions(+), 32 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 72dbf2f..ecf2ef2 100644 --- a/compiler/main/DynFlags.hs +++ b/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 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 11810a6..ad56090 100644 --- a/compiler/parser/Lexer.x +++ b/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 -- 1.7.10.4