haskell-src 1.0.1.3 → 1.0.4.2
raw patch · 12 files changed
Files
- LICENSE +4/−4
- Language/Haskell/Lexer.hs +356/−355
- Language/Haskell/ParseMonad.hs +141/−74
- Language/Haskell/ParseUtils.hs +156/−157
- Language/Haskell/Parser.ly +418/−418
- Language/Haskell/Pretty.hs +440/−422
- Language/Haskell/Syntax.hs +215/−214
- changelog.md +77/−0
- examples/Makefile +0/−18
- examples/hsparser.hs +0/−110
- haskell-src.cabal +55/−22
- prologue.txt +0/−2
LICENSE view
@@ -1,6 +1,6 @@ The Glasgow Haskell Compiler License -Copyright 2004, The University Court of the University of Glasgow. +Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without@@ -8,14 +8,14 @@ - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.- + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.- + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without-specific prior written permission. +specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
Language/Haskell/Lexer.hs view
@@ -1,12 +1,11 @@--- #hide ----------------------------------------------------------------------------- -- | -- 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+-- License : BSD-3-Clause+--+-- Maintainer : Andreas Abel+-- Stability : stable -- Portability : portable -- -- Lexer for Haskell.@@ -19,91 +18,91 @@ module Language.Haskell.Lexer (Token(..), lexer) where -import Language.Haskell.ParseMonad+import Language.Haskell.ParseMonad -import Data.Char (isAlpha, isLower, isUpper, toLower,- isDigit, isHexDigit, isOctDigit, isSpace,- ord, chr, digitToInt)-import qualified Data.Char (isSymbol)-import Data.Ratio+import Data.Char (chr, digitToInt, isAlpha, isDigit,+ isHexDigit, isLower, isOctDigit,+ isSpace, isUpper, ord, toLower)+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 +124,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 +138,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 +171,10 @@ 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+ case s of+ c':_ | c == c' -> discard 1+ _ -> fail msg -- The top-level lexer. -- We need to know whether we are at the beginning of the line to decide@@ -181,74 +182,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 +257,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
@@ -1,46 +1,82 @@--- #hide ----------------------------------------------------------------------------- -- | -- 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+-- License : BSD-3-Clause+--+-- Maintainer : Andreas Abel+-- Stability : stable -- Portability : portable -- -- Monads for the Haskell parser and lexer. -- ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 900+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+#endif+ 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 as App+import Control.Monad (ap, liftM)+import qualified Control.Monad.Fail as Fail+import Data.Semigroup as Semi+import Language.Haskell.Syntax (SrcLoc (..)) -- | 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 _ (ParseFailed loc msg) = ParseFailed loc msg++instance App.Applicative ParseResult where+ pure = ParseOk+ ParseOk f <*> x = f <$> x+ ParseFailed loc msg <*> _ = ParseFailed loc msg++instance Monad ParseResult where+ return = pure+ ParseOk x >>= f = f x+ ParseFailed loc msg >>= _ = ParseFailed loc msg++-- TODO: relax constraint to 'Semigroup s => Semigroup (ParseResult+-- s)' in the long distant future++-- | @since 1.0.3.0+instance Monoid m => Semi.Semigroup (ParseResult m) where+ ParseOk x <> ParseOk y = ParseOk $ x `mappend` y+ ParseOk _ <> err = err+ err <> _ = err -- left-biased++instance Monoid m => Monoid (ParseResult m) where+ mempty = ParseOk mempty+ mappend = (<>)+ -- 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] @@ -52,51 +88,66 @@ -- 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 +-- | @since 1.0.2.0+instance Functor P where+ fmap = liftM++-- | @since 1.0.2.0+instance Applicative P where+ pure a = P $ \_i _x _y _l s _m -> Ok s a+ (<*>) = ap+ 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 = pure+ 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+#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif +-- | @since 1.0.3.0+instance Fail.MonadFail P where+ 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 @@ -110,22 +161,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" @@ -134,12 +185,28 @@ newtype Lex r a = Lex { runL :: (a -> P r) -> P r } +-- | @since 1.0.2.0+instance Functor (Lex r) where+ fmap = liftM++-- | @since 1.0.2.0+instance Applicative (Lex r) where+ pure a = Lex $ \k -> k a+ (<*>) = ap+ Lex v *> Lex w = Lex $ \k -> v (\_ -> w k)+ 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 = pure+ Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k)+ (>>) = (*>)+#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif +-- | @since 1.0.3.0+instance Fail.MonadFail (Lex r) where+ fail s = Lex $ \_ -> Fail.fail s+ -- Operations on this monad getInput :: Lex r String@@ -170,16 +237,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.@@ -198,8 +265,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@@ -208,12 +275,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)@@ -222,13 +289,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
@@ -1,12 +1,11 @@--- #hide ----------------------------------------------------------------------------- -- | -- 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+-- License : BSD-3-Clause+--+-- Maintainer : Andreas Abel+-- Stability : stable -- Portability : portable -- -- Utilities for the Haskell parser.@@ -14,62 +13,62 @@ ----------------------------------------------------------------------------- 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-import Language.Haskell.ParseMonad-import Language.Haskell.Pretty+import Language.Haskell.ParseMonad+import Language.Haskell.Pretty+import Language.Haskell.Syntax 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,13 +77,13 @@ 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) checkInsts (HsTyCon c) ts = return (c,ts)-checkInsts _ _ = fail "Illegal instance declaration"+checkInsts _ _ = fail "Illegal instance declaration" ----------------------------------------------------------------------------- -- Checking Patterns.@@ -98,45 +97,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,89 +145,89 @@ 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) checkStmt :: HsStmt -> P HsStmt checkStmt (HsGenerator loc p e) = check1Expr e (HsGenerator loc p)-checkStmt (HsQualifier e) = check1Expr e HsQualifier-checkStmt s@(HsLetStmt _) = return s+checkStmt (HsQualifier e) = check1Expr e HsQualifier+checkStmt s@(HsLetStmt _) = return s checkField :: HsFieldUpdate -> P HsFieldUpdate checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)@@ -239,34 +238,34 @@ 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. isFunLhs :: HsExp -> [HsExp] -> Maybe (HsName, [HsExp]) isFunLhs (HsInfixApp l (HsQVarOp (UnQual op)) r) es = Just (op, l:r:es)-isFunLhs (HsApp (HsVar (UnQual f)) e) es = Just (f, e:es)-isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es)-isFunLhs (HsApp f e) es = isFunLhs f (e:es)-isFunLhs _ _ = Nothing+isFunLhs (HsApp (HsVar (UnQual f)) e) es = Just (f, e:es)+isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es)+isFunLhs (HsApp f e) es = isFunLhs f (e:es)+isFunLhs _ _ = Nothing ----------------------------------------------------------------------------- -- In a class or instance body, a pattern binding must be of a variable. 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 () -----------------------------------------------------------------------------@@ -274,8 +273,8 @@ -- For occasions when doing this in the grammar would cause conflicts. checkUnQual :: HsQName -> P HsName-checkUnQual (Qual _ _) = fail "Illegal qualified name"-checkUnQual (UnQual n) = return n+checkUnQual (Qual _ _) = fail "Illegal qualified name"+checkUnQual (UnQual n) = return n checkUnQual (Special _) = fail "Illegal special name" -----------------------------------------------------------------------------@@ -283,7 +282,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 +296,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
@@ -6,7 +6,7 @@ > -- License : BSD-style (see the file libraries/base/LICENSE) > -- > -- Maintainer : libraries@haskell.org-> -- Stability : experimental+> -- Stability : stable > -- Portability : portable > -- > -- Haskell parser.@@ -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
@@ -1,41 +1,53 @@-{-# OPTIONS_GHC -w #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Pretty -- Copyright : (c) The GHC Team, Noel Winstanley 1997-2000--- License : BSD-style (see the file libraries/base/LICENSE)+-- License : BSD-3-Clause ----- Maintainer : libraries@haskell.org--- Stability : experimental+-- Maintainer : Andreas Abel+-- Stability : stable -- Portability : portable -- -- Pretty printer for Haskell. -- ----------------------------------------------------------------------------- -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+module Language.Haskell.Pretty+ ( -- * Pretty printing+ Pretty,+ prettyPrintStyleMode,+ prettyPrintWithMode,+ prettyPrint, -import Language.Haskell.Syntax+ -- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ")+ P.Style(..),+ P.style,+ P.Mode(..), -import qualified Text.PrettyPrint as P+ -- * Haskell formatting modes+ PPHsMode(..),+ Indent,+ PPLayout(..),+ defaultMode+ ) where +import Language.Haskell.Syntax++import Control.Applicative as App (Applicative (..))+import Control.Monad (ap)++import qualified Text.PrettyPrint as P+ infixl 5 $$$ ----------------------------------------------------------------------------- -- | 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 +55,64 @@ -- -- /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) +-- | @since 1.0.2.0+instance App.Applicative (DocM s) where+ pure = retDocM+ (<*>) = ap+ (*>) = then_DocM+ instance Monad (DocM s) where- (>>=) = thenDocM- (>>) = then_DocM- return = retDocM+ (>>=) = thenDocM+ (>>) = (*>)+ return = pure {-# INLINE thenDocM #-} {-# INLINE then_DocM #-}@@ -128,12 +146,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 @@ -146,9 +164,9 @@ -- Literals -text, ptext :: String -> Doc+text :: String -> Doc text = return . P.text-ptext = return . P.text+-- ptext = return . P.text char :: Char -> Doc char = return . P.char@@ -165,80 +183,80 @@ double :: Double -> Doc double = return . P.double -rational :: Rational -> Doc-rational = return . P.rational+-- rational :: Rational -> Doc+-- rational = return . P.rational -- Simple Combining Forms -parens, brackets, braces,quotes,doubleQuotes :: Doc -> Doc+parens, brackets, braces :: Doc -> Doc parens d = d >>= return . P.parens brackets d = d >>= return . P.brackets braces d = d >>= return . P.braces-quotes d = d >>= return . P.quotes-doubleQuotes d = d >>= return . P.doubleQuotes+-- quotes d = d >>= return . P.quotes+-- doubleQuotes d = d >>= return . P.doubleQuotes parensIf :: Bool -> Doc -> Doc-parensIf True = parens+parensIf True = parens parensIf False = id -- Constants -semi,comma,colon,space,equals :: Doc+semi,comma,space,equals :: Doc semi = return P.semi comma = return P.comma-colon = return P.colon+-- colon = return P.colon space = return P.space equals = return P.equals -lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc-lparen = return P.lparen-rparen = return P.rparen-lbrack = return P.lbrack-rbrack = return P.rbrack-lbrace = return P.lbrace-rbrace = return P.rbrace+-- lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc+-- lparen = return P.lparen+-- rparen = return P.rparen+-- lbrack = return P.lbrack+-- rbrack = return P.rbrack+-- lbrace = return P.lbrace+-- rbrace = return P.rbrace -- Combinators -(<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc-aM <> bM = do{a<-aM;b<-bM;return (a P.<> b)}+(<<>>),(<+>),($$) :: Doc -> Doc -> Doc+aM <<>> bM = do{a<-aM;b<-bM;return (a P.<> b)} aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)} aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)}-aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)}+-- aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)} -hcat,hsep,vcat,sep,cat,fsep,fcat :: [Doc] -> Doc+hcat,hsep,vcat,fsep :: [Doc] -> Doc hcat dl = sequence dl >>= return . P.hcat hsep dl = sequence dl >>= return . P.hsep vcat dl = sequence dl >>= return . P.vcat-sep dl = sequence dl >>= return . P.sep-cat dl = sequence dl >>= return . P.cat+-- sep dl = sequence dl >>= return . P.sep+-- cat dl = sequence dl >>= return . P.cat fsep dl = sequence dl >>= return . P.fsep-fcat dl = sequence dl >>= return . P.fcat+-- fcat dl = sequence dl >>= return . P.fcat -- Some More -hang :: Doc -> Int -> Doc -> Doc-hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r}+-- hang :: Doc -> Int -> Doc -> Doc+-- hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r} -- Yuk, had to cut-n-paste this one from Pretty.hs punctuate :: Doc -> [Doc] -> [Doc] punctuate _ [] = [] punctuate p (d1:ds) = go d1 ds where- go d [] = [d]- go d (e:es) = (d <> p) : go e es+ go d [] = [d]+ go d (e:es) = (d <<>> p) : go e es -- | render the document with a given style and mode. renderStyleMode :: P.Style -> PPHsMode -> Doc -> String renderStyleMode ppStyle ppMode d = P.renderStyle ppStyle . unDocM d $ ppMode --- | render the document with a given mode.-renderWithMode :: PPHsMode -> Doc -> String-renderWithMode = renderStyleMode P.style+-- --- | render the document with a given mode.+-- renderWithMode :: PPHsMode -> Doc -> String+-- renderWithMode = renderStyleMode P.style --- | render the document with 'defaultMode'.-render :: Doc -> String-render = renderWithMode defaultMode+-- -- | render the document with 'defaultMode'.+-- render :: Doc -> String+-- render = renderWithMode defaultMode -- | pretty-print with a given style and mode. prettyPrintStyleMode :: Pretty a => P.Style -> PPHsMode -> a -> String@@ -252,198 +270,198 @@ prettyPrint :: Pretty a => a -> String prettyPrint = prettyPrintWithMode defaultMode -fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float ->- (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---fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a)- -> a -> Doc -> a-fullRender = fullRenderWithMode defaultMode+-- fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float ->+-- (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+--+--+-- fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> 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-ppWhere l = nest 2 (text "where" $$$ ppBody whereIndent (map pretty l))+ppWhere l = nest 2 (text "where" $$$ ppBody whereIndent (map pretty l)) ------------------------- 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 +470,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,209 +481,209 @@ -- 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-ppHsQName (Qual m name) = pretty m <> char '.' <> ppHsName name+ppHsQName (Qual m name) = pretty m <<>> char '.' <<>> ppHsName name 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-isSymbolName _ = False+isSymbolName _ = False getName :: HsQName -> HsName-getName (UnQual s) = s-getName (Qual _ s) = s-getName (Special HsCons) = HsSymbol ":"+getName (UnQual s) = s+getName (Qual _ s) = s+getName (Special HsCons) = HsSymbol ":" getName (Special HsFunCon) = HsSymbol "->"-getName (Special s) = HsIdent (specialName s)+getName (Special s) = HsIdent (specialName s) specialName :: HsSpecialCon -> String-specialName HsUnitCon = "()"-specialName HsListCon = "[]"-specialName HsFunCon = "->"+specialName HsUnitCon = "()"+specialName HsListCon = "[]"+specialName HsFunCon = "->" specialName (HsTupleCon n) = "(" ++ replicate (n-1) ',' ++ ")"-specialName HsCons = ":"+specialName HsCons = ":" ppHsContext :: HsContext -> Doc ppHsContext [] = empty@@ -678,7 +696,7 @@ ------------------------- pp utils ------------------------- maybePP :: (a -> Doc) -> Maybe a -> Doc-maybePP _ Nothing = empty+maybePP _ Nothing = empty maybePP pp (Just a) = pp a parenList :: [Doc] -> Doc@@ -693,53 +711,53 @@ -- Wrap in braces and semicolons, with an extra space at the start in -- case the first doc begins with "-", which would be scanned as {- flatBlock :: [Doc] -> Doc-flatBlock = braces . (space <>) . hsep . punctuate semi+flatBlock = braces . (space <<>>) . hsep . punctuate semi -- Same, but put each thing on a separate line prettyBlock :: [Doc] -> Doc-prettyBlock = braces . (space <>) . vcat . punctuate semi+prettyBlock = braces . (space <<>>) . vcat . punctuate semi -- Monadic PP Combinators -- these examine the env 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 +769,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 +788,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
@@ -1,23 +1,24 @@-{-# OPTIONS_GHC -fglasgow-exts -cpp #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+ ----------------------------------------------------------------------------- -- | -- 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+-- License : BSD-3-Clause+--+-- Maintainer : Andreas Abel+-- Stability : stable -- Portability : portable ----- A suite of datatypes describing the abstract syntax of Haskell 98--- <http://www.haskell.org/onlinereport/> plus a few extensions:+-- A suite of datatypes describing the abstract syntax of+-- <http://www.haskell.org/onlinereport/ Haskell 98> plus a few extensions: -- -- * 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.+--+-- For GHC, we also derive 'Data' for all types. ----------------------------------------------------------------------------- @@ -63,18 +64,18 @@ #ifdef __GLASGOW_HASKELL__-import Data.Generics.Basics-import Data.Generics.Instances()+import Data.Generics.Basics+import Data.Generics.Instances () #endif -- | 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)+ deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif@@ -82,7 +83,7 @@ -- | The name of a Haskell module. newtype Module = Module String #ifdef __GLASGOW_HASKELL__- deriving (Eq,Ord,Show,Typeable,Data)+ deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif@@ -92,14 +93,14 @@ -- 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)+ deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif@@ -107,41 +108,41 @@ -- | 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)+ deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif -- | 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)+ deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif -- | 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)+ deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif -- | 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)+ deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif@@ -149,10 +150,10 @@ -- | 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)+ deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif@@ -161,113 +162,113 @@ data HsModule = HsModule SrcLoc Module (Maybe [HsExportSpec]) [HsImportDecl] [HsDecl] #ifdef __GLASGOW_HASKELL__- deriving (Show,Typeable,Data)+ deriving (Eq,Show,Data) #else- deriving (Show)+ deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif@@ -275,21 +276,21 @@ -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif@@ -297,19 +298,19 @@ -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif --- | Safety level for invoking a foreign entity+-- | 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)+ deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif@@ -317,22 +318,22 @@ -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif@@ -349,17 +350,17 @@ -- 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif@@ -381,76 +382,76 @@ -- 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | An /fpat/ in a labeled record pattern. data HsPatField- = HsPFieldPat HsQName HsPat+ = HsPFieldPat HsQName HsPat #ifdef __GLASGOW_HASKELL__- deriving (Eq,Show,Typeable,Data)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif@@ -458,41 +459,41 @@ -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif data HsGuardedAlts- = HsUnGuardedAlt HsExp -- ^ @->@ /exp/- | HsGuardedAlts [HsGuardedAlt] -- ^ /gdpat/+ = HsUnGuardedAlt HsExp -- ^ @->@ /exp/.+ | HsGuardedAlts [HsGuardedAlt] -- ^ /gdpat/. #ifdef __GLASGOW_HASKELL__- deriving (Eq,Show,Typeable,Data)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif@@ -500,9 +501,9 @@ -- | 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)+ deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif@@ -511,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@@ -541,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)
+ changelog.md view
@@ -0,0 +1,77 @@+## 1.0.4.2++_Andreas Abel, 2025-08-28_++ - Drop support for GHC 7.+ - Tested with GHC 8.0 - 9.14 alpha1.++## 1.0.4.1++_Andreas Abel, 2024-09-22_++ - Replace use of `head` to pacify `-Wx-partial`.+ - Remove upper bound on `happy`.+ - Tested with GHC 8.0 - 9.10.1.++## 1.0.4 Revision 1++_Andreas Abel, 2022-05-25_++ - Support GHC 9.4, allow base-4.17 and higher.++## 1.0.4++_Andreas Abel, 2022-02-07_++ - Add `Eq` instance for `HsModule`.++## 1.0.3.2++_Andreas Abel, 2022-02-07_++ - Version tested with GHC 7.0 - 9.2.+ - Silence warning `incomplete-uni-patterns` in module `ParseMonad` for GHC >= 9.2.+ - Cosmetic documentation changes.++## 1.0.3.1 Revision 5++ - Support happy-1.21.++## 1.0.3.1 Revision 4++ - Support GHC 9.2 & base-4.16.++## 1.0.3.1 Revision 3++ - Support GHC 9.0 & base-4.15.++## 1.0.3.0/1 Revision 2++ - Support happy-1.20.++## 1.0.3.1++_Herbert Valerio Riedel, 2019-11-09_++ - Version for GHC 8.8 and 8.10.++## 1.0.3.0++_Herbert Valerio Riedel, 2018-03-13_++ - Version for GHC 7.10 - 8.6.+ (Dropped support for GHC versions prior to GHC 7.0.)++ - Add support for `MonadFail` & `Semigroup` proposals by+ adding respective instances for `P` and `Lex`.++ - Remove `-O2` from `ghc-options`.++## 1.0.2.0++_Herbert Valerio Riedel, 2015-01-24_++ - Add support for GHC 7.10 & base-4.8.++ - Add missing `Functor` & `Applicative` instances for `P` and `Lex`+ monads needed for AMP compatibility.
− examples/Makefile
@@ -1,18 +0,0 @@-# -------------------------------------------------------------------------------TOP = ../..-include $(TOP)/mk/boilerplate.mk--# -------------------------------------------------------------------------------ifeq "$(way)" ""-HS_PROG = hsparser$(exeext)-endif--HC = $(GHC_INPLACE)-MKDEPENDHS = $(GHC_INPLACE)-SRC_HC_OPTS += -package haskell-src--# -------------------------------------------------------------------------------include $(TOP)/mk/target.mk
− examples/hsparser.hs
@@ -1,110 +0,0 @@--- A simple test program for the Haskell parser,--- originally written by Sven Panne.--module Main (main, mainArgs, testLexer) where--import Data.List-import Language.Haskell.Lexer (lexer, Token(EOF))-import Language.Haskell.ParseMonad (runParserWithMode)-import Language.Haskell.Parser-import Language.Haskell.Syntax-import Language.Haskell.Pretty-import System.Environment-import System.Console.GetOpt--data Flag- = LexOnlyLength -- print number of tokens only- | LexOnlyRev -- print tokens in reverse order- | LexOnly -- print tokens- | ParseLength -- print number of declarations only- | ParseInternal -- print abstract syntax in internal format- | ParsePretty PPLayout -- pretty print in this style- | Help -- give short usage info--title :: String-title = "A simple test program for the haskell-src package"--usage :: String-usage = "usage: hsparser [option] [filename]\n"--options :: [OptDescr Flag]-options =- [ Option ['n'] ["numtokens"] (NoArg LexOnlyLength) "print number of tokens only",- Option ['r'] ["revtokens"] (NoArg LexOnlyRev) "print tokens in reverse order",- Option ['t'] ["tokens"] (NoArg LexOnly) "print tokens",- Option ['d'] ["numdecls"] (NoArg ParseLength) "print number of declarations only",- Option ['a'] ["abstract"] (NoArg ParseInternal) "print abstract syntax in internal format",- Option ['p'] ["pretty"] (OptArg pStyle "STYLE") "pretty print in STYLE[(o)ffside|(s)emicolon|(i)nline|(n)one](default = offside)",- Option ['h','?'] ["help"] (NoArg Help) "display this help and exit"]--pStyle :: Maybe String -> Flag-pStyle Nothing = ParsePretty PPOffsideRule-pStyle (Just s) = ParsePretty $ case s of- "o" -> PPOffsideRule- "offside" -> PPOffsideRule- "s" -> PPSemiColon- "semicolon" -> PPSemiColon- "i" -> PPInLine- "inline" -> PPInLine- "n" -> PPNoLayout- "none" -> PPNoLayout- _ -> PPOffsideRule--main :: IO ()-main = do- args <- getArgs- mainArgs args--mainArgs :: [String] -> IO ()-mainArgs cmdline =- case getOpt Permute options cmdline of- (flags, args, []) -> do- inp <- case args of- [] -> getContents- [f] -> readFile f- _ -> error usage- let parse_mode = case args of- [] -> defaultParseMode- [f] -> defaultParseMode {parseFilename = f}- putStrLn (handleFlag (getFlag flags) parse_mode inp)- (_, _, errors) ->- error (concat errors ++ usageInfo usage options)--getFlag :: [Flag] -> Flag-getFlag [] = ParsePretty PPOffsideRule-getFlag [f] = f-getFlag _ = error usage--handleFlag :: Flag -> ParseMode -> String -> String-handleFlag LexOnlyLength parse_mode = show . length . testLexerRev parse_mode-handleFlag LexOnlyRev parse_mode =- concat . intersperse "\n" . map show . testLexerRev parse_mode-handleFlag LexOnly parse_mode =- concat . intersperse "\n" . map show . testLexer parse_mode-handleFlag ParseLength parse_mode =- show . modLength . testParser parse_mode- where modLength (HsModule _ _ _ imp d) = length imp + length d-handleFlag ParseInternal parse_mode = show . testParser parse_mode-handleFlag (ParsePretty l) parse_mode =- prettyPrintStyleMode style{lineLength=80} defaultMode{layout=l} .- testParser parse_mode-handleFlag Help _parse_mode = const $- usageInfo (title ++ "\n" ++ usage) options--testLexerRev :: ParseMode -> String -> [Token]-testLexerRev parse_mode = getResult . runParserWithMode parse_mode (loop [])- where loop toks = lexer $ \t -> case t of - EOF -> return toks- _ -> loop (t:toks)--testLexer :: ParseMode -> String -> [Token]-testLexer parse_mode = reverse . testLexerRev parse_mode--testParser :: ParseMode -> String -> HsModule-testParser parse_mode = getResult . parseModuleWithMode parse_mode--getResult :: ParseResult a -> a-getResult (ParseOk a) = a-getResult (ParseFailed loc err) =- error (srcFilename loc ++ ":" ++ show (srcLine loc) ++ ":" ++- show (srcColumn loc) ++ ": " ++ err)
haskell-src.cabal view
@@ -1,19 +1,46 @@-name: haskell-src-version: 1.0.1.3-license: BSD3-license-file: LICENSE-author: Simon Marlow, Sven Panne and Noel Winstanley-maintainer: libraries@haskell.org-category: Language-synopsis: Manipulating Haskell source code-description:- Facilities for manipulating Haskell source code:- an abstract syntax, lexer, parser and pretty-printer.+cabal-version: 1.18+name: haskell-src+-- don't forget to update the changelog.md!+version: 1.0.4.2 build-type: Simple-cabal-version: >=1.2 -flag split-base+license: BSD3+license-file: LICENSE+author: Simon Marlow, Sven Panne and Noel Winstanley+maintainer: Andreas Abel+bug-reports: https://github.com/haskell-pkg-janitors/haskell-src/issues+stability: stable+category: Language+synopsis: Support for manipulating Haskell source code+description:+ The @haskell-src@ package provides support for manipulating Haskell+ source code. The package provides a lexer, parser and+ pretty-printer, and a definition of a Haskell abstract syntax tree+ (AST). Common uses of this package are to parse or generate+ <http://www.haskell.org/onlinereport/ Haskell 98> code. +tested-with:+ GHC == 9.14.1+ GHC == 9.12.2+ GHC == 9.10.2+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2++extra-doc-files: changelog.md++source-repository head+ type: git+ location: https://github.com/haskell-pkg-janitors/haskell-src.git+ library exposed-modules: Language.Haskell.Lexer,@@ -22,12 +49,18 @@ Language.Haskell.Pretty, Language.Haskell.Syntax, Language.Haskell.ParseUtils- if flag(split-base)- build-depends: base >= 3 && < 4, pretty, array- else- build-depends: base < 3- build-depends: haskell98- -- The dependency on Haskell 98 is only because- -- Happy generates a parser that imports Array- extensions: CPP- nhc98-options: -K11M++ build-depends: base >= 4.9 && < 5+ -- no confirmed upper bound on base yet+ , syb >= 0.1 && < 0.8+ , pretty >= 1.0.1.2 && < 1.2+ , array >= 0.3 && < 0.6++ build-tools: happy >= 1.19++ default-language: Haskell98++ ghc-options:+ -Wall+ -Wcompat+ -Wnoncanonical-monad-instances
− prologue.txt
@@ -1,2 +0,0 @@-Facilities for manipulating Haskell source code: an abstract syntax,-lexer, parser and pretty-printer.