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