haskell-src 1.0.1.5 → 1.0.1.6
raw patch · 8 files changed
+1580/−1578 lines, 8 filesdep ~arraydep ~basedep ~prettyPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: array, base, pretty, syb
API changes (from Hackage documentation)
- Language.Haskell.Syntax: prelude_mod, main_mod :: Module
- Language.Haskell.Syntax: unit_tycon, list_tycon, fun_tycon :: HsType
- Language.Haskell.Syntax: unit_tycon_name, list_tycon_name, fun_tycon_name :: HsQName
+ Language.Haskell.Syntax: fun_tycon :: HsType
+ Language.Haskell.Syntax: fun_tycon_name :: HsQName
+ Language.Haskell.Syntax: list_tycon :: HsType
+ Language.Haskell.Syntax: list_tycon_name :: HsQName
+ Language.Haskell.Syntax: main_mod :: Module
+ Language.Haskell.Syntax: prelude_mod :: Module
+ Language.Haskell.Syntax: unit_tycon :: HsType
+ Language.Haskell.Syntax: unit_tycon_name :: HsQName
Files
- Language/Haskell/Lexer.hs +348/−348
- Language/Haskell/ParseMonad.hs +70/−70
- Language/Haskell/ParseUtils.hs +141/−141
- Language/Haskell/Parser.ly +417/−417
- Language/Haskell/Pretty.hs +361/−361
- Language/Haskell/Syntax.hs +171/−171
- dist/build/Language/Haskell/Parser.hs +70/−69
- haskell-src.cabal +2/−1
Language/Haskell/Lexer.hs view
@@ -4,7 +4,7 @@ -- Module : Language.Haskell.Lexer -- Copyright : (c) The GHC Team, 1997-2000 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable@@ -21,89 +21,89 @@ import Language.Haskell.ParseMonad -import Data.Char (isAlpha, isLower, isUpper, toLower,- isDigit, isHexDigit, isOctDigit, isSpace,- ord, chr, digitToInt)+import Data.Char (isAlpha, isLower, isUpper, toLower,+ isDigit, isHexDigit, isOctDigit, isSpace,+ ord, chr, digitToInt) import qualified Data.Char (isSymbol) import Data.Ratio data Token = VarId String | QVarId (String,String)- | ConId String+ | ConId String | QConId (String,String) | VarSym String | ConSym String | QVarSym (String,String) | QConSym (String,String)- | IntTok Integer- | FloatTok Rational- | Character Char+ | IntTok Integer+ | FloatTok Rational+ | Character Char | StringTok String -- Symbols - | LeftParen- | RightParen- | SemiColon+ | LeftParen+ | RightParen+ | SemiColon | LeftCurly | RightCurly- | VRightCurly -- a virtual close brace+ | VRightCurly -- a virtual close brace | LeftSquare | RightSquare- | Comma+ | Comma | Underscore | BackQuote -- Reserved operators - | DotDot- | Colon- | DoubleColon- | Equals- | Backslash- | Bar- | LeftArrow- | RightArrow- | At- | Tilde- | DoubleArrow- | Minus- | Exclamation+ | DotDot+ | Colon+ | DoubleColon+ | Equals+ | Backslash+ | Bar+ | LeftArrow+ | RightArrow+ | At+ | Tilde+ | DoubleArrow+ | Minus+ | Exclamation -- Reserved Ids - | KW_Case- | KW_Class- | KW_Data- | KW_Default- | KW_Deriving- | KW_Do- | KW_Else- | KW_Foreign- | KW_If- | KW_Import- | KW_In- | KW_Infix- | KW_InfixL- | KW_InfixR- | KW_Instance- | KW_Let- | KW_Module- | KW_NewType- | KW_Of- | KW_Then- | KW_Type- | KW_Where+ | KW_Case+ | KW_Class+ | KW_Data+ | KW_Default+ | KW_Deriving+ | KW_Do+ | KW_Else+ | KW_Foreign+ | KW_If+ | KW_Import+ | KW_In+ | KW_Infix+ | KW_InfixL+ | KW_InfixR+ | KW_Instance+ | KW_Let+ | KW_Module+ | KW_NewType+ | KW_Of+ | KW_Then+ | KW_Type+ | KW_Where -- Special Ids - | KW_As- | KW_Export- | KW_Hiding- | KW_Qualified- | KW_Safe- | KW_Unsafe+ | KW_As+ | KW_Export+ | KW_Hiding+ | KW_Qualified+ | KW_Safe+ | KW_Unsafe | EOF deriving (Eq,Show)@@ -125,8 +125,8 @@ special_varops :: [(String,Token)] special_varops = [- ( "-", Minus ), --ToDo: shouldn't be here- ( "!", Exclamation ) --ditto+ ( "-", Minus ), --ToDo: shouldn't be here+ ( "!", Exclamation ) --ditto ] reserved_ids :: [(String,Token)]@@ -139,31 +139,31 @@ ( "deriving", KW_Deriving ), ( "do", KW_Do ), ( "else", KW_Else ),- ( "foreign", KW_Foreign ),- ( "if", KW_If ),+ ( "foreign", KW_Foreign ),+ ( "if", KW_If ), ( "import", KW_Import ),- ( "in", KW_In ),- ( "infix", KW_Infix ),- ( "infixl", KW_InfixL ),- ( "infixr", KW_InfixR ),+ ( "in", KW_In ),+ ( "infix", KW_Infix ),+ ( "infixl", KW_InfixL ),+ ( "infixr", KW_InfixR ), ( "instance", KW_Instance ),- ( "let", KW_Let ),- ( "module", KW_Module ),+ ( "let", KW_Let ),+ ( "module", KW_Module ), ( "newtype", KW_NewType ),- ( "of", KW_Of ),- ( "then", KW_Then ),- ( "type", KW_Type ),- ( "where", KW_Where )+ ( "of", KW_Of ),+ ( "then", KW_Then ),+ ( "type", KW_Type ),+ ( "where", KW_Where ) ] special_varids :: [(String,Token)] special_varids = [- ( "as", KW_As ),- ( "export", KW_Export ),- ( "hiding", KW_Hiding ),+ ( "as", KW_As ),+ ( "export", KW_Export ),+ ( "hiding", KW_Hiding ), ( "qualified", KW_Qualified ),- ( "safe", KW_Safe ),- ( "unsafe", KW_Unsafe )+ ( "safe", KW_Safe ),+ ( "unsafe", KW_Unsafe ) ] isIdent, isSymbol :: Char -> Bool@@ -172,8 +172,8 @@ matchChar :: Char -> String -> Lex a () matchChar c msg = do- s <- getInput- if null s || head s /= c then fail msg else discard 1+ s <- getInput+ if null s || head s /= c then fail msg else discard 1 -- The top-level lexer. -- We need to know whether we are at the beginning of the line to decide@@ -181,74 +181,74 @@ lexer :: (Token -> P a) -> P a lexer = runL $ do- bol <- checkBOL- bol <- lexWhiteSpace bol- startToken- if bol then lexBOL else lexToken+ bol <- checkBOL+ bol' <- lexWhiteSpace bol+ startToken+ if bol' then lexBOL else lexToken lexWhiteSpace :: Bool -> Lex a Bool lexWhiteSpace bol = do- s <- getInput- case s of- '{':'-':_ -> do- discard 2- bol <- lexNestedComment bol- lexWhiteSpace bol- '-':'-':rest | all (== '-') (takeWhile isSymbol rest) -> do- lexWhile (== '-')- lexWhile (/= '\n')- s' <- getInput- case s' of- [] -> fail "Unterminated end-of-line comment"- _ -> do- lexNewline- lexWhiteSpace True- '\n':_ -> do- lexNewline- lexWhiteSpace True- '\t':_ -> do- lexTab- lexWhiteSpace bol- c:_ | isSpace c -> do- discard 1- lexWhiteSpace bol- _ -> return bol+ s <- getInput+ case s of+ '{':'-':_ -> do+ discard 2+ bol' <- lexNestedComment bol+ lexWhiteSpace bol'+ '-':'-':rest | all (== '-') (takeWhile isSymbol rest) -> do+ _ <- lexWhile (== '-')+ _ <- lexWhile (/= '\n')+ s' <- getInput+ case s' of+ [] -> fail "Unterminated end-of-line comment"+ _ -> do+ lexNewline+ lexWhiteSpace True+ '\n':_ -> do+ lexNewline+ lexWhiteSpace True+ '\t':_ -> do+ lexTab+ lexWhiteSpace bol+ c:_ | isSpace c -> do+ discard 1+ lexWhiteSpace bol+ _ -> return bol lexNestedComment :: Bool -> Lex a Bool lexNestedComment bol = do- s <- getInput- case s of- '-':'}':_ -> discard 2 >> return bol- '{':'-':_ -> do- discard 2- bol <- lexNestedComment bol -- rest of the subcomment- lexNestedComment bol -- rest of this comment- '\t':_ -> lexTab >> lexNestedComment bol- '\n':_ -> lexNewline >> lexNestedComment True- _:_ -> discard 1 >> lexNestedComment bol- [] -> fail "Unterminated nested comment"+ s <- getInput+ case s of+ '-':'}':_ -> discard 2 >> return bol+ '{':'-':_ -> do+ discard 2+ bol' <- lexNestedComment bol -- rest of the subcomment+ lexNestedComment bol' -- rest of this comment+ '\t':_ -> lexTab >> lexNestedComment bol+ '\n':_ -> lexNewline >> lexNestedComment True+ _:_ -> discard 1 >> lexNestedComment bol+ [] -> fail "Unterminated nested comment" -- When we are lexing the first token of a line, check whether we need to -- insert virtual semicolons or close braces due to layout. lexBOL :: Lex a Token lexBOL = do- pos <- getOffside- case pos of- LT -> do+ pos <- getOffside+ case pos of+ LT -> do -- trace "layout: inserting '}'\n" $- -- Set col to 0, indicating that we're still at the- -- beginning of the line, in case we need a semi-colon too.- -- Also pop the context here, so that we don't insert- -- another close brace before the parser can pop it.- setBOL- popContextL "lexBOL"- return VRightCurly- EQ ->+ -- Set col to 0, indicating that we're still at the+ -- beginning of the line, in case we need a semi-colon too.+ -- Also pop the context here, so that we don't insert+ -- another close brace before the parser can pop it.+ setBOL+ popContextL "lexBOL"+ return VRightCurly+ EQ -> -- trace "layout: inserting ';'\n" $- return SemiColon- GT ->- lexToken+ return SemiColon+ GT ->+ lexToken lexToken :: Lex a Token lexToken = do@@ -256,284 +256,284 @@ case s of [] -> return EOF - '0':c:d:_ | toLower c == 'o' && isOctDigit d -> do- discard 2- n <- lexOctal- return (IntTok n)- | toLower c == 'x' && isHexDigit d -> do- discard 2- n <- lexHexadecimal- return (IntTok n)+ '0':c:d:_ | toLower c == 'o' && isOctDigit d -> do+ discard 2+ n <- lexOctal+ return (IntTok n)+ | toLower c == 'x' && isHexDigit d -> do+ discard 2+ n <- lexHexadecimal+ return (IntTok n) - c:_ | isDigit c -> lexDecimalOrFloat+ c:_ | isDigit c -> lexDecimalOrFloat - | isUpper c -> lexConIdOrQual ""+ | isUpper c -> lexConIdOrQual "" - | isLower c || c == '_' -> do- ident <- lexWhile isIdent- return $ case lookup ident (reserved_ids ++ special_varids) of- Just keyword -> keyword- Nothing -> VarId ident+ | isLower c || c == '_' -> do+ ident <- lexWhile isIdent+ return $ case lookup ident (reserved_ids ++ special_varids) of+ Just keyword -> keyword+ Nothing -> VarId ident - | isSymbol c -> do- sym <- lexWhile isSymbol- return $ case lookup sym (reserved_ops ++ special_varops) of- Just t -> t- Nothing -> case c of- ':' -> ConSym sym- _ -> VarSym sym+ | isSymbol c -> do+ sym <- lexWhile isSymbol+ return $ case lookup sym (reserved_ops ++ special_varops) of+ Just t -> t+ Nothing -> case c of+ ':' -> ConSym sym+ _ -> VarSym sym - | otherwise -> do- discard 1- case c of+ | otherwise -> do+ discard 1+ case c of - -- First the special symbols- '(' -> return LeftParen- ')' -> return RightParen- ',' -> return Comma- ';' -> return SemiColon- '[' -> return LeftSquare- ']' -> return RightSquare- '`' -> return BackQuote- '{' -> do- pushContextL NoLayout- return LeftCurly- '}' -> do- popContextL "lexToken"- return RightCurly+ -- First the special symbols+ '(' -> return LeftParen+ ')' -> return RightParen+ ',' -> return Comma+ ';' -> return SemiColon+ '[' -> return LeftSquare+ ']' -> return RightSquare+ '`' -> return BackQuote+ '{' -> do+ pushContextL NoLayout+ return LeftCurly+ '}' -> do+ popContextL "lexToken"+ return RightCurly - '\'' -> do- c2 <- lexChar- matchChar '\'' "Improperly terminated character constant"- return (Character c2)+ '\'' -> do+ c2 <- lexChar+ matchChar '\'' "Improperly terminated character constant"+ return (Character c2) - '"' -> lexString+ '"' -> lexString - _ -> fail ("Illegal character \'" ++ show c ++ "\'\n")+ _ -> fail ("Illegal character \'" ++ show c ++ "\'\n") lexDecimalOrFloat :: Lex a Token lexDecimalOrFloat = do- ds <- lexWhile isDigit- rest <- getInput- case rest of- ('.':d:_) | isDigit d -> do- discard 1- frac <- lexWhile isDigit- let num = parseInteger 10 (ds ++ frac)- decimals = toInteger (length frac)- exponent <- do- rest2 <- getInput- case rest2 of- 'e':_ -> lexExponent- 'E':_ -> lexExponent- _ -> return 0- return (FloatTok ((num%1) * 10^^(exponent - decimals)))- e:_ | toLower e == 'e' -> do- exponent <- lexExponent- return (FloatTok ((parseInteger 10 ds%1) * 10^^exponent))- _ -> return (IntTok (parseInteger 10 ds))+ ds <- lexWhile isDigit+ rest <- getInput+ case rest of+ ('.':d:_) | isDigit d -> do+ discard 1+ frac <- lexWhile isDigit+ let num = parseInteger 10 (ds ++ frac)+ decimals = toInteger (length frac)+ exponent' <- do+ rest2 <- getInput+ case rest2 of+ 'e':_ -> lexExponent+ 'E':_ -> lexExponent+ _ -> return 0+ return (FloatTok ((num%1) * 10^^(exponent' - decimals)))+ e:_ | toLower e == 'e' -> do+ exponent' <- lexExponent+ return (FloatTok ((parseInteger 10 ds%1) * 10^^exponent'))+ _ -> return (IntTok (parseInteger 10 ds)) where- lexExponent :: Lex a Integer- lexExponent = do- discard 1 -- 'e' or 'E'- r <- getInput- case r of- '+':d:_ | isDigit d -> do- discard 1- lexDecimal- '-':d:_ | isDigit d -> do- discard 1- n <- lexDecimal- return (negate n)- d:_ | isDigit d -> lexDecimal- _ -> fail "Float with missing exponent"+ lexExponent :: Lex a Integer+ lexExponent = do+ discard 1 -- 'e' or 'E'+ r <- getInput+ case r of+ '+':d:_ | isDigit d -> do+ discard 1+ lexDecimal+ '-':d:_ | isDigit d -> do+ discard 1+ n <- lexDecimal+ return (negate n)+ d:_ | isDigit d -> lexDecimal+ _ -> fail "Float with missing exponent" lexConIdOrQual :: String -> Lex a Token lexConIdOrQual qual = do- con <- lexWhile isIdent- let conid | null qual = ConId con- | otherwise = QConId (qual,con)- qual' | null qual = con- | otherwise = qual ++ '.':con- just_a_conid <- alternative (return conid)- rest <- getInput- case rest of- '.':c:_- | isLower c || c == '_' -> do -- qualified varid?- discard 1- ident <- lexWhile isIdent- case lookup ident reserved_ids of- -- cannot qualify a reserved word- Just _ -> just_a_conid- Nothing -> return (QVarId (qual', ident))+ con <- lexWhile isIdent+ let conid | null qual = ConId con+ | otherwise = QConId (qual,con)+ qual' | null qual = con+ | otherwise = qual ++ '.':con+ just_a_conid <- alternative (return conid)+ rest <- getInput+ case rest of+ '.':c:_+ | isLower c || c == '_' -> do -- qualified varid?+ discard 1+ ident <- lexWhile isIdent+ case lookup ident reserved_ids of+ -- cannot qualify a reserved word+ Just _ -> just_a_conid+ Nothing -> return (QVarId (qual', ident)) - | isUpper c -> do -- qualified conid?- discard 1- lexConIdOrQual qual'+ | isUpper c -> do -- qualified conid?+ discard 1+ lexConIdOrQual qual' - | isSymbol c -> do -- qualified symbol?- discard 1- sym <- lexWhile isSymbol- case lookup sym reserved_ops of- -- cannot qualify a reserved operator- Just _ -> just_a_conid- Nothing -> return $ case c of- ':' -> QConSym (qual', sym)- _ -> QVarSym (qual', sym)+ | isSymbol c -> do -- qualified symbol?+ discard 1+ sym <- lexWhile isSymbol+ case lookup sym reserved_ops of+ -- cannot qualify a reserved operator+ Just _ -> just_a_conid+ Nothing -> return $ case c of+ ':' -> QConSym (qual', sym)+ _ -> QVarSym (qual', sym) - _ -> return conid -- not a qualified thing+ _ -> return conid -- not a qualified thing lexChar :: Lex a Char lexChar = do- r <- getInput- case r of- '\\':_ -> lexEscape- c:_ -> discard 1 >> return c- [] -> fail "Incomplete character constant"+ r <- getInput+ case r of+ '\\':_ -> lexEscape+ c:_ -> discard 1 >> return c+ [] -> fail "Incomplete character constant" lexString :: Lex a Token lexString = loop "" where- loop s = do- r <- getInput- case r of- '\\':'&':_ -> do- discard 2- loop s- '\\':c:_ | isSpace c -> do- discard 1- lexWhiteChars- matchChar '\\' "Illegal character in string gap"- loop s- | otherwise -> do- ce <- lexEscape- loop (ce:s)- '"':_ -> do- discard 1- return (StringTok (reverse s))- c:_ -> do- discard 1- loop (c:s)- [] -> fail "Improperly terminated string"+ loop s = do+ r <- getInput+ case r of+ '\\':'&':_ -> do+ discard 2+ loop s+ '\\':c:_ | isSpace c -> do+ discard 1+ lexWhiteChars+ matchChar '\\' "Illegal character in string gap"+ loop s+ | otherwise -> do+ ce <- lexEscape+ loop (ce:s)+ '"':_ -> do+ discard 1+ return (StringTok (reverse s))+ c:_ -> do+ discard 1+ loop (c:s)+ [] -> fail "Improperly terminated string" - lexWhiteChars :: Lex a ()- lexWhiteChars = do- s <- getInput- case s of- '\n':_ -> do- lexNewline- lexWhiteChars- '\t':_ -> do- lexTab- lexWhiteChars- c:_ | isSpace c -> do- discard 1- lexWhiteChars- _ -> return ()+ lexWhiteChars :: Lex a ()+ lexWhiteChars = do+ s <- getInput+ case s of+ '\n':_ -> do+ lexNewline+ lexWhiteChars+ '\t':_ -> do+ lexTab+ lexWhiteChars+ c:_ | isSpace c -> do+ discard 1+ lexWhiteChars+ _ -> return () lexEscape :: Lex a Char lexEscape = do- discard 1- r <- getInput- case r of+ discard 1+ r <- getInput+ case r of -- Production charesc from section B.2 (Note: \& is handled by caller) - 'a':_ -> discard 1 >> return '\a'- 'b':_ -> discard 1 >> return '\b'- 'f':_ -> discard 1 >> return '\f'- 'n':_ -> discard 1 >> return '\n'- 'r':_ -> discard 1 >> return '\r'- 't':_ -> discard 1 >> return '\t'- 'v':_ -> discard 1 >> return '\v'- '\\':_ -> discard 1 >> return '\\'- '"':_ -> discard 1 >> return '\"'- '\'':_ -> discard 1 >> return '\''+ 'a':_ -> discard 1 >> return '\a'+ 'b':_ -> discard 1 >> return '\b'+ 'f':_ -> discard 1 >> return '\f'+ 'n':_ -> discard 1 >> return '\n'+ 'r':_ -> discard 1 >> return '\r'+ 't':_ -> discard 1 >> return '\t'+ 'v':_ -> discard 1 >> return '\v'+ '\\':_ -> discard 1 >> return '\\'+ '"':_ -> discard 1 >> return '\"'+ '\'':_ -> discard 1 >> return '\'' -- Production ascii from section B.2 - '^':c:_ -> discard 2 >> cntrl c- 'N':'U':'L':_ -> discard 3 >> return '\NUL'- 'S':'O':'H':_ -> discard 3 >> return '\SOH'- 'S':'T':'X':_ -> discard 3 >> return '\STX'- 'E':'T':'X':_ -> discard 3 >> return '\ETX'- 'E':'O':'T':_ -> discard 3 >> return '\EOT'- 'E':'N':'Q':_ -> discard 3 >> return '\ENQ'- 'A':'C':'K':_ -> discard 3 >> return '\ACK'- 'B':'E':'L':_ -> discard 3 >> return '\BEL'- 'B':'S':_ -> discard 2 >> return '\BS'- 'H':'T':_ -> discard 2 >> return '\HT'- 'L':'F':_ -> discard 2 >> return '\LF'- 'V':'T':_ -> discard 2 >> return '\VT'- 'F':'F':_ -> discard 2 >> return '\FF'- 'C':'R':_ -> discard 2 >> return '\CR'- 'S':'O':_ -> discard 2 >> return '\SO'- 'S':'I':_ -> discard 2 >> return '\SI'- 'D':'L':'E':_ -> discard 3 >> return '\DLE'- 'D':'C':'1':_ -> discard 3 >> return '\DC1'- 'D':'C':'2':_ -> discard 3 >> return '\DC2'- 'D':'C':'3':_ -> discard 3 >> return '\DC3'- 'D':'C':'4':_ -> discard 3 >> return '\DC4'- 'N':'A':'K':_ -> discard 3 >> return '\NAK'- 'S':'Y':'N':_ -> discard 3 >> return '\SYN'- 'E':'T':'B':_ -> discard 3 >> return '\ETB'- 'C':'A':'N':_ -> discard 3 >> return '\CAN'- 'E':'M':_ -> discard 2 >> return '\EM'- 'S':'U':'B':_ -> discard 3 >> return '\SUB'- 'E':'S':'C':_ -> discard 3 >> return '\ESC'- 'F':'S':_ -> discard 2 >> return '\FS'- 'G':'S':_ -> discard 2 >> return '\GS'- 'R':'S':_ -> discard 2 >> return '\RS'- 'U':'S':_ -> discard 2 >> return '\US'- 'S':'P':_ -> discard 2 >> return '\SP'- 'D':'E':'L':_ -> discard 3 >> return '\DEL'+ '^':c:_ -> discard 2 >> cntrl c+ 'N':'U':'L':_ -> discard 3 >> return '\NUL'+ 'S':'O':'H':_ -> discard 3 >> return '\SOH'+ 'S':'T':'X':_ -> discard 3 >> return '\STX'+ 'E':'T':'X':_ -> discard 3 >> return '\ETX'+ 'E':'O':'T':_ -> discard 3 >> return '\EOT'+ 'E':'N':'Q':_ -> discard 3 >> return '\ENQ'+ 'A':'C':'K':_ -> discard 3 >> return '\ACK'+ 'B':'E':'L':_ -> discard 3 >> return '\BEL'+ 'B':'S':_ -> discard 2 >> return '\BS'+ 'H':'T':_ -> discard 2 >> return '\HT'+ 'L':'F':_ -> discard 2 >> return '\LF'+ 'V':'T':_ -> discard 2 >> return '\VT'+ 'F':'F':_ -> discard 2 >> return '\FF'+ 'C':'R':_ -> discard 2 >> return '\CR'+ 'S':'O':_ -> discard 2 >> return '\SO'+ 'S':'I':_ -> discard 2 >> return '\SI'+ 'D':'L':'E':_ -> discard 3 >> return '\DLE'+ 'D':'C':'1':_ -> discard 3 >> return '\DC1'+ 'D':'C':'2':_ -> discard 3 >> return '\DC2'+ 'D':'C':'3':_ -> discard 3 >> return '\DC3'+ 'D':'C':'4':_ -> discard 3 >> return '\DC4'+ 'N':'A':'K':_ -> discard 3 >> return '\NAK'+ 'S':'Y':'N':_ -> discard 3 >> return '\SYN'+ 'E':'T':'B':_ -> discard 3 >> return '\ETB'+ 'C':'A':'N':_ -> discard 3 >> return '\CAN'+ 'E':'M':_ -> discard 2 >> return '\EM'+ 'S':'U':'B':_ -> discard 3 >> return '\SUB'+ 'E':'S':'C':_ -> discard 3 >> return '\ESC'+ 'F':'S':_ -> discard 2 >> return '\FS'+ 'G':'S':_ -> discard 2 >> return '\GS'+ 'R':'S':_ -> discard 2 >> return '\RS'+ 'U':'S':_ -> discard 2 >> return '\US'+ 'S':'P':_ -> discard 2 >> return '\SP'+ 'D':'E':'L':_ -> discard 3 >> return '\DEL' -- Escaped numbers - 'o':c:_ | isOctDigit c -> do- discard 1- n <- lexOctal- checkChar n- 'x':c:_ | isHexDigit c -> do- discard 1- n <- lexHexadecimal- checkChar n- c:_ | isDigit c -> do- n <- lexDecimal- checkChar n+ 'o':c:_ | isOctDigit c -> do+ discard 1+ n <- lexOctal+ checkChar n+ 'x':c:_ | isHexDigit c -> do+ discard 1+ n <- lexHexadecimal+ checkChar n+ c:_ | isDigit c -> do+ n <- lexDecimal+ checkChar n - _ -> fail "Illegal escape sequence"+ _ -> fail "Illegal escape sequence" where- checkChar n | n <= 0x10FFFF = return (chr (fromInteger n))- checkChar _ = fail "Character constant out of range"+ checkChar n | n <= 0x10FFFF = return (chr (fromInteger n))+ checkChar _ = fail "Character constant out of range" -- Production cntrl from section B.2 - cntrl :: Char -> Lex a Char- cntrl c | c >= '@' && c <= '_' = return (chr (ord c - ord '@'))- cntrl _ = fail "Illegal control character"+ cntrl :: Char -> Lex a Char+ cntrl c | c >= '@' && c <= '_' = return (chr (ord c - ord '@'))+ cntrl _ = fail "Illegal control character" -- assumes at least one octal digit lexOctal :: Lex a Integer lexOctal = do- ds <- lexWhile isOctDigit- return (parseInteger 8 ds)+ ds <- lexWhile isOctDigit+ return (parseInteger 8 ds) -- assumes at least one hexadecimal digit lexHexadecimal :: Lex a Integer lexHexadecimal = do- ds <- lexWhile isHexDigit- return (parseInteger 16 ds)+ ds <- lexWhile isHexDigit+ return (parseInteger 16 ds) -- assumes at least one decimal digit lexDecimal :: Lex a Integer lexDecimal = do- ds <- lexWhile isDigit- return (parseInteger 10 ds)+ ds <- lexWhile isDigit+ return (parseInteger 10 ds) -- Stolen from Hugs's Prelude parseInteger :: Integer -> String -> Integer parseInteger radix ds =- foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds)+ foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds)
Language/Haskell/ParseMonad.hs view
@@ -4,7 +4,7 @@ -- Module : Language.Haskell.ParseMonad -- Copyright : (c) The GHC Team, 1997-2000 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable@@ -14,16 +14,16 @@ ----------------------------------------------------------------------------- module Language.Haskell.ParseMonad(- -- * Parsing- P, ParseResult(..), atSrcLoc, LexContext(..),- ParseMode(..), defaultParseMode,- runParserWithMode, runParser,- getSrcLoc, pushCurrentContext, popContext,- -- * Lexing- Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,- alternative, checkBOL, setBOL, startToken, getOffside,- pushContextL, popContextL- ) where+ -- * Parsing+ P, ParseResult(..), atSrcLoc, LexContext(..),+ ParseMode(..), defaultParseMode,+ runParserWithMode, runParser,+ getSrcLoc, pushCurrentContext, popContext,+ -- * Lexing+ Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,+ alternative, checkBOL, setBOL, startToken, getOffside,+ pushContextL, popContextL+ ) where import Language.Haskell.Syntax(SrcLoc(..)) import Control.Applicative@@ -31,15 +31,15 @@ -- | The result of a parse. data ParseResult a- = ParseOk a -- ^ The parse succeeded, yielding a value.- | ParseFailed SrcLoc String- -- ^ The parse failed at the specified- -- source location, with an error message.- deriving Show+ = ParseOk a -- ^ The parse succeeded, yielding a value.+ | ParseFailed SrcLoc String+ -- ^ The parse failed at the specified+ -- source location, with an error message.+ deriving Show instance Functor ParseResult where fmap f (ParseOk x) = ParseOk $ f x- fmap f (ParseFailed loc msg) = ParseFailed loc msg+ fmap _ (ParseFailed loc msg) = ParseFailed loc msg instance Applicative ParseResult where pure = ParseOk@@ -59,10 +59,10 @@ -- internal version data ParseStatus a = Ok ParseState a | Failed SrcLoc String- deriving Show+ deriving Show data LexContext = NoLayout | Layout Int- deriving (Eq,Ord,Show)+ deriving (Eq,Ord,Show) type ParseState = [LexContext] @@ -74,50 +74,50 @@ -- More to come later, e.g. literate mode, language extensions. data ParseMode = ParseMode {- -- | original name of the file being parsed- parseFilename :: String- }+ -- | original name of the file being parsed+ parseFilename :: String+ } -- | Default parameters for a parse, -- currently just a marker for an unknown filename. defaultParseMode :: ParseMode defaultParseMode = ParseMode {- parseFilename = "<unknown>"- }+ parseFilename = "<unknown>"+ } -- | Monad for parsing newtype P a = P { runP ::- String -- input string- -> Int -- current column- -> Int -- current line- -> SrcLoc -- location of last token read- -> ParseState -- layout info.- -> ParseMode -- parse parameters- -> ParseStatus a- }+ String -- input string+ -> Int -- current column+ -> Int -- current line+ -> SrcLoc -- location of last token read+ -> ParseState -- layout info.+ -> ParseMode -- parse parameters+ -> ParseStatus a+ } runParserWithMode :: ParseMode -> P a -> String -> ParseResult a runParserWithMode mode (P m) s = case m s 0 1 start [] mode of- Ok _ a -> ParseOk a- Failed loc msg -> ParseFailed loc msg+ Ok _ a -> ParseOk a+ Failed loc msg -> ParseFailed loc msg where start = SrcLoc {- srcFilename = parseFilename mode,- srcLine = 1,- srcColumn = 1- }+ srcFilename = parseFilename mode,+ srcLine = 1,+ srcColumn = 1+ } runParser :: P a -> String -> ParseResult a runParser = runParserWithMode defaultParseMode instance Monad P where- return a = P $ \_i _x _y _l s _m -> Ok s a- P m >>= k = P $ \i x y l s mode ->- case m i x y l s mode of- Failed loc msg -> Failed loc msg- Ok s' a -> runP (k a) i x y l s' mode- fail s = P $ \_r _col _line loc _stk _m -> Failed loc s+ return a = P $ \_i _x _y _l s _m -> Ok s a+ P m >>= k = P $ \i x y l s mode ->+ case m i x y l s mode of+ Failed loc msg -> Failed loc msg+ Ok s' a -> runP (k a) i x y l s' mode+ fail s = P $ \_r _col _line loc _stk _m -> Failed loc s atSrcLoc :: P a -> SrcLoc -> P a P m `atSrcLoc` loc = P $ \i x y _l -> m i x y loc@@ -132,22 +132,22 @@ pushCurrentContext :: P () pushCurrentContext = do- loc <- getSrcLoc- indent <- currentIndent- pushContext (Layout (max (indent+1) (srcColumn loc)))+ loc <- getSrcLoc+ indent <- currentIndent+ pushContext (Layout (max (indent+1) (srcColumn loc))) currentIndent :: P Int-currentIndent = P $ \_r _x _y loc stk _mode -> Ok stk (indentOfParseState stk)+currentIndent = P $ \_r _x _y _loc stk _mode -> Ok stk (indentOfParseState stk) pushContext :: LexContext -> P () pushContext ctxt = --trace ("pushing lexical scope: " ++ show ctxt ++"\n") $- P $ \_i _x _y _l s _m -> Ok (ctxt:s) ()+ P $ \_i _x _y _l s _m -> Ok (ctxt:s) () popContext :: P () popContext = P $ \_i _x _y _l stk _m -> case stk of- (_:s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $+ (_:s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $ Ok s () [] -> error "Internal error: empty context in popContext" @@ -157,10 +157,10 @@ newtype Lex r a = Lex { runL :: (a -> P r) -> P r } instance Monad (Lex r) where- return a = Lex $ \k -> k a- Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k)- Lex v >> Lex w = Lex $ \k -> v (\_ -> w k)- fail s = Lex $ \_ -> fail s+ return a = Lex $ \k -> k a+ Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k)+ Lex v >> Lex w = Lex $ \k -> v (\_ -> w k)+ fail s = Lex $ \_ -> fail s -- Operations on this monad @@ -192,16 +192,16 @@ lexWhile :: (Char -> Bool) -> Lex a String lexWhile p = Lex $ \cont -> P $ \r x ->- let (cs,rest) = span p r in- runP (cont cs) rest (x + length cs)+ let (cs,rest) = span p r in+ runP (cont cs) rest (x + length cs) -- An alternative scan, to which we can return if subsequent scanning -- is unsuccessful. alternative :: Lex a v -> Lex a (Lex a v) alternative (Lex v) = Lex $ \cont -> P $ \r x y ->- runP (cont (Lex $ \cont' -> P $ \_r _x _y ->- runP (v cont') r x y)) r x y+ runP (cont (Lex $ \cont' -> P $ \_r _x _y ->+ runP (v cont') r x y)) r x y -- The source location is the coordinates of the previous token, -- or, while scanning a token, the start of the current token.@@ -220,8 +220,8 @@ checkBOL :: Lex a Bool checkBOL = Lex $ \cont -> P $ \r x y loc ->- if x == 0 then runP (cont True) r (srcColumn loc) y loc- else runP (cont False) r x y loc+ if x == 0 then runP (cont True) r (srcColumn loc) y loc+ else runP (cont False) r x y loc setBOL :: Lex a () setBOL = Lex $ \cont -> P $ \r _ -> runP (cont ()) r 0@@ -230,12 +230,12 @@ startToken :: Lex a () startToken = Lex $ \cont -> P $ \s x y _ stk mode ->- let loc = SrcLoc {- srcFilename = parseFilename mode,- srcLine = y,- srcColumn = x- } in- runP (cont ()) s x y loc stk mode+ let loc = SrcLoc {+ srcFilename = parseFilename mode,+ srcLine = y,+ srcColumn = x+ } in+ runP (cont ()) s x y loc stk mode -- Current status with respect to the offside (layout) rule: -- LT: we are to the left of the current indent (if any)@@ -244,13 +244,13 @@ getOffside :: Lex a Ordering getOffside = Lex $ \cont -> P $ \r x y loc stk ->- runP (cont (compare x (indentOfParseState stk))) r x y loc stk+ runP (cont (compare x (indentOfParseState stk))) r x y loc stk pushContextL :: LexContext -> Lex a () pushContextL ctxt = Lex $ \cont -> P $ \r x y loc stk ->- runP (cont ()) r x y loc (ctxt:stk)+ runP (cont ()) r x y loc (ctxt:stk) popContextL :: String -> Lex a () popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case stk of- (_:ctxt) -> runP (cont ()) r x y loc ctxt- [] -> error ("Internal error: empty context in " ++ fn)+ (_:ctxt) -> runP (cont ()) r x y loc ctxt+ [] -> error ("Internal error: empty context in " ++ fn)
Language/Haskell/ParseUtils.hs view
@@ -4,7 +4,7 @@ -- Module : Language.Haskell.ParseUtils -- Copyright : (c) The GHC Team, 1997-2000 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable@@ -14,20 +14,20 @@ ----------------------------------------------------------------------------- module Language.Haskell.ParseUtils (- splitTyConApp -- HsType -> P (HsName,[HsType])- , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp- , checkPrec -- Integer -> P Int- , checkContext -- HsType -> P HsContext- , checkAssertion -- HsType -> P HsAsst- , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])- , checkClassHeader -- HsQualType -> P (HsContext,HsName,[HsName])- , checkInstHeader -- HsQualType -> P (HsContext,HsQName,[HsType])- , checkPattern -- HsExp -> P HsPat- , checkExpr -- HsExp -> P HsExp- , checkValDef -- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl- , checkClassBody -- [HsDecl] -> P [HsDecl]- , checkUnQual -- HsQName -> P HsName- , checkRevDecls -- [HsDecl] -> P [HsDecl]+ splitTyConApp -- HsType -> P (HsName,[HsType])+ , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp+ , checkPrec -- Integer -> P Int+ , checkContext -- HsType -> P HsContext+ , checkAssertion -- HsType -> P HsAsst+ , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])+ , checkClassHeader -- HsQualType -> P (HsContext,HsName,[HsName])+ , checkInstHeader -- HsQualType -> P (HsContext,HsQName,[HsType])+ , checkPattern -- HsExp -> P HsPat+ , checkExpr -- HsExp -> P HsExp+ , checkValDef -- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl+ , checkClassBody -- [HsDecl] -> P [HsDecl]+ , checkUnQual -- HsQName -> P HsName+ , checkRevDecls -- [HsDecl] -> P [HsDecl] ) where import Language.Haskell.Syntax@@ -37,39 +37,39 @@ splitTyConApp :: HsType -> P (HsName,[HsType]) splitTyConApp t0 = split t0 [] where- split :: HsType -> [HsType] -> P (HsName,[HsType])- split (HsTyApp t u) ts = split t (u:ts)- split (HsTyCon (UnQual t)) ts = return (t,ts)- split _ _ = fail "Illegal data/newtype declaration"+ split :: HsType -> [HsType] -> P (HsName,[HsType])+ split (HsTyApp t u) ts = split t (u:ts)+ split (HsTyCon (UnQual t)) ts = return (t,ts)+ split _ _ = fail "Illegal data/newtype declaration" ----------------------------------------------------------------------------- -- Various Syntactic Checks checkContext :: HsType -> P HsContext checkContext (HsTyTuple ts) =- mapM checkAssertion ts+ mapM checkAssertion ts checkContext t = do- c <- checkAssertion t- return [c]+ c <- checkAssertion t+ return [c] -- Changed for multi-parameter type classes checkAssertion :: HsType -> P HsAsst checkAssertion = checkAssertion' []- where checkAssertion' ts (HsTyCon c) = return (c,ts)- checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a- checkAssertion' _ _ = fail "Illegal class assertion"+ where checkAssertion' ts (HsTyCon c) = return (c,ts)+ checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a+ checkAssertion' _ _ = fail "Illegal class assertion" checkDataHeader :: HsQualType -> P (HsContext,HsName,[HsName]) checkDataHeader (HsQualType cs t) = do- (c,ts) <- checkSimple "data/newtype" t []- return (cs,c,ts)+ (c,ts) <- checkSimple "data/newtype" t []+ return (cs,c,ts) checkClassHeader :: HsQualType -> P (HsContext,HsName,[HsName]) checkClassHeader (HsQualType cs t) = do- (c,ts) <- checkSimple "class" t []- return (cs,c,ts)+ (c,ts) <- checkSimple "class" t []+ return (cs,c,ts) checkSimple :: String -> HsType -> [HsName] -> P ((HsName,[HsName])) checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs)@@ -78,8 +78,8 @@ checkInstHeader :: HsQualType -> P (HsContext,HsQName,[HsType]) checkInstHeader (HsQualType cs t) = do- (c,ts) <- checkInsts t []- return (cs,c,ts)+ (c,ts) <- checkInsts t []+ return (cs,c,ts) checkInsts :: HsType -> [HsType] -> P ((HsQName,[HsType])) checkInsts (HsTyApp l t) ts = checkInsts l (t:ts)@@ -98,45 +98,45 @@ checkPat :: HsExp -> [HsPat] -> P HsPat checkPat (HsCon c) args = return (HsPApp c args) checkPat (HsApp f x) args = do- x <- checkPat x []- checkPat f (x:args)+ x' <- checkPat x []+ checkPat f (x':args) checkPat e [] = case e of- HsVar (UnQual x) -> return (HsPVar x)- HsLit l -> return (HsPLit l)- HsInfixApp l op r -> do- l <- checkPat l []- r <- checkPat r []- case op of- HsQConOp c -> return (HsPInfixApp l c r)- _ -> patFail- HsTuple es -> do- ps <- mapM (\e -> checkPat e []) es- return (HsPTuple ps)- HsList es -> do- ps <- mapM (\e -> checkPat e []) es- return (HsPList ps)- HsParen e -> do- p <- checkPat e []- return (HsPParen p)- HsAsPat n e -> do- p <- checkPat e []- return (HsPAsPat n p)- HsWildCard -> return HsPWildCard- HsIrrPat e -> do- p <- checkPat e []- return (HsPIrrPat p)- HsRecConstr c fs -> do- fs <- mapM checkPatField fs- return (HsPRec c fs)- HsNegApp (HsLit l) -> return (HsPNeg (HsPLit l))- _ -> patFail+ HsVar (UnQual x) -> return (HsPVar x)+ HsLit l -> return (HsPLit l)+ HsInfixApp l op r -> do+ l' <- checkPat l []+ r' <- checkPat r []+ case op of+ HsQConOp c -> return (HsPInfixApp l' c r')+ _ -> patFail+ HsTuple es -> do+ ps <- mapM (\e' -> checkPat e' []) es+ return (HsPTuple ps)+ HsList es -> do+ ps <- mapM (\e' -> checkPat e' []) es+ return (HsPList ps)+ HsParen e' -> do+ p <- checkPat e' []+ return (HsPParen p)+ HsAsPat n e' -> do+ p <- checkPat e' []+ return (HsPAsPat n p)+ HsWildCard -> return HsPWildCard+ HsIrrPat e' -> do+ p <- checkPat e' []+ return (HsPIrrPat p)+ HsRecConstr c fs -> do+ fs' <- mapM checkPatField fs+ return (HsPRec c fs')+ HsNegApp (HsLit l) -> return (HsPNeg (HsPLit l))+ _ -> patFail checkPat _ _ = patFail checkPatField :: HsFieldUpdate -> P HsPatField checkPatField (HsFieldUpdate n e) = do- p <- checkPat e []- return (HsPFieldPat n p)+ p <- checkPat e []+ return (HsPFieldPat n p) patFail :: P a patFail = fail "Parse error in pattern"@@ -146,81 +146,81 @@ checkExpr :: HsExp -> P HsExp checkExpr e = case e of- HsVar _ -> return e- HsCon _ -> return e- HsLit _ -> return e- HsInfixApp e1 op e2 -> check2Exprs e1 e2 (flip HsInfixApp op)- HsApp e1 e2 -> check2Exprs e1 e2 HsApp- HsNegApp e -> check1Expr e HsNegApp- HsLambda loc ps e -> check1Expr e (HsLambda loc ps)- HsLet bs e -> check1Expr e (HsLet bs)- HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf- HsCase e alts -> do- alts <- mapM checkAlt alts- e <- checkExpr e- return (HsCase e alts)- HsDo stmts -> do- stmts <- mapM checkStmt stmts- return (HsDo stmts)- HsTuple es -> checkManyExprs es HsTuple- HsList es -> checkManyExprs es HsList- HsParen e -> check1Expr e HsParen- HsLeftSection e op -> check1Expr e (flip HsLeftSection op)- HsRightSection op e -> check1Expr e (HsRightSection op)- HsRecConstr c fields -> do- fields <- mapM checkField fields- return (HsRecConstr c fields)- HsRecUpdate e fields -> do- fields <- mapM checkField fields- e <- checkExpr e- return (HsRecUpdate e fields)- HsEnumFrom e -> check1Expr e HsEnumFrom- HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo- HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen- HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo- HsListComp e stmts -> do- stmts <- mapM checkStmt stmts- e <- checkExpr e- return (HsListComp e stmts)- HsExpTypeSig loc e ty -> do- e <- checkExpr e- return (HsExpTypeSig loc e ty)- _ -> fail "Parse error in expression"+ HsVar _ -> return e+ HsCon _ -> return e+ HsLit _ -> return e+ HsInfixApp e1 op e2 -> check2Exprs e1 e2 (flip HsInfixApp op)+ HsApp e1 e2 -> check2Exprs e1 e2 HsApp+ HsNegApp e1 -> check1Expr e1 HsNegApp+ HsLambda loc ps e1 -> check1Expr e1 (HsLambda loc ps)+ HsLet bs e1 -> check1Expr e1 (HsLet bs)+ HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf+ HsCase e1 alts -> do+ alts' <- mapM checkAlt alts+ e1' <- checkExpr e1+ return (HsCase e1' alts')+ HsDo stmts -> do+ stmts' <- mapM checkStmt stmts+ return (HsDo stmts')+ HsTuple es -> checkManyExprs es HsTuple+ HsList es -> checkManyExprs es HsList+ HsParen e1 -> check1Expr e1 HsParen+ HsLeftSection e1 op -> check1Expr e1 (flip HsLeftSection op)+ HsRightSection op e1 -> check1Expr e1 (HsRightSection op)+ HsRecConstr c fields -> do+ fields' <- mapM checkField fields+ return (HsRecConstr c fields')+ HsRecUpdate e1 fields -> do+ fields' <- mapM checkField fields+ e1' <- checkExpr e1+ return (HsRecUpdate e1' fields')+ HsEnumFrom e1 -> check1Expr e1 HsEnumFrom+ HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo+ HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen+ HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo+ HsListComp e1 stmts -> do+ stmts' <- mapM checkStmt stmts+ e1' <- checkExpr e1+ return (HsListComp e1' stmts')+ HsExpTypeSig loc e1 ty -> do+ e1' <- checkExpr e1+ return (HsExpTypeSig loc e1' ty)+ _ -> fail "Parse error in expression" -- type signature for polymorphic recursion!! check1Expr :: HsExp -> (HsExp -> a) -> P a check1Expr e1 f = do- e1 <- checkExpr e1- return (f e1)+ e1' <- checkExpr e1+ return (f e1') check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a check2Exprs e1 e2 f = do- e1 <- checkExpr e1- e2 <- checkExpr e2- return (f e1 e2)+ e1' <- checkExpr e1+ e2' <- checkExpr e2+ return (f e1' e2') check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a check3Exprs e1 e2 e3 f = do- e1 <- checkExpr e1- e2 <- checkExpr e2- e3 <- checkExpr e3- return (f e1 e2 e3)+ e1' <- checkExpr e1+ e2' <- checkExpr e2+ e3' <- checkExpr e3+ return (f e1' e2' e3') checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a checkManyExprs es f = do- es <- mapM checkExpr es- return (f es)+ es' <- mapM checkExpr es+ return (f es') checkAlt :: HsAlt -> P HsAlt checkAlt (HsAlt loc p galts bs) = do- galts <- checkGAlts galts- return (HsAlt loc p galts bs)+ galts' <- checkGAlts galts+ return (HsAlt loc p galts' bs) checkGAlts :: HsGuardedAlts -> P HsGuardedAlts checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt checkGAlts (HsGuardedAlts galts) = do- galts <- mapM checkGAlt galts- return (HsGuardedAlts galts)+ galts' <- mapM checkGAlt galts+ return (HsGuardedAlts galts') checkGAlt :: HsGuardedAlt -> P HsGuardedAlt checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc)@@ -239,12 +239,12 @@ checkValDef :: SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl checkValDef srcloc lhs rhs whereBinds = case isFunLhs lhs [] of- Just (f,es) -> do- ps <- mapM checkPattern es- return (HsFunBind [HsMatch srcloc f ps rhs whereBinds])+ Just (f,es) -> do+ ps <- mapM checkPattern es+ return (HsFunBind [HsMatch srcloc f ps rhs whereBinds]) Nothing -> do- lhs <- checkPattern lhs- return (HsPatBind srcloc lhs rhs whereBinds)+ lhs' <- checkPattern lhs+ return (HsPatBind srcloc lhs' rhs whereBinds) -- A variable binding is parsed as an HsPatBind. @@ -260,13 +260,13 @@ checkClassBody :: [HsDecl] -> P [HsDecl] checkClassBody decls = do- mapM_ checkMethodDef decls- return decls+ mapM_ checkMethodDef decls+ return decls checkMethodDef :: HsDecl -> P () checkMethodDef (HsPatBind _ (HsPVar _) _ _) = return () checkMethodDef (HsPatBind loc _ _ _) =- fail "illegal method definition" `atSrcLoc` loc+ fail "illegal method definition" `atSrcLoc` loc checkMethodDef _ = return () -----------------------------------------------------------------------------@@ -283,7 +283,7 @@ checkPrec :: Integer -> P Int checkPrec i | 0 <= i && i <= 9 = return (fromInteger i)-checkPrec i | otherwise = fail ("Illegal precedence " ++ show i)+checkPrec i | otherwise = fail ("Illegal precedence " ++ show i) mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp mkRecConstrOrUpdate (HsCon c) fs = return (HsRecConstr c fs)@@ -297,16 +297,16 @@ checkRevDecls :: [HsDecl] -> P [HsDecl] checkRevDecls = mergeFunBinds [] where- mergeFunBinds revDs [] = return revDs- mergeFunBinds revDs (HsFunBind ms1@(HsMatch _ name ps _ _:_):ds1) =- mergeMatches ms1 ds1- where- arity = length ps- mergeMatches ms' (HsFunBind ms@(HsMatch loc name' ps' _ _:_):ds)- | name' == name =- if length ps' /= arity- then fail ("arity mismatch for '" ++ prettyPrint name ++ "'")- `atSrcLoc` loc- else mergeMatches (ms++ms') ds- mergeMatches ms' ds = mergeFunBinds (HsFunBind ms':revDs) ds- mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds+ mergeFunBinds revDs [] = return revDs+ mergeFunBinds revDs (HsFunBind ms1@(HsMatch _ name ps _ _:_):ds1) =+ mergeMatches ms1 ds1+ where+ arity = length ps+ mergeMatches ms' (HsFunBind ms@(HsMatch loc name' ps' _ _:_):ds)+ | name' == name =+ if length ps' /= arity+ then fail ("arity mismatch for '" ++ prettyPrint name ++ "'")+ `atSrcLoc` loc+ else mergeMatches (ms++ms') ds+ mergeMatches ms' ds = mergeFunBinds (HsFunBind ms':revDs) ds+ mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds
Language/Haskell/Parser.ly view
@@ -14,9 +14,9 @@ > ----------------------------------------------------------------------------- > > module Language.Haskell.Parser (-> parseModule, parseModuleWithMode,-> ParseMode(..), defaultParseMode, ParseResult(..)) where-> +> parseModule, parseModuleWithMode,+> ParseMode(..), defaultParseMode, ParseResult(..)) where+> > import Language.Haskell.Syntax > import Language.Haskell.ParseMonad > import Language.Haskell.Lexer@@ -33,93 +33,93 @@ Conflicts: 2 shift/reduce 2 for ambiguity in 'case x of y | let z = y in z :: Bool -> b'- (don't know whether to reduce 'Bool' as a btype or shift the '->'.- Similarly lambda and if. The default resolution in favour of the- shift means that a guard can never end with a type signature.- In mitigation: it's a rare case and no Haskell implementation- allows these, because it would require unbounded lookahead.)- There are 2 conflicts rather than one because contexts are parsed- as btypes (cf ctype).+ (don't know whether to reduce 'Bool' as a btype or shift the '->'.+ Similarly lambda and if. The default resolution in favour of the+ shift means that a guard can never end with a type signature.+ In mitigation: it's a rare case and no Haskell implementation+ allows these, because it would require unbounded lookahead.)+ There are 2 conflicts rather than one because contexts are parsed+ as btypes (cf ctype). ----------------------------------------------------------------------------- > %token-> VARID { VarId $$ }-> QVARID { QVarId $$ }-> CONID { ConId $$ }-> QCONID { QConId $$ }-> VARSYM { VarSym $$ }-> CONSYM { ConSym $$ }-> QVARSYM { QVarSym $$ }-> QCONSYM { QConSym $$ }-> INT { IntTok $$ }-> RATIONAL { FloatTok $$ }-> CHAR { Character $$ }-> STRING { StringTok $$ }+> VARID { VarId $$ }+> QVARID { QVarId $$ }+> CONID { ConId $$ }+> QCONID { QConId $$ }+> VARSYM { VarSym $$ }+> CONSYM { ConSym $$ }+> QVARSYM { QVarSym $$ }+> QCONSYM { QConSym $$ }+> INT { IntTok $$ }+> RATIONAL { FloatTok $$ }+> CHAR { Character $$ }+> STRING { StringTok $$ } Symbols -> '(' { LeftParen }-> ')' { RightParen }-> ';' { SemiColon }-> '{' { LeftCurly }-> '}' { RightCurly }-> vccurly { VRightCurly } -- a virtual close brace-> '[' { LeftSquare }-> ']' { RightSquare }-> ',' { Comma }-> '_' { Underscore }-> '`' { BackQuote }+> '(' { LeftParen }+> ')' { RightParen }+> ';' { SemiColon }+> '{' { LeftCurly }+> '}' { RightCurly }+> vccurly { VRightCurly } -- a virtual close brace+> '[' { LeftSquare }+> ']' { RightSquare }+> ',' { Comma }+> '_' { Underscore }+> '`' { BackQuote } Reserved operators -> '..' { DotDot }-> ':' { Colon }-> '::' { DoubleColon }-> '=' { Equals }-> '\\' { Backslash }-> '|' { Bar }-> '<-' { LeftArrow }-> '->' { RightArrow }-> '@' { At }-> '~' { Tilde }-> '=>' { DoubleArrow }-> '-' { Minus }-> '!' { Exclamation }+> '..' { DotDot }+> ':' { Colon }+> '::' { DoubleColon }+> '=' { Equals }+> '\\' { Backslash }+> '|' { Bar }+> '<-' { LeftArrow }+> '->' { RightArrow }+> '@' { At }+> '~' { Tilde }+> '=>' { DoubleArrow }+> '-' { Minus }+> '!' { Exclamation } Reserved Ids -> 'case' { KW_Case }-> 'class' { KW_Class }-> 'data' { KW_Data }-> 'default' { KW_Default }-> 'deriving' { KW_Deriving }-> 'do' { KW_Do }-> 'else' { KW_Else }-> 'foreign' { KW_Foreign }-> 'if' { KW_If }-> 'import' { KW_Import }-> 'in' { KW_In }-> 'infix' { KW_Infix }-> 'infixl' { KW_InfixL }-> 'infixr' { KW_InfixR }-> 'instance' { KW_Instance }-> 'let' { KW_Let }-> 'module' { KW_Module }-> 'newtype' { KW_NewType }-> 'of' { KW_Of }-> 'then' { KW_Then }-> 'type' { KW_Type }-> 'where' { KW_Where }+> 'case' { KW_Case }+> 'class' { KW_Class }+> 'data' { KW_Data }+> 'default' { KW_Default }+> 'deriving' { KW_Deriving }+> 'do' { KW_Do }+> 'else' { KW_Else }+> 'foreign' { KW_Foreign }+> 'if' { KW_If }+> 'import' { KW_Import }+> 'in' { KW_In }+> 'infix' { KW_Infix }+> 'infixl' { KW_InfixL }+> 'infixr' { KW_InfixR }+> 'instance' { KW_Instance }+> 'let' { KW_Let }+> 'module' { KW_Module }+> 'newtype' { KW_NewType }+> 'of' { KW_Of }+> 'then' { KW_Then }+> 'type' { KW_Type }+> 'where' { KW_Where } Special Ids -> 'as' { KW_As }-> 'export' { KW_Export }-> 'hiding' { KW_Hiding }-> 'qualified' { KW_Qualified }-> 'safe' { KW_Safe }-> 'unsafe' { KW_Unsafe }+> 'as' { KW_As }+> 'export' { KW_Export }+> 'hiding' { KW_Hiding }+> 'qualified' { KW_Qualified }+> 'safe' { KW_Safe }+> 'unsafe' { KW_Unsafe } > %monad { P } > %lexer { lexer } { EOF }@@ -131,125 +131,125 @@ Module Header > module :: { HsModule }-> : srcloc 'module' modid maybeexports 'where' body-> { HsModule $1 $3 $4 (fst $6) (snd $6) }-> | srcloc body-> { HsModule $1 main_mod (Just [HsEVar (UnQual main_name)])-> (fst $2) (snd $2) }+> : srcloc 'module' modid maybeexports 'where' body+> { HsModule $1 $3 $4 (fst $6) (snd $6) }+> | srcloc body+> { HsModule $1 main_mod (Just [HsEVar (UnQual main_name)])+> (fst $2) (snd $2) } > body :: { ([HsImportDecl],[HsDecl]) }-> : '{' bodyaux '}' { $2 }-> | open bodyaux close { $2 }+> : '{' bodyaux '}' { $2 }+> | open bodyaux close { $2 } > bodyaux :: { ([HsImportDecl],[HsDecl]) }-> : optsemis impdecls semis topdecls { (reverse $2, $4) }-> | optsemis topdecls { ([], $2) }-> | optsemis impdecls optsemis { (reverse $2, []) }-> | optsemis { ([], []) }+> : optsemis impdecls semis topdecls { (reverse $2, $4) }+> | optsemis topdecls { ([], $2) }+> | optsemis impdecls optsemis { (reverse $2, []) }+> | optsemis { ([], []) } > semis :: { () }-> : optsemis ';' { () }+> : optsemis ';' { () } > optsemis :: { () }-> : semis { () }-> | {- empty -} { () }+> : semis { () }+> | {- empty -} { () } ----------------------------------------------------------------------------- The Export List > maybeexports :: { Maybe [HsExportSpec] }-> : exports { Just $1 }-> | {- empty -} { Nothing }+> : exports { Just $1 }+> | {- empty -} { Nothing } > exports :: { [HsExportSpec] }-> : '(' exportlist optcomma ')' { reverse $2 }-> | '(' optcomma ')' { [] }+> : '(' exportlist optcomma ')' { reverse $2 }+> | '(' optcomma ')' { [] } > optcomma :: { () }-> : ',' { () }-> | {- empty -} { () }+> : ',' { () }+> | {- empty -} { () } > exportlist :: { [HsExportSpec] }-> : exportlist ',' export { $3 : $1 }-> | export { [$1] }+> : exportlist ',' export { $3 : $1 }+> | export { [$1] } > export :: { HsExportSpec }-> : qvar { HsEVar $1 }-> | qtyconorcls { HsEAbs $1 }-> | qtyconorcls '(' '..' ')' { HsEThingAll $1 }-> | qtyconorcls '(' ')' { HsEThingWith $1 [] }-> | qtyconorcls '(' cnames ')' { HsEThingWith $1 (reverse $3) }-> | 'module' modid { HsEModuleContents $2 }+> : qvar { HsEVar $1 }+> | qtyconorcls { HsEAbs $1 }+> | qtyconorcls '(' '..' ')' { HsEThingAll $1 }+> | qtyconorcls '(' ')' { HsEThingWith $1 [] }+> | qtyconorcls '(' cnames ')' { HsEThingWith $1 (reverse $3) }+> | 'module' modid { HsEModuleContents $2 } ----------------------------------------------------------------------------- Import Declarations > impdecls :: { [HsImportDecl] }-> : impdecls semis impdecl { $3 : $1 }-> | impdecl { [$1] }+> : impdecls semis impdecl { $3 : $1 }+> | impdecl { [$1] } > impdecl :: { HsImportDecl }-> : srcloc 'import' optqualified modid maybeas maybeimpspec-> { HsImportDecl $1 $4 $3 $5 $6 }+> : srcloc 'import' optqualified modid maybeas maybeimpspec+> { HsImportDecl $1 $4 $3 $5 $6 } > optqualified :: { Bool } > : 'qualified' { True }-> | {- empty -} { False }+> | {- empty -} { False } > maybeas :: { Maybe Module } > : 'as' modid { Just $2 }-> | {- empty -} { Nothing }+> | {- empty -} { Nothing } > maybeimpspec :: { Maybe (Bool, [HsImportSpec]) }-> : impspec { Just $1 }-> | {- empty -} { Nothing }+> : impspec { Just $1 }+> | {- empty -} { Nothing } > impspec :: { (Bool, [HsImportSpec]) }-> : opthiding '(' importlist optcomma ')' { ($1, reverse $3) }-> | opthiding '(' optcomma ')' { ($1, []) }+> : opthiding '(' importlist optcomma ')' { ($1, reverse $3) }+> | opthiding '(' optcomma ')' { ($1, []) } > opthiding :: { Bool }-> : 'hiding' { True }-> | {- empty -} { False }+> : 'hiding' { True }+> | {- empty -} { False } > importlist :: { [HsImportSpec] }-> : importlist ',' importspec { $3 : $1 }-> | importspec { [$1] }+> : importlist ',' importspec { $3 : $1 }+> | importspec { [$1] } > importspec :: { HsImportSpec }-> : var { HsIVar $1 }-> | tyconorcls { HsIAbs $1 }-> | tyconorcls '(' '..' ')' { HsIThingAll $1 }-> | tyconorcls '(' ')' { HsIThingWith $1 [] }-> | tyconorcls '(' cnames ')' { HsIThingWith $1 (reverse $3) }+> : var { HsIVar $1 }+> | tyconorcls { HsIAbs $1 }+> | tyconorcls '(' '..' ')' { HsIThingAll $1 }+> | tyconorcls '(' ')' { HsIThingWith $1 [] }+> | tyconorcls '(' cnames ')' { HsIThingWith $1 (reverse $3) } > cnames :: { [HsCName] }-> : cnames ',' cname { $3 : $1 }-> | cname { [$1] }+> : cnames ',' cname { $3 : $1 }+> | cname { [$1] } > cname :: { HsCName }-> : var { HsVarName $1 }-> | con { HsConName $1 }+> : var { HsVarName $1 }+> | con { HsConName $1 } ----------------------------------------------------------------------------- Fixity Declarations > fixdecl :: { HsDecl }-> : srcloc infix prec ops { HsInfixDecl $1 $2 $3 (reverse $4) }+> : srcloc infix prec ops { HsInfixDecl $1 $2 $3 (reverse $4) } > prec :: { Int }-> : {- empty -} { 9 }-> | INT {% checkPrec $1 }+> : {- empty -} { 9 }+> | INT {% checkPrec $1 } > infix :: { HsAssoc }-> : 'infix' { HsAssocNone }-> | 'infixl' { HsAssocLeft }-> | 'infixr' { HsAssocRight }+> : 'infix' { HsAssocNone }+> | 'infixl' { HsAssocLeft }+> | 'infixr' { HsAssocRight } > ops :: { [HsOp] }-> : ops ',' op { $3 : $1 }-> | op { [$1] }+> : ops ',' op { $3 : $1 }+> | op { [$1] } ----------------------------------------------------------------------------- Top-Level Declarations@@ -258,56 +258,56 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux. > topdecls :: { [HsDecl] }-> : topdecls1 optsemis {% checkRevDecls $1 }+> : topdecls1 optsemis {% checkRevDecls $1 } > topdecls1 :: { [HsDecl] }-> : topdecls1 semis topdecl { $3 : $1 }-> | topdecl { [$1] }+> : topdecls1 semis topdecl { $3 : $1 }+> | topdecl { [$1] } > topdecl :: { HsDecl }-> : srcloc 'type' simpletype '=' type-> { HsTypeDecl $1 (fst $3) (snd $3) $5 }-> | srcloc 'data' ctype '=' constrs deriving-> {% do { (cs,c,t) <- checkDataHeader $3;-> return (HsDataDecl $1 cs c t (reverse $5) $6) } }-> | srcloc 'newtype' ctype '=' constr deriving-> {% do { (cs,c,t) <- checkDataHeader $3;-> return (HsNewTypeDecl $1 cs c t $5 $6) } }-> | srcloc 'class' ctype optcbody-> {% do { (cs,c,vs) <- checkClassHeader $3;-> return (HsClassDecl $1 cs c vs $4) } }-> | srcloc 'instance' ctype optvaldefs-> {% do { (cs,c,ts) <- checkInstHeader $3;-> return (HsInstDecl $1 cs c ts $4) } }-> | srcloc 'default' '(' typelist ')'-> { HsDefaultDecl $1 $4 }-> | foreigndecl { $1 }-> | decl { $1 }+> : srcloc 'type' simpletype '=' type+> { HsTypeDecl $1 (fst $3) (snd $3) $5 }+> | srcloc 'data' ctype '=' constrs deriving+> {% do { (cs,c,t) <- checkDataHeader $3;+> return (HsDataDecl $1 cs c t (reverse $5) $6) } }+> | srcloc 'newtype' ctype '=' constr deriving+> {% do { (cs,c,t) <- checkDataHeader $3;+> return (HsNewTypeDecl $1 cs c t $5 $6) } }+> | srcloc 'class' ctype optcbody+> {% do { (cs,c,vs) <- checkClassHeader $3;+> return (HsClassDecl $1 cs c vs $4) } }+> | srcloc 'instance' ctype optvaldefs+> {% do { (cs,c,ts) <- checkInstHeader $3;+> return (HsInstDecl $1 cs c ts $4) } }+> | srcloc 'default' '(' typelist ')'+> { HsDefaultDecl $1 $4 }+> | foreigndecl { $1 }+> | decl { $1 } > typelist :: { [HsType] }-> : types { reverse $1 }-> | type { [$1] }-> | {- empty -} { [] }+> : types { reverse $1 }+> | type { [$1] }+> | {- empty -} { [] } > decls :: { [HsDecl] }-> : optsemis decls1 optsemis {% checkRevDecls $2 }-> | optsemis { [] }+> : optsemis decls1 optsemis {% checkRevDecls $2 }+> | optsemis { [] } > decls1 :: { [HsDecl] }-> : decls1 semis decl { $3 : $1 }-> | decl { [$1] }+> : decls1 semis decl { $3 : $1 }+> | decl { [$1] } > decl :: { HsDecl }-> : signdecl { $1 }-> | fixdecl { $1 }-> | valdef { $1 }+> : signdecl { $1 }+> | fixdecl { $1 }+> | valdef { $1 } > decllist :: { [HsDecl] }-> : '{' decls '}' { $2 }-> | open decls close { $2 }+> : '{' decls '}' { $2 }+> | open decls close { $2 } > signdecl :: { HsDecl }-> : srcloc vars '::' ctype { HsTypeSig $1 (reverse $2) $4 }+> : srcloc vars '::' ctype { HsTypeSig $1 (reverse $2) $4 } ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var instead of qvar, we get another shift/reduce-conflict. Consider the@@ -320,10 +320,10 @@ instead of a var only (which would be correct). But deciding what the + is, would require more lookahead. So let's check for ourselves... -> vars :: { [HsName] }-> : vars ',' var { $3 : $1 }-> | qvar {% do { n <- checkUnQual $1;-> return [n] } }+> vars :: { [HsName] }+> : vars ',' var { $3 : $1 }+> | qvar {% do { n <- checkUnQual $1;+> return [n] } } Foreign declarations - calling conventions are uninterpreted@@ -331,177 +331,177 @@ - special ids are not allowed as internal names > foreigndecl :: { HsDecl }-> : srcloc 'foreign' 'import' VARID optsafety optentity fvar '::' type-> { HsForeignImport $1 $4 $5 $6 $7 $9 }-> | srcloc 'foreign' 'export' VARID optentity fvar '::' type-> { HsForeignExport $1 $4 $5 $6 $8 }+> : srcloc 'foreign' 'import' VARID optsafety optentity fvar '::' type+> { HsForeignImport $1 $4 $5 $6 $7 $9 }+> | srcloc 'foreign' 'export' VARID optentity fvar '::' type+> { HsForeignExport $1 $4 $5 $6 $8 } > optsafety :: { HsSafety }-> : 'safe' { HsSafe }-> | 'unsafe' { HsUnsafe }-> | {- empty -} { HsSafe }+> : 'safe' { HsSafe }+> | 'unsafe' { HsUnsafe }+> | {- empty -} { HsSafe } > optentity :: { String }-> : STRING { $1 }-> | {- empty -} { "" }+> : STRING { $1 }+> | {- empty -} { "" } > fvar :: { HsName }-> : VARID { HsIdent $1 }-> | '(' varsym ')' { $2 }+> : VARID { HsIdent $1 }+> | '(' varsym ')' { $2 } ----------------------------------------------------------------------------- Types > type :: { HsType }-> : btype '->' type { HsTyFun $1 $3 }-> | btype { $1 }+> : btype '->' type { HsTyFun $1 $3 }+> | btype { $1 } > btype :: { HsType }-> : btype atype { HsTyApp $1 $2 }-> | atype { $1 }+> : btype atype { HsTyApp $1 $2 }+> | atype { $1 } > atype :: { HsType }-> : gtycon { HsTyCon $1 }-> | tyvar { HsTyVar $1 }-> | '(' types ')' { HsTyTuple (reverse $2) }-> | '[' type ']' { HsTyApp list_tycon $2 }-> | '(' type ')' { $2 }+> : gtycon { HsTyCon $1 }+> | tyvar { HsTyVar $1 }+> | '(' types ')' { HsTyTuple (reverse $2) }+> | '[' type ']' { HsTyApp list_tycon $2 }+> | '(' type ')' { $2 } > gtycon :: { HsQName }-> : qconid { $1 }-> | '(' ')' { unit_tycon_name }-> | '(' '->' ')' { fun_tycon_name }-> | '[' ']' { list_tycon_name }-> | '(' commas ')' { tuple_tycon_name $2 }+> : qconid { $1 }+> | '(' ')' { unit_tycon_name }+> | '(' '->' ')' { fun_tycon_name }+> | '[' ']' { list_tycon_name }+> | '(' commas ')' { tuple_tycon_name $2 } (Slightly edited) Comment from GHC's hsparser.y: "context => type" vs "type" is a problem, because you can't distinguish between - foo :: (Baz a, Baz a)- bar :: (Baz a, Baz a) => [a] -> [a] -> [a]+ foo :: (Baz a, Baz a)+ bar :: (Baz a, Baz a) => [a] -> [a] -> [a] with one token of lookahead. The HACK is to parse the context as a btype (more specifically as a tuple type), then check that it has the right form C a, or (C1 a, C2 b, ... Cn z) and convert it into a context. Blaach! > ctype :: { HsQualType }-> : context '=>' type { HsQualType $1 $3 }-> | type { HsQualType [] $1 }+> : context '=>' type { HsQualType $1 $3 }+> | type { HsQualType [] $1 } > context :: { HsContext }-> : btype {% checkContext $1 }+> : btype {% checkContext $1 } -> types :: { [HsType] }-> : types ',' type { $3 : $1 }-> | type ',' type { [$3, $1] }+> types :: { [HsType] }+> : types ',' type { $3 : $1 }+> | type ',' type { [$3, $1] } > simpletype :: { (HsName, [HsName]) }-> : tycon tyvars { ($1,reverse $2) }+> : tycon tyvars { ($1,reverse $2) } > tyvars :: { [HsName] }-> : tyvars tyvar { $2 : $1 }-> | {- empty -} { [] }+> : tyvars tyvar { $2 : $1 }+> | {- empty -} { [] } ----------------------------------------------------------------------------- Datatype declarations > constrs :: { [HsConDecl] }-> : constrs '|' constr { $3 : $1 }-> | constr { [$1] }+> : constrs '|' constr { $3 : $1 }+> | constr { [$1] } > constr :: { HsConDecl }-> : srcloc scontype { HsConDecl $1 (fst $2) (snd $2) }-> | srcloc sbtype conop sbtype { HsConDecl $1 $3 [$2,$4] }-> | srcloc con '{' '}' { HsRecDecl $1 $2 [] }-> | srcloc con '{' fielddecls '}' { HsRecDecl $1 $2 (reverse $4) }+> : srcloc scontype { HsConDecl $1 (fst $2) (snd $2) }+> | srcloc sbtype conop sbtype { HsConDecl $1 $3 [$2,$4] }+> | srcloc con '{' '}' { HsRecDecl $1 $2 [] }+> | srcloc con '{' fielddecls '}' { HsRecDecl $1 $2 (reverse $4) } > scontype :: { (HsName, [HsBangType]) }-> : btype {% do { (c,ts) <- splitTyConApp $1;-> return (c,map HsUnBangedTy ts) } }-> | scontype1 { $1 }+> : btype {% do { (c,ts) <- splitTyConApp $1;+> return (c,map HsUnBangedTy ts) } }+> | scontype1 { $1 } > scontype1 :: { (HsName, [HsBangType]) }-> : btype '!' atype {% do { (c,ts) <- splitTyConApp $1;-> return (c,map HsUnBangedTy ts++-> [HsBangedTy $3]) } }-> | scontype1 satype { (fst $1, snd $1 ++ [$2] ) }+> : btype '!' atype {% do { (c,ts) <- splitTyConApp $1;+> return (c,map HsUnBangedTy ts+++> [HsBangedTy $3]) } }+> | scontype1 satype { (fst $1, snd $1 ++ [$2] ) } > satype :: { HsBangType }-> : atype { HsUnBangedTy $1 }-> | '!' atype { HsBangedTy $2 }+> : atype { HsUnBangedTy $1 }+> | '!' atype { HsBangedTy $2 } > sbtype :: { HsBangType }-> : btype { HsUnBangedTy $1 }-> | '!' atype { HsBangedTy $2 }+> : btype { HsUnBangedTy $1 }+> | '!' atype { HsBangedTy $2 } > fielddecls :: { [([HsName],HsBangType)] }-> : fielddecls ',' fielddecl { $3 : $1 }-> | fielddecl { [$1] }+> : fielddecls ',' fielddecl { $3 : $1 }+> | fielddecl { [$1] } > fielddecl :: { ([HsName],HsBangType) }-> : vars '::' stype { (reverse $1, $3) }+> : vars '::' stype { (reverse $1, $3) } > stype :: { HsBangType }-> : type { HsUnBangedTy $1 } -> | '!' atype { HsBangedTy $2 }+> : type { HsUnBangedTy $1 }+> | '!' atype { HsBangedTy $2 } > deriving :: { [HsQName] }-> : {- empty -} { [] }-> | 'deriving' qtycls { [$2] }-> | 'deriving' '(' ')' { [] }-> | 'deriving' '(' dclasses ')' { reverse $3 }+> : {- empty -} { [] }+> | 'deriving' qtycls { [$2] }+> | 'deriving' '(' ')' { [] }+> | 'deriving' '(' dclasses ')' { reverse $3 } > dclasses :: { [HsQName] }-> : dclasses ',' qtycls { $3 : $1 }-> | qtycls { [$1] }+> : dclasses ',' qtycls { $3 : $1 }+> | qtycls { [$1] } ----------------------------------------------------------------------------- Class declarations > optcbody :: { [HsDecl] }-> : 'where' decllist {% checkClassBody $2 }-> | {- empty -} { [] }+> : 'where' decllist {% checkClassBody $2 }+> | {- empty -} { [] } ----------------------------------------------------------------------------- Instance declarations > optvaldefs :: { [HsDecl] }-> : 'where' '{' valdefs '}' {% checkClassBody $3 }-> | 'where' open valdefs close {% checkClassBody $3 }-> | {- empty -} { [] }+> : 'where' '{' valdefs '}' {% checkClassBody $3 }+> | 'where' open valdefs close {% checkClassBody $3 }+> | {- empty -} { [] } > valdefs :: { [HsDecl] }-> : optsemis valdefs1 optsemis {% checkRevDecls $2 }-> | optsemis { [] }+> : optsemis valdefs1 optsemis {% checkRevDecls $2 }+> | optsemis { [] } > valdefs1 :: { [HsDecl] }-> : valdefs1 semis valdef { $3 : $1 }-> | valdef { [$1] }+> : valdefs1 semis valdef { $3 : $1 }+> | valdef { [$1] } ----------------------------------------------------------------------------- Value definitions > valdef :: { HsDecl }-> : srcloc exp0b rhs optwhere {% checkValDef $1 $2 $3 $4 }+> : srcloc exp0b rhs optwhere {% checkValDef $1 $2 $3 $4 } > optwhere :: { [HsDecl] }-> : 'where' decllist { $2 }-> | {- empty -} { [] }+> : 'where' decllist { $2 }+> | {- empty -} { [] } -> rhs :: { HsRhs }-> : '=' exp {% do { e <- checkExpr $2;-> return (HsUnGuardedRhs e) } }-> | gdrhs { HsGuardedRhss (reverse $1) }+> rhs :: { HsRhs }+> : '=' exp {% do { e <- checkExpr $2;+> return (HsUnGuardedRhs e) } }+> | gdrhs { HsGuardedRhss (reverse $1) } > gdrhs :: { [HsGuardedRhs] }-> : gdrhs gdrh { $2 : $1 }-> | gdrh { [$1] }+> : gdrhs gdrh { $2 : $1 }+> | gdrh { [$1] } > gdrh :: { HsGuardedRhs }-> : srcloc '|' exp0 '=' exp {% do { g <- checkExpr $3;-> e <- checkExpr $5;-> return (HsGuardedRhs $1 g e) } }+> : srcloc '|' exp0 '=' exp {% do { g <- checkExpr $3;+> e <- checkExpr $5;+> return (HsGuardedRhs $1 g e) } } ----------------------------------------------------------------------------- Expressions@@ -516,42 +516,42 @@ the exp0 productions to distinguish these from the others (exp0a). > exp :: { HsExp }-> : exp0b '::' srcloc ctype { HsExpTypeSig $3 $1 $4 }-> | exp0 { $1 }+> : exp0b '::' srcloc ctype { HsExpTypeSig $3 $1 $4 }+> | exp0 { $1 } > exp0 :: { HsExp }-> : exp0a { $1 }-> | exp0b { $1 }+> : exp0a { $1 }+> | exp0b { $1 } > exp0a :: { HsExp }-> : exp0b qop exp10a { HsInfixApp $1 $2 $3 }-> | exp10a { $1 }+> : exp0b qop exp10a { HsInfixApp $1 $2 $3 }+> | exp10a { $1 } > exp0b :: { HsExp }-> : exp0b qop exp10b { HsInfixApp $1 $2 $3 }-> | exp10b { $1 }+> : exp0b qop exp10b { HsInfixApp $1 $2 $3 }+> | exp10b { $1 } > exp10a :: { HsExp }-> : '\\' srcloc apats '->' exp { HsLambda $2 (reverse $3) $5 }-> | 'let' decllist 'in' exp { HsLet $2 $4 }-> | 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 }+> : '\\' srcloc apats '->' exp { HsLambda $2 (reverse $3) $5 }+> | 'let' decllist 'in' exp { HsLet $2 $4 }+> | 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 } > exp10b :: { HsExp }-> : 'case' exp 'of' altslist { HsCase $2 $4 }-> | '-' fexp { HsNegApp $2 }-> | 'do' stmtlist { HsDo $2 }-> | fexp { $1 }+> : 'case' exp 'of' altslist { HsCase $2 $4 }+> | '-' fexp { HsNegApp $2 }+> | 'do' stmtlist { HsDo $2 }+> | fexp { $1 } > fexp :: { HsExp }-> : fexp aexp { HsApp $1 $2 }-> | aexp { $1 }+> : fexp aexp { HsApp $1 $2 }+> | aexp { $1 } > apats :: { [HsPat] }-> : apats apat { $2 : $1 }-> | apat { [$1] }+> : apats apat { $2 : $1 }+> | apat { [$1] } > apat :: { HsPat }-> : aexp {% checkPattern $1 }+> : aexp {% checkPattern $1 } UGLY: Because patterns and expressions are mixed, aexp has to be split into two rules: One right-recursive and one left-recursive. Otherwise we get two@@ -561,41 +561,41 @@ qvar here to avoid a shift/reduce conflict, and then check it ourselves (as for vars above). -> aexp :: { HsExp }-> : qvar '@' aexp {% do { n <- checkUnQual $1;-> return (HsAsPat n $3) } }-> | '~' aexp { HsIrrPat $2 }-> | aexp1 { $1 }+> aexp :: { HsExp }+> : qvar '@' aexp {% do { n <- checkUnQual $1;+> return (HsAsPat n $3) } }+> | '~' aexp { HsIrrPat $2 }+> | aexp1 { $1 } Note: The first two alternatives of aexp1 are not necessarily record updates: they could be labeled constructions. -> aexp1 :: { HsExp }-> : aexp1 '{' '}' {% mkRecConstrOrUpdate $1 [] }-> | aexp1 '{' fbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) }-> | aexp2 { $1 }+> aexp1 :: { HsExp }+> : aexp1 '{' '}' {% mkRecConstrOrUpdate $1 [] }+> | aexp1 '{' fbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) }+> | aexp2 { $1 } According to the Report, the left section (e op) is legal iff (e op x) parses equivalently to ((e) op x). Thus e must be an exp0b. -> aexp2 :: { HsExp }-> : qvar { HsVar $1 }-> | gcon { $1 }-> | literal { HsLit $1 }-> | '(' exp ')' { HsParen $2 }-> | '(' texps ')' { HsTuple (reverse $2) }-> | '[' list ']' { $2 }-> | '(' exp0b qop ')' { HsLeftSection $2 $3 }-> | '(' qopm exp0 ')' { HsRightSection $2 $3 }-> | '_' { HsWildCard }+> aexp2 :: { HsExp }+> : qvar { HsVar $1 }+> | gcon { $1 }+> | literal { HsLit $1 }+> | '(' exp ')' { HsParen $2 }+> | '(' texps ')' { HsTuple (reverse $2) }+> | '[' list ']' { $2 }+> | '(' exp0b qop ')' { HsLeftSection $2 $3 }+> | '(' qopm exp0 ')' { HsRightSection $2 $3 }+> | '_' { HsWildCard } > commas :: { Int }-> : commas ',' { $1 + 1 }-> | ',' { 1 }+> : commas ',' { $1 + 1 }+> | ',' { 1 } > texps :: { [HsExp] }-> : texps ',' exp { $3 : $1 }-> | exp ',' exp { [$3,$1] }+> : texps ',' exp { $3 : $1 }+> | exp ',' exp { [$3,$1] } ----------------------------------------------------------------------------- List expressions@@ -604,60 +604,60 @@ avoiding another shift/reduce-conflict. > list :: { HsExp }-> : exp { HsList [$1] }-> | lexps { HsList (reverse $1) }-> | exp '..' { HsEnumFrom $1 }-> | exp ',' exp '..' { HsEnumFromThen $1 $3 }-> | exp '..' exp { HsEnumFromTo $1 $3 }-> | exp ',' exp '..' exp { HsEnumFromThenTo $1 $3 $5 }-> | exp '|' quals { HsListComp $1 (reverse $3) }+> : exp { HsList [$1] }+> | lexps { HsList (reverse $1) }+> | exp '..' { HsEnumFrom $1 }+> | exp ',' exp '..' { HsEnumFromThen $1 $3 }+> | exp '..' exp { HsEnumFromTo $1 $3 }+> | exp ',' exp '..' exp { HsEnumFromThenTo $1 $3 $5 }+> | exp '|' quals { HsListComp $1 (reverse $3) } > lexps :: { [HsExp] }-> : lexps ',' exp { $3 : $1 }-> | exp ',' exp { [$3,$1] }+> : lexps ',' exp { $3 : $1 }+> | exp ',' exp { [$3,$1] } ----------------------------------------------------------------------------- List comprehensions > quals :: { [HsStmt] }-> : quals ',' qual { $3 : $1 }-> | qual { [$1] }+> : quals ',' qual { $3 : $1 }+> | qual { [$1] } > qual :: { HsStmt }-> : pat srcloc '<-' exp { HsGenerator $2 $1 $4 }-> | exp { HsQualifier $1 }-> | 'let' decllist { HsLetStmt $2 }+> : pat srcloc '<-' exp { HsGenerator $2 $1 $4 }+> | exp { HsQualifier $1 }+> | 'let' decllist { HsLetStmt $2 } ----------------------------------------------------------------------------- Case alternatives > altslist :: { [HsAlt] }-> : '{' alts '}' { $2 }-> | open alts close { $2 }+> : '{' alts '}' { $2 }+> | open alts close { $2 } > alts :: { [HsAlt] }-> : optsemis alts1 optsemis { reverse $2 }+> : optsemis alts1 optsemis { reverse $2 } > alts1 :: { [HsAlt] }-> : alts1 semis alt { $3 : $1 }-> | alt { [$1] }+> : alts1 semis alt { $3 : $1 }+> | alt { [$1] } > alt :: { HsAlt }-> : srcloc pat ralt optwhere { HsAlt $1 $2 $3 $4 }+> : srcloc pat ralt optwhere { HsAlt $1 $2 $3 $4 } > ralt :: { HsGuardedAlts }-> : '->' exp { HsUnGuardedAlt $2 }-> | gdpats { HsGuardedAlts (reverse $1) }+> : '->' exp { HsUnGuardedAlt $2 }+> | gdpats { HsGuardedAlts (reverse $1) } > gdpats :: { [HsGuardedAlt] }-> : gdpats gdpat { $2 : $1 }-> | gdpat { [$1] }+> : gdpats gdpat { $2 : $1 }+> | gdpat { [$1] } -> gdpat :: { HsGuardedAlt }-> : srcloc '|' exp0 '->' exp { HsGuardedAlt $1 $3 $5 }+> gdpat :: { HsGuardedAlt }+> : srcloc '|' exp0 '->' exp { HsGuardedAlt $1 $3 $5 } > pat :: { HsPat }-> : exp0b {% checkPattern $1 }+> : exp0b {% checkPattern $1 } ----------------------------------------------------------------------------- Statement sequences@@ -667,176 +667,176 @@ an expression. > stmtlist :: { [HsStmt] }-> : '{' stmts '}' { $2 }-> | open stmts close { $2 }+> : '{' stmts '}' { $2 }+> | open stmts close { $2 } > stmts :: { [HsStmt] }-> : 'let' decllist ';' stmts { HsLetStmt $2 : $4 }-> | pat srcloc '<-' exp ';' stmts { HsGenerator $2 $1 $4 : $6 }-> | exp ';' stmts { HsQualifier $1 : $3 }-> | ';' stmts { $2 }-> | exp ';' { [HsQualifier $1] }-> | exp { [HsQualifier $1] }+> : 'let' decllist ';' stmts { HsLetStmt $2 : $4 }+> | pat srcloc '<-' exp ';' stmts { HsGenerator $2 $1 $4 : $6 }+> | exp ';' stmts { HsQualifier $1 : $3 }+> | ';' stmts { $2 }+> | exp ';' { [HsQualifier $1] }+> | exp { [HsQualifier $1] } ----------------------------------------------------------------------------- Record Field Update/Construction > fbinds :: { [HsFieldUpdate] }-> : fbinds ',' fbind { $3 : $1 }-> | fbind { [$1] }+> : fbinds ',' fbind { $3 : $1 }+> | fbind { [$1] } -> fbind :: { HsFieldUpdate }-> : qvar '=' exp { HsFieldUpdate $1 $3 }+> fbind :: { HsFieldUpdate }+> : qvar '=' exp { HsFieldUpdate $1 $3 } ----------------------------------------------------------------------------- Variables, Constructors and Operators. > gcon :: { HsExp }-> : '(' ')' { unit_con }-> | '[' ']' { HsList [] }-> | '(' commas ')' { tuple_con $2 }-> | qcon { HsCon $1 }+> : '(' ')' { unit_con }+> | '[' ']' { HsList [] }+> | '(' commas ')' { tuple_con $2 }+> | qcon { HsCon $1 } -> var :: { HsName }-> : varid { $1 }-> | '(' varsym ')' { $2 }+> var :: { HsName }+> : varid { $1 }+> | '(' varsym ')' { $2 } -> qvar :: { HsQName }-> : qvarid { $1 }-> | '(' qvarsym ')' { $2 }+> qvar :: { HsQName }+> : qvarid { $1 }+> | '(' qvarsym ')' { $2 } -> con :: { HsName }-> : conid { $1 }-> | '(' consym ')' { $2 }+> con :: { HsName }+> : conid { $1 }+> | '(' consym ')' { $2 } -> qcon :: { HsQName }-> : qconid { $1 }-> | '(' gconsym ')' { $2 }+> qcon :: { HsQName }+> : qconid { $1 }+> | '(' gconsym ')' { $2 } -> varop :: { HsName }-> : varsym { $1 }-> | '`' varid '`' { $2 }+> varop :: { HsName }+> : varsym { $1 }+> | '`' varid '`' { $2 } > qvarop :: { HsQName }-> : qvarsym { $1 }-> | '`' qvarid '`' { $2 }+> : qvarsym { $1 }+> | '`' qvarid '`' { $2 } > qvaropm :: { HsQName }-> : qvarsymm { $1 }-> | '`' qvarid '`' { $2 }+> : qvarsymm { $1 }+> | '`' qvarid '`' { $2 } > conop :: { HsName }-> : consym { $1 } -> | '`' conid '`' { $2 }+> : consym { $1 }+> | '`' conid '`' { $2 } > qconop :: { HsQName }-> : gconsym { $1 }-> | '`' qconid '`' { $2 }+> : gconsym { $1 }+> | '`' qconid '`' { $2 } -> op :: { HsOp }-> : varop { HsVarOp $1 }-> | conop { HsConOp $1 }+> op :: { HsOp }+> : varop { HsVarOp $1 }+> | conop { HsConOp $1 } -> qop :: { HsQOp }-> : qvarop { HsQVarOp $1 }-> | qconop { HsQConOp $1 }+> qop :: { HsQOp }+> : qvarop { HsQVarOp $1 }+> | qconop { HsQConOp $1 } -> qopm :: { HsQOp }-> : qvaropm { HsQVarOp $1 }-> | qconop { HsQConOp $1 }+> qopm :: { HsQOp }+> : qvaropm { HsQVarOp $1 }+> | qconop { HsQConOp $1 } > gconsym :: { HsQName }-> : ':' { list_cons_name }-> | qconsym { $1 }+> : ':' { list_cons_name }+> | qconsym { $1 } ----------------------------------------------------------------------------- Identifiers and Symbols > qvarid :: { HsQName }-> : varid { UnQual $1 }-> | QVARID { Qual (Module (fst $1)) (HsIdent (snd $1)) }+> : varid { UnQual $1 }+> | QVARID { Qual (Module (fst $1)) (HsIdent (snd $1)) } > varid :: { HsName }-> : VARID { HsIdent $1 }-> | 'as' { HsIdent "as" }-> | 'export' { HsIdent "export" }-> | 'hiding' { HsIdent "hiding" }-> | 'qualified' { HsIdent "qualified" }-> | 'safe' { HsIdent "safe" }-> | 'unsafe' { HsIdent "unsafe" }+> : VARID { HsIdent $1 }+> | 'as' { HsIdent "as" }+> | 'export' { HsIdent "export" }+> | 'hiding' { HsIdent "hiding" }+> | 'qualified' { HsIdent "qualified" }+> | 'safe' { HsIdent "safe" }+> | 'unsafe' { HsIdent "unsafe" } > qconid :: { HsQName }-> : conid { UnQual $1 }-> | QCONID { Qual (Module (fst $1)) (HsIdent (snd $1)) }+> : conid { UnQual $1 }+> | QCONID { Qual (Module (fst $1)) (HsIdent (snd $1)) } > conid :: { HsName }-> : CONID { HsIdent $1 }+> : CONID { HsIdent $1 } > qconsym :: { HsQName }-> : consym { UnQual $1 }-> | QCONSYM { Qual (Module (fst $1)) (HsSymbol (snd $1)) }+> : consym { UnQual $1 }+> | QCONSYM { Qual (Module (fst $1)) (HsSymbol (snd $1)) } > consym :: { HsName }-> : CONSYM { HsSymbol $1 }+> : CONSYM { HsSymbol $1 } > qvarsym :: { HsQName }-> : varsym { UnQual $1 }-> | qvarsym1 { $1 }+> : varsym { UnQual $1 }+> | qvarsym1 { $1 } > qvarsymm :: { HsQName }-> : varsymm { UnQual $1 }-> | qvarsym1 { $1 }+> : varsymm { UnQual $1 }+> | qvarsym1 { $1 } > varsym :: { HsName }-> : VARSYM { HsSymbol $1 }-> | '-' { HsSymbol "-" }-> | '!' { HsSymbol "!" }+> : VARSYM { HsSymbol $1 }+> | '-' { HsSymbol "-" }+> | '!' { HsSymbol "!" } > varsymm :: { HsName } -- varsym not including '-'-> : VARSYM { HsSymbol $1 }-> | '!' { HsSymbol "!" }+> : VARSYM { HsSymbol $1 }+> | '!' { HsSymbol "!" } > qvarsym1 :: { HsQName }-> : QVARSYM { Qual (Module (fst $1)) (HsSymbol (snd $1)) }+> : QVARSYM { Qual (Module (fst $1)) (HsSymbol (snd $1)) } > literal :: { HsLiteral }-> : INT { HsInt $1 }-> | CHAR { HsChar $1 }-> | RATIONAL { HsFrac $1 }-> | STRING { HsString $1 }+> : INT { HsInt $1 }+> | CHAR { HsChar $1 }+> | RATIONAL { HsFrac $1 }+> | STRING { HsString $1 } -> srcloc :: { SrcLoc } : {% getSrcLoc }- +> srcloc :: { SrcLoc } : {% getSrcLoc }+ ----------------------------------------------------------------------------- Layout -> open :: { () } : {% pushCurrentContext }+> open :: { () } : {% pushCurrentContext } > close :: { () }-> : vccurly { () } -- context popped in lexer.-> | error {% popContext }+> : vccurly { () } -- context popped in lexer.+> | error {% popContext } ----------------------------------------------------------------------------- Miscellaneous (mostly renamings) > modid :: { Module }-> : CONID { Module $1 }-> | QCONID { Module (fst $1 ++ '.':snd $1) }+> : CONID { Module $1 }+> | QCONID { Module (fst $1 ++ '.':snd $1) } > tyconorcls :: { HsName }-> : conid { $1 }+> : conid { $1 } > tycon :: { HsName }-> : conid { $1 }+> : conid { $1 } > qtyconorcls :: { HsQName }-> : qconid { $1 }+> : qconid { $1 } > qtycls :: { HsQName }-> : qconid { $1 }+> : qconid { $1 } > tyvar :: { HsName }-> : varid { $1 }+> : varid { $1 } -----------------------------------------------------------------------------
Language/Haskell/Pretty.hs view
@@ -14,13 +14,13 @@ ----------------------------------------------------------------------------- module Language.Haskell.Pretty (- -- * Pretty printing- Pretty,- prettyPrintStyleMode, prettyPrintWithMode, prettyPrint,- -- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ")- P.Style(..), P.style, P.Mode(..),- -- * Haskell formatting modes- PPHsMode(..), Indent, PPLayout(..), defaultMode) where+ -- * Pretty printing+ Pretty,+ prettyPrintStyleMode, prettyPrintWithMode, prettyPrint,+ -- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ")+ P.Style(..), P.style, P.Mode(..),+ -- * Haskell formatting modes+ PPHsMode(..), Indent, PPLayout(..), defaultMode) where import Language.Haskell.Syntax @@ -31,11 +31,11 @@ ----------------------------------------------------------------------------- -- | Varieties of layout we can use.-data PPLayout = PPOffsideRule -- ^ classical layout- | PPSemiColon -- ^ classical layout made explicit- | PPInLine -- ^ inline decls, with newlines between them- | PPNoLayout -- ^ everything on a single line- deriving Eq+data PPLayout = PPOffsideRule -- ^ classical layout+ | PPSemiColon -- ^ classical layout made explicit+ | PPInLine -- ^ inline decls, with newlines between them+ | PPNoLayout -- ^ everything on a single line+ deriving Eq type Indent = Int @@ -43,58 +43,58 @@ -- -- /Note:/ the 'onsideIndent' must be positive and less than all other indents. data PPHsMode = PPHsMode {- -- | indentation of a class or instance- classIndent :: Indent,- -- | indentation of a @do@-expression- doIndent :: Indent,- -- | indentation of the body of a- -- @case@ expression- caseIndent :: Indent,- -- | indentation of the declarations in a- -- @let@ expression- letIndent :: Indent,- -- | indentation of the declarations in a- -- @where@ clause- whereIndent :: Indent,- -- | indentation added for continuation- -- lines that would otherwise be offside- onsideIndent :: Indent,- -- | blank lines between statements?- spacing :: Bool,- -- | Pretty-printing style to use- layout :: PPLayout,- -- | add GHC-style @LINE@ pragmas to output?- linePragmas :: Bool,- -- | not implemented yet- comments :: Bool- }+ -- | indentation of a class or instance+ classIndent :: Indent,+ -- | indentation of a @do@-expression+ doIndent :: Indent,+ -- | indentation of the body of a+ -- @case@ expression+ caseIndent :: Indent,+ -- | indentation of the declarations in a+ -- @let@ expression+ letIndent :: Indent,+ -- | indentation of the declarations in a+ -- @where@ clause+ whereIndent :: Indent,+ -- | indentation added for continuation+ -- lines that would otherwise be offside+ onsideIndent :: Indent,+ -- | blank lines between statements?+ spacing :: Bool,+ -- | Pretty-printing style to use+ layout :: PPLayout,+ -- | add GHC-style @LINE@ pragmas to output?+ linePragmas :: Bool,+ -- | not implemented yet+ comments :: Bool+ } -- | The default mode: pretty-print using the offside rule and sensible -- defaults. defaultMode :: PPHsMode defaultMode = PPHsMode{- classIndent = 8,- doIndent = 3,- caseIndent = 4,- letIndent = 4,- whereIndent = 6,- onsideIndent = 2,- spacing = True,- layout = PPOffsideRule,- linePragmas = False,- comments = True- }+ classIndent = 8,+ doIndent = 3,+ caseIndent = 4,+ letIndent = 4,+ whereIndent = 6,+ onsideIndent = 2,+ spacing = True,+ layout = PPOffsideRule,+ linePragmas = False,+ comments = True+ } -- | Pretty printing monad newtype DocM s a = DocM (s -> a) instance Functor (DocM s) where- fmap f xs = do x <- xs; return (f x)+ fmap f xs = do x <- xs; return (f x) instance Monad (DocM s) where- (>>=) = thenDocM- (>>) = then_DocM- return = retDocM+ (>>=) = thenDocM+ (>>) = then_DocM+ return = retDocM {-# INLINE thenDocM #-} {-# INLINE then_DocM #-}@@ -128,12 +128,12 @@ -- | Things that can be pretty-printed, including all the syntactic objects -- in "Language.Haskell.Syntax". class Pretty a where- -- | Pretty-print something in isolation.- pretty :: a -> Doc- -- | Pretty-print something in a precedence context.- prettyPrec :: Int -> a -> Doc- pretty = prettyPrec 0- prettyPrec _ = pretty+ -- | Pretty-print something in isolation.+ pretty :: a -> Doc+ -- | Pretty-print something in a precedence context.+ prettyPrec :: Int -> a -> Doc+ pretty = prettyPrec 0+ prettyPrec _ = pretty -- The pretty printing combinators @@ -253,173 +253,173 @@ prettyPrint = prettyPrintWithMode defaultMode fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float ->- (P.TextDetails -> a -> a) -> a -> Doc -> a+ (P.TextDetails -> a -> a) -> a -> Doc -> a fullRenderWithMode ppMode m i f fn e mD =- P.fullRender m i f fn e $ (unDocM mD) ppMode+ P.fullRender m i f fn e $ (unDocM mD) ppMode fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a)- -> a -> Doc -> a+ -> a -> Doc -> a fullRender = fullRenderWithMode defaultMode ------------------------- Pretty-Print a Module -------------------- instance Pretty HsModule where- pretty (HsModule pos m mbExports imp decls) =- markLine pos $- topLevel (ppHsModuleHeader m mbExports)- (map pretty imp ++ map pretty decls)+ pretty (HsModule pos m mbExports imp decls) =+ markLine pos $+ topLevel (ppHsModuleHeader m mbExports)+ (map pretty imp ++ map pretty decls) -------------------------- Module Header ------------------------------ ppHsModuleHeader :: Module -> Maybe [HsExportSpec] -> Doc ppHsModuleHeader m mbExportList = mySep [- text "module",- pretty m,- maybePP (parenList . map pretty) mbExportList,- text "where"]+ text "module",+ pretty m,+ maybePP (parenList . map pretty) mbExportList,+ text "where"] instance Pretty Module where- pretty (Module modName) = text modName+ pretty (Module modName) = text modName instance Pretty HsExportSpec where- pretty (HsEVar name) = pretty name- pretty (HsEAbs name) = pretty name- pretty (HsEThingAll name) = pretty name <> text "(..)"- pretty (HsEThingWith name nameList) =- pretty name <> (parenList . map pretty $ nameList)- pretty (HsEModuleContents m) = text "module" <+> pretty m+ pretty (HsEVar name) = pretty name+ pretty (HsEAbs name) = pretty name+ pretty (HsEThingAll name) = pretty name <> text "(..)"+ pretty (HsEThingWith name nameList) =+ pretty name <> (parenList . map pretty $ nameList)+ pretty (HsEModuleContents m) = text "module" <+> pretty m instance Pretty HsImportDecl where- pretty (HsImportDecl pos m qual mbName mbSpecs) =- markLine pos $- mySep [text "import",- if qual then text "qualified" else empty,- pretty m,- maybePP (\m' -> text "as" <+> pretty m') mbName,- maybePP exports mbSpecs]- where- exports (b,specList) =- if b then text "hiding" <+> specs else specs- where specs = parenList . map pretty $ specList+ pretty (HsImportDecl pos m qual mbName mbSpecs) =+ markLine pos $+ mySep [text "import",+ if qual then text "qualified" else empty,+ pretty m,+ maybePP (\m' -> text "as" <+> pretty m') mbName,+ maybePP exports mbSpecs]+ where+ exports (b,specList) =+ if b then text "hiding" <+> specs else specs+ where specs = parenList . map pretty $ specList instance Pretty HsImportSpec where- pretty (HsIVar name) = pretty name- pretty (HsIAbs name) = pretty name- pretty (HsIThingAll name) = pretty name <> text "(..)"- pretty (HsIThingWith name nameList) =- pretty name <> (parenList . map pretty $ nameList)+ pretty (HsIVar name) = pretty name+ pretty (HsIAbs name) = pretty name+ pretty (HsIThingAll name) = pretty name <> text "(..)"+ pretty (HsIThingWith name nameList) =+ pretty name <> (parenList . map pretty $ nameList) ------------------------- Declarations ------------------------------ instance Pretty HsDecl where- pretty (HsTypeDecl loc name nameList htype) =- blankline $- markLine loc $- mySep ( [text "type", pretty name]- ++ map pretty nameList- ++ [equals, pretty htype])+ pretty (HsTypeDecl loc name nameList htype) =+ blankline $+ markLine loc $+ mySep ( [text "type", pretty name]+ ++ map pretty nameList+ ++ [equals, pretty htype]) - pretty (HsDataDecl loc context name nameList constrList derives) =- blankline $- markLine loc $- mySep ( [text "data", ppHsContext context, pretty name]- ++ map pretty nameList)- <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))- (map pretty constrList))- $$$ ppHsDeriving derives)+ pretty (HsDataDecl loc context name nameList constrList derives) =+ blankline $+ markLine loc $+ mySep ( [text "data", ppHsContext context, pretty name]+ ++ map pretty nameList)+ <+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))+ (map pretty constrList))+ $$$ ppHsDeriving derives) - pretty (HsNewTypeDecl pos context name nameList constr derives) =- blankline $- markLine pos $- mySep ( [text "newtype", ppHsContext context, pretty name]- ++ map pretty nameList)- <+> equals <+> (pretty constr $$$ ppHsDeriving derives)+ pretty (HsNewTypeDecl pos context name nameList constr derives) =+ blankline $+ markLine pos $+ mySep ( [text "newtype", ppHsContext context, pretty name]+ ++ map pretty nameList)+ <+> equals <+> (pretty constr $$$ ppHsDeriving derives) - --m{spacing=False}- -- special case for empty class declaration- pretty (HsClassDecl pos context name nameList []) =- blankline $- markLine pos $- mySep ( [text "class", ppHsContext context, pretty name]- ++ map pretty nameList)- pretty (HsClassDecl pos context name nameList declList) =- blankline $- markLine pos $- mySep ( [text "class", ppHsContext context, pretty name]- ++ map pretty nameList ++ [text "where"])- $$$ ppBody classIndent (map pretty declList)+ --m{spacing=False}+ -- special case for empty class declaration+ pretty (HsClassDecl pos context name nameList []) =+ blankline $+ markLine pos $+ mySep ( [text "class", ppHsContext context, pretty name]+ ++ map pretty nameList)+ pretty (HsClassDecl pos context name nameList declList) =+ blankline $+ markLine pos $+ mySep ( [text "class", ppHsContext context, pretty name]+ ++ map pretty nameList ++ [text "where"])+ $$$ ppBody classIndent (map pretty declList) - -- m{spacing=False}- -- special case for empty instance declaration- pretty (HsInstDecl pos context name args []) =- blankline $- markLine pos $- mySep ( [text "instance", ppHsContext context, pretty name]- ++ map ppHsAType args)- pretty (HsInstDecl pos context name args declList) =- blankline $- markLine pos $- mySep ( [text "instance", ppHsContext context, pretty name]- ++ map ppHsAType args ++ [text "where"])- $$$ ppBody classIndent (map pretty declList)+ -- m{spacing=False}+ -- special case for empty instance declaration+ pretty (HsInstDecl pos context name args []) =+ blankline $+ markLine pos $+ mySep ( [text "instance", ppHsContext context, pretty name]+ ++ map ppHsAType args)+ pretty (HsInstDecl pos context name args declList) =+ blankline $+ markLine pos $+ mySep ( [text "instance", ppHsContext context, pretty name]+ ++ map ppHsAType args ++ [text "where"])+ $$$ ppBody classIndent (map pretty declList) - pretty (HsDefaultDecl pos htypes) =- blankline $- markLine pos $- text "default" <+> parenList (map pretty htypes)+ pretty (HsDefaultDecl pos htypes) =+ blankline $+ markLine pos $+ text "default" <+> parenList (map pretty htypes) - pretty (HsTypeSig pos nameList qualType) =- blankline $- markLine pos $- mySep ((punctuate comma . map pretty $ nameList)- ++ [text "::", pretty qualType])+ pretty (HsTypeSig pos nameList qualType) =+ blankline $+ markLine pos $+ mySep ((punctuate comma . map pretty $ nameList)+ ++ [text "::", pretty qualType]) - pretty (HsForeignImport pos conv safety entity name ty) =- blankline $- markLine pos $- mySep $ [text "foreign", text "import", text conv, pretty safety] ++- (if null entity then [] else [text (show entity)]) ++- [pretty name, text "::", pretty ty]+ pretty (HsForeignImport pos conv safety entity name ty) =+ blankline $+ markLine pos $+ mySep $ [text "foreign", text "import", text conv, pretty safety] +++ (if null entity then [] else [text (show entity)]) +++ [pretty name, text "::", pretty ty] - pretty (HsForeignExport pos conv entity name ty) =- blankline $- markLine pos $- mySep $ [text "foreign", text "export", text conv] ++- (if null entity then [] else [text (show entity)]) ++- [pretty name, text "::", pretty ty]+ pretty (HsForeignExport pos conv entity name ty) =+ blankline $+ markLine pos $+ mySep $ [text "foreign", text "export", text conv] +++ (if null entity then [] else [text (show entity)]) +++ [pretty name, text "::", pretty ty] - pretty (HsFunBind matches) =- ppBindings (map pretty matches)+ pretty (HsFunBind matches) =+ ppBindings (map pretty matches) - pretty (HsPatBind pos pat rhs whereDecls) =- markLine pos $- myFsep [pretty pat, pretty rhs] $$$ ppWhere whereDecls+ pretty (HsPatBind pos pat rhs whereDecls) =+ markLine pos $+ myFsep [pretty pat, pretty rhs] $$$ ppWhere whereDecls - pretty (HsInfixDecl pos assoc prec opList) =- blankline $- markLine pos $- mySep ([pretty assoc, int prec]- ++ (punctuate comma . map pretty $ opList))+ pretty (HsInfixDecl pos assoc prec opList) =+ blankline $+ markLine pos $+ mySep ([pretty assoc, int prec]+ ++ (punctuate comma . map pretty $ opList)) instance Pretty HsAssoc where- pretty HsAssocNone = text "infix"- pretty HsAssocLeft = text "infixl"- pretty HsAssocRight = text "infixr"+ pretty HsAssocNone = text "infix"+ pretty HsAssocLeft = text "infixl"+ pretty HsAssocRight = text "infixr" instance Pretty HsSafety where- pretty HsSafe = text "safe"- pretty HsUnsafe = text "unsafe"+ pretty HsSafe = text "safe"+ pretty HsUnsafe = text "unsafe" instance Pretty HsMatch where- pretty (HsMatch pos f ps rhs whereDecls) =- markLine pos $- myFsep (lhs ++ [pretty rhs])- $$$ ppWhere whereDecls- where- lhs = case ps of- l:r:ps' | isSymbolName f ->- let hd = [pretty l, ppHsName f, pretty r] in- if null ps' then hd- else parens (myFsep hd) : map (prettyPrec 2) ps'- _ -> pretty f : map (prettyPrec 2) ps+ pretty (HsMatch pos f ps rhs whereDecls) =+ markLine pos $+ myFsep (lhs ++ [pretty rhs])+ $$$ ppWhere whereDecls+ where+ lhs = case ps of+ l:r:ps' | isSymbolName f ->+ let hd = [pretty l, ppHsName f, pretty r] in+ if null ps' then hd+ else parens (myFsep hd) : map (prettyPrec 2) ps'+ _ -> pretty f : map (prettyPrec 2) ps ppWhere :: [HsDecl] -> Doc ppWhere [] = empty@@ -427,23 +427,23 @@ ------------------------- Data & Newtype Bodies ------------------------- instance Pretty HsConDecl where- pretty (HsRecDecl _pos name fieldList) =- pretty name <> (braceList . map ppField $ fieldList)+ pretty (HsRecDecl _pos name fieldList) =+ pretty name <> (braceList . map ppField $ fieldList) - pretty (HsConDecl _pos name@(HsSymbol _) [l, r]) =- myFsep [prettyPrec prec_btype l, ppHsName name,- prettyPrec prec_btype r]- pretty (HsConDecl _pos name typeList) =- mySep $ ppHsName name : map (prettyPrec prec_atype) typeList+ pretty (HsConDecl _pos name@(HsSymbol _) [l, r]) =+ myFsep [prettyPrec prec_btype l, ppHsName name,+ prettyPrec prec_btype r]+ pretty (HsConDecl _pos name typeList) =+ mySep $ ppHsName name : map (prettyPrec prec_atype) typeList ppField :: ([HsName],HsBangType) -> Doc ppField (names, ty) =- myFsepSimple $ (punctuate comma . map pretty $ names) ++- [text "::", pretty ty]+ myFsepSimple $ (punctuate comma . map pretty $ names) +++ [text "::", pretty ty] instance Pretty HsBangType where- prettyPrec _ (HsBangedTy ty) = char '!' <> ppHsAType ty- prettyPrec p (HsUnBangedTy ty) = prettyPrec p ty+ prettyPrec _ (HsBangedTy ty) = char '!' <> ppHsAType ty+ prettyPrec p (HsUnBangedTy ty) = prettyPrec p ty ppHsDeriving :: [HsQName] -> Doc ppHsDeriving [] = empty@@ -452,8 +452,8 @@ ------------------------- Types ------------------------- instance Pretty HsQualType where- pretty (HsQualType context htype) =- myFsep [ppHsContext context, pretty htype]+ pretty (HsQualType context htype) =+ myFsep [ppHsContext context, pretty htype] ppHsBType :: HsType -> Doc ppHsBType = prettyPrec prec_btype@@ -463,166 +463,166 @@ -- precedences for types prec_btype, prec_atype :: Int-prec_btype = 1 -- left argument of ->,- -- or either argument of an infix data constructor-prec_atype = 2 -- argument of type or data constructor, or of a class+prec_btype = 1 -- left argument of ->,+ -- or either argument of an infix data constructor+prec_atype = 2 -- argument of type or data constructor, or of a class instance Pretty HsType where- prettyPrec p (HsTyFun a b) = parensIf (p > 0) $- myFsep [ppHsBType a, text "->", pretty b]- prettyPrec _ (HsTyTuple l) = parenList . map pretty $ l- prettyPrec p (HsTyApp a b)- | a == list_tycon = brackets $ pretty b -- special case- | otherwise = parensIf (p > prec_btype) $- myFsep [pretty a, ppHsAType b]- prettyPrec _ (HsTyVar name) = pretty name- prettyPrec _ (HsTyCon name) = pretty name+ prettyPrec p (HsTyFun a b) = parensIf (p > 0) $+ myFsep [ppHsBType a, text "->", pretty b]+ prettyPrec _ (HsTyTuple l) = parenList . map pretty $ l+ prettyPrec p (HsTyApp a b)+ | a == list_tycon = brackets $ pretty b -- special case+ | otherwise = parensIf (p > prec_btype) $+ myFsep [pretty a, ppHsAType b]+ prettyPrec _ (HsTyVar name) = pretty name+ prettyPrec _ (HsTyCon name) = pretty name ------------------------- Expressions ------------------------- instance Pretty HsRhs where- pretty (HsUnGuardedRhs e) = equals <+> pretty e- pretty (HsGuardedRhss guardList) = myVcat . map pretty $ guardList+ pretty (HsUnGuardedRhs e) = equals <+> pretty e+ pretty (HsGuardedRhss guardList) = myVcat . map pretty $ guardList instance Pretty HsGuardedRhs where- pretty (HsGuardedRhs _pos guard body) =- myFsep [char '|', pretty guard, equals, pretty body]+ pretty (HsGuardedRhs _pos guard body) =+ myFsep [char '|', pretty guard, equals, pretty body] instance Pretty HsLiteral where- pretty (HsInt i) = integer i- pretty (HsChar c) = text (show c)- pretty (HsString s) = text (show s)- pretty (HsFrac r) = double (fromRational r)- -- GHC unboxed literals:- pretty (HsCharPrim c) = text (show c) <> char '#'- pretty (HsStringPrim s) = text (show s) <> char '#'- pretty (HsIntPrim i) = integer i <> char '#'- pretty (HsFloatPrim r) = float (fromRational r) <> char '#'- pretty (HsDoublePrim r) = double (fromRational r) <> text "##"+ pretty (HsInt i) = integer i+ pretty (HsChar c) = text (show c)+ pretty (HsString s) = text (show s)+ pretty (HsFrac r) = double (fromRational r)+ -- GHC unboxed literals:+ pretty (HsCharPrim c) = text (show c) <> char '#'+ pretty (HsStringPrim s) = text (show s) <> char '#'+ pretty (HsIntPrim i) = integer i <> char '#'+ pretty (HsFloatPrim r) = float (fromRational r) <> char '#'+ pretty (HsDoublePrim r) = double (fromRational r) <> text "##" instance Pretty HsExp where- pretty (HsLit l) = pretty l- -- lambda stuff- pretty (HsInfixApp a op b) = myFsep [pretty a, pretty op, pretty b]- pretty (HsNegApp e) = myFsep [char '-', pretty e]- pretty (HsApp a b) = myFsep [pretty a, pretty b]- pretty (HsLambda _loc expList body) = myFsep $- char '\\' : map pretty expList ++ [text "->", pretty body]- -- keywords- pretty (HsLet expList letBody) =- myFsep [text "let" <+> ppBody letIndent (map pretty expList),- text "in", pretty letBody]- pretty (HsIf cond thenexp elsexp) =- myFsep [text "if", pretty cond,- text "then", pretty thenexp,- text "else", pretty elsexp]- pretty (HsCase cond altList) =- myFsep [text "case", pretty cond, text "of"]- $$$ ppBody caseIndent (map pretty altList)- pretty (HsDo stmtList) =- text "do" $$$ ppBody doIndent (map pretty stmtList)- -- Constructors & Vars- pretty (HsVar name) = pretty name- pretty (HsCon name) = pretty name- pretty (HsTuple expList) = parenList . map pretty $ expList- -- weird stuff- pretty (HsParen e) = parens . pretty $ e- pretty (HsLeftSection e op) = parens (pretty e <+> pretty op)- pretty (HsRightSection op e) = parens (pretty op <+> pretty e)- pretty (HsRecConstr c fieldList) =- pretty c <> (braceList . map pretty $ fieldList)- pretty (HsRecUpdate e fieldList) =- pretty e <> (braceList . map pretty $ fieldList)- -- patterns- -- special case that would otherwise be buggy- pretty (HsAsPat name (HsIrrPat e)) =- myFsep [pretty name <> char '@', char '~' <> pretty e]- pretty (HsAsPat name e) = hcat [pretty name, char '@', pretty e]- pretty HsWildCard = char '_'- pretty (HsIrrPat e) = char '~' <> pretty e- -- Lists- pretty (HsList list) =- bracketList . punctuate comma . map pretty $ list- pretty (HsEnumFrom e) =- bracketList [pretty e, text ".."]- pretty (HsEnumFromTo from to) =- bracketList [pretty from, text "..", pretty to]- pretty (HsEnumFromThen from thenE) =- bracketList [pretty from <> comma, pretty thenE, text ".."]- pretty (HsEnumFromThenTo from thenE to) =- bracketList [pretty from <> comma, pretty thenE,- text "..", pretty to]- pretty (HsListComp e stmtList) =- bracketList ([pretty e, char '|']- ++ (punctuate comma . map pretty $ stmtList))- pretty (HsExpTypeSig _pos e ty) =- myFsep [pretty e, text "::", pretty ty]+ pretty (HsLit l) = pretty l+ -- lambda stuff+ pretty (HsInfixApp a op b) = myFsep [pretty a, pretty op, pretty b]+ pretty (HsNegApp e) = myFsep [char '-', pretty e]+ pretty (HsApp a b) = myFsep [pretty a, pretty b]+ pretty (HsLambda _loc expList body) = myFsep $+ char '\\' : map pretty expList ++ [text "->", pretty body]+ -- keywords+ pretty (HsLet expList letBody) =+ myFsep [text "let" <+> ppBody letIndent (map pretty expList),+ text "in", pretty letBody]+ pretty (HsIf cond thenexp elsexp) =+ myFsep [text "if", pretty cond,+ text "then", pretty thenexp,+ text "else", pretty elsexp]+ pretty (HsCase cond altList) =+ myFsep [text "case", pretty cond, text "of"]+ $$$ ppBody caseIndent (map pretty altList)+ pretty (HsDo stmtList) =+ text "do" $$$ ppBody doIndent (map pretty stmtList)+ -- Constructors & Vars+ pretty (HsVar name) = pretty name+ pretty (HsCon name) = pretty name+ pretty (HsTuple expList) = parenList . map pretty $ expList+ -- weird stuff+ pretty (HsParen e) = parens . pretty $ e+ pretty (HsLeftSection e op) = parens (pretty e <+> pretty op)+ pretty (HsRightSection op e) = parens (pretty op <+> pretty e)+ pretty (HsRecConstr c fieldList) =+ pretty c <> (braceList . map pretty $ fieldList)+ pretty (HsRecUpdate e fieldList) =+ pretty e <> (braceList . map pretty $ fieldList)+ -- patterns+ -- special case that would otherwise be buggy+ pretty (HsAsPat name (HsIrrPat e)) =+ myFsep [pretty name <> char '@', char '~' <> pretty e]+ pretty (HsAsPat name e) = hcat [pretty name, char '@', pretty e]+ pretty HsWildCard = char '_'+ pretty (HsIrrPat e) = char '~' <> pretty e+ -- Lists+ pretty (HsList list) =+ bracketList . punctuate comma . map pretty $ list+ pretty (HsEnumFrom e) =+ bracketList [pretty e, text ".."]+ pretty (HsEnumFromTo from to) =+ bracketList [pretty from, text "..", pretty to]+ pretty (HsEnumFromThen from thenE) =+ bracketList [pretty from <> comma, pretty thenE, text ".."]+ pretty (HsEnumFromThenTo from thenE to) =+ bracketList [pretty from <> comma, pretty thenE,+ text "..", pretty to]+ pretty (HsListComp e stmtList) =+ bracketList ([pretty e, char '|']+ ++ (punctuate comma . map pretty $ stmtList))+ pretty (HsExpTypeSig _pos e ty) =+ myFsep [pretty e, text "::", pretty ty] ------------------------- Patterns ----------------------------- instance Pretty HsPat where- prettyPrec _ (HsPVar name) = pretty name- prettyPrec _ (HsPLit lit) = pretty lit- prettyPrec _ (HsPNeg p) = myFsep [char '-', pretty p]- prettyPrec p (HsPInfixApp a op b) = parensIf (p > 0) $- myFsep [pretty a, pretty (HsQConOp op), pretty b]- prettyPrec p (HsPApp n ps) = parensIf (p > 1) $- myFsep (pretty n : map pretty ps)- prettyPrec _ (HsPTuple ps) = parenList . map pretty $ ps- prettyPrec _ (HsPList ps) =- bracketList . punctuate comma . map pretty $ ps- prettyPrec _ (HsPParen p) = parens . pretty $ p- prettyPrec _ (HsPRec c fields) =- pretty c <> (braceList . map pretty $ fields)- -- special case that would otherwise be buggy- prettyPrec _ (HsPAsPat name (HsPIrrPat pat)) =- myFsep [pretty name <> char '@', char '~' <> pretty pat]- prettyPrec _ (HsPAsPat name pat) =- hcat [pretty name, char '@', pretty pat]- prettyPrec _ HsPWildCard = char '_'- prettyPrec _ (HsPIrrPat pat) = char '~' <> pretty pat+ prettyPrec _ (HsPVar name) = pretty name+ prettyPrec _ (HsPLit lit) = pretty lit+ prettyPrec _ (HsPNeg p) = myFsep [char '-', pretty p]+ prettyPrec p (HsPInfixApp a op b) = parensIf (p > 0) $+ myFsep [pretty a, pretty (HsQConOp op), pretty b]+ prettyPrec p (HsPApp n ps) = parensIf (p > 1) $+ myFsep (pretty n : map pretty ps)+ prettyPrec _ (HsPTuple ps) = parenList . map pretty $ ps+ prettyPrec _ (HsPList ps) =+ bracketList . punctuate comma . map pretty $ ps+ prettyPrec _ (HsPParen p) = parens . pretty $ p+ prettyPrec _ (HsPRec c fields) =+ pretty c <> (braceList . map pretty $ fields)+ -- special case that would otherwise be buggy+ prettyPrec _ (HsPAsPat name (HsPIrrPat pat)) =+ myFsep [pretty name <> char '@', char '~' <> pretty pat]+ prettyPrec _ (HsPAsPat name pat) =+ hcat [pretty name, char '@', pretty pat]+ prettyPrec _ HsPWildCard = char '_'+ prettyPrec _ (HsPIrrPat pat) = char '~' <> pretty pat instance Pretty HsPatField where- pretty (HsPFieldPat name pat) =- myFsep [pretty name, equals, pretty pat]+ pretty (HsPFieldPat name pat) =+ myFsep [pretty name, equals, pretty pat] ------------------------- Case bodies ------------------------- instance Pretty HsAlt where- pretty (HsAlt _pos e gAlts decls) =- myFsep [pretty e, pretty gAlts] $$$ ppWhere decls+ pretty (HsAlt _pos e gAlts decls) =+ myFsep [pretty e, pretty gAlts] $$$ ppWhere decls instance Pretty HsGuardedAlts where- pretty (HsUnGuardedAlt e) = text "->" <+> pretty e- pretty (HsGuardedAlts altList) = myVcat . map pretty $ altList+ pretty (HsUnGuardedAlt e) = text "->" <+> pretty e+ pretty (HsGuardedAlts altList) = myVcat . map pretty $ altList instance Pretty HsGuardedAlt where- pretty (HsGuardedAlt _pos e body) =- myFsep [char '|', pretty e, text "->", pretty body]+ pretty (HsGuardedAlt _pos e body) =+ myFsep [char '|', pretty e, text "->", pretty body] ------------------------- Statements in monads & list comprehensions ----- instance Pretty HsStmt where- pretty (HsGenerator _loc e from) =- pretty e <+> text "<-" <+> pretty from- pretty (HsQualifier e) = pretty e- pretty (HsLetStmt declList) =- text "let" $$$ ppBody letIndent (map pretty declList)+ pretty (HsGenerator _loc e from) =+ pretty e <+> text "<-" <+> pretty from+ pretty (HsQualifier e) = pretty e+ pretty (HsLetStmt declList) =+ text "let" $$$ ppBody letIndent (map pretty declList) ------------------------- Record updates instance Pretty HsFieldUpdate where- pretty (HsFieldUpdate name e) =- myFsep [pretty name, equals, pretty e]+ pretty (HsFieldUpdate name e) =+ myFsep [pretty name, equals, pretty e] ------------------------- Names ------------------------- instance Pretty HsQOp where- pretty (HsQVarOp n) = ppHsQNameInfix n- pretty (HsQConOp n) = ppHsQNameInfix n+ pretty (HsQVarOp n) = ppHsQNameInfix n+ pretty (HsQConOp n) = ppHsQNameInfix n ppHsQNameInfix :: HsQName -> Doc ppHsQNameInfix name- | isSymbolName (getName name) = ppHsQName name- | otherwise = char '`' <> ppHsQName name <> char '`'+ | isSymbolName (getName name) = ppHsQName name+ | otherwise = char '`' <> ppHsQName name <> char '`' instance Pretty HsQName where- pretty name = parensIf (isSymbolName (getName name)) (ppHsQName name)+ pretty name = parensIf (isSymbolName (getName name)) (ppHsQName name) ppHsQName :: HsQName -> Doc ppHsQName (UnQual name) = ppHsName name@@ -630,24 +630,24 @@ ppHsQName (Special sym) = text (specialName sym) instance Pretty HsOp where- pretty (HsVarOp n) = ppHsNameInfix n- pretty (HsConOp n) = ppHsNameInfix n+ pretty (HsVarOp n) = ppHsNameInfix n+ pretty (HsConOp n) = ppHsNameInfix n ppHsNameInfix :: HsName -> Doc ppHsNameInfix name- | isSymbolName name = ppHsName name- | otherwise = char '`' <> ppHsName name <> char '`'+ | isSymbolName name = ppHsName name+ | otherwise = char '`' <> ppHsName name <> char '`' instance Pretty HsName where- pretty name = parensIf (isSymbolName name) (ppHsName name)+ pretty name = parensIf (isSymbolName name) (ppHsName name) ppHsName :: HsName -> Doc ppHsName (HsIdent s) = text s ppHsName (HsSymbol s) = text s instance Pretty HsCName where- pretty (HsVarName n) = pretty n- pretty (HsConName n) = pretty n+ pretty (HsVarName n) = pretty n+ pretty (HsConName n) = pretty n isSymbolName :: HsName -> Bool isSymbolName (HsSymbol _) = True@@ -703,43 +703,43 @@ blankline :: Doc -> Doc blankline dl = do{e<-getPPEnv;if spacing e && layout e /= PPNoLayout- then space $$ dl else dl}+ then space $$ dl else dl} topLevel :: Doc -> [Doc] -> Doc topLevel header dl = do- e <- fmap layout getPPEnv- case e of- PPOffsideRule -> header $$ vcat dl- PPSemiColon -> header $$ prettyBlock dl- PPInLine -> header $$ prettyBlock dl- PPNoLayout -> header <+> flatBlock dl+ e <- fmap layout getPPEnv+ case e of+ PPOffsideRule -> header $$ vcat dl+ PPSemiColon -> header $$ prettyBlock dl+ PPInLine -> header $$ prettyBlock dl+ PPNoLayout -> header <+> flatBlock dl ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc ppBody f dl = do- e <- fmap layout getPPEnv- i <- fmap f getPPEnv- case e of- PPOffsideRule -> nest i . vcat $ dl- PPSemiColon -> nest i . prettyBlock $ dl- _ -> flatBlock dl+ e <- fmap layout getPPEnv+ i <- fmap f getPPEnv+ case e of+ PPOffsideRule -> nest i . vcat $ dl+ PPSemiColon -> nest i . prettyBlock $ dl+ _ -> flatBlock dl ppBindings :: [Doc] -> Doc ppBindings dl = do- e <- fmap layout getPPEnv- case e of- PPOffsideRule -> vcat dl- PPSemiColon -> vcat . punctuate semi $ dl- _ -> hsep . punctuate semi $ dl+ e <- fmap layout getPPEnv+ case e of+ PPOffsideRule -> vcat dl+ PPSemiColon -> vcat . punctuate semi $ dl+ _ -> hsep . punctuate semi $ dl ($$$) :: Doc -> Doc -> Doc a $$$ b = layoutChoice (a $$) (a <+>) b mySep :: [Doc] -> Doc mySep = layoutChoice mySep' hsep- where- -- ensure paragraph fills with indentation.- mySep' [x] = x- mySep' (x:xs) = x <+> fsep xs- mySep' [] = error "Internal error: mySep"+ where+ -- ensure paragraph fills with indentation.+ mySep' [x] = x+ mySep' (x:xs) = x <+> fsep xs+ mySep' [] = error "Internal error: mySep" myVcat :: [Doc] -> Doc myVcat = layoutChoice vcat hsep@@ -751,11 +751,11 @@ -- which is necessary to avoid triggering the offside rule. myFsep :: [Doc] -> Doc myFsep = layoutChoice fsep' hsep- where fsep' [] = empty- fsep' (d:ds) = do- e <- getPPEnv- let n = onsideIndent e- nest n (fsep (nest (-n) d:ds))+ where fsep' [] = empty+ fsep' (d:ds) = do+ e <- getPPEnv+ let n = onsideIndent e+ nest n (fsep (nest (-n) d:ds)) layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc layoutChoice a b dl = do e <- getPPEnv@@ -770,9 +770,9 @@ markLine :: SrcLoc -> Doc -> Doc markLine loc doc = do- e <- getPPEnv- let y = srcLine loc- let line l =- text ("{-# LINE " ++ show l ++ " \"" ++ srcFilename loc ++ "\" #-}")- if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc- else doc+ e <- getPPEnv+ let y = srcLine loc+ let line l =+ text ("{-# LINE " ++ show l ++ " \"" ++ srcFilename loc ++ "\" #-}")+ if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc+ else doc
Language/Haskell/Syntax.hs view
@@ -5,7 +5,7 @@ -- Module : Language.Haskell.Syntax -- Copyright : (c) The GHC Team, 1997-2000 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable@@ -16,7 +16,7 @@ -- * multi-parameter type classes -- -- * parameters of type class assertions are unrestricted--- +-- -- This module has been changed so that show is a real show. -- For GHC, we also derive Typeable and Data for all types. @@ -70,10 +70,10 @@ -- | A position in the source. data SrcLoc = SrcLoc {- srcFilename :: String,- srcLine :: Int,- srcColumn :: Int- }+ srcFilename :: String,+ srcLine :: Int,+ srcColumn :: Int+ } #ifdef __GLASGOW_HASKELL__ deriving (Eq,Ord,Show,Typeable,Data) #else@@ -93,12 +93,12 @@ -- data constructors. data HsSpecialCon- = HsUnitCon -- ^ unit type and data constructor @()@- | HsListCon -- ^ list type constructor @[]@- | HsFunCon -- ^ function type constructor @->@- | HsTupleCon Int -- ^ /n/-ary tuple type and data- -- constructors @(,)@ etc- | HsCons -- ^ list data constructor @(:)@+ = HsUnitCon -- ^ unit type and data constructor @()@+ | HsListCon -- ^ list type constructor @[]@+ | HsFunCon -- ^ function type constructor @->@+ | HsTupleCon Int -- ^ /n/-ary tuple type and data+ -- constructors @(,)@ etc+ | HsCons -- ^ list data constructor @(:)@ #ifdef __GLASGOW_HASKELL__ deriving (Eq,Ord,Show,Typeable,Data) #else@@ -108,9 +108,9 @@ -- | This type is used to represent qualified variables, and also -- qualified constructors. data HsQName- = Qual Module HsName -- ^ name qualified with a module name- | UnQual HsName -- ^ unqualified name- | Special HsSpecialCon -- ^ built-in constructor with special syntax+ = Qual Module HsName -- ^ name qualified with a module name+ | UnQual HsName -- ^ unqualified name+ | Special HsSpecialCon -- ^ built-in constructor with special syntax #ifdef __GLASGOW_HASKELL__ deriving (Eq,Ord,Show,Typeable,Data) #else@@ -119,8 +119,8 @@ -- | This type is used to represent variables, and also constructors. data HsName- = HsIdent String -- ^ /varid/ or /conid/- | HsSymbol String -- ^ /varsym/ or /consym/+ = HsIdent String -- ^ /varid/ or /conid/+ | HsSymbol String -- ^ /varsym/ or /consym/ #ifdef __GLASGOW_HASKELL__ deriving (Eq,Ord,Show,Typeable,Data) #else@@ -129,8 +129,8 @@ -- | Possibly qualified infix operators (/qop/), appearing in expressions. data HsQOp- = HsQVarOp HsQName -- ^ variable operator (/qvarop/)- | HsQConOp HsQName -- ^ constructor operator (/qconop/)+ = HsQVarOp HsQName -- ^ variable operator (/qvarop/)+ | HsQConOp HsQName -- ^ constructor operator (/qconop/) #ifdef __GLASGOW_HASKELL__ deriving (Eq,Ord,Show,Typeable,Data) #else@@ -139,8 +139,8 @@ -- | Operators, appearing in @infix@ declarations. data HsOp- = HsVarOp HsName -- ^ variable operator (/varop/)- | HsConOp HsName -- ^ constructor operator (/conop/)+ = HsVarOp HsName -- ^ variable operator (/varop/)+ | HsConOp HsName -- ^ constructor operator (/conop/) #ifdef __GLASGOW_HASKELL__ deriving (Eq,Ord,Show,Typeable,Data) #else@@ -150,8 +150,8 @@ -- | A name (/cname/) of a component of a class or data type in an @import@ -- or export specification. data HsCName- = HsVarName HsName -- ^ name of a method or field- | HsConName HsName -- ^ name of a data constructor+ = HsVarName HsName -- ^ name of a method or field+ | HsConName HsName -- ^ name of a data constructor #ifdef __GLASGOW_HASKELL__ deriving (Eq,Ord,Show,Typeable,Data) #else@@ -169,18 +169,18 @@ -- | Export specification. data HsExportSpec- = HsEVar HsQName -- ^ variable- | HsEAbs HsQName -- ^ @T@:- -- a class or datatype exported abstractly,- -- or a type synonym.- | HsEThingAll HsQName -- ^ @T(..)@:- -- a class exported with all of its methods, or- -- a datatype exported with all of its constructors.- | HsEThingWith HsQName [HsCName] -- ^ @T(C_1,...,C_n)@:- -- a class exported with some of its methods, or- -- a datatype exported with some of its constructors.- | HsEModuleContents Module -- ^ @module M@:- -- re-export a module.+ = HsEVar HsQName -- ^ variable+ | HsEAbs HsQName -- ^ @T@:+ -- a class or datatype exported abstractly,+ -- or a type synonym.+ | HsEThingAll HsQName -- ^ @T(..)@:+ -- a class exported with all of its methods, or+ -- a datatype exported with all of its constructors.+ | HsEThingWith HsQName [HsCName] -- ^ @T(C_1,...,C_n)@:+ -- a class exported with some of its methods, or+ -- a datatype exported with some of its constructors.+ | HsEModuleContents Module -- ^ @module M@:+ -- re-export a module. #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -189,16 +189,16 @@ -- | Import declaration. data HsImportDecl = HsImportDecl- { importLoc :: SrcLoc -- ^ position of the @import@ keyword.- , importModule :: Module -- ^ name of the module imported.- , importQualified :: Bool -- ^ imported @qualified@?- , importAs :: Maybe Module -- ^ optional alias name in an- -- @as@ clause.- , importSpecs :: Maybe (Bool,[HsImportSpec])- -- ^ optional list of import specifications.- -- The 'Bool' is 'True' if the names are excluded- -- by @hiding@.- }+ { importLoc :: SrcLoc -- ^ position of the @import@ keyword.+ , importModule :: Module -- ^ name of the module imported.+ , importQualified :: Bool -- ^ imported @qualified@?+ , importAs :: Maybe Module -- ^ optional alias name in an+ -- @as@ clause.+ , importSpecs :: Maybe (Bool,[HsImportSpec])+ -- ^ optional list of import specifications.+ -- The 'Bool' is 'True' if the names are excluded+ -- by @hiding@.+ } #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -207,15 +207,15 @@ -- | Import specification. data HsImportSpec- = HsIVar HsName -- ^ variable- | HsIAbs HsName -- ^ @T@:- -- the name of a class, datatype or type synonym.- | HsIThingAll HsName -- ^ @T(..)@:- -- a class imported with all of its methods, or- -- a datatype imported with all of its constructors.- | HsIThingWith HsName [HsCName] -- ^ @T(C_1,...,C_n)@:- -- a class imported with some of its methods, or- -- a datatype imported with some of its constructors.+ = HsIVar HsName -- ^ variable+ | HsIAbs HsName -- ^ @T@:+ -- the name of a class, datatype or type synonym.+ | HsIThingAll HsName -- ^ @T(..)@:+ -- a class imported with all of its methods, or+ -- a datatype imported with all of its constructors.+ | HsIThingWith HsName [HsCName] -- ^ @T(C_1,...,C_n)@:+ -- a class imported with some of its methods, or+ -- a datatype imported with some of its constructors. #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -224,9 +224,9 @@ -- | Associativity of an operator. data HsAssoc- = HsAssocNone -- ^ non-associative operator (declared with @infix@)- | HsAssocLeft -- ^ left-associative operator (declared with @infixl@).- | HsAssocRight -- ^ right-associative operator (declared with @infixr@)+ = HsAssocNone -- ^ non-associative operator (declared with @infix@)+ | HsAssocLeft -- ^ left-associative operator (declared with @infixl@).+ | HsAssocRight -- ^ right-associative operator (declared with @infixr@) #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -234,18 +234,18 @@ #endif data HsDecl- = HsTypeDecl SrcLoc HsName [HsName] HsType- | HsDataDecl SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName]- | HsInfixDecl SrcLoc HsAssoc Int [HsOp]- | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName]- | HsClassDecl SrcLoc HsContext HsName [HsName] [HsDecl]- | HsInstDecl SrcLoc HsContext HsQName [HsType] [HsDecl]- | HsDefaultDecl SrcLoc [HsType]- | HsTypeSig SrcLoc [HsName] HsQualType- | HsFunBind [HsMatch]- | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl]- | HsForeignImport SrcLoc String HsSafety String HsName HsType- | HsForeignExport SrcLoc String String HsName HsType+ = HsTypeDecl SrcLoc HsName [HsName] HsType+ | HsDataDecl SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName]+ | HsInfixDecl SrcLoc HsAssoc Int [HsOp]+ | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName]+ | HsClassDecl SrcLoc HsContext HsName [HsName] [HsDecl]+ | HsInstDecl SrcLoc HsContext HsQName [HsType] [HsDecl]+ | HsDefaultDecl SrcLoc [HsType]+ | HsTypeSig SrcLoc [HsName] HsQualType+ | HsFunBind [HsMatch]+ | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl]+ | HsForeignImport SrcLoc String HsSafety String HsName HsType+ | HsForeignExport SrcLoc String String HsName HsType #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -254,7 +254,7 @@ -- | Clauses of a function binding. data HsMatch- = HsMatch SrcLoc HsName [HsPat] HsRhs {-where-} [HsDecl]+ = HsMatch SrcLoc HsName [HsPat] HsRhs {-where-} [HsDecl] #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -263,10 +263,10 @@ -- | Declaration of a data constructor. data HsConDecl- = HsConDecl SrcLoc HsName [HsBangType]- -- ^ ordinary data constructor- | HsRecDecl SrcLoc HsName [([HsName],HsBangType)]- -- ^ record constructor+ = HsConDecl SrcLoc HsName [HsBangType]+ -- ^ ordinary data constructor+ | HsRecDecl SrcLoc HsName [([HsName],HsBangType)]+ -- ^ record constructor #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -276,8 +276,8 @@ -- | The type of a constructor argument or field, optionally including -- a strictness annotation. data HsBangType- = HsBangedTy HsType -- ^ strict component, marked with \"@!@\"- | HsUnBangedTy HsType -- ^ non-strict component+ = HsBangedTy HsType -- ^ strict component, marked with \"@!@\"+ | HsUnBangedTy HsType -- ^ non-strict component #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -286,9 +286,9 @@ -- | The right hand side of a function or pattern binding. data HsRhs- = HsUnGuardedRhs HsExp -- ^ unguarded right hand side (/exp/)- | HsGuardedRhss [HsGuardedRhs]- -- ^ guarded right hand side (/gdrhs/)+ = HsUnGuardedRhs HsExp -- ^ unguarded right hand side (/exp/)+ | HsGuardedRhss [HsGuardedRhs]+ -- ^ guarded right hand side (/gdrhs/) #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -298,7 +298,7 @@ -- | A guarded right hand side @|@ /exp/ @=@ /exp/. -- The first expression will be Boolean-valued. data HsGuardedRhs- = HsGuardedRhs SrcLoc HsExp HsExp+ = HsGuardedRhs SrcLoc HsExp HsExp #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -307,8 +307,8 @@ -- | Safety level for invoking a foreign entity data HsSafety- = HsSafe -- ^ call may generate callbacks- | HsUnsafe -- ^ call will not generate callbacks+ = HsSafe -- ^ call may generate callbacks+ | HsUnsafe -- ^ call will not generate callbacks #ifdef __GLASGOW_HASKELL__ deriving (Eq,Ord,Show,Typeable,Data) #else@@ -318,7 +318,7 @@ -- | A type qualified with a context. -- An unqualified type has an empty context. data HsQualType- = HsQualType HsContext HsType+ = HsQualType HsContext HsType #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -327,11 +327,11 @@ -- | Haskell types and type constructors. data HsType- = HsTyFun HsType HsType -- ^ function type- | HsTyTuple [HsType] -- ^ tuple type- | HsTyApp HsType HsType -- ^ application of a type constructor- | HsTyVar HsName -- ^ type variable- | HsTyCon HsQName -- ^ named type or type constructor+ = HsTyFun HsType HsType -- ^ function type+ | HsTyTuple [HsType] -- ^ tuple type+ | HsTyApp HsType HsType -- ^ application of a type constructor+ | HsTyVar HsName -- ^ type variable+ | HsTyCon HsQName -- ^ named type or type constructor #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -350,15 +350,15 @@ -- precise string representation used. For example, @10@, @0o12@ and @0xa@ -- have the same representation. data HsLiteral- = HsChar Char -- ^ character literal- | HsString String -- ^ string literal- | HsInt Integer -- ^ integer literal- | HsFrac Rational -- ^ floating point literal- | HsCharPrim Char -- ^ GHC unboxed character literal- | HsStringPrim String -- ^ GHC unboxed string literal- | HsIntPrim Integer -- ^ GHC unboxed integer literal- | HsFloatPrim Rational -- ^ GHC unboxed float literal- | HsDoublePrim Rational -- ^ GHC unboxed double literal+ = HsChar Char -- ^ character literal+ | HsString String -- ^ string literal+ | HsInt Integer -- ^ integer literal+ | HsFrac Rational -- ^ floating point literal+ | HsCharPrim Char -- ^ GHC unboxed character literal+ | HsStringPrim String -- ^ GHC unboxed string literal+ | HsIntPrim Integer -- ^ GHC unboxed integer literal+ | HsFloatPrim Rational -- ^ GHC unboxed float literal+ | HsDoublePrim Rational -- ^ GHC unboxed double literal #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -382,43 +382,43 @@ -- add parentheses in printing. data HsExp- = HsVar HsQName -- ^ variable- | HsCon HsQName -- ^ data constructor- | HsLit HsLiteral -- ^ literal constant- | HsInfixApp HsExp HsQOp HsExp -- ^ infix application- | HsApp HsExp HsExp -- ^ ordinary application- | HsNegApp HsExp -- ^ negation expression @-@ /exp/- | HsLambda SrcLoc [HsPat] HsExp -- ^ lambda expression- | HsLet [HsDecl] HsExp -- ^ local declarations with @let@- | HsIf HsExp HsExp HsExp -- ^ @if@ /exp/ @then@ /exp/ @else@ /exp/- | HsCase HsExp [HsAlt] -- ^ @case@ /exp/ @of@ /alts/- | HsDo [HsStmt] -- ^ @do@-expression:- -- the last statement in the list- -- should be an expression.- | HsTuple [HsExp] -- ^ tuple expression- | HsList [HsExp] -- ^ list expression- | HsParen HsExp -- ^ parenthesized expression- | HsLeftSection HsExp HsQOp -- ^ left section @(@/exp/ /qop/@)@- | HsRightSection HsQOp HsExp -- ^ right section @(@/qop/ /exp/@)@- | HsRecConstr HsQName [HsFieldUpdate]- -- ^ record construction expression- | HsRecUpdate HsExp [HsFieldUpdate]- -- ^ record update expression- | HsEnumFrom HsExp -- ^ unbounded arithmetic sequence,- -- incrementing by 1- | HsEnumFromTo HsExp HsExp -- ^ bounded arithmetic sequence,- -- incrementing by 1- | HsEnumFromThen HsExp HsExp -- ^ unbounded arithmetic sequence,- -- with first two elements given- | HsEnumFromThenTo HsExp HsExp HsExp- -- ^ bounded arithmetic sequence,- -- with first two elements given- | HsListComp HsExp [HsStmt] -- ^ list comprehension- | HsExpTypeSig SrcLoc HsExp HsQualType- -- ^ expression type signature- | HsAsPat HsName HsExp -- ^ patterns only- | HsWildCard -- ^ patterns only- | HsIrrPat HsExp -- ^ patterns only+ = HsVar HsQName -- ^ variable+ | HsCon HsQName -- ^ data constructor+ | HsLit HsLiteral -- ^ literal constant+ | HsInfixApp HsExp HsQOp HsExp -- ^ infix application+ | HsApp HsExp HsExp -- ^ ordinary application+ | HsNegApp HsExp -- ^ negation expression @-@ /exp/+ | HsLambda SrcLoc [HsPat] HsExp -- ^ lambda expression+ | HsLet [HsDecl] HsExp -- ^ local declarations with @let@+ | HsIf HsExp HsExp HsExp -- ^ @if@ /exp/ @then@ /exp/ @else@ /exp/+ | HsCase HsExp [HsAlt] -- ^ @case@ /exp/ @of@ /alts/+ | HsDo [HsStmt] -- ^ @do@-expression:+ -- the last statement in the list+ -- should be an expression.+ | HsTuple [HsExp] -- ^ tuple expression+ | HsList [HsExp] -- ^ list expression+ | HsParen HsExp -- ^ parenthesized expression+ | HsLeftSection HsExp HsQOp -- ^ left section @(@/exp/ /qop/@)@+ | HsRightSection HsQOp HsExp -- ^ right section @(@/qop/ /exp/@)@+ | HsRecConstr HsQName [HsFieldUpdate]+ -- ^ record construction expression+ | HsRecUpdate HsExp [HsFieldUpdate]+ -- ^ record update expression+ | HsEnumFrom HsExp -- ^ unbounded arithmetic sequence,+ -- incrementing by 1+ | HsEnumFromTo HsExp HsExp -- ^ bounded arithmetic sequence,+ -- incrementing by 1+ | HsEnumFromThen HsExp HsExp -- ^ unbounded arithmetic sequence,+ -- with first two elements given+ | HsEnumFromThenTo HsExp HsExp HsExp+ -- ^ bounded arithmetic sequence,+ -- with first two elements given+ | HsListComp HsExp [HsStmt] -- ^ list comprehension+ | HsExpTypeSig SrcLoc HsExp HsQualType+ -- ^ expression type signature+ | HsAsPat HsName HsExp -- ^ patterns only+ | HsWildCard -- ^ patterns only+ | HsIrrPat HsExp -- ^ patterns only #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -427,20 +427,20 @@ -- | A pattern, to be matched against a value. data HsPat- = HsPVar HsName -- ^ variable- | HsPLit HsLiteral -- ^ literal constant- | HsPNeg HsPat -- ^ negated pattern- | HsPInfixApp HsPat HsQName HsPat- -- ^ pattern with infix data constructor- | HsPApp HsQName [HsPat] -- ^ data constructor and argument- -- patterns- | HsPTuple [HsPat] -- ^ tuple pattern- | HsPList [HsPat] -- ^ list pattern- | HsPParen HsPat -- ^ parenthesized pattern- | HsPRec HsQName [HsPatField] -- ^ labelled pattern- | HsPAsPat HsName HsPat -- ^ @\@@-pattern- | HsPWildCard -- ^ wildcard pattern (@_@)- | HsPIrrPat HsPat -- ^ irrefutable pattern (@~@)+ = HsPVar HsName -- ^ variable+ | HsPLit HsLiteral -- ^ literal constant+ | HsPNeg HsPat -- ^ negated pattern+ | HsPInfixApp HsPat HsQName HsPat+ -- ^ pattern with infix data constructor+ | HsPApp HsQName [HsPat] -- ^ data constructor and argument+ -- patterns+ | HsPTuple [HsPat] -- ^ tuple pattern+ | HsPList [HsPat] -- ^ list pattern+ | HsPParen HsPat -- ^ parenthesized pattern+ | HsPRec HsQName [HsPatField] -- ^ labelled pattern+ | HsPAsPat HsName HsPat -- ^ @\@@-pattern+ | HsPWildCard -- ^ wildcard pattern (@_@)+ | HsPIrrPat HsPat -- ^ irrefutable pattern (@~@) #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -449,7 +449,7 @@ -- | An /fpat/ in a labeled record pattern. data HsPatField- = HsPFieldPat HsQName HsPat+ = HsPFieldPat HsQName HsPat #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -459,12 +459,12 @@ -- | This type represents both /stmt/ in a @do@-expression, -- and /qual/ in a list comprehension. data HsStmt- = HsGenerator SrcLoc HsPat HsExp- -- ^ a generator /pat/ @<-@ /exp/- | HsQualifier HsExp -- ^ an /exp/ by itself: in a @do@-expression,- -- an action whose result is discarded;- -- in a list comprehension, a guard expression- | HsLetStmt [HsDecl] -- ^ local bindings+ = HsGenerator SrcLoc HsPat HsExp+ -- ^ a generator /pat/ @<-@ /exp/+ | HsQualifier HsExp -- ^ an /exp/ by itself: in a @do@-expression,+ -- an action whose result is discarded;+ -- in a list comprehension, a guard expression+ | HsLetStmt [HsDecl] -- ^ local bindings #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -473,7 +473,7 @@ -- | An /fbind/ in a labeled record construction or update expression. data HsFieldUpdate- = HsFieldUpdate HsQName HsExp+ = HsFieldUpdate HsQName HsExp #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -482,7 +482,7 @@ -- | An /alt/ in a @case@ expression. data HsAlt- = HsAlt SrcLoc HsPat HsGuardedAlts [HsDecl]+ = HsAlt SrcLoc HsPat HsGuardedAlts [HsDecl] #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -490,8 +490,8 @@ #endif data HsGuardedAlts- = HsUnGuardedAlt HsExp -- ^ @->@ /exp/- | HsGuardedAlts [HsGuardedAlt] -- ^ /gdpat/+ = HsUnGuardedAlt HsExp -- ^ @->@ /exp/+ | HsGuardedAlts [HsGuardedAlt] -- ^ /gdpat/ #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -501,7 +501,7 @@ -- | A guarded alternative @|@ /exp/ @->@ /exp/. -- The first expression will be Boolean-valued. data HsGuardedAlt- = HsGuardedAlt SrcLoc HsExp HsExp+ = HsGuardedAlt SrcLoc HsExp HsExp #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) #else@@ -512,26 +512,26 @@ -- Builtin names. prelude_mod, main_mod :: Module-prelude_mod = Module "Prelude"-main_mod = Module "Main"+prelude_mod = Module "Prelude"+main_mod = Module "Main" main_name :: HsName-main_name = HsIdent "main"+main_name = HsIdent "main" unit_con_name :: HsQName-unit_con_name = Special HsUnitCon+unit_con_name = Special HsUnitCon tuple_con_name :: Int -> HsQName tuple_con_name i = Special (HsTupleCon (i+1)) list_cons_name :: HsQName-list_cons_name = Special HsCons+list_cons_name = Special HsCons unit_con :: HsExp-unit_con = HsCon unit_con_name+unit_con = HsCon unit_con_name tuple_con :: Int -> HsExp-tuple_con i = HsCon (tuple_con_name i)+tuple_con i = HsCon (tuple_con_name i) unit_tycon_name, fun_tycon_name, list_tycon_name :: HsQName unit_tycon_name = unit_con_name@@ -542,9 +542,9 @@ tuple_tycon_name i = tuple_con_name i unit_tycon, fun_tycon, list_tycon :: HsType-unit_tycon = HsTyCon unit_tycon_name-fun_tycon = HsTyCon fun_tycon_name-list_tycon = HsTyCon list_tycon_name+unit_tycon = HsTyCon unit_tycon_name+fun_tycon = HsTyCon fun_tycon_name+list_tycon = HsTyCon list_tycon_name tuple_tycon :: Int -> HsType-tuple_tycon i = HsTyCon (tuple_tycon_name i)+tuple_tycon i = HsTyCon (tuple_tycon_name i)
dist/build/Language/Haskell/Parser.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+{-# OPTIONS_GHC -w #-} {-# OPTIONS -fglasgow-exts -cpp #-} ----------------------------------------------------------------------------- -- |@@ -14,25 +14,16 @@ -- ----------------------------------------------------------------------------- module Language.Haskell.Parser (- parseModule, parseModuleWithMode,- ParseMode(..), defaultParseMode, ParseResult(..)) where-+ parseModule, parseModuleWithMode,+ ParseMode(..), defaultParseMode, ParseResult(..)) where import Language.Haskell.Syntax import Language.Haskell.ParseMonad import Language.Haskell.Lexer import Language.Haskell.ParseUtils-#if __GLASGOW_HASKELL__ >= 503 import qualified Data.Array as Happy_Data_Array-#else-import qualified Array as Happy_Data_Array-#endif-#if __GLASGOW_HASKELL__ >= 503 import qualified GHC.Exts as Happy_GHC_Exts-#else-import qualified GlaExts as Happy_GHC_Exts-#endif --- parser produced by Happy Version 1.18.4+-- parser produced by Happy Version 1.19.0 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607@@ -1192,7 +1183,7 @@ case happyOut5 happy_x_2 of { happy_var_2 -> happyIn4 (HsModule happy_var_1 main_mod (Just [HsEVar (UnQual main_name)])- (fst happy_var_2) (snd happy_var_2)+ (fst happy_var_2) (snd happy_var_2) )}} happyReduce_3 = happySpecReduce_3 1# happyReduction_3@@ -1691,7 +1682,7 @@ case happyOut52 happy_x_5 of { happy_var_5 -> case happyOut61 happy_x_6 of { happy_var_6 -> ( do { (cs,c,t) <- checkDataHeader happy_var_3;- return (HsDataDecl happy_var_1 cs c t (reverse happy_var_5) happy_var_6) })}}}}+ return (HsDataDecl happy_var_1 cs c t (reverse happy_var_5) happy_var_6) })}}}} ) (\r -> happyReturn (happyIn31 r)) happyReduce_63 = happyMonadReduce 6# 27# happyReduction_63@@ -1707,7 +1698,7 @@ case happyOut53 happy_x_5 of { happy_var_5 -> case happyOut61 happy_x_6 of { happy_var_6 -> ( do { (cs,c,t) <- checkDataHeader happy_var_3;- return (HsNewTypeDecl happy_var_1 cs c t happy_var_5 happy_var_6) })}}}}+ return (HsNewTypeDecl happy_var_1 cs c t happy_var_5 happy_var_6) })}}}} ) (\r -> happyReturn (happyIn31 r)) happyReduce_64 = happyMonadReduce 4# 27# happyReduction_64@@ -1720,7 +1711,7 @@ case happyOut47 happy_x_3 of { happy_var_3 -> case happyOut63 happy_x_4 of { happy_var_4 -> ( do { (cs,c,vs) <- checkClassHeader happy_var_3;- return (HsClassDecl happy_var_1 cs c vs happy_var_4) })}}}+ return (HsClassDecl happy_var_1 cs c vs happy_var_4) })}}} ) (\r -> happyReturn (happyIn31 r)) happyReduce_65 = happyMonadReduce 4# 27# happyReduction_65@@ -1733,7 +1724,7 @@ case happyOut47 happy_x_3 of { happy_var_3 -> case happyOut64 happy_x_4 of { happy_var_4 -> ( do { (cs,c,ts) <- checkInstHeader happy_var_3;- return (HsInstDecl happy_var_1 cs c ts happy_var_4) })}}}+ return (HsInstDecl happy_var_1 cs c ts happy_var_4) })}}} ) (\r -> happyReturn (happyIn31 r)) happyReduce_66 = happyReduce 5# 27# happyReduction_66@@ -1881,7 +1872,7 @@ happyRest) tk = happyThen (case happyOut104 happy_x_1 of { happy_var_1 -> ( do { n <- checkUnQual happy_var_1;- return [n] })}+ return [n] })} ) (\r -> happyReturn (happyIn38 r)) happyReduce_84 = happyReduce 9# 35# happyReduction_84@@ -2219,7 +2210,7 @@ happyRest) tk = happyThen (case happyOut44 happy_x_1 of { happy_var_1 -> ( do { (c,ts) <- splitTyConApp happy_var_1;- return (c,map HsUnBangedTy ts) })}+ return (c,map HsUnBangedTy ts) })} ) (\r -> happyReturn (happyIn54 r)) happyReduce_122 = happySpecReduce_1 50# happyReduction_122@@ -2237,8 +2228,8 @@ = happyThen (case happyOut44 happy_x_1 of { happy_var_1 -> case happyOut45 happy_x_3 of { happy_var_3 -> ( do { (c,ts) <- splitTyConApp happy_var_1;- return (c,map HsUnBangedTy ts++- [HsBangedTy happy_var_3]) })}}+ return (c,map HsUnBangedTy ts+++ [HsBangedTy happy_var_3]) })}} ) (\r -> happyReturn (happyIn55 r)) happyReduce_124 = happySpecReduce_2 51# happyReduction_124@@ -2473,7 +2464,7 @@ happyRest) tk = happyThen (case happyOut72 happy_x_2 of { happy_var_2 -> ( do { e <- checkExpr happy_var_2;- return (HsUnGuardedRhs e) })}+ return (HsUnGuardedRhs e) })} ) (\r -> happyReturn (happyIn69 r)) happyReduce_153 = happySpecReduce_1 65# happyReduction_153@@ -2510,8 +2501,8 @@ case happyOut73 happy_x_3 of { happy_var_3 -> case happyOut72 happy_x_5 of { happy_var_5 -> ( do { g <- checkExpr happy_var_3;- e <- checkExpr happy_var_5;- return (HsGuardedRhs happy_var_1 g e) })}}}+ e <- checkExpr happy_var_5;+ return (HsGuardedRhs happy_var_1 g e) })}}} ) (\r -> happyReturn (happyIn71 r)) happyReduce_157 = happyReduce 4# 68# happyReduction_157@@ -2707,7 +2698,7 @@ = happyThen (case happyOut104 happy_x_1 of { happy_var_1 -> case happyOut81 happy_x_3 of { happy_var_3 -> ( do { n <- checkUnQual happy_var_1;- return (HsAsPat n happy_var_3) })}}+ return (HsAsPat n happy_var_3) })}} ) (\r -> happyReturn (happyIn81 r)) happyReduce_178 = happySpecReduce_2 77# happyReduction_178@@ -3779,7 +3770,8 @@ _ -> happyError' tk }) -happyError_ tk = happyError' tk+happyError_ 65# tk = happyError' tk+happyError_ _ tk = happyError' tk happyThen :: () => P a -> (a -> P b) -> P b happyThen = (>>=)@@ -3814,20 +3806,35 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp -{-# LINE 28 "templates/GenericTemplate.hs" #-}+{-# LINE 13 "templates/GenericTemplate.hs" #-} ++++#if __GLASGOW_HASKELL__ > 706+#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool)+#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool)+#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool)+#else+#define LT(n,m) (n Happy_GHC_Exts.<# m)+#define GTE(n,m) (n Happy_GHC_Exts.>=# m)+#define EQ(n,m) (n Happy_GHC_Exts.==# m)+#endif+{-# LINE 45 "templates/GenericTemplate.hs" #-}++ data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList -{-# LINE 49 "templates/GenericTemplate.hs" #-}+{-# LINE 66 "templates/GenericTemplate.hs" #-} -{-# LINE 59 "templates/GenericTemplate.hs" #-}+{-# LINE 76 "templates/GenericTemplate.hs" #-} -{-# LINE 68 "templates/GenericTemplate.hs" #-}+{-# LINE 85 "templates/GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a)@@ -3862,7 +3869,7 @@ happyFail i tk st -1# -> {- nothing -} happyAccept i tk st- n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}+ n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} (happyReduceArr Happy_Data_Array.! rule) i tk st where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))@@ -3870,35 +3877,24 @@ happyShift new_state i tk st- where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))+ where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) where off = indexShortOffAddr happyActOffsets st- off_i = (off Happy_GHC_Exts.+# i)- check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#))- then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i)- else False- action | check = indexShortOffAddr happyTable off_i- | otherwise = indexShortOffAddr happyDefActions st--{-# LINE 127 "templates/GenericTemplate.hs" #-}+ off_i = (off Happy_GHC_Exts.+# i)+ check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))+ then EQ(indexShortOffAddr happyCheck off_i, i)+ else False+ action+ | check = indexShortOffAddr happyTable off_i+ | otherwise = indexShortOffAddr happyDefActions st indexShortOffAddr (HappyA# arr) off =-#if __GLASGOW_HASKELL__ > 500 Happy_GHC_Exts.narrow16Int# i-#elif __GLASGOW_HASKELL__ == 500- Happy_GHC_Exts.intToInt16# i-#else- Happy_GHC_Exts.iShiftRA# (Happy_GHC_Exts.iShiftL# i 16#) 16#-#endif where-#if __GLASGOW_HASKELL__ >= 503- i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)-#else- i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.shiftL# high 8#) low)-#endif- high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))- low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))- off' = off Happy_GHC_Exts.*# 2#+ i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)+ high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))+ low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+ off' = off Happy_GHC_Exts.*# 2# @@ -3912,7 +3908,7 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 170 "templates/GenericTemplate.hs" #-}+{-# LINE 169 "templates/GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- Shifting a token@@ -3961,23 +3957,26 @@ happyMonadReduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk happyMonadReduce k nt fn j tk st sts stk =- happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))- where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))- drop_stk = happyDropStk k stk+ case happyDrop k (HappyCons (st) (sts)) of+ sts1@((HappyCons (st1@(action)) (_))) ->+ let drop_stk = happyDropStk k stk in+ happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) happyMonad2Reduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk =- happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))- where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))- drop_stk = happyDropStk k stk+ case happyDrop k (HappyCons (st) (sts)) of+ sts1@((HappyCons (st1@(action)) (_))) ->+ let drop_stk = happyDropStk k stk - off = indexShortOffAddr happyGotoOffsets st1- off_i = (off Happy_GHC_Exts.+# nt)+ off = indexShortOffAddr happyGotoOffsets st1+ off_i = (off Happy_GHC_Exts.+# nt) new_state = indexShortOffAddr happyTable off_i + in+ happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) happyDrop 0# l = l happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t@@ -3992,9 +3991,9 @@ happyGoto nt j tk st = {- nothing -} happyDoAction j tk new_state- where off = indexShortOffAddr happyGotoOffsets st- off_i = (off Happy_GHC_Exts.+# nt)- new_state = indexShortOffAddr happyTable off_i+ where off = indexShortOffAddr happyGotoOffsets st+ off_i = (off Happy_GHC_Exts.+# nt)+ new_state = indexShortOffAddr happyTable off_i @@ -4003,9 +4002,10 @@ -- Error recovery (0# is the error token) -- parse error if we are in recovery and we fail again-happyFail 0# tk old_st _ stk =+happyFail 0# tk old_st _ stk@(x `HappyStk` _) =+ let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "failing" $ - happyError_ tk+ happyError_ i tk {- We don't need state discarding for our restricted implementation of "error". In fact, it can cause some bogus parses, so I've disabled it@@ -4026,6 +4026,7 @@ -- Internal happy errors: +notHappyAtAll :: a notHappyAtAll = error "Internal Happy error\n" -----------------------------------------------------------------------------
haskell-src.cabal view
@@ -1,5 +1,5 @@ name: haskell-src-version: 1.0.1.5+version: 1.0.1.6 license: BSD3 license-file: LICENSE author: Simon Marlow, Sven Panne and Noel Winstanley@@ -36,3 +36,4 @@ build-depends: base < 3 extensions: CPP nhc98-options: -K11M+ ghc-options: -Wall -O2