diff options
Diffstat (limited to 'compiler/parser')
| -rw-r--r-- | compiler/parser/Ctype.lhs | 8 | ||||
| -rw-r--r-- | compiler/parser/LexCore.hs | 115 | ||||
| -rw-r--r-- | compiler/parser/Lexer.x | 394 | ||||
| -rw-r--r-- | compiler/parser/Parser.y.pp | 21 | ||||
| -rw-r--r-- | compiler/parser/ParserCore.y | 397 | ||||
| -rw-r--r-- | compiler/parser/ParserCoreUtils.hs | 77 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.lhs | 78 |
7 files changed, 275 insertions, 815 deletions
diff --git a/compiler/parser/Ctype.lhs b/compiler/parser/Ctype.lhs index b5173b2612..c024ebe45a 100644 --- a/compiler/parser/Ctype.lhs +++ b/compiler/parser/Ctype.lhs @@ -1,7 +1,8 @@ Character classification \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -18,7 +19,7 @@ module Ctype , is_digit -- Char# -> Bool , is_alphanum -- Char# -> Bool - , is_decdigit, is_hexdigit, is_octdigit + , is_decdigit, is_hexdigit, is_octdigit, is_bindigit , hexDigit, octDecDigit ) where @@ -86,6 +87,9 @@ is_hexdigit c is_octdigit :: Char -> Bool is_octdigit c = c >= '0' && c <= '7' +is_bindigit :: Char -> Bool +is_bindigit c = c == '0' || c == '1' + to_lower :: Char -> Char to_lower c | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a')) diff --git a/compiler/parser/LexCore.hs b/compiler/parser/LexCore.hs deleted file mode 100644 index 861fffb7f6..0000000000 --- a/compiler/parser/LexCore.hs +++ /dev/null @@ -1,115 +0,0 @@ -module LexCore where - -import ParserCoreUtils -import Panic -import Data.Char -import Numeric - -isNameChar :: Char -> Bool -isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'') - || (c == '$') || (c == '-') || (c == '.') - -isKeywordChar :: Char -> Bool -isKeywordChar c = isAlpha c || (c == '_') - -lexer :: (Token -> P a) -> P a -lexer cont [] = cont TKEOF [] -lexer cont ('\n':cs) = \line -> lexer cont cs (line+1) -lexer cont ('-':'>':cs) = cont TKrarrow cs - -lexer cont (c:cs) - | isSpace c = lexer cont cs - | isLower c || (c == '_') = lexName cont TKname (c:cs) - | isUpper c = lexName cont TKcname (c:cs) - | isDigit c || (c == '-') = lexNum cont (c:cs) - -lexer cont ('%':cs) = lexKeyword cont cs -lexer cont ('\'':cs) = lexChar cont cs -lexer cont ('\"':cs) = lexString [] cont cs -lexer cont ('#':cs) = cont TKhash cs -lexer cont ('(':cs) = cont TKoparen cs -lexer cont (')':cs) = cont TKcparen cs -lexer cont ('{':cs) = cont TKobrace cs -lexer cont ('}':cs) = cont TKcbrace cs -lexer cont ('=':cs) = cont TKeq cs -lexer cont (':':'=':':':cs) = cont TKcoloneqcolon cs -lexer cont (':':':':cs) = cont TKcoloncolon cs -lexer cont ('*':cs) = cont TKstar cs -lexer cont ('.':cs) = cont TKdot cs -lexer cont ('\\':cs) = cont TKlambda cs -lexer cont ('@':cs) = cont TKat cs -lexer cont ('?':cs) = cont TKquestion cs -lexer cont (';':cs) = cont TKsemicolon cs --- 20060420 GHC spits out constructors with colon in them nowadays. jds --- 20061103 but it's easier to parse if we split on the colon, and treat them --- as several tokens -lexer cont (':':cs) = cont TKcolon cs --- 20060420 Likewise does it create identifiers starting with dollar. jds -lexer cont ('$':cs) = lexName cont TKname ('$':cs) -lexer _ (c:_) = failP "invalid character" [c] - -lexChar :: (Token -> String -> Int -> ParseResult a) -> String -> Int - -> ParseResult a -lexChar cont ('\\':'x':h1:h0:'\'':cs) - | isHexEscape [h1,h0] = cont (TKchar (hexToChar h1 h0)) cs -lexChar _ ('\\':cs) = failP "invalid char character" ('\\':(take 10 cs)) -lexChar _ ('\'':_) = failP "invalid char character" ['\''] -lexChar _ ('\"':_) = failP "invalid char character" ['\"'] -lexChar cont (c:'\'':cs) = cont (TKchar c) cs -lexChar _ cs = panic ("lexChar: " ++ show cs) - -lexString :: String -> (Token -> [Char] -> Int -> ParseResult a) - -> String -> Int -> ParseResult a -lexString s cont ('\\':'x':h1:h0:cs) - | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs -lexString _ _ ('\\':_) = failP "invalid string character" ['\\'] -lexString _ _ ('\'':_) = failP "invalid string character" ['\''] -lexString s cont ('\"':cs) = cont (TKstring s) cs -lexString s cont (c:cs) = lexString (s++[c]) cont cs -lexString _ _ [] = panic "lexString []" - -isHexEscape :: String -> Bool -isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c)) - -hexToChar :: Char -> Char -> Char -hexToChar h1 h0 = chr (digitToInt h1 * 16 + digitToInt h0) - -lexNum :: (Token -> String -> a) -> String -> a -lexNum cont cs = - case cs of - ('-':cs) -> f (-1) cs - _ -> f 1 cs - where f sgn cs = - case span isDigit cs of - (digits,'.':c:rest) - | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest' - where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest)) - -- When reading a floating-point number, which is - -- a bit complicated, use the standard library function - -- "readFloat" - (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest - -lexName :: (a -> String -> b) -> (String -> a) -> String -> b -lexName cont cstr cs = cont (cstr name) rest - where (name,rest) = span isNameChar cs - -lexKeyword :: (Token -> [Char] -> Int -> ParseResult a) -> String -> Int - -> ParseResult a -lexKeyword cont cs = - case span isKeywordChar cs of - ("module",rest) -> cont TKmodule rest - ("data",rest) -> cont TKdata rest - ("newtype",rest) -> cont TKnewtype rest - ("forall",rest) -> cont TKforall rest - ("rec",rest) -> cont TKrec rest - ("let",rest) -> cont TKlet rest - ("in",rest) -> cont TKin rest - ("case",rest) -> cont TKcase rest - ("of",rest) -> cont TKof rest - ("cast",rest) -> cont TKcast rest - ("note",rest) -> cont TKnote rest - ("external",rest) -> cont TKexternal rest - ("local",rest) -> cont TKlocal rest - ("_",rest) -> cont TKwild rest - _ -> failP "invalid keyword" ('%':cs) - diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 3d02393d17..fe3d6a5d2b 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -117,6 +117,7 @@ $small = [$ascsmall $unismall \_] $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar. $graphic = [$small $large $symbol $digit $special $unigraphic \:\"\'] +$binit = 0-1 $octit = 0-7 $hexit = [$decdigit A-F a-f] $symchar = [$symbol \:] @@ -134,6 +135,7 @@ $docsym = [\| \^ \* \$] @consym = \: $symchar* @decimal = $decdigit+ +@binary = $binit+ @octal = $octit+ @hexadecimal = $hexit+ @exponent = [eE] [\-\+]? @decimal @@ -401,9 +403,12 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } <0> { -- Normal integral literals (:: Num a => a, from Integer) @decimal { tok_num positive 0 0 decimal } + 0[bB] @binary / { ifExtension binaryLiteralsEnabled } { tok_num positive 2 2 binary } 0[oO] @octal { tok_num positive 2 2 octal } 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal } @negative @decimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 1 1 decimal } + @negative 0[bB] @binary / { ifExtension negativeLiteralsEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_num negative 3 3 binary } @negative 0[oO] @octal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal } @negative 0[xX] @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal } @@ -417,13 +422,19 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- It's simpler (and faster?) to give separate cases to the negatives, -- especially considering octal/hexadecimal prefixes. @decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal } + 0[bB] @binary \# / { ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_primint positive 2 3 binary } 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal } 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal } @negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal } + @negative 0[bB] @binary \# / { ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary } @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal } @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal } @decimal \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal } + 0[bB] @binary \# \# / { ifExtension magicHashEnabled `alexAndPred` + ifExtension binaryLiteralsEnabled } { tok_primword 2 4 binary } 0[oO] @octal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal } 0[xX] @hexadecimal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal } @@ -516,6 +527,9 @@ data Token | ITvect_scalar_prag | ITnovect_prag | ITminimal_prag + | ITno_overlap_prag -- instance overlap mode + | IToverlap_prag -- instance overlap mode + | ITincoherent_prag -- instance overlap mode | ITctype | ITdotdot -- reserved symbols @@ -635,7 +649,7 @@ data Token -- facilitates using a keyword in two different extensions that can be -- activated independently) -- -reservedWordsFM :: UniqFM (Token, Int) +reservedWordsFM :: UniqFM (Token, ExtsBitmap) reservedWordsFM = listToUFM $ map (\(x, y, z) -> (mkFastString x, (y, z))) [( "_", ITunderscore, 0 ), @@ -664,34 +678,34 @@ reservedWordsFM = listToUFM $ ( "type", ITtype, 0 ), ( "where", ITwhere, 0 ), - ( "forall", ITforall, bit explicitForallBit .|. - bit inRulePragBit), - ( "mdo", ITmdo, bit recursiveDoBit), + ( "forall", ITforall, xbit ExplicitForallBit .|. + xbit InRulePragBit), + ( "mdo", ITmdo, xbit RecursiveDoBit), -- See Note [Lexing type pseudo-keywords] ( "family", ITfamily, 0 ), ( "role", ITrole, 0 ), - ( "pattern", ITpattern, bit patternSynonymsBit), - ( "group", ITgroup, bit transformComprehensionsBit), - ( "by", ITby, bit transformComprehensionsBit), - ( "using", ITusing, bit transformComprehensionsBit), - - ( "foreign", ITforeign, bit ffiBit), - ( "export", ITexport, bit ffiBit), - ( "label", ITlabel, bit ffiBit), - ( "dynamic", ITdynamic, bit ffiBit), - ( "safe", ITsafe, bit ffiBit .|. - bit safeHaskellBit), - ( "interruptible", ITinterruptible, bit interruptibleFfiBit), - ( "unsafe", ITunsafe, bit ffiBit), - ( "stdcall", ITstdcallconv, bit ffiBit), - ( "ccall", ITccallconv, bit ffiBit), - ( "capi", ITcapiconv, bit cApiFfiBit), - ( "prim", ITprimcallconv, bit ffiBit), - ( "javascript", ITjavascriptcallconv, bit ffiBit), - - ( "rec", ITrec, bit arrowsBit .|. - bit recursiveDoBit), - ( "proc", ITproc, bit arrowsBit) + ( "pattern", ITpattern, xbit PatternSynonymsBit), + ( "group", ITgroup, xbit TransformComprehensionsBit), + ( "by", ITby, xbit TransformComprehensionsBit), + ( "using", ITusing, xbit TransformComprehensionsBit), + + ( "foreign", ITforeign, xbit FfiBit), + ( "export", ITexport, xbit FfiBit), + ( "label", ITlabel, xbit FfiBit), + ( "dynamic", ITdynamic, xbit FfiBit), + ( "safe", ITsafe, xbit FfiBit .|. + xbit SafeHaskellBit), + ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), + ( "unsafe", ITunsafe, xbit FfiBit), + ( "stdcall", ITstdcallconv, xbit FfiBit), + ( "ccall", ITccallconv, xbit FfiBit), + ( "capi", ITcapiconv, xbit CApiFfiBit), + ( "prim", ITprimcallconv, xbit FfiBit), + ( "javascript", ITjavascriptcallconv, xbit FfiBit), + + ( "rec", ITrec, xbit ArrowsBit .|. + xbit RecursiveDoBit), + ( "proc", ITproc, xbit ArrowsBit) ] {----------------------------------- @@ -711,7 +725,7 @@ Also, note that these are included in the `varid` production in the parser -- a key detail to make all this work. -------------------------------------} -reservedSymsFM :: UniqFM (Token, Int -> Bool) +reservedSymsFM :: UniqFM (Token, ExtsBitmap -> Bool) reservedSymsFM = listToUFM $ map (\ (x,y,z) -> (mkFastString x,(y,z))) [ ("..", ITdotdot, always) @@ -822,11 +836,11 @@ nextCharIs buf p = not (atEnd buf) && p (currentChar buf) nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool nextCharIsNot buf p = not (nextCharIs buf p) -notFollowedBy :: Char -> AlexAccPred Int +notFollowedBy :: Char -> AlexAccPred ExtsBitmap notFollowedBy char _ _ _ (AI _ buf) = nextCharIsNot buf (== char) -notFollowedBySymbol :: AlexAccPred Int +notFollowedBySymbol :: AlexAccPred ExtsBitmap notFollowedBySymbol _ _ _ (AI _ buf) = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") @@ -835,7 +849,7 @@ notFollowedBySymbol _ _ _ (AI _ buf) -- maximal munch, but not always, because the nested comment rule is -- valid in all states, but the doc-comment rules are only valid in -- the non-layout states. -isNormalComment :: AlexAccPred Int +isNormalComment :: AlexAccPred ExtsBitmap isNormalComment bits _ _ (AI _ buf) | haddockEnabled bits = notFollowedByDocOrPragma | otherwise = nextCharIsNot buf (== '#') @@ -849,10 +863,10 @@ afterOptionalSpace buf p then p (snd (nextChar buf)) else p buf -atEOL :: AlexAccPred Int +atEOL :: AlexAccPred ExtsBitmap atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' -ifExtension :: (Int -> Bool) -> AlexAccPred Int +ifExtension :: (ExtsBitmap -> Bool) -> AlexAccPred ExtsBitmap ifExtension pred bits _ _ _ = pred bits multiline_doc_comment :: Action @@ -954,12 +968,12 @@ withLexedDocType lexDocComment = do -- off again at the end of the pragma. rulePrag :: Action rulePrag span _buf _len = do - setExts (.|. bit inRulePragBit) + setExts (.|. xbit InRulePragBit) return (L span ITrules_prag) endPrag :: Action endPrag span _buf _len = do - setExts (.&. complement (bit inRulePragBit)) + setExts (.&. complement (xbit InRulePragBit)) return (L span ITclose_prag) -- docCommentEnd @@ -1112,6 +1126,7 @@ positive = id negative = negate decimal, octal, hexadecimal :: (Integer, Char -> Int) decimal = (10,octDecDigit) +binary = (2,octDecDigit) octal = (8,octDecDigit) hexadecimal = (16,hexDigit) @@ -1410,6 +1425,7 @@ lex_escape = do 'x' -> readNum is_hexdigit 16 hexDigit 'o' -> readNum is_octdigit 8 octDecDigit + 'b' -> readNum is_bindigit 2 octDecDigit x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) c1 -> do @@ -1592,7 +1608,7 @@ data PState = PState { last_loc :: RealSrcSpan, -- pos of previous token last_len :: !Int, -- len of previous token loc :: RealSrcLoc, -- current loc (end of prev token + 1) - extsBitmap :: !Int, -- bitmap that determines permitted + extsBitmap :: !ExtsBitmap, -- bitmap that determines permitted -- extensions context :: [LayoutContext], lex_state :: [Int], @@ -1669,13 +1685,13 @@ withThisPackage f = do pkg <- liftM thisPackage getDynFlags return $ f pkg -extension :: (Int -> Bool) -> P Bool +extension :: (ExtsBitmap -> Bool) -> P Bool extension p = P $ \s -> POk s (p $! extsBitmap s) -getExts :: P Int +getExts :: P ExtsBitmap getExts = P $ \s -> POk s (extsBitmap s) -setExts :: (Int -> Int) -> P () +setExts :: (ExtsBitmap -> ExtsBitmap) -> P () setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () setSrcLoc :: RealSrcLoc -> P () @@ -1855,130 +1871,110 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- for reasons of efficiency, flags indicating language extensions (eg, -- -fglasgow-exts or -XParallelArrays) are represented by a bitmap --- stored in an unboxed Int - -ffiBit :: Int -ffiBit= 0 -interruptibleFfiBit :: Int -interruptibleFfiBit = 1 -cApiFfiBit :: Int -cApiFfiBit = 2 -parrBit :: Int -parrBit = 3 -arrowsBit :: Int -arrowsBit = 4 -thBit :: Int -thBit = 5 -ipBit :: Int -ipBit = 6 -explicitForallBit :: Int -explicitForallBit = 7 -- the 'forall' keyword and '.' symbol -bangPatBit :: Int -bangPatBit = 8 -- Tells the parser to understand bang-patterns - -- (doesn't affect the lexer) -patternSynonymsBit :: Int -patternSynonymsBit = 9 -- pattern synonyms -haddockBit :: Int -haddockBit = 10 -- Lex and parse Haddock comments -magicHashBit :: Int -magicHashBit = 11 -- "#" in both functions and operators -kindSigsBit :: Int -kindSigsBit = 12 -- Kind signatures on type variables -recursiveDoBit :: Int -recursiveDoBit = 13 -- mdo -unicodeSyntaxBit :: Int -unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc -unboxedTuplesBit :: Int -unboxedTuplesBit = 15 -- (# and #) -datatypeContextsBit :: Int -datatypeContextsBit = 16 -transformComprehensionsBit :: Int -transformComprehensionsBit = 17 -qqBit :: Int -qqBit = 18 -- enable quasiquoting -inRulePragBit :: Int -inRulePragBit = 19 -rawTokenStreamBit :: Int -rawTokenStreamBit = 20 -- producing a token stream with all comments included -sccProfilingOnBit :: Int -sccProfilingOnBit = 21 -hpcBit :: Int -hpcBit = 22 -alternativeLayoutRuleBit :: Int -alternativeLayoutRuleBit = 23 -relaxedLayoutBit :: Int -relaxedLayoutBit = 24 -nondecreasingIndentationBit :: Int -nondecreasingIndentationBit = 25 -safeHaskellBit :: Int -safeHaskellBit = 26 -traditionalRecordSyntaxBit :: Int -traditionalRecordSyntaxBit = 27 -typeLiteralsBit :: Int -typeLiteralsBit = 28 -explicitNamespacesBit :: Int -explicitNamespacesBit = 29 -lambdaCaseBit :: Int -lambdaCaseBit = 30 -negativeLiteralsBit :: Int -negativeLiteralsBit = 31 - - -always :: Int -> Bool +-- stored in an unboxed Word64 +type ExtsBitmap = Word64 + +xbit :: ExtBits -> ExtsBitmap +xbit = bit . fromEnum + +xtest :: ExtBits -> ExtsBitmap -> Bool +xtest ext xmap = testBit xmap (fromEnum ext) + +data ExtBits + = FfiBit + | InterruptibleFfiBit + | CApiFfiBit + | ParrBit + | ArrowsBit + | ThBit + | IpBit + | ExplicitForallBit -- the 'forall' keyword and '.' symbol + | BangPatBit -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) + | PatternSynonymsBit -- pattern synonyms + | HaddockBit-- Lex and parse Haddock comments + | MagicHashBit -- "#" in both functions and operators + | KindSigsBit -- Kind signatures on type variables + | RecursiveDoBit -- mdo + | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc + | UnboxedTuplesBit -- (# and #) + | DatatypeContextsBit + | TransformComprehensionsBit + | QqBit -- enable quasiquoting + | InRulePragBit + | RawTokenStreamBit -- producing a token stream with all comments included + | SccProfilingOnBit + | HpcBit + | AlternativeLayoutRuleBit + | RelaxedLayoutBit + | NondecreasingIndentationBit + | SafeHaskellBit + | TraditionalRecordSyntaxBit + | TypeLiteralsBit + | ExplicitNamespacesBit + | LambdaCaseBit + | BinaryLiteralsBit + | NegativeLiteralsBit + deriving Enum + + +always :: ExtsBitmap -> Bool always _ = True -parrEnabled :: Int -> Bool -parrEnabled flags = testBit flags parrBit -arrowsEnabled :: Int -> Bool -arrowsEnabled flags = testBit flags arrowsBit -thEnabled :: Int -> Bool -thEnabled flags = testBit flags thBit -ipEnabled :: Int -> Bool -ipEnabled flags = testBit flags ipBit -explicitForallEnabled :: Int -> Bool -explicitForallEnabled flags = testBit flags explicitForallBit -bangPatEnabled :: Int -> Bool -bangPatEnabled flags = testBit flags bangPatBit -haddockEnabled :: Int -> Bool -haddockEnabled flags = testBit flags haddockBit -magicHashEnabled :: Int -> Bool -magicHashEnabled flags = testBit flags magicHashBit --- kindSigsEnabled :: Int -> Bool --- kindSigsEnabled flags = testBit flags kindSigsBit -unicodeSyntaxEnabled :: Int -> Bool -unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit -unboxedTuplesEnabled :: Int -> Bool -unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit -datatypeContextsEnabled :: Int -> Bool -datatypeContextsEnabled flags = testBit flags datatypeContextsBit -qqEnabled :: Int -> Bool -qqEnabled flags = testBit flags qqBit -inRulePrag :: Int -> Bool -inRulePrag flags = testBit flags inRulePragBit -rawTokenStreamEnabled :: Int -> Bool -rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit -alternativeLayoutRule :: Int -> Bool -alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit -hpcEnabled :: Int -> Bool -hpcEnabled flags = testBit flags hpcBit -relaxedLayout :: Int -> Bool -relaxedLayout flags = testBit flags relaxedLayoutBit -nondecreasingIndentation :: Int -> Bool -nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit -sccProfilingOn :: Int -> Bool -sccProfilingOn flags = testBit flags sccProfilingOnBit -traditionalRecordSyntaxEnabled :: Int -> Bool -traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit -typeLiteralsEnabled :: Int -> Bool -typeLiteralsEnabled flags = testBit flags typeLiteralsBit - -explicitNamespacesEnabled :: Int -> Bool -explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit -lambdaCaseEnabled :: Int -> Bool -lambdaCaseEnabled flags = testBit flags lambdaCaseBit -negativeLiteralsEnabled :: Int -> Bool -negativeLiteralsEnabled flags = testBit flags negativeLiteralsBit -patternSynonymsEnabled :: Int -> Bool -patternSynonymsEnabled flags = testBit flags patternSynonymsBit +parrEnabled :: ExtsBitmap -> Bool +parrEnabled = xtest ParrBit +arrowsEnabled :: ExtsBitmap -> Bool +arrowsEnabled = xtest ArrowsBit +thEnabled :: ExtsBitmap -> Bool +thEnabled = xtest ThBit +ipEnabled :: ExtsBitmap -> Bool +ipEnabled = xtest IpBit +explicitForallEnabled :: ExtsBitmap -> Bool +explicitForallEnabled = xtest ExplicitForallBit +bangPatEnabled :: ExtsBitmap -> Bool +bangPatEnabled = xtest BangPatBit +haddockEnabled :: ExtsBitmap -> Bool +haddockEnabled = xtest HaddockBit +magicHashEnabled :: ExtsBitmap -> Bool +magicHashEnabled = xtest MagicHashBit +-- kindSigsEnabled :: ExtsBitmap -> Bool +-- kindSigsEnabled = xtest KindSigsBit +unicodeSyntaxEnabled :: ExtsBitmap -> Bool +unicodeSyntaxEnabled = xtest UnicodeSyntaxBit +unboxedTuplesEnabled :: ExtsBitmap -> Bool +unboxedTuplesEnabled = xtest UnboxedTuplesBit +datatypeContextsEnabled :: ExtsBitmap -> Bool +datatypeContextsEnabled = xtest DatatypeContextsBit +qqEnabled :: ExtsBitmap -> Bool +qqEnabled = xtest QqBit +inRulePrag :: ExtsBitmap -> Bool +inRulePrag = xtest InRulePragBit +rawTokenStreamEnabled :: ExtsBitmap -> Bool +rawTokenStreamEnabled = xtest RawTokenStreamBit +alternativeLayoutRule :: ExtsBitmap -> Bool +alternativeLayoutRule = xtest AlternativeLayoutRuleBit +hpcEnabled :: ExtsBitmap -> Bool +hpcEnabled = xtest HpcBit +relaxedLayout :: ExtsBitmap -> Bool +relaxedLayout = xtest RelaxedLayoutBit +nondecreasingIndentation :: ExtsBitmap -> Bool +nondecreasingIndentation = xtest NondecreasingIndentationBit +sccProfilingOn :: ExtsBitmap -> Bool +sccProfilingOn = xtest SccProfilingOnBit +traditionalRecordSyntaxEnabled :: ExtsBitmap -> Bool +traditionalRecordSyntaxEnabled = xtest TraditionalRecordSyntaxBit +typeLiteralsEnabled :: ExtsBitmap -> Bool +typeLiteralsEnabled = xtest TypeLiteralsBit + +explicitNamespacesEnabled :: ExtsBitmap -> Bool +explicitNamespacesEnabled = xtest ExplicitNamespacesBit +lambdaCaseEnabled :: ExtsBitmap -> Bool +lambdaCaseEnabled = xtest LambdaCaseBit +binaryLiteralsEnabled :: ExtsBitmap -> Bool +binaryLiteralsEnabled = xtest BinaryLiteralsBit +negativeLiteralsEnabled :: ExtsBitmap -> Bool +negativeLiteralsEnabled = xtest NegativeLiteralsBit +patternSynonymsEnabled :: ExtsBitmap -> Bool +patternSynonymsEnabled = xtest PatternSynonymsBit -- PState for parsing options pragmas -- @@ -1999,7 +1995,7 @@ mkPState flags buf loc = last_loc = mkRealSrcSpan loc loc, last_len = 0, loc = loc, - extsBitmap = fromIntegral bitmap, + extsBitmap = bitmap, context = [], lex_state = [bol, 0], srcfiles = [], @@ -2011,41 +2007,42 @@ mkPState flags buf loc = alr_justClosedExplicitLetBlock = False } where - bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags - .|. interruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI flags - .|. cApiFfiBit `setBitIf` xopt Opt_CApiFFI flags - .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags - .|. arrowsBit `setBitIf` xopt Opt_Arrows flags - .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags - .|. haddockBit `setBitIf` gopt Opt_Haddock flags - .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags - .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags - .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags - .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags - .|. rawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags - .|. hpcBit `setBitIf` gopt Opt_Hpc flags - .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags - .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags - .|. sccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags - .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags - .|. safeHaskellBit `setBitIf` safeImportsOn flags - .|. traditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags - .|. typeLiteralsBit `setBitIf` xopt Opt_DataKinds flags - .|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags - .|. lambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags - .|. negativeLiteralsBit `setBitIf` xopt Opt_NegativeLiterals flags - .|. patternSynonymsBit `setBitIf` xopt Opt_PatternSynonyms flags + bitmap = FfiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. InterruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI flags + .|. CApiFfiBit `setBitIf` xopt Opt_CApiFFI flags + .|. ParrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. ArrowsBit `setBitIf` xopt Opt_Arrows flags + .|. ThBit `setBitIf` xopt Opt_TemplateHaskell flags + .|. QqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. IpBit `setBitIf` xopt Opt_ImplicitParams flags + .|. ExplicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. BangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. HaddockBit `setBitIf` gopt Opt_Haddock flags + .|. MagicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. KindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. RecursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. UnicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. UnboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + .|. DatatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags + .|. TransformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags + .|. TransformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags + .|. RawTokenStreamBit `setBitIf` gopt Opt_KeepRawTokenStream flags + .|. HpcBit `setBitIf` gopt Opt_Hpc flags + .|. AlternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags + .|. RelaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + .|. SccProfilingOnBit `setBitIf` gopt Opt_SccProfilingOn flags + .|. NondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags + .|. SafeHaskellBit `setBitIf` safeImportsOn flags + .|. TraditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags + .|. TypeLiteralsBit `setBitIf` xopt Opt_DataKinds flags + .|. ExplicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags + .|. LambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags + .|. BinaryLiteralsBit `setBitIf` xopt Opt_BinaryLiterals flags + .|. NegativeLiteralsBit `setBitIf` xopt Opt_NegativeLiterals flags + .|. PatternSynonymsBit `setBitIf` xopt Opt_PatternSynonyms flags -- - setBitIf :: Int -> Bool -> Int - b `setBitIf` cond | cond = bit b + setBitIf :: ExtBits -> Bool -> ExtsBitmap + b `setBitIf` cond | cond = xbit b | otherwise = 0 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () @@ -2434,6 +2431,9 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("vectorize", token ITvect_prag), ("novectorize", token ITnovect_prag), ("minimal", token ITminimal_prag), + ("no_overlap", token ITno_overlap_prag), + ("overlap", token IToverlap_prag), + ("incoherent", token ITincoherent_prag), ("ctype", token ITctype)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), @@ -2447,7 +2447,7 @@ dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToStr Just found -> found span buf len Nothing -> lexError "unknown pragma" -known_pragma :: Map String Action -> AlexAccPred Int +known_pragma :: Map String Action -> AlexAccPred ExtsBitmap known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) = isKnown && nextCharIsNot curbuf pragmaNameChar where l = lexemeToString startbuf (byteDiff startbuf curbuf) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 4f4ec0b123..a3c68c3e59 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -269,6 +269,9 @@ incorrect. '{-# NOVECTORISE' { L _ ITnovect_prag } '{-# MINIMAL' { L _ ITminimal_prag } '{-# CTYPE' { L _ ITctype } + '{-# NO_OVERLAP' { L _ ITno_overlap_prag } + '{-# OVERLAP' { L _ IToverlap_prag } + '{-# INCOHERENT' { L _ ITincoherent_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -654,12 +657,13 @@ ty_decl :: { LTyClDecl RdrName } {% mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) } inst_decl :: { LInstDecl RdrName } - : 'instance' inst_type where_inst - { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $3) in - let cid = ClsInstDecl { cid_poly_ty = $2, cid_binds = binds + : 'instance' overlap_pragma inst_type where_inst + { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $4) in + let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = $2 , cid_datafam_insts = adts } - in L (comb3 $1 $2 $3) (ClsInstD { cid_inst = cid }) } + in L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }) } -- type instance declarations | 'type' 'instance' ty_fam_inst_eqn @@ -677,6 +681,13 @@ inst_decl :: { LInstDecl RdrName } {% mkDataFamInst (comb4 $1 $4 $6 $7) (unLoc $1) $3 $4 (unLoc $5) (unLoc $6) (unLoc $7) } +overlap_pragma :: { Maybe OverlapMode } + : '{-# OVERLAP' '#-}' { Just OverlapOk } + | '{-# INCOHERENT' '#-}' { Just Incoherent } + | '{-# NO_OVERLAP' '#-}' { Just NoOverlap } + | {- empty -} { Nothing } + + -- Closed type families where_type_family :: { Located (FamilyInfo RdrName) } @@ -783,7 +794,7 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTR -- Glasgow extension: stand-alone deriving declarations stand_alone_deriving :: { LDerivDecl RdrName } - : 'deriving' 'instance' inst_type { LL (DerivDecl $3) } + : 'deriving' 'instance' overlap_pragma inst_type { LL (DerivDecl $4 $3) } ----------------------------------------------------------------------------- -- Role annotations diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y deleted file mode 100644 index 4e7f48c6fc..0000000000 --- a/compiler/parser/ParserCore.y +++ /dev/null @@ -1,397 +0,0 @@ -{ -{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 -{-# OPTIONS -Wwarn -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -module ParserCore ( parseCore ) where - -import IfaceSyn -import ForeignCall -import RdrHsSyn -import HsSyn hiding (toHsType, toHsKind) -import RdrName -import OccName -import TypeRep ( TyThing(..) ) -import Type ( Kind, - liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - mkTyConApp - ) -import Kind( mkArrowKind ) -import Name( Name, nameOccName, nameModule, mkExternalName, wiredInNameTyThing_maybe ) -import Module -import ParserCoreUtils -import LexCore -import Literal -import SrcLoc -import PrelNames -import TysPrim -import TyCon ( TyCon, tyConName ) -import FastString -import Outputable -import Data.Char -import Unique - -#include "../HsVersions.h" - -} - -%name parseCore -%expect 0 -%tokentype { Token } - -%token - '%module' { TKmodule } - '%data' { TKdata } - '%newtype' { TKnewtype } - '%forall' { TKforall } - '%rec' { TKrec } - '%let' { TKlet } - '%in' { TKin } - '%case' { TKcase } - '%of' { TKof } - '%cast' { TKcast } - '%note' { TKnote } - '%external' { TKexternal } - '%local' { TKlocal } - '%_' { TKwild } - '(' { TKoparen } - ')' { TKcparen } - '{' { TKobrace } - '}' { TKcbrace } - '#' { TKhash} - '=' { TKeq } - ':' { TKcolon } - '::' { TKcoloncolon } - ':=:' { TKcoloneqcolon } - '*' { TKstar } - '->' { TKrarrow } - '\\' { TKlambda} - '@' { TKat } - '.' { TKdot } - '?' { TKquestion} - ';' { TKsemicolon } - NAME { TKname $$ } - CNAME { TKcname $$ } - INTEGER { TKinteger $$ } - RATIONAL { TKrational $$ } - STRING { TKstring $$ } - CHAR { TKchar $$ } - -%monad { P } { thenP } { returnP } -%lexer { lexer } { TKEOF } - -%% - -module :: { HsExtCore RdrName } - -- : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 } - : '%module' modid tdefs vdefgs { HsExtCore $2 [] [] } - - -------------------------------------------------------------- --- Names: the trickiest bit in here - --- A name of the form A.B.C could be: --- module A.B.C --- dcon C in module A.B --- tcon C in module A.B -modid :: { Module } - : NAME ':' mparts { undefined } - -q_dc_name :: { Name } - : NAME ':' mparts { undefined } - -q_tc_name :: { Name } - : NAME ':' mparts { undefined } - -q_var_occ :: { Name } - : NAME ':' vparts { undefined } - -mparts :: { [String] } - : CNAME { [$1] } - | CNAME '.' mparts { $1:$3 } - -vparts :: { [String] } - : var_occ { [$1] } - | CNAME '.' vparts { $1:$3 } - -------------------------------------------------------------- --- Type and newtype declarations are in HsSyn syntax - -tdefs :: { [TyClDecl RdrName] } - : {- empty -} {[]} - | tdef tdefs {$1:$2} - -tdef :: { TyClDecl RdrName } - : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';' - { DataDecl { tcdLName = noLoc (ifaceExtRdrName $2) - , tcdTyVars = mkHsQTvs (map toHsTvBndr $3) - , tcdDataDefn = HsDataDefn { dd_ND = DataType, dd_ctxt = noLoc [] - , dd_kindSig = Nothing - , dd_cons = $6, dd_derivs = Nothing } } } - | '%newtype' q_tc_name tv_bndrs trep ';' - { let tc_rdr = ifaceExtRdrName $2 in - DataDecl { tcdLName = noLoc tc_rdr - , tcdTyVars = mkHsQTvs (map toHsTvBndr $3) - , tcdDataDefn = HsDataDefn { dd_ND = NewType, dd_ctxt = noLoc [] - , dd_kindSig = Nothing - , dd_cons = $4 (rdrNameOcc tc_rdr), dd_derivs = Nothing } } } - --- For a newtype we have to invent a fake data constructor name --- It doesn't matter what it is, because it won't be used -trep :: { OccName -> [LConDecl RdrName] } - : {- empty -} { (\ tc_occ -> []) } - | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ; - con_info = PrefixCon [toHsType $2] } - in [noLoc $ mkSimpleConDecl (noLoc dc_name) [] - (noLoc []) con_info]) } - -cons :: { [LConDecl RdrName] } - : {- empty -} { [] } -- 20060420 Empty data types allowed. jds - | con { [$1] } - | con ';' cons { $1:$3 } - -con :: { LConDecl RdrName } - : d_pat_occ attv_bndrs hs_atys - { noLoc $ mkSimpleConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3) } --- ToDo: parse record-style declarations - -attv_bndrs :: { [LHsTyVarBndr RdrName] } - : {- empty -} { [] } - | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 } - -hs_atys :: { [LHsType RdrName] } - : atys { map toHsType $1 } - - ---------------------------------------- --- Types ---------------------------------------- - -atys :: { [IfaceType] } - : {- empty -} { [] } - | aty atys { $1:$2 } - -aty :: { IfaceType } - : fs_var_occ { IfaceTyVar $1 } - | q_tc_name { IfaceTyConApp (IfaceTc $1) [] } - | '(' ty ')' { $2 } - -bty :: { IfaceType } - : fs_var_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 } - | q_var_occ atys { undefined } - | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 } - | '(' ty ')' { $2 } - -ty :: { IfaceType } - : bty { $1 } - | bty '->' ty { IfaceFunTy $1 $3 } - | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 } - ----------------------------------------------- --- Bindings are in Iface syntax - -vdefgs :: { [IfaceBinding] } - : {- empty -} { [] } - | let_bind ';' vdefgs { $1 : $3 } - -let_bind :: { IfaceBinding } - : '%rec' '{' vdefs1 '}' { IfaceRec $3 } -- Can be empty. Do we care? - | vdef { let (b,r) = $1 - in IfaceNonRec b r } - -vdefs1 :: { [(IfaceLetBndr, IfaceExpr)] } - : vdef { [$1] } - | vdef ';' vdefs1 { $1:$3 } - -vdef :: { (IfaceLetBndr, IfaceExpr) } - : fs_var_occ '::' ty '=' exp { (IfLetBndr $1 $3 NoInfo, $5) } - | '%local' vdef { $2 } - - -- NB: qd_occ includes data constructors, because - -- we allow data-constructor wrappers at top level - -- But we discard the module name, because it must be the - -- same as the module being compiled, and Iface syntax only - -- has OccNames in binding positions. Ah, but it has Names now! - ---------------------------------------- --- Binders -bndr :: { IfaceBndr } - : '@' tv_bndr { IfaceTvBndr $2 } - | id_bndr { IfaceIdBndr $1 } - -bndrs :: { [IfaceBndr] } - : bndr { [$1] } - | bndr bndrs { $1:$2 } - -id_bndr :: { IfaceIdBndr } - : '(' fs_var_occ '::' ty ')' { ($2,$4) } - -tv_bndr :: { IfaceTvBndr } - : fs_var_occ { ($1, ifaceLiftedTypeKind) } - | '(' fs_var_occ '::' akind ')' { ($2, $4) } - -tv_bndrs :: { [IfaceTvBndr] } - : {- empty -} { [] } - | tv_bndr tv_bndrs { $1:$2 } - -akind :: { IfaceKind } - : '*' { ifaceLiftedTypeKind } - | '#' { ifaceUnliftedTypeKind } - | '?' { ifaceOpenTypeKind } - | '(' kind ')' { $2 } - -kind :: { IfaceKind } - : akind { $1 } - | akind '->' kind { ifaceArrow $1 $3 } - ------------------------------------------ --- Expressions - -aexp :: { IfaceExpr } - : fs_var_occ { IfaceLcl $1 } - | q_var_occ { IfaceExt $1 } - | q_dc_name { IfaceExt $1 } - | lit { IfaceLit $1 } - | '(' exp ')' { $2 } - -fexp :: { IfaceExpr } - : fexp aexp { IfaceApp $1 $2 } - | fexp '@' aty { IfaceApp $1 (IfaceType $3) } - | aexp { $1 } - -exp :: { IfaceExpr } - : fexp { $1 } - | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 } - | '%let' let_bind '%in' exp { IfaceLet $2 $4 } --- gaw 2004 - | '%case' '(' ty ')' aexp '%of' id_bndr - '{' alts1 '}' { IfaceCase $5 (fst $7) $9 } --- The following line is broken and is hard to fix. Not fixing now --- because this whole parser is bitrotten anyway. --- Richard Eisenberg, July 2013 --- | '%cast' aexp aty { IfaceCast $2 $3 } --- No InlineMe any more --- | '%note' STRING exp --- { case $2 of --- --"SCC" -> IfaceNote (IfaceSCC "scc") $3 --- "InlineMe" -> IfaceNote IfaceInlineMe $3 --- } - | '%external' STRING aty { IfaceFCall (ForeignCall.CCall - (CCallSpec (StaticTarget (mkFastString $2) Nothing True) - CCallConv PlaySafe)) - $3 } - -alts1 :: { [IfaceAlt] } - : alt { [$1] } - | alt ';' alts1 { $1:$3 } - -alt :: { IfaceAlt } - : q_dc_name bndrs '->' exp - { (IfaceDataAlt $1, map ifaceBndrName $2, $4) } - -- The external syntax currently includes the types of the - -- the args, but they aren't needed internally - -- Nor is the module qualifier - | q_dc_name '->' exp - { (IfaceDataAlt $1, [], $3) } - | lit '->' exp - { (IfaceLitAlt $1, [], $3) } - | '%_' '->' exp - { (IfaceDefault, [], $3) } - -lit :: { Literal } - : '(' INTEGER '::' aty ')' { convIntLit $2 $4 } - | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 } - | '(' CHAR '::' aty ')' { MachChar $2 } - | '(' STRING '::' aty ')' { MachStr (fastStringToByteString (mkFastString $2)) } - -fs_var_occ :: { FastString } - : NAME { mkFastString $1 } - -var_occ :: { String } - : NAME { $1 } - - --- Data constructor in a pattern or data type declaration; use the dataName, --- because that's what we expect in Core case patterns -d_pat_occ :: { OccName } - : CNAME { mkOccName dataName $1 } - -{ - -ifaceKind kc = IfaceTyConApp kc [] - -ifaceBndrName (IfaceIdBndr (n,_)) = n -ifaceBndrName (IfaceTvBndr (n,_)) = n - -convIntLit :: Integer -> IfaceType -> Literal -convIntLit i (IfaceTyConApp tc []) - | tc `eqTc` intPrimTyCon = MachInt i - | tc `eqTc` wordPrimTyCon = MachWord i - | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i)) - | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr -convIntLit i aty - = pprPanic "Unknown integer literal type" (ppr aty) - -convRatLit :: Rational -> IfaceType -> Literal -convRatLit r (IfaceTyConApp tc []) - | tc `eqTc` floatPrimTyCon = MachFloat r - | tc `eqTc` doublePrimTyCon = MachDouble r -convRatLit i aty - = pprPanic "Unknown rational literal type" (ppr aty) - -eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh! -eqTc (IfaceTc name) tycon = name == tyConName tycon - --- Tiresomely, we have to generate both HsTypes (in type/class decls) --- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes, --- and convert to HsTypes here. But the IfaceTypes we can see here --- are very limited (see the productions for 'ty'), so the translation --- isn't hard -toHsType :: IfaceType -> LHsType RdrName -toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS v)) -toHsType (IfaceAppTy t1 t2) = noLoc $ HsAppTy (toHsType t1) (toHsType t2) -toHsType (IfaceFunTy t1 t2) = noLoc $ HsFunTy (toHsType t1) (toHsType t2) -toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) -toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t) - --- Only a limited form of kind will be encountered... hopefully -toHsKind :: IfaceKind -> LHsKind RdrName --- IA0_NOTE: Shouldn't we add kind variables? -toHsKind (IfaceFunTy ifK1 ifK2) = noLoc $ HsFunTy (toHsKind ifK1) (toHsKind ifK2) -toHsKind (IfaceTyConApp ifKc []) = noLoc $ HsTyVar (nameRdrName (tyConName (toKindTc ifKc))) -toHsKind other = pprPanic "toHsKind" (ppr other) - -toKindTc :: IfaceTyCon -> TyCon -toKindTc (IfaceTc n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n = tc -toKindTc other = pprPanic "toKindTc" (ppr other) - -ifaceTcType ifTc = IfaceTyConApp ifTc [] - -ifaceLiftedTypeKind = ifaceTcType (IfaceTc liftedTypeKindTyConName) -ifaceOpenTypeKind = ifaceTcType (IfaceTc openTypeKindTyConName) -ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName) - -ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 - -toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig - where - bsig = toHsKind k - -ifaceExtRdrName :: Name -> RdrName -ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name) -ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) - -add_forall tv (L _ (HsForAllTy exp tvs cxt t)) - = noLoc $ HsForAllTy exp (mkHsQTvs (tv : hsQTvBndrs tvs)) cxt t -add_forall tv t - = noLoc $ HsForAllTy Explicit (mkHsQTvs [tv]) (noLoc []) t - -happyError :: P a -happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l -} - diff --git a/compiler/parser/ParserCoreUtils.hs b/compiler/parser/ParserCoreUtils.hs deleted file mode 100644 index 8f67d96239..0000000000 --- a/compiler/parser/ParserCoreUtils.hs +++ /dev/null @@ -1,77 +0,0 @@ -module ParserCoreUtils where - -import Exception -import System.IO - -data ParseResult a = OkP a | FailP String -type P a = String -> Int -> ParseResult a - -thenP :: P a -> (a -> P b) -> P b -m `thenP` k = \ s l -> - case m s l of - OkP a -> k a s l - FailP s -> FailP s - -returnP :: a -> P a -returnP m _ _ = OkP m - -failP :: String -> P a -failP s s' _ = FailP (s ++ ":" ++ s') - -getCoreModuleName :: FilePath -> IO String -getCoreModuleName fpath = - catchIO (do - h <- openFile fpath ReadMode - ls <- hGetContents h - let mo = findMod (words ls) - -- make sure we close up the file right away. - (length mo) `seq` return () - hClose h - return mo) - (\ _ -> return "Main") - where - findMod [] = "Main" - -- TODO: this should just return the module name, without the package name - findMod ("%module":m:_) = m - findMod (_:xs) = findMod xs - - -data Token = - TKmodule - | TKdata - | TKnewtype - | TKforall - | TKrec - | TKlet - | TKin - | TKcase - | TKof - | TKcast - | TKnote - | TKexternal - | TKlocal - | TKwild - | TKoparen - | TKcparen - | TKobrace - | TKcbrace - | TKhash - | TKeq - | TKcolon - | TKcoloncolon - | TKcoloneqcolon - | TKstar - | TKrarrow - | TKlambda - | TKat - | TKdot - | TKquestion - | TKsemicolon - | TKname String - | TKcname String - | TKinteger Integer - | TKrational Rational - | TKstring String - | TKchar Char - | TKEOF - diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 03ec622223..93a98d068e 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -4,6 +4,8 @@ o% Functions over HsSyn specialised to RdrName. \begin{code} +{-# LANGUAGE CPP #-} + module RdrHsSyn ( mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, @@ -32,6 +34,7 @@ module RdrHsSyn ( mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkSimpleConDecl, mkDeprecatedGadtRecordDecl, + mkATDefault, -- Bunch of functions in the parser monad for -- checking and constructing values @@ -71,7 +74,7 @@ import TysWiredIn ( unitTyCon, unitDataCon ) import ForeignCall import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) -import PrelNames ( forall_tv_RDR ) +import PrelNames ( forall_tv_RDR, allNameStrings ) import DynFlags import SrcLoc import OrdList ( OrdList, fromOL ) @@ -122,16 +125,31 @@ mkClassDecl :: SrcSpan -> P (LTyClDecl RdrName) mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls - = do { let (binds, sigs, ats, at_defs, _, docs) = cvBindsAndSigs (unLoc where_cls) + = do { let (binds, sigs, ats, at_insts, _, docs) = cvBindsAndSigs (unLoc where_cls) cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams) <- checkTyClHdr tycl_hdr - ; tyvars <- checkTyVars (ptext (sLit "class")) whereDots - cls tparams -- Only type vars allowed + ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams + ; at_defs <- mapM (eitherToP . mkATDefault) at_insts ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars, tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds, tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs, tcdFVs = placeHolderNames })) } +mkATDefault :: LTyFamInstDecl RdrName + -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName) +-- Take a type-family instance declaration and turn it into +-- a type-family default equation for a class declaration +-- We parse things as the former and use this function to convert to the latter +-- +-- We use the Either monad because this also called +-- from Convert.hs +mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) + | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e + = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats) + ; return (L loc (TyFamEqn { tfe_tycon = tc + , tfe_pats = tvs + , tfe_rhs = rhs })) } + mkTyData :: SrcSpan -> NewOrData -> Maybe CType @@ -142,7 +160,7 @@ mkTyData :: SrcSpan -> P (LTyClDecl RdrName) mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr - ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams + ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, tcdDataDefn = defn, @@ -170,7 +188,7 @@ mkTySynonym :: SrcSpan -> P (LTyClDecl RdrName) mkTySynonym loc lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs - ; tyvars <- checkTyVars (ptext (sLit "type")) equalsDots tc tparams + ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars , tcdRhs = rhs, tcdFVs = placeHolderNames })) } @@ -179,9 +197,9 @@ mkTyFamInstEqn :: LHsType RdrName -> P (TyFamInstEqn RdrName) mkTyFamInstEqn lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs - ; return (TyFamInstEqn { tfie_tycon = tc - , tfie_pats = mkHsWithBndrs tparams - , tfie_rhs = rhs }) } + ; return (TyFamEqn { tfe_tycon = tc + , tfe_pats = mkHsWithBndrs tparams + , tfe_rhs = rhs }) } mkDataFamInst :: SrcSpan -> NewOrData @@ -212,7 +230,7 @@ mkFamDecl :: SrcSpan -> P (LTyClDecl RdrName) mkFamDecl loc info lhs ksig = do { (tc, tparams) <- checkTyClHdr lhs - ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams + ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc , fdTyVars = tyvars, fdKindSig = ksig }))) } where @@ -500,26 +518,42 @@ we can bring x,y into scope. So: * For RecCon we do not \begin{code} -checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName) +checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName) +-- Same as checkTyVars, but in the P monad +checkTyVarsP pp_what equals_or_where tc tparms + = eitherToP $ checkTyVars pp_what equals_or_where tc tparms + +eitherToP :: Either (SrcSpan, SDoc) a -> P a +-- Adapts the Either monad to the P monad +eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc +eitherToP (Right thing) = return thing +checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] + -> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName) -- Check whether the given list of type parameters are all type variables --- (possibly with a kind signature). -checkTyVars pp_what equals_or_where tc tparms = do { tvs <- mapM chk tparms - ; return (mkHsQTvs tvs) } +-- (possibly with a kind signature) +-- We use the Either monad because it's also called (via mkATDefault) from +-- Convert.hs +checkTyVars pp_what equals_or_where tc tparms + = do { tvs <- mapM chk tparms + ; return (mkHsQTvs tvs) } where + -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) | isRdrTyVar tv = return (L l (KindedTyVar tv k)) chk (L l (HsTyVar tv)) | isRdrTyVar tv = return (L l (UserTyVar tv)) - chk t@(L l _) - = parseErrorSDoc l $ - vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t) - , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc) - , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form")) - , nest 2 (pp_what <+> ppr tc <+> ptext (sLit "a b c") - <+> equals_or_where) ] ] + chk t@(L loc _) + = Left (loc, + vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t) + , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc) + , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form")) + , nest 2 (pp_what <+> ppr tc + <+> hsep (map text (takeList tparms allNameStrings)) + <+> equals_or_where) ] ]) whereDots, equalsDots :: SDoc +-- Second argument to checkTyVars whereDots = ptext (sLit "where ...") equalsDots = ptext (sLit "= ...") @@ -666,7 +700,7 @@ checkAPat msg loc e0 = do ExplicitTuple es b | all tupArgPresent es -> do ps <- mapM (checkLPat msg) [e | Present e <- es] - return (TuplePat ps b placeHolderType) + return (TuplePat ps b []) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) RecordCon c _ (HsRecFields fs dd) |