diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ The Glasgow Haskell Compiler License -Copyright 2004, The University Court of the University of Glasgow. +Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -8,14 +8,14 @@ - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without -specific prior written permission. +specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, diff --git a/Language/Haskell/Lexer.hs b/Language/Haskell/Lexer.hs --- a/Language/Haskell/Lexer.hs +++ b/Language/Haskell/Lexer.hs @@ -1,12 +1,11 @@ --- #hide ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Lexer -- Copyright : (c) The GHC Team, 1997-2000 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental +-- License : BSD-3-Clause +-- +-- Maintainer : Andreas Abel +-- Stability : stable -- Portability : portable -- -- Lexer for Haskell. @@ -19,91 +18,91 @@ module Language.Haskell.Lexer (Token(..), lexer) where -import Language.Haskell.ParseMonad +import Language.Haskell.ParseMonad -import Data.Char (isAlpha, isLower, isUpper, toLower, - isDigit, isHexDigit, isOctDigit, isSpace, - ord, chr, digitToInt) -import qualified Data.Char (isSymbol) -import Data.Ratio +import Data.Char (chr, digitToInt, isAlpha, isDigit, + isHexDigit, isLower, isOctDigit, + isSpace, isUpper, ord, toLower) +import qualified Data.Char (isSymbol) +import Data.Ratio data Token = VarId String | QVarId (String,String) - | ConId String + | ConId String | QConId (String,String) | VarSym String | ConSym String | QVarSym (String,String) | QConSym (String,String) - | IntTok Integer - | FloatTok Rational - | Character Char + | IntTok Integer + | FloatTok Rational + | Character Char | StringTok String -- Symbols - | LeftParen - | RightParen - | SemiColon + | LeftParen + | RightParen + | SemiColon | LeftCurly | RightCurly - | VRightCurly -- a virtual close brace + | VRightCurly -- a virtual close brace | LeftSquare | RightSquare - | Comma + | Comma | Underscore | BackQuote -- Reserved operators - | DotDot - | Colon - | DoubleColon - | Equals - | Backslash - | Bar - | LeftArrow - | RightArrow - | At - | Tilde - | DoubleArrow - | Minus - | Exclamation + | DotDot + | Colon + | DoubleColon + | Equals + | Backslash + | Bar + | LeftArrow + | RightArrow + | At + | Tilde + | DoubleArrow + | Minus + | Exclamation -- Reserved Ids - | KW_Case - | KW_Class - | KW_Data - | KW_Default - | KW_Deriving - | KW_Do - | KW_Else - | KW_Foreign - | KW_If - | KW_Import - | KW_In - | KW_Infix - | KW_InfixL - | KW_InfixR - | KW_Instance - | KW_Let - | KW_Module - | KW_NewType - | KW_Of - | KW_Then - | KW_Type - | KW_Where + | KW_Case + | KW_Class + | KW_Data + | KW_Default + | KW_Deriving + | KW_Do + | KW_Else + | KW_Foreign + | KW_If + | KW_Import + | KW_In + | KW_Infix + | KW_InfixL + | KW_InfixR + | KW_Instance + | KW_Let + | KW_Module + | KW_NewType + | KW_Of + | KW_Then + | KW_Type + | KW_Where -- Special Ids - | KW_As - | KW_Export - | KW_Hiding - | KW_Qualified - | KW_Safe - | KW_Unsafe + | KW_As + | KW_Export + | KW_Hiding + | KW_Qualified + | KW_Safe + | KW_Unsafe | EOF deriving (Eq,Show) @@ -125,8 +124,8 @@ special_varops :: [(String,Token)] special_varops = [ - ( "-", Minus ), --ToDo: shouldn't be here - ( "!", Exclamation ) --ditto + ( "-", Minus ), --ToDo: shouldn't be here + ( "!", Exclamation ) --ditto ] reserved_ids :: [(String,Token)] @@ -139,31 +138,31 @@ ( "deriving", KW_Deriving ), ( "do", KW_Do ), ( "else", KW_Else ), - ( "foreign", KW_Foreign ), - ( "if", KW_If ), + ( "foreign", KW_Foreign ), + ( "if", KW_If ), ( "import", KW_Import ), - ( "in", KW_In ), - ( "infix", KW_Infix ), - ( "infixl", KW_InfixL ), - ( "infixr", KW_InfixR ), + ( "in", KW_In ), + ( "infix", KW_Infix ), + ( "infixl", KW_InfixL ), + ( "infixr", KW_InfixR ), ( "instance", KW_Instance ), - ( "let", KW_Let ), - ( "module", KW_Module ), + ( "let", KW_Let ), + ( "module", KW_Module ), ( "newtype", KW_NewType ), - ( "of", KW_Of ), - ( "then", KW_Then ), - ( "type", KW_Type ), - ( "where", KW_Where ) + ( "of", KW_Of ), + ( "then", KW_Then ), + ( "type", KW_Type ), + ( "where", KW_Where ) ] special_varids :: [(String,Token)] special_varids = [ - ( "as", KW_As ), - ( "export", KW_Export ), - ( "hiding", KW_Hiding ), + ( "as", KW_As ), + ( "export", KW_Export ), + ( "hiding", KW_Hiding ), ( "qualified", KW_Qualified ), - ( "safe", KW_Safe ), - ( "unsafe", KW_Unsafe ) + ( "safe", KW_Safe ), + ( "unsafe", KW_Unsafe ) ] isIdent, isSymbol :: Char -> Bool @@ -172,8 +171,10 @@ matchChar :: Char -> String -> Lex a () matchChar c msg = do - s <- getInput - if null s || head s /= c then fail msg else discard 1 + s <- getInput + case s of + c':_ | c == c' -> discard 1 + _ -> fail msg -- The top-level lexer. -- We need to know whether we are at the beginning of the line to decide @@ -181,74 +182,74 @@ lexer :: (Token -> P a) -> P a lexer = runL $ do - bol <- checkBOL - bol <- lexWhiteSpace bol - startToken - if bol then lexBOL else lexToken + bol <- checkBOL + bol' <- lexWhiteSpace bol + startToken + if bol' then lexBOL else lexToken lexWhiteSpace :: Bool -> Lex a Bool lexWhiteSpace bol = do - s <- getInput - case s of - '{':'-':_ -> do - discard 2 - bol <- lexNestedComment bol - lexWhiteSpace bol - '-':'-':rest | all (== '-') (takeWhile isSymbol rest) -> do - lexWhile (== '-') - lexWhile (/= '\n') - s' <- getInput - case s' of - [] -> fail "Unterminated end-of-line comment" - _ -> do - lexNewline - lexWhiteSpace True - '\n':_ -> do - lexNewline - lexWhiteSpace True - '\t':_ -> do - lexTab - lexWhiteSpace bol - c:_ | isSpace c -> do - discard 1 - lexWhiteSpace bol - _ -> return bol + s <- getInput + case s of + '{':'-':_ -> do + discard 2 + bol' <- lexNestedComment bol + lexWhiteSpace bol' + '-':'-':rest | all (== '-') (takeWhile isSymbol rest) -> do + _ <- lexWhile (== '-') + _ <- lexWhile (/= '\n') + s' <- getInput + case s' of + [] -> fail "Unterminated end-of-line comment" + _ -> do + lexNewline + lexWhiteSpace True + '\n':_ -> do + lexNewline + lexWhiteSpace True + '\t':_ -> do + lexTab + lexWhiteSpace bol + c:_ | isSpace c -> do + discard 1 + lexWhiteSpace bol + _ -> return bol lexNestedComment :: Bool -> Lex a Bool lexNestedComment bol = do - s <- getInput - case s of - '-':'}':_ -> discard 2 >> return bol - '{':'-':_ -> do - discard 2 - bol <- lexNestedComment bol -- rest of the subcomment - lexNestedComment bol -- rest of this comment - '\t':_ -> lexTab >> lexNestedComment bol - '\n':_ -> lexNewline >> lexNestedComment True - _:_ -> discard 1 >> lexNestedComment bol - [] -> fail "Unterminated nested comment" + s <- getInput + case s of + '-':'}':_ -> discard 2 >> return bol + '{':'-':_ -> do + discard 2 + bol' <- lexNestedComment bol -- rest of the subcomment + lexNestedComment bol' -- rest of this comment + '\t':_ -> lexTab >> lexNestedComment bol + '\n':_ -> lexNewline >> lexNestedComment True + _:_ -> discard 1 >> lexNestedComment bol + [] -> fail "Unterminated nested comment" -- When we are lexing the first token of a line, check whether we need to -- insert virtual semicolons or close braces due to layout. lexBOL :: Lex a Token lexBOL = do - pos <- getOffside - case pos of - LT -> do + pos <- getOffside + case pos of + LT -> do -- trace "layout: inserting '}'\n" $ - -- Set col to 0, indicating that we're still at the - -- beginning of the line, in case we need a semi-colon too. - -- Also pop the context here, so that we don't insert - -- another close brace before the parser can pop it. - setBOL - popContextL "lexBOL" - return VRightCurly - EQ -> + -- Set col to 0, indicating that we're still at the + -- beginning of the line, in case we need a semi-colon too. + -- Also pop the context here, so that we don't insert + -- another close brace before the parser can pop it. + setBOL + popContextL "lexBOL" + return VRightCurly + EQ -> -- trace "layout: inserting ';'\n" $ - return SemiColon - GT -> - lexToken + return SemiColon + GT -> + lexToken lexToken :: Lex a Token lexToken = do @@ -256,284 +257,284 @@ case s of [] -> return EOF - '0':c:d:_ | toLower c == 'o' && isOctDigit d -> do - discard 2 - n <- lexOctal - return (IntTok n) - | toLower c == 'x' && isHexDigit d -> do - discard 2 - n <- lexHexadecimal - return (IntTok n) + '0':c:d:_ | toLower c == 'o' && isOctDigit d -> do + discard 2 + n <- lexOctal + return (IntTok n) + | toLower c == 'x' && isHexDigit d -> do + discard 2 + n <- lexHexadecimal + return (IntTok n) - c:_ | isDigit c -> lexDecimalOrFloat + c:_ | isDigit c -> lexDecimalOrFloat - | isUpper c -> lexConIdOrQual "" + | isUpper c -> lexConIdOrQual "" - | isLower c || c == '_' -> do - ident <- lexWhile isIdent - return $ case lookup ident (reserved_ids ++ special_varids) of - Just keyword -> keyword - Nothing -> VarId ident + | isLower c || c == '_' -> do + ident <- lexWhile isIdent + return $ case lookup ident (reserved_ids ++ special_varids) of + Just keyword -> keyword + Nothing -> VarId ident - | isSymbol c -> do - sym <- lexWhile isSymbol - return $ case lookup sym (reserved_ops ++ special_varops) of - Just t -> t - Nothing -> case c of - ':' -> ConSym sym - _ -> VarSym sym + | isSymbol c -> do + sym <- lexWhile isSymbol + return $ case lookup sym (reserved_ops ++ special_varops) of + Just t -> t + Nothing -> case c of + ':' -> ConSym sym + _ -> VarSym sym - | otherwise -> do - discard 1 - case c of + | otherwise -> do + discard 1 + case c of - -- First the special symbols - '(' -> return LeftParen - ')' -> return RightParen - ',' -> return Comma - ';' -> return SemiColon - '[' -> return LeftSquare - ']' -> return RightSquare - '`' -> return BackQuote - '{' -> do - pushContextL NoLayout - return LeftCurly - '}' -> do - popContextL "lexToken" - return RightCurly + -- First the special symbols + '(' -> return LeftParen + ')' -> return RightParen + ',' -> return Comma + ';' -> return SemiColon + '[' -> return LeftSquare + ']' -> return RightSquare + '`' -> return BackQuote + '{' -> do + pushContextL NoLayout + return LeftCurly + '}' -> do + popContextL "lexToken" + return RightCurly - '\'' -> do - c2 <- lexChar - matchChar '\'' "Improperly terminated character constant" - return (Character c2) + '\'' -> do + c2 <- lexChar + matchChar '\'' "Improperly terminated character constant" + return (Character c2) - '"' -> lexString + '"' -> lexString - _ -> fail ("Illegal character \'" ++ show c ++ "\'\n") + _ -> fail ("Illegal character \'" ++ show c ++ "\'\n") lexDecimalOrFloat :: Lex a Token lexDecimalOrFloat = do - ds <- lexWhile isDigit - rest <- getInput - case rest of - ('.':d:_) | isDigit d -> do - discard 1 - frac <- lexWhile isDigit - let num = parseInteger 10 (ds ++ frac) - decimals = toInteger (length frac) - exponent <- do - rest2 <- getInput - case rest2 of - 'e':_ -> lexExponent - 'E':_ -> lexExponent - _ -> return 0 - return (FloatTok ((num%1) * 10^^(exponent - decimals))) - e:_ | toLower e == 'e' -> do - exponent <- lexExponent - return (FloatTok ((parseInteger 10 ds%1) * 10^^exponent)) - _ -> return (IntTok (parseInteger 10 ds)) + ds <- lexWhile isDigit + rest <- getInput + case rest of + ('.':d:_) | isDigit d -> do + discard 1 + frac <- lexWhile isDigit + let num = parseInteger 10 (ds ++ frac) + decimals = toInteger (length frac) + exponent' <- do + rest2 <- getInput + case rest2 of + 'e':_ -> lexExponent + 'E':_ -> lexExponent + _ -> return 0 + return (FloatTok ((num%1) * 10^^(exponent' - decimals))) + e:_ | toLower e == 'e' -> do + exponent' <- lexExponent + return (FloatTok ((parseInteger 10 ds%1) * 10^^exponent')) + _ -> return (IntTok (parseInteger 10 ds)) where - lexExponent :: Lex a Integer - lexExponent = do - discard 1 -- 'e' or 'E' - r <- getInput - case r of - '+':d:_ | isDigit d -> do - discard 1 - lexDecimal - '-':d:_ | isDigit d -> do - discard 1 - n <- lexDecimal - return (negate n) - d:_ | isDigit d -> lexDecimal - _ -> fail "Float with missing exponent" + lexExponent :: Lex a Integer + lexExponent = do + discard 1 -- 'e' or 'E' + r <- getInput + case r of + '+':d:_ | isDigit d -> do + discard 1 + lexDecimal + '-':d:_ | isDigit d -> do + discard 1 + n <- lexDecimal + return (negate n) + d:_ | isDigit d -> lexDecimal + _ -> fail "Float with missing exponent" lexConIdOrQual :: String -> Lex a Token lexConIdOrQual qual = do - con <- lexWhile isIdent - let conid | null qual = ConId con - | otherwise = QConId (qual,con) - qual' | null qual = con - | otherwise = qual ++ '.':con - just_a_conid <- alternative (return conid) - rest <- getInput - case rest of - '.':c:_ - | isLower c || c == '_' -> do -- qualified varid? - discard 1 - ident <- lexWhile isIdent - case lookup ident reserved_ids of - -- cannot qualify a reserved word - Just _ -> just_a_conid - Nothing -> return (QVarId (qual', ident)) + con <- lexWhile isIdent + let conid | null qual = ConId con + | otherwise = QConId (qual,con) + qual' | null qual = con + | otherwise = qual ++ '.':con + just_a_conid <- alternative (return conid) + rest <- getInput + case rest of + '.':c:_ + | isLower c || c == '_' -> do -- qualified varid? + discard 1 + ident <- lexWhile isIdent + case lookup ident reserved_ids of + -- cannot qualify a reserved word + Just _ -> just_a_conid + Nothing -> return (QVarId (qual', ident)) - | isUpper c -> do -- qualified conid? - discard 1 - lexConIdOrQual qual' + | isUpper c -> do -- qualified conid? + discard 1 + lexConIdOrQual qual' - | isSymbol c -> do -- qualified symbol? - discard 1 - sym <- lexWhile isSymbol - case lookup sym reserved_ops of - -- cannot qualify a reserved operator - Just _ -> just_a_conid - Nothing -> return $ case c of - ':' -> QConSym (qual', sym) - _ -> QVarSym (qual', sym) + | isSymbol c -> do -- qualified symbol? + discard 1 + sym <- lexWhile isSymbol + case lookup sym reserved_ops of + -- cannot qualify a reserved operator + Just _ -> just_a_conid + Nothing -> return $ case c of + ':' -> QConSym (qual', sym) + _ -> QVarSym (qual', sym) - _ -> return conid -- not a qualified thing + _ -> return conid -- not a qualified thing lexChar :: Lex a Char lexChar = do - r <- getInput - case r of - '\\':_ -> lexEscape - c:_ -> discard 1 >> return c - [] -> fail "Incomplete character constant" + r <- getInput + case r of + '\\':_ -> lexEscape + c:_ -> discard 1 >> return c + [] -> fail "Incomplete character constant" lexString :: Lex a Token lexString = loop "" where - loop s = do - r <- getInput - case r of - '\\':'&':_ -> do - discard 2 - loop s - '\\':c:_ | isSpace c -> do - discard 1 - lexWhiteChars - matchChar '\\' "Illegal character in string gap" - loop s - | otherwise -> do - ce <- lexEscape - loop (ce:s) - '"':_ -> do - discard 1 - return (StringTok (reverse s)) - c:_ -> do - discard 1 - loop (c:s) - [] -> fail "Improperly terminated string" + loop s = do + r <- getInput + case r of + '\\':'&':_ -> do + discard 2 + loop s + '\\':c:_ | isSpace c -> do + discard 1 + lexWhiteChars + matchChar '\\' "Illegal character in string gap" + loop s + | otherwise -> do + ce <- lexEscape + loop (ce:s) + '"':_ -> do + discard 1 + return (StringTok (reverse s)) + c:_ -> do + discard 1 + loop (c:s) + [] -> fail "Improperly terminated string" - lexWhiteChars :: Lex a () - lexWhiteChars = do - s <- getInput - case s of - '\n':_ -> do - lexNewline - lexWhiteChars - '\t':_ -> do - lexTab - lexWhiteChars - c:_ | isSpace c -> do - discard 1 - lexWhiteChars - _ -> return () + lexWhiteChars :: Lex a () + lexWhiteChars = do + s <- getInput + case s of + '\n':_ -> do + lexNewline + lexWhiteChars + '\t':_ -> do + lexTab + lexWhiteChars + c:_ | isSpace c -> do + discard 1 + lexWhiteChars + _ -> return () lexEscape :: Lex a Char lexEscape = do - discard 1 - r <- getInput - case r of + discard 1 + r <- getInput + case r of -- Production charesc from section B.2 (Note: \& is handled by caller) - 'a':_ -> discard 1 >> return '\a' - 'b':_ -> discard 1 >> return '\b' - 'f':_ -> discard 1 >> return '\f' - 'n':_ -> discard 1 >> return '\n' - 'r':_ -> discard 1 >> return '\r' - 't':_ -> discard 1 >> return '\t' - 'v':_ -> discard 1 >> return '\v' - '\\':_ -> discard 1 >> return '\\' - '"':_ -> discard 1 >> return '\"' - '\'':_ -> discard 1 >> return '\'' + 'a':_ -> discard 1 >> return '\a' + 'b':_ -> discard 1 >> return '\b' + 'f':_ -> discard 1 >> return '\f' + 'n':_ -> discard 1 >> return '\n' + 'r':_ -> discard 1 >> return '\r' + 't':_ -> discard 1 >> return '\t' + 'v':_ -> discard 1 >> return '\v' + '\\':_ -> discard 1 >> return '\\' + '"':_ -> discard 1 >> return '\"' + '\'':_ -> discard 1 >> return '\'' -- Production ascii from section B.2 - '^':c:_ -> discard 2 >> cntrl c - 'N':'U':'L':_ -> discard 3 >> return '\NUL' - 'S':'O':'H':_ -> discard 3 >> return '\SOH' - 'S':'T':'X':_ -> discard 3 >> return '\STX' - 'E':'T':'X':_ -> discard 3 >> return '\ETX' - 'E':'O':'T':_ -> discard 3 >> return '\EOT' - 'E':'N':'Q':_ -> discard 3 >> return '\ENQ' - 'A':'C':'K':_ -> discard 3 >> return '\ACK' - 'B':'E':'L':_ -> discard 3 >> return '\BEL' - 'B':'S':_ -> discard 2 >> return '\BS' - 'H':'T':_ -> discard 2 >> return '\HT' - 'L':'F':_ -> discard 2 >> return '\LF' - 'V':'T':_ -> discard 2 >> return '\VT' - 'F':'F':_ -> discard 2 >> return '\FF' - 'C':'R':_ -> discard 2 >> return '\CR' - 'S':'O':_ -> discard 2 >> return '\SO' - 'S':'I':_ -> discard 2 >> return '\SI' - 'D':'L':'E':_ -> discard 3 >> return '\DLE' - 'D':'C':'1':_ -> discard 3 >> return '\DC1' - 'D':'C':'2':_ -> discard 3 >> return '\DC2' - 'D':'C':'3':_ -> discard 3 >> return '\DC3' - 'D':'C':'4':_ -> discard 3 >> return '\DC4' - 'N':'A':'K':_ -> discard 3 >> return '\NAK' - 'S':'Y':'N':_ -> discard 3 >> return '\SYN' - 'E':'T':'B':_ -> discard 3 >> return '\ETB' - 'C':'A':'N':_ -> discard 3 >> return '\CAN' - 'E':'M':_ -> discard 2 >> return '\EM' - 'S':'U':'B':_ -> discard 3 >> return '\SUB' - 'E':'S':'C':_ -> discard 3 >> return '\ESC' - 'F':'S':_ -> discard 2 >> return '\FS' - 'G':'S':_ -> discard 2 >> return '\GS' - 'R':'S':_ -> discard 2 >> return '\RS' - 'U':'S':_ -> discard 2 >> return '\US' - 'S':'P':_ -> discard 2 >> return '\SP' - 'D':'E':'L':_ -> discard 3 >> return '\DEL' + '^':c:_ -> discard 2 >> cntrl c + 'N':'U':'L':_ -> discard 3 >> return '\NUL' + 'S':'O':'H':_ -> discard 3 >> return '\SOH' + 'S':'T':'X':_ -> discard 3 >> return '\STX' + 'E':'T':'X':_ -> discard 3 >> return '\ETX' + 'E':'O':'T':_ -> discard 3 >> return '\EOT' + 'E':'N':'Q':_ -> discard 3 >> return '\ENQ' + 'A':'C':'K':_ -> discard 3 >> return '\ACK' + 'B':'E':'L':_ -> discard 3 >> return '\BEL' + 'B':'S':_ -> discard 2 >> return '\BS' + 'H':'T':_ -> discard 2 >> return '\HT' + 'L':'F':_ -> discard 2 >> return '\LF' + 'V':'T':_ -> discard 2 >> return '\VT' + 'F':'F':_ -> discard 2 >> return '\FF' + 'C':'R':_ -> discard 2 >> return '\CR' + 'S':'O':_ -> discard 2 >> return '\SO' + 'S':'I':_ -> discard 2 >> return '\SI' + 'D':'L':'E':_ -> discard 3 >> return '\DLE' + 'D':'C':'1':_ -> discard 3 >> return '\DC1' + 'D':'C':'2':_ -> discard 3 >> return '\DC2' + 'D':'C':'3':_ -> discard 3 >> return '\DC3' + 'D':'C':'4':_ -> discard 3 >> return '\DC4' + 'N':'A':'K':_ -> discard 3 >> return '\NAK' + 'S':'Y':'N':_ -> discard 3 >> return '\SYN' + 'E':'T':'B':_ -> discard 3 >> return '\ETB' + 'C':'A':'N':_ -> discard 3 >> return '\CAN' + 'E':'M':_ -> discard 2 >> return '\EM' + 'S':'U':'B':_ -> discard 3 >> return '\SUB' + 'E':'S':'C':_ -> discard 3 >> return '\ESC' + 'F':'S':_ -> discard 2 >> return '\FS' + 'G':'S':_ -> discard 2 >> return '\GS' + 'R':'S':_ -> discard 2 >> return '\RS' + 'U':'S':_ -> discard 2 >> return '\US' + 'S':'P':_ -> discard 2 >> return '\SP' + 'D':'E':'L':_ -> discard 3 >> return '\DEL' -- Escaped numbers - 'o':c:_ | isOctDigit c -> do - discard 1 - n <- lexOctal - checkChar n - 'x':c:_ | isHexDigit c -> do - discard 1 - n <- lexHexadecimal - checkChar n - c:_ | isDigit c -> do - n <- lexDecimal - checkChar n + 'o':c:_ | isOctDigit c -> do + discard 1 + n <- lexOctal + checkChar n + 'x':c:_ | isHexDigit c -> do + discard 1 + n <- lexHexadecimal + checkChar n + c:_ | isDigit c -> do + n <- lexDecimal + checkChar n - _ -> fail "Illegal escape sequence" + _ -> fail "Illegal escape sequence" where - checkChar n | n <= 0x10FFFF = return (chr (fromInteger n)) - checkChar _ = fail "Character constant out of range" + checkChar n | n <= 0x10FFFF = return (chr (fromInteger n)) + checkChar _ = fail "Character constant out of range" -- Production cntrl from section B.2 - cntrl :: Char -> Lex a Char - cntrl c | c >= '@' && c <= '_' = return (chr (ord c - ord '@')) - cntrl _ = fail "Illegal control character" + cntrl :: Char -> Lex a Char + cntrl c | c >= '@' && c <= '_' = return (chr (ord c - ord '@')) + cntrl _ = fail "Illegal control character" -- assumes at least one octal digit lexOctal :: Lex a Integer lexOctal = do - ds <- lexWhile isOctDigit - return (parseInteger 8 ds) + ds <- lexWhile isOctDigit + return (parseInteger 8 ds) -- assumes at least one hexadecimal digit lexHexadecimal :: Lex a Integer lexHexadecimal = do - ds <- lexWhile isHexDigit - return (parseInteger 16 ds) + ds <- lexWhile isHexDigit + return (parseInteger 16 ds) -- assumes at least one decimal digit lexDecimal :: Lex a Integer lexDecimal = do - ds <- lexWhile isDigit - return (parseInteger 10 ds) + ds <- lexWhile isDigit + return (parseInteger 10 ds) -- Stolen from Hugs's Prelude parseInteger :: Integer -> String -> Integer parseInteger radix ds = - foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds) + foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds) diff --git a/Language/Haskell/ParseMonad.hs b/Language/Haskell/ParseMonad.hs --- a/Language/Haskell/ParseMonad.hs +++ b/Language/Haskell/ParseMonad.hs @@ -1,46 +1,82 @@ --- #hide ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.ParseMonad -- Copyright : (c) The GHC Team, 1997-2000 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental +-- License : BSD-3-Clause +-- +-- Maintainer : Andreas Abel +-- Stability : stable -- Portability : portable -- -- Monads for the Haskell parser and lexer. -- ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 900 +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +#endif + module Language.Haskell.ParseMonad( - -- * Parsing - P, ParseResult(..), atSrcLoc, LexContext(..), - ParseMode(..), defaultParseMode, - runParserWithMode, runParser, - getSrcLoc, pushCurrentContext, popContext, - -- * Lexing - Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile, - alternative, checkBOL, setBOL, startToken, getOffside, - pushContextL, popContextL - ) where + -- * Parsing + P, ParseResult(..), atSrcLoc, LexContext(..), + ParseMode(..), defaultParseMode, + runParserWithMode, runParser, + getSrcLoc, pushCurrentContext, popContext, + -- * Lexing + Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile, + alternative, checkBOL, setBOL, startToken, getOffside, + pushContextL, popContextL + ) where -import Language.Haskell.Syntax(SrcLoc(..)) +import Control.Applicative as App +import Control.Monad (ap, liftM) +import qualified Control.Monad.Fail as Fail +import Data.Semigroup as Semi +import Language.Haskell.Syntax (SrcLoc (..)) -- | The result of a parse. data ParseResult a - = ParseOk a -- ^ The parse succeeded, yielding a value. - | ParseFailed SrcLoc String - -- ^ The parse failed at the specified - -- source location, with an error message. - deriving Show + = ParseOk a -- ^ The parse succeeded, yielding a value. + | ParseFailed SrcLoc String + -- ^ The parse failed at the specified + -- source location, with an error message. + deriving Show +instance Functor ParseResult where + fmap f (ParseOk x) = ParseOk $ f x + fmap _ (ParseFailed loc msg) = ParseFailed loc msg + +instance App.Applicative ParseResult where + pure = ParseOk + ParseOk f <*> x = f <$> x + ParseFailed loc msg <*> _ = ParseFailed loc msg + +instance Monad ParseResult where + return = pure + ParseOk x >>= f = f x + ParseFailed loc msg >>= _ = ParseFailed loc msg + +-- TODO: relax constraint to 'Semigroup s => Semigroup (ParseResult +-- s)' in the long distant future + +-- | @since 1.0.3.0 +instance Monoid m => Semi.Semigroup (ParseResult m) where + ParseOk x <> ParseOk y = ParseOk $ x `mappend` y + ParseOk _ <> err = err + err <> _ = err -- left-biased + +instance Monoid m => Monoid (ParseResult m) where + mempty = ParseOk mempty + mappend = (<>) + -- internal version data ParseStatus a = Ok ParseState a | Failed SrcLoc String - deriving Show + deriving Show data LexContext = NoLayout | Layout Int - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) type ParseState = [LexContext] @@ -52,51 +88,66 @@ -- More to come later, e.g. literate mode, language extensions. data ParseMode = ParseMode { - -- | original name of the file being parsed - parseFilename :: String - } + -- | original name of the file being parsed + parseFilename :: String + } -- | Default parameters for a parse, -- currently just a marker for an unknown filename. defaultParseMode :: ParseMode defaultParseMode = ParseMode { - parseFilename = "" - } + 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 +-- | @since 1.0.2.0 +instance Functor P where + fmap = liftM + +-- | @since 1.0.2.0 +instance Applicative P where + pure a = P $ \_i _x _y _l s _m -> Ok s a + (<*>) = ap + instance Monad P where - return a = P $ \_i _x _y _l s _m -> Ok s a - P m >>= k = P $ \i x y l s mode -> - case m i x y l s mode of - Failed loc msg -> Failed loc msg - Ok s' a -> runP (k a) i x y l s' mode - fail s = P $ \_r _col _line loc _stk _m -> Failed loc s + return = pure + P m >>= k = P $ \i x y l s mode -> + case m i x y l s mode of + Failed loc msg -> Failed loc msg + Ok s' a -> runP (k a) i x y l s' mode +#if !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif +-- | @since 1.0.3.0 +instance Fail.MonadFail P where + fail s = P $ \_r _col _line loc _stk _m -> Failed loc s + atSrcLoc :: P a -> SrcLoc -> P a P m `atSrcLoc` loc = P $ \i x y _l -> m i x y loc @@ -110,22 +161,22 @@ pushCurrentContext :: P () pushCurrentContext = do - loc <- getSrcLoc - indent <- currentIndent - pushContext (Layout (max (indent+1) (srcColumn loc))) + loc <- getSrcLoc + indent <- currentIndent + pushContext (Layout (max (indent+1) (srcColumn loc))) currentIndent :: P Int -currentIndent = P $ \_r _x _y loc stk _mode -> Ok stk (indentOfParseState stk) +currentIndent = P $ \_r _x _y _loc stk _mode -> Ok stk (indentOfParseState stk) pushContext :: LexContext -> P () pushContext ctxt = --trace ("pushing lexical scope: " ++ show ctxt ++"\n") $ - P $ \_i _x _y _l s _m -> Ok (ctxt:s) () + P $ \_i _x _y _l s _m -> Ok (ctxt:s) () popContext :: P () popContext = P $ \_i _x _y _l stk _m -> case stk of - (_:s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $ + (_:s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $ Ok s () [] -> error "Internal error: empty context in popContext" @@ -134,12 +185,28 @@ newtype Lex r a = Lex { runL :: (a -> P r) -> P r } +-- | @since 1.0.2.0 +instance Functor (Lex r) where + fmap = liftM + +-- | @since 1.0.2.0 +instance Applicative (Lex r) where + pure a = Lex $ \k -> k a + (<*>) = ap + Lex v *> Lex w = Lex $ \k -> v (\_ -> w k) + instance Monad (Lex r) where - return a = Lex $ \k -> k a - Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k) - Lex v >> Lex w = Lex $ \k -> v (\_ -> w k) - fail s = Lex $ \_ -> fail s + return = pure + Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k) + (>>) = (*>) +#if !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif +-- | @since 1.0.3.0 +instance Fail.MonadFail (Lex r) where + fail s = Lex $ \_ -> Fail.fail s + -- Operations on this monad getInput :: Lex r String @@ -170,16 +237,16 @@ lexWhile :: (Char -> Bool) -> Lex a String lexWhile p = Lex $ \cont -> P $ \r x -> - let (cs,rest) = span p r in - runP (cont cs) rest (x + length cs) + let (cs,rest) = span p r in + runP (cont cs) rest (x + length cs) -- An alternative scan, to which we can return if subsequent scanning -- is unsuccessful. alternative :: Lex a v -> Lex a (Lex a v) alternative (Lex v) = Lex $ \cont -> P $ \r x y -> - runP (cont (Lex $ \cont' -> P $ \_r _x _y -> - runP (v cont') r x y)) r x y + runP (cont (Lex $ \cont' -> P $ \_r _x _y -> + runP (v cont') r x y)) r x y -- The source location is the coordinates of the previous token, -- or, while scanning a token, the start of the current token. @@ -198,8 +265,8 @@ checkBOL :: Lex a Bool checkBOL = Lex $ \cont -> P $ \r x y loc -> - if x == 0 then runP (cont True) r (srcColumn loc) y loc - else runP (cont False) r x y loc + if x == 0 then runP (cont True) r (srcColumn loc) y loc + else runP (cont False) r x y loc setBOL :: Lex a () setBOL = Lex $ \cont -> P $ \r _ -> runP (cont ()) r 0 @@ -208,12 +275,12 @@ startToken :: Lex a () startToken = Lex $ \cont -> P $ \s x y _ stk mode -> - let loc = SrcLoc { - srcFilename = parseFilename mode, - srcLine = y, - srcColumn = x - } in - runP (cont ()) s x y loc stk mode + let loc = SrcLoc { + srcFilename = parseFilename mode, + srcLine = y, + srcColumn = x + } in + runP (cont ()) s x y loc stk mode -- Current status with respect to the offside (layout) rule: -- LT: we are to the left of the current indent (if any) @@ -222,13 +289,13 @@ getOffside :: Lex a Ordering getOffside = Lex $ \cont -> P $ \r x y loc stk -> - runP (cont (compare x (indentOfParseState stk))) r x y loc stk + runP (cont (compare x (indentOfParseState stk))) r x y loc stk pushContextL :: LexContext -> Lex a () pushContextL ctxt = Lex $ \cont -> P $ \r x y loc stk -> - runP (cont ()) r x y loc (ctxt:stk) + runP (cont ()) r x y loc (ctxt:stk) popContextL :: String -> Lex a () popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case stk of - (_:ctxt) -> runP (cont ()) r x y loc ctxt - [] -> error ("Internal error: empty context in " ++ fn) + (_:ctxt) -> runP (cont ()) r x y loc ctxt + [] -> error ("Internal error: empty context in " ++ fn) diff --git a/Language/Haskell/ParseUtils.hs b/Language/Haskell/ParseUtils.hs --- a/Language/Haskell/ParseUtils.hs +++ b/Language/Haskell/ParseUtils.hs @@ -1,12 +1,11 @@ --- #hide ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.ParseUtils -- Copyright : (c) The GHC Team, 1997-2000 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental +-- License : BSD-3-Clause +-- +-- Maintainer : Andreas Abel +-- Stability : stable -- Portability : portable -- -- Utilities for the Haskell parser. @@ -14,62 +13,62 @@ ----------------------------------------------------------------------------- module Language.Haskell.ParseUtils ( - splitTyConApp -- HsType -> P (HsName,[HsType]) - , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp - , checkPrec -- Integer -> P Int - , checkContext -- HsType -> P HsContext - , checkAssertion -- HsType -> P HsAsst - , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) - , checkClassHeader -- HsQualType -> P (HsContext,HsName,[HsName]) - , checkInstHeader -- HsQualType -> P (HsContext,HsQName,[HsType]) - , checkPattern -- HsExp -> P HsPat - , checkExpr -- HsExp -> P HsExp - , checkValDef -- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl - , checkClassBody -- [HsDecl] -> P [HsDecl] - , checkUnQual -- HsQName -> P HsName - , checkRevDecls -- [HsDecl] -> P [HsDecl] + splitTyConApp -- HsType -> P (HsName,[HsType]) + , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp + , checkPrec -- Integer -> P Int + , checkContext -- HsType -> P HsContext + , checkAssertion -- HsType -> P HsAsst + , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) + , checkClassHeader -- HsQualType -> P (HsContext,HsName,[HsName]) + , checkInstHeader -- HsQualType -> P (HsContext,HsQName,[HsType]) + , checkPattern -- HsExp -> P HsPat + , checkExpr -- HsExp -> P HsExp + , checkValDef -- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl + , checkClassBody -- [HsDecl] -> P [HsDecl] + , checkUnQual -- HsQName -> P HsName + , checkRevDecls -- [HsDecl] -> P [HsDecl] ) where -import Language.Haskell.Syntax -import Language.Haskell.ParseMonad -import Language.Haskell.Pretty +import Language.Haskell.ParseMonad +import Language.Haskell.Pretty +import Language.Haskell.Syntax splitTyConApp :: HsType -> P (HsName,[HsType]) splitTyConApp t0 = split t0 [] where - split :: HsType -> [HsType] -> P (HsName,[HsType]) - split (HsTyApp t u) ts = split t (u:ts) - split (HsTyCon (UnQual t)) ts = return (t,ts) - split _ _ = fail "Illegal data/newtype declaration" + split :: HsType -> [HsType] -> P (HsName,[HsType]) + split (HsTyApp t u) ts = split t (u:ts) + split (HsTyCon (UnQual t)) ts = return (t,ts) + split _ _ = fail "Illegal data/newtype declaration" ----------------------------------------------------------------------------- -- Various Syntactic Checks checkContext :: HsType -> P HsContext checkContext (HsTyTuple ts) = - mapM checkAssertion ts + mapM checkAssertion ts checkContext t = do - c <- checkAssertion t - return [c] + c <- checkAssertion t + return [c] -- Changed for multi-parameter type classes checkAssertion :: HsType -> P HsAsst checkAssertion = checkAssertion' [] - where checkAssertion' ts (HsTyCon c) = return (c,ts) - checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a - checkAssertion' _ _ = fail "Illegal class assertion" + where checkAssertion' ts (HsTyCon c) = return (c,ts) + checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a + checkAssertion' _ _ = fail "Illegal class assertion" checkDataHeader :: HsQualType -> P (HsContext,HsName,[HsName]) checkDataHeader (HsQualType cs t) = do - (c,ts) <- checkSimple "data/newtype" t [] - return (cs,c,ts) + (c,ts) <- checkSimple "data/newtype" t [] + return (cs,c,ts) checkClassHeader :: HsQualType -> P (HsContext,HsName,[HsName]) checkClassHeader (HsQualType cs t) = do - (c,ts) <- checkSimple "class" t [] - return (cs,c,ts) + (c,ts) <- checkSimple "class" t [] + return (cs,c,ts) checkSimple :: String -> HsType -> [HsName] -> P ((HsName,[HsName])) checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs) @@ -78,13 +77,13 @@ checkInstHeader :: HsQualType -> P (HsContext,HsQName,[HsType]) checkInstHeader (HsQualType cs t) = do - (c,ts) <- checkInsts t [] - return (cs,c,ts) + (c,ts) <- checkInsts t [] + return (cs,c,ts) checkInsts :: HsType -> [HsType] -> P ((HsQName,[HsType])) checkInsts (HsTyApp l t) ts = checkInsts l (t:ts) checkInsts (HsTyCon c) ts = return (c,ts) -checkInsts _ _ = fail "Illegal instance declaration" +checkInsts _ _ = fail "Illegal instance declaration" ----------------------------------------------------------------------------- -- Checking Patterns. @@ -98,45 +97,45 @@ checkPat :: HsExp -> [HsPat] -> P HsPat checkPat (HsCon c) args = return (HsPApp c args) checkPat (HsApp f x) args = do - x <- checkPat x [] - checkPat f (x:args) + x' <- checkPat x [] + checkPat f (x':args) checkPat e [] = case e of - HsVar (UnQual x) -> return (HsPVar x) - HsLit l -> return (HsPLit l) - HsInfixApp l op r -> do - l <- checkPat l [] - r <- checkPat r [] - case op of - HsQConOp c -> return (HsPInfixApp l c r) - _ -> patFail - HsTuple es -> do - ps <- mapM (\e -> checkPat e []) es - return (HsPTuple ps) - HsList es -> do - ps <- mapM (\e -> checkPat e []) es - return (HsPList ps) - HsParen e -> do - p <- checkPat e [] - return (HsPParen p) - HsAsPat n e -> do - p <- checkPat e [] - return (HsPAsPat n p) - HsWildCard -> return HsPWildCard - HsIrrPat e -> do - p <- checkPat e [] - return (HsPIrrPat p) - HsRecConstr c fs -> do - fs <- mapM checkPatField fs - return (HsPRec c fs) - HsNegApp (HsLit l) -> return (HsPNeg (HsPLit l)) - _ -> patFail + HsVar (UnQual x) -> return (HsPVar x) + HsLit l -> return (HsPLit l) + HsInfixApp l op r -> do + l' <- checkPat l [] + r' <- checkPat r [] + case op of + HsQConOp c -> return (HsPInfixApp l' c r') + _ -> patFail + HsTuple es -> do + ps <- mapM (\e' -> checkPat e' []) es + return (HsPTuple ps) + HsList es -> do + ps <- mapM (\e' -> checkPat e' []) es + return (HsPList ps) + HsParen e' -> do + p <- checkPat e' [] + return (HsPParen p) + HsAsPat n e' -> do + p <- checkPat e' [] + return (HsPAsPat n p) + HsWildCard -> return HsPWildCard + HsIrrPat e' -> do + p <- checkPat e' [] + return (HsPIrrPat p) + HsRecConstr c fs -> do + fs' <- mapM checkPatField fs + return (HsPRec c fs') + HsNegApp (HsLit l) -> return (HsPNeg (HsPLit l)) + _ -> patFail checkPat _ _ = patFail checkPatField :: HsFieldUpdate -> P HsPatField checkPatField (HsFieldUpdate n e) = do - p <- checkPat e [] - return (HsPFieldPat n p) + p <- checkPat e [] + return (HsPFieldPat n p) patFail :: P a patFail = fail "Parse error in pattern" @@ -146,89 +145,89 @@ checkExpr :: HsExp -> P HsExp checkExpr e = case e of - HsVar _ -> return e - HsCon _ -> return e - HsLit _ -> return e - HsInfixApp e1 op e2 -> check2Exprs e1 e2 (flip HsInfixApp op) - HsApp e1 e2 -> check2Exprs e1 e2 HsApp - HsNegApp e -> check1Expr e HsNegApp - HsLambda loc ps e -> check1Expr e (HsLambda loc ps) - HsLet bs e -> check1Expr e (HsLet bs) - HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf - HsCase e alts -> do - alts <- mapM checkAlt alts - e <- checkExpr e - return (HsCase e alts) - HsDo stmts -> do - stmts <- mapM checkStmt stmts - return (HsDo stmts) - HsTuple es -> checkManyExprs es HsTuple - HsList es -> checkManyExprs es HsList - HsParen e -> check1Expr e HsParen - HsLeftSection e op -> check1Expr e (flip HsLeftSection op) - HsRightSection op e -> check1Expr e (HsRightSection op) - HsRecConstr c fields -> do - fields <- mapM checkField fields - return (HsRecConstr c fields) - HsRecUpdate e fields -> do - fields <- mapM checkField fields - e <- checkExpr e - return (HsRecUpdate e fields) - HsEnumFrom e -> check1Expr e HsEnumFrom - HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo - HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen - HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo - HsListComp e stmts -> do - stmts <- mapM checkStmt stmts - e <- checkExpr e - return (HsListComp e stmts) - HsExpTypeSig loc e ty -> do - e <- checkExpr e - return (HsExpTypeSig loc e ty) - _ -> fail "Parse error in expression" + HsVar _ -> return e + HsCon _ -> return e + HsLit _ -> return e + HsInfixApp e1 op e2 -> check2Exprs e1 e2 (flip HsInfixApp op) + HsApp e1 e2 -> check2Exprs e1 e2 HsApp + HsNegApp e1 -> check1Expr e1 HsNegApp + HsLambda loc ps e1 -> check1Expr e1 (HsLambda loc ps) + HsLet bs e1 -> check1Expr e1 (HsLet bs) + HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf + HsCase e1 alts -> do + alts' <- mapM checkAlt alts + e1' <- checkExpr e1 + return (HsCase e1' alts') + HsDo stmts -> do + stmts' <- mapM checkStmt stmts + return (HsDo stmts') + HsTuple es -> checkManyExprs es HsTuple + HsList es -> checkManyExprs es HsList + HsParen e1 -> check1Expr e1 HsParen + HsLeftSection e1 op -> check1Expr e1 (flip HsLeftSection op) + HsRightSection op e1 -> check1Expr e1 (HsRightSection op) + HsRecConstr c fields -> do + fields' <- mapM checkField fields + return (HsRecConstr c fields') + HsRecUpdate e1 fields -> do + fields' <- mapM checkField fields + e1' <- checkExpr e1 + return (HsRecUpdate e1' fields') + HsEnumFrom e1 -> check1Expr e1 HsEnumFrom + HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo + HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen + HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo + HsListComp e1 stmts -> do + stmts' <- mapM checkStmt stmts + e1' <- checkExpr e1 + return (HsListComp e1' stmts') + HsExpTypeSig loc e1 ty -> do + e1' <- checkExpr e1 + return (HsExpTypeSig loc e1' ty) + _ -> fail "Parse error in expression" -- type signature for polymorphic recursion!! check1Expr :: HsExp -> (HsExp -> a) -> P a check1Expr e1 f = do - e1 <- checkExpr e1 - return (f e1) + e1' <- checkExpr e1 + return (f e1') check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a check2Exprs e1 e2 f = do - e1 <- checkExpr e1 - e2 <- checkExpr e2 - return (f e1 e2) + e1' <- checkExpr e1 + e2' <- checkExpr e2 + return (f e1' e2') check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a check3Exprs e1 e2 e3 f = do - e1 <- checkExpr e1 - e2 <- checkExpr e2 - e3 <- checkExpr e3 - return (f e1 e2 e3) + e1' <- checkExpr e1 + e2' <- checkExpr e2 + e3' <- checkExpr e3 + return (f e1' e2' e3') checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a checkManyExprs es f = do - es <- mapM checkExpr es - return (f es) + es' <- mapM checkExpr es + return (f es') checkAlt :: HsAlt -> P HsAlt checkAlt (HsAlt loc p galts bs) = do - galts <- checkGAlts galts - return (HsAlt loc p galts bs) + galts' <- checkGAlts galts + return (HsAlt loc p galts' bs) checkGAlts :: HsGuardedAlts -> P HsGuardedAlts checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt checkGAlts (HsGuardedAlts galts) = do - galts <- mapM checkGAlt galts - return (HsGuardedAlts galts) + galts' <- mapM checkGAlt galts + return (HsGuardedAlts galts') checkGAlt :: HsGuardedAlt -> P HsGuardedAlt checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc) checkStmt :: HsStmt -> P HsStmt checkStmt (HsGenerator loc p e) = check1Expr e (HsGenerator loc p) -checkStmt (HsQualifier e) = check1Expr e HsQualifier -checkStmt s@(HsLetStmt _) = return s +checkStmt (HsQualifier e) = check1Expr e HsQualifier +checkStmt s@(HsLetStmt _) = return s checkField :: HsFieldUpdate -> P HsFieldUpdate checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n) @@ -239,34 +238,34 @@ checkValDef :: SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl checkValDef srcloc lhs rhs whereBinds = case isFunLhs lhs [] of - Just (f,es) -> do - ps <- mapM checkPattern es - return (HsFunBind [HsMatch srcloc f ps rhs whereBinds]) + Just (f,es) -> do + ps <- mapM checkPattern es + return (HsFunBind [HsMatch srcloc f ps rhs whereBinds]) Nothing -> do - lhs <- checkPattern lhs - return (HsPatBind srcloc lhs rhs whereBinds) + lhs' <- checkPattern lhs + return (HsPatBind srcloc lhs' rhs whereBinds) -- A variable binding is parsed as an HsPatBind. isFunLhs :: HsExp -> [HsExp] -> Maybe (HsName, [HsExp]) isFunLhs (HsInfixApp l (HsQVarOp (UnQual op)) r) es = Just (op, l:r:es) -isFunLhs (HsApp (HsVar (UnQual f)) e) es = Just (f, e:es) -isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es) -isFunLhs (HsApp f e) es = isFunLhs f (e:es) -isFunLhs _ _ = Nothing +isFunLhs (HsApp (HsVar (UnQual f)) e) es = Just (f, e:es) +isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es) +isFunLhs (HsApp f e) es = isFunLhs f (e:es) +isFunLhs _ _ = Nothing ----------------------------------------------------------------------------- -- In a class or instance body, a pattern binding must be of a variable. checkClassBody :: [HsDecl] -> P [HsDecl] checkClassBody decls = do - mapM_ checkMethodDef decls - return decls + mapM_ checkMethodDef decls + return decls checkMethodDef :: HsDecl -> P () checkMethodDef (HsPatBind _ (HsPVar _) _ _) = return () checkMethodDef (HsPatBind loc _ _ _) = - fail "illegal method definition" `atSrcLoc` loc + fail "illegal method definition" `atSrcLoc` loc checkMethodDef _ = return () ----------------------------------------------------------------------------- @@ -274,8 +273,8 @@ -- For occasions when doing this in the grammar would cause conflicts. checkUnQual :: HsQName -> P HsName -checkUnQual (Qual _ _) = fail "Illegal qualified name" -checkUnQual (UnQual n) = return n +checkUnQual (Qual _ _) = fail "Illegal qualified name" +checkUnQual (UnQual n) = return n checkUnQual (Special _) = fail "Illegal special name" ----------------------------------------------------------------------------- @@ -283,7 +282,7 @@ checkPrec :: Integer -> P Int checkPrec i | 0 <= i && i <= 9 = return (fromInteger i) -checkPrec i | otherwise = fail ("Illegal precedence " ++ show i) +checkPrec i | otherwise = fail ("Illegal precedence " ++ show i) mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp mkRecConstrOrUpdate (HsCon c) fs = return (HsRecConstr c fs) @@ -297,16 +296,16 @@ checkRevDecls :: [HsDecl] -> P [HsDecl] checkRevDecls = mergeFunBinds [] where - mergeFunBinds revDs [] = return revDs - mergeFunBinds revDs (HsFunBind ms1@(HsMatch _ name ps _ _:_):ds1) = - mergeMatches ms1 ds1 - where - arity = length ps - mergeMatches ms' (HsFunBind ms@(HsMatch loc name' ps' _ _:_):ds) - | name' == name = - if length ps' /= arity - then fail ("arity mismatch for '" ++ prettyPrint name ++ "'") - `atSrcLoc` loc - else mergeMatches (ms++ms') ds - mergeMatches ms' ds = mergeFunBinds (HsFunBind ms':revDs) ds - mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds + mergeFunBinds revDs [] = return revDs + mergeFunBinds revDs (HsFunBind ms1@(HsMatch _ name ps _ _:_):ds1) = + mergeMatches ms1 ds1 + where + arity = length ps + mergeMatches ms' (HsFunBind ms@(HsMatch loc name' ps' _ _:_):ds) + | name' == name = + if length ps' /= arity + then fail ("arity mismatch for '" ++ prettyPrint name ++ "'") + `atSrcLoc` loc + else mergeMatches (ms++ms') ds + mergeMatches ms' ds = mergeFunBinds (HsFunBind ms':revDs) ds + mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds diff --git a/Language/Haskell/Parser.ly b/Language/Haskell/Parser.ly --- a/Language/Haskell/Parser.ly +++ b/Language/Haskell/Parser.ly @@ -6,7 +6,7 @@ > -- License : BSD-style (see the file libraries/base/LICENSE) > -- > -- Maintainer : libraries@haskell.org -> -- Stability : experimental +> -- Stability : stable > -- Portability : portable > -- > -- Haskell parser. @@ -14,9 +14,9 @@ > ----------------------------------------------------------------------------- > > module Language.Haskell.Parser ( -> parseModule, parseModuleWithMode, -> ParseMode(..), defaultParseMode, ParseResult(..)) where -> +> parseModule, parseModuleWithMode, +> ParseMode(..), defaultParseMode, ParseResult(..)) where +> > import Language.Haskell.Syntax > import Language.Haskell.ParseMonad > import Language.Haskell.Lexer @@ -33,93 +33,93 @@ Conflicts: 2 shift/reduce 2 for ambiguity in 'case x of y | let z = y in z :: Bool -> b' - (don't know whether to reduce 'Bool' as a btype or shift the '->'. - Similarly lambda and if. The default resolution in favour of the - shift means that a guard can never end with a type signature. - In mitigation: it's a rare case and no Haskell implementation - allows these, because it would require unbounded lookahead.) - There are 2 conflicts rather than one because contexts are parsed - as btypes (cf ctype). + (don't know whether to reduce 'Bool' as a btype or shift the '->'. + Similarly lambda and if. The default resolution in favour of the + shift means that a guard can never end with a type signature. + In mitigation: it's a rare case and no Haskell implementation + allows these, because it would require unbounded lookahead.) + There are 2 conflicts rather than one because contexts are parsed + as btypes (cf ctype). ----------------------------------------------------------------------------- > %token -> VARID { VarId $$ } -> QVARID { QVarId $$ } -> CONID { ConId $$ } -> QCONID { QConId $$ } -> VARSYM { VarSym $$ } -> CONSYM { ConSym $$ } -> QVARSYM { QVarSym $$ } -> QCONSYM { QConSym $$ } -> INT { IntTok $$ } -> RATIONAL { FloatTok $$ } -> CHAR { Character $$ } -> STRING { StringTok $$ } +> VARID { VarId $$ } +> QVARID { QVarId $$ } +> CONID { ConId $$ } +> QCONID { QConId $$ } +> VARSYM { VarSym $$ } +> CONSYM { ConSym $$ } +> QVARSYM { QVarSym $$ } +> QCONSYM { QConSym $$ } +> INT { IntTok $$ } +> RATIONAL { FloatTok $$ } +> CHAR { Character $$ } +> STRING { StringTok $$ } Symbols -> '(' { LeftParen } -> ')' { RightParen } -> ';' { SemiColon } -> '{' { LeftCurly } -> '}' { RightCurly } -> vccurly { VRightCurly } -- a virtual close brace -> '[' { LeftSquare } -> ']' { RightSquare } -> ',' { Comma } -> '_' { Underscore } -> '`' { BackQuote } +> '(' { LeftParen } +> ')' { RightParen } +> ';' { SemiColon } +> '{' { LeftCurly } +> '}' { RightCurly } +> vccurly { VRightCurly } -- a virtual close brace +> '[' { LeftSquare } +> ']' { RightSquare } +> ',' { Comma } +> '_' { Underscore } +> '`' { BackQuote } Reserved operators -> '..' { DotDot } -> ':' { Colon } -> '::' { DoubleColon } -> '=' { Equals } -> '\\' { Backslash } -> '|' { Bar } -> '<-' { LeftArrow } -> '->' { RightArrow } -> '@' { At } -> '~' { Tilde } -> '=>' { DoubleArrow } -> '-' { Minus } -> '!' { Exclamation } +> '..' { DotDot } +> ':' { Colon } +> '::' { DoubleColon } +> '=' { Equals } +> '\\' { Backslash } +> '|' { Bar } +> '<-' { LeftArrow } +> '->' { RightArrow } +> '@' { At } +> '~' { Tilde } +> '=>' { DoubleArrow } +> '-' { Minus } +> '!' { Exclamation } Reserved Ids -> 'case' { KW_Case } -> 'class' { KW_Class } -> 'data' { KW_Data } -> 'default' { KW_Default } -> 'deriving' { KW_Deriving } -> 'do' { KW_Do } -> 'else' { KW_Else } -> 'foreign' { KW_Foreign } -> 'if' { KW_If } -> 'import' { KW_Import } -> 'in' { KW_In } -> 'infix' { KW_Infix } -> 'infixl' { KW_InfixL } -> 'infixr' { KW_InfixR } -> 'instance' { KW_Instance } -> 'let' { KW_Let } -> 'module' { KW_Module } -> 'newtype' { KW_NewType } -> 'of' { KW_Of } -> 'then' { KW_Then } -> 'type' { KW_Type } -> 'where' { KW_Where } +> 'case' { KW_Case } +> 'class' { KW_Class } +> 'data' { KW_Data } +> 'default' { KW_Default } +> 'deriving' { KW_Deriving } +> 'do' { KW_Do } +> 'else' { KW_Else } +> 'foreign' { KW_Foreign } +> 'if' { KW_If } +> 'import' { KW_Import } +> 'in' { KW_In } +> 'infix' { KW_Infix } +> 'infixl' { KW_InfixL } +> 'infixr' { KW_InfixR } +> 'instance' { KW_Instance } +> 'let' { KW_Let } +> 'module' { KW_Module } +> 'newtype' { KW_NewType } +> 'of' { KW_Of } +> 'then' { KW_Then } +> 'type' { KW_Type } +> 'where' { KW_Where } Special Ids -> 'as' { KW_As } -> 'export' { KW_Export } -> 'hiding' { KW_Hiding } -> 'qualified' { KW_Qualified } -> 'safe' { KW_Safe } -> 'unsafe' { KW_Unsafe } +> 'as' { KW_As } +> 'export' { KW_Export } +> 'hiding' { KW_Hiding } +> 'qualified' { KW_Qualified } +> 'safe' { KW_Safe } +> 'unsafe' { KW_Unsafe } > %monad { P } > %lexer { lexer } { EOF } @@ -131,125 +131,125 @@ Module Header > module :: { HsModule } -> : srcloc 'module' modid maybeexports 'where' body -> { HsModule $1 $3 $4 (fst $6) (snd $6) } -> | srcloc body -> { HsModule $1 main_mod (Just [HsEVar (UnQual main_name)]) -> (fst $2) (snd $2) } +> : srcloc 'module' modid maybeexports 'where' body +> { HsModule $1 $3 $4 (fst $6) (snd $6) } +> | srcloc body +> { HsModule $1 main_mod (Just [HsEVar (UnQual main_name)]) +> (fst $2) (snd $2) } > body :: { ([HsImportDecl],[HsDecl]) } -> : '{' bodyaux '}' { $2 } -> | open bodyaux close { $2 } +> : '{' bodyaux '}' { $2 } +> | open bodyaux close { $2 } > bodyaux :: { ([HsImportDecl],[HsDecl]) } -> : optsemis impdecls semis topdecls { (reverse $2, $4) } -> | optsemis topdecls { ([], $2) } -> | optsemis impdecls optsemis { (reverse $2, []) } -> | optsemis { ([], []) } +> : optsemis impdecls semis topdecls { (reverse $2, $4) } +> | optsemis topdecls { ([], $2) } +> | optsemis impdecls optsemis { (reverse $2, []) } +> | optsemis { ([], []) } > semis :: { () } -> : optsemis ';' { () } +> : optsemis ';' { () } > optsemis :: { () } -> : semis { () } -> | {- empty -} { () } +> : semis { () } +> | {- empty -} { () } ----------------------------------------------------------------------------- The Export List > maybeexports :: { Maybe [HsExportSpec] } -> : exports { Just $1 } -> | {- empty -} { Nothing } +> : exports { Just $1 } +> | {- empty -} { Nothing } > exports :: { [HsExportSpec] } -> : '(' exportlist optcomma ')' { reverse $2 } -> | '(' optcomma ')' { [] } +> : '(' exportlist optcomma ')' { reverse $2 } +> | '(' optcomma ')' { [] } > optcomma :: { () } -> : ',' { () } -> | {- empty -} { () } +> : ',' { () } +> | {- empty -} { () } > exportlist :: { [HsExportSpec] } -> : exportlist ',' export { $3 : $1 } -> | export { [$1] } +> : exportlist ',' export { $3 : $1 } +> | export { [$1] } > export :: { HsExportSpec } -> : qvar { HsEVar $1 } -> | qtyconorcls { HsEAbs $1 } -> | qtyconorcls '(' '..' ')' { HsEThingAll $1 } -> | qtyconorcls '(' ')' { HsEThingWith $1 [] } -> | qtyconorcls '(' cnames ')' { HsEThingWith $1 (reverse $3) } -> | 'module' modid { HsEModuleContents $2 } +> : qvar { HsEVar $1 } +> | qtyconorcls { HsEAbs $1 } +> | qtyconorcls '(' '..' ')' { HsEThingAll $1 } +> | qtyconorcls '(' ')' { HsEThingWith $1 [] } +> | qtyconorcls '(' cnames ')' { HsEThingWith $1 (reverse $3) } +> | 'module' modid { HsEModuleContents $2 } ----------------------------------------------------------------------------- Import Declarations > impdecls :: { [HsImportDecl] } -> : impdecls semis impdecl { $3 : $1 } -> | impdecl { [$1] } +> : impdecls semis impdecl { $3 : $1 } +> | impdecl { [$1] } > impdecl :: { HsImportDecl } -> : srcloc 'import' optqualified modid maybeas maybeimpspec -> { HsImportDecl $1 $4 $3 $5 $6 } +> : srcloc 'import' optqualified modid maybeas maybeimpspec +> { HsImportDecl $1 $4 $3 $5 $6 } > optqualified :: { Bool } > : 'qualified' { True } -> | {- empty -} { False } +> | {- empty -} { False } > maybeas :: { Maybe Module } > : 'as' modid { Just $2 } -> | {- empty -} { Nothing } +> | {- empty -} { Nothing } > maybeimpspec :: { Maybe (Bool, [HsImportSpec]) } -> : impspec { Just $1 } -> | {- empty -} { Nothing } +> : impspec { Just $1 } +> | {- empty -} { Nothing } > impspec :: { (Bool, [HsImportSpec]) } -> : opthiding '(' importlist optcomma ')' { ($1, reverse $3) } -> | opthiding '(' optcomma ')' { ($1, []) } +> : opthiding '(' importlist optcomma ')' { ($1, reverse $3) } +> | opthiding '(' optcomma ')' { ($1, []) } > opthiding :: { Bool } -> : 'hiding' { True } -> | {- empty -} { False } +> : 'hiding' { True } +> | {- empty -} { False } > importlist :: { [HsImportSpec] } -> : importlist ',' importspec { $3 : $1 } -> | importspec { [$1] } +> : importlist ',' importspec { $3 : $1 } +> | importspec { [$1] } > importspec :: { HsImportSpec } -> : var { HsIVar $1 } -> | tyconorcls { HsIAbs $1 } -> | tyconorcls '(' '..' ')' { HsIThingAll $1 } -> | tyconorcls '(' ')' { HsIThingWith $1 [] } -> | tyconorcls '(' cnames ')' { HsIThingWith $1 (reverse $3) } +> : var { HsIVar $1 } +> | tyconorcls { HsIAbs $1 } +> | tyconorcls '(' '..' ')' { HsIThingAll $1 } +> | tyconorcls '(' ')' { HsIThingWith $1 [] } +> | tyconorcls '(' cnames ')' { HsIThingWith $1 (reverse $3) } > cnames :: { [HsCName] } -> : cnames ',' cname { $3 : $1 } -> | cname { [$1] } +> : cnames ',' cname { $3 : $1 } +> | cname { [$1] } > cname :: { HsCName } -> : var { HsVarName $1 } -> | con { HsConName $1 } +> : var { HsVarName $1 } +> | con { HsConName $1 } ----------------------------------------------------------------------------- Fixity Declarations > fixdecl :: { HsDecl } -> : srcloc infix prec ops { HsInfixDecl $1 $2 $3 (reverse $4) } +> : srcloc infix prec ops { HsInfixDecl $1 $2 $3 (reverse $4) } > prec :: { Int } -> : {- empty -} { 9 } -> | INT {% checkPrec $1 } +> : {- empty -} { 9 } +> | INT {% checkPrec $1 } > infix :: { HsAssoc } -> : 'infix' { HsAssocNone } -> | 'infixl' { HsAssocLeft } -> | 'infixr' { HsAssocRight } +> : 'infix' { HsAssocNone } +> | 'infixl' { HsAssocLeft } +> | 'infixr' { HsAssocRight } > ops :: { [HsOp] } -> : ops ',' op { $3 : $1 } -> | op { [$1] } +> : ops ',' op { $3 : $1 } +> | op { [$1] } ----------------------------------------------------------------------------- Top-Level Declarations @@ -258,56 +258,56 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux. > topdecls :: { [HsDecl] } -> : topdecls1 optsemis {% checkRevDecls $1 } +> : topdecls1 optsemis {% checkRevDecls $1 } > topdecls1 :: { [HsDecl] } -> : topdecls1 semis topdecl { $3 : $1 } -> | topdecl { [$1] } +> : topdecls1 semis topdecl { $3 : $1 } +> | topdecl { [$1] } > topdecl :: { HsDecl } -> : srcloc 'type' simpletype '=' type -> { HsTypeDecl $1 (fst $3) (snd $3) $5 } -> | srcloc 'data' ctype '=' constrs deriving -> {% do { (cs,c,t) <- checkDataHeader $3; -> return (HsDataDecl $1 cs c t (reverse $5) $6) } } -> | srcloc 'newtype' ctype '=' constr deriving -> {% do { (cs,c,t) <- checkDataHeader $3; -> return (HsNewTypeDecl $1 cs c t $5 $6) } } -> | srcloc 'class' ctype optcbody -> {% do { (cs,c,vs) <- checkClassHeader $3; -> return (HsClassDecl $1 cs c vs $4) } } -> | srcloc 'instance' ctype optvaldefs -> {% do { (cs,c,ts) <- checkInstHeader $3; -> return (HsInstDecl $1 cs c ts $4) } } -> | srcloc 'default' '(' typelist ')' -> { HsDefaultDecl $1 $4 } -> | foreigndecl { $1 } -> | decl { $1 } +> : srcloc 'type' simpletype '=' type +> { HsTypeDecl $1 (fst $3) (snd $3) $5 } +> | srcloc 'data' ctype '=' constrs deriving +> {% do { (cs,c,t) <- checkDataHeader $3; +> return (HsDataDecl $1 cs c t (reverse $5) $6) } } +> | srcloc 'newtype' ctype '=' constr deriving +> {% do { (cs,c,t) <- checkDataHeader $3; +> return (HsNewTypeDecl $1 cs c t $5 $6) } } +> | srcloc 'class' ctype optcbody +> {% do { (cs,c,vs) <- checkClassHeader $3; +> return (HsClassDecl $1 cs c vs $4) } } +> | srcloc 'instance' ctype optvaldefs +> {% do { (cs,c,ts) <- checkInstHeader $3; +> return (HsInstDecl $1 cs c ts $4) } } +> | srcloc 'default' '(' typelist ')' +> { HsDefaultDecl $1 $4 } +> | foreigndecl { $1 } +> | decl { $1 } > typelist :: { [HsType] } -> : types { reverse $1 } -> | type { [$1] } -> | {- empty -} { [] } +> : types { reverse $1 } +> | type { [$1] } +> | {- empty -} { [] } > decls :: { [HsDecl] } -> : optsemis decls1 optsemis {% checkRevDecls $2 } -> | optsemis { [] } +> : optsemis decls1 optsemis {% checkRevDecls $2 } +> | optsemis { [] } > decls1 :: { [HsDecl] } -> : decls1 semis decl { $3 : $1 } -> | decl { [$1] } +> : decls1 semis decl { $3 : $1 } +> | decl { [$1] } > decl :: { HsDecl } -> : signdecl { $1 } -> | fixdecl { $1 } -> | valdef { $1 } +> : signdecl { $1 } +> | fixdecl { $1 } +> | valdef { $1 } > decllist :: { [HsDecl] } -> : '{' decls '}' { $2 } -> | open decls close { $2 } +> : '{' decls '}' { $2 } +> | open decls close { $2 } > signdecl :: { HsDecl } -> : srcloc vars '::' ctype { HsTypeSig $1 (reverse $2) $4 } +> : srcloc vars '::' ctype { HsTypeSig $1 (reverse $2) $4 } ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var instead of qvar, we get another shift/reduce-conflict. Consider the @@ -320,10 +320,10 @@ instead of a var only (which would be correct). But deciding what the + is, would require more lookahead. So let's check for ourselves... -> vars :: { [HsName] } -> : vars ',' var { $3 : $1 } -> | qvar {% do { n <- checkUnQual $1; -> return [n] } } +> vars :: { [HsName] } +> : vars ',' var { $3 : $1 } +> | qvar {% do { n <- checkUnQual $1; +> return [n] } } Foreign declarations - calling conventions are uninterpreted @@ -331,177 +331,177 @@ - special ids are not allowed as internal names > foreigndecl :: { HsDecl } -> : srcloc 'foreign' 'import' VARID optsafety optentity fvar '::' type -> { HsForeignImport $1 $4 $5 $6 $7 $9 } -> | srcloc 'foreign' 'export' VARID optentity fvar '::' type -> { HsForeignExport $1 $4 $5 $6 $8 } +> : srcloc 'foreign' 'import' VARID optsafety optentity fvar '::' type +> { HsForeignImport $1 $4 $5 $6 $7 $9 } +> | srcloc 'foreign' 'export' VARID optentity fvar '::' type +> { HsForeignExport $1 $4 $5 $6 $8 } > optsafety :: { HsSafety } -> : 'safe' { HsSafe } -> | 'unsafe' { HsUnsafe } -> | {- empty -} { HsSafe } +> : 'safe' { HsSafe } +> | 'unsafe' { HsUnsafe } +> | {- empty -} { HsSafe } > optentity :: { String } -> : STRING { $1 } -> | {- empty -} { "" } +> : STRING { $1 } +> | {- empty -} { "" } > fvar :: { HsName } -> : VARID { HsIdent $1 } -> | '(' varsym ')' { $2 } +> : VARID { HsIdent $1 } +> | '(' varsym ')' { $2 } ----------------------------------------------------------------------------- Types > type :: { HsType } -> : btype '->' type { HsTyFun $1 $3 } -> | btype { $1 } +> : btype '->' type { HsTyFun $1 $3 } +> | btype { $1 } > btype :: { HsType } -> : btype atype { HsTyApp $1 $2 } -> | atype { $1 } +> : btype atype { HsTyApp $1 $2 } +> | atype { $1 } > atype :: { HsType } -> : gtycon { HsTyCon $1 } -> | tyvar { HsTyVar $1 } -> | '(' types ')' { HsTyTuple (reverse $2) } -> | '[' type ']' { HsTyApp list_tycon $2 } -> | '(' type ')' { $2 } +> : gtycon { HsTyCon $1 } +> | tyvar { HsTyVar $1 } +> | '(' types ')' { HsTyTuple (reverse $2) } +> | '[' type ']' { HsTyApp list_tycon $2 } +> | '(' type ')' { $2 } > gtycon :: { HsQName } -> : qconid { $1 } -> | '(' ')' { unit_tycon_name } -> | '(' '->' ')' { fun_tycon_name } -> | '[' ']' { list_tycon_name } -> | '(' commas ')' { tuple_tycon_name $2 } +> : qconid { $1 } +> | '(' ')' { unit_tycon_name } +> | '(' '->' ')' { fun_tycon_name } +> | '[' ']' { list_tycon_name } +> | '(' commas ')' { tuple_tycon_name $2 } (Slightly edited) Comment from GHC's hsparser.y: "context => type" vs "type" is a problem, because you can't distinguish between - foo :: (Baz a, Baz a) - bar :: (Baz a, Baz a) => [a] -> [a] -> [a] + foo :: (Baz a, Baz a) + bar :: (Baz a, Baz a) => [a] -> [a] -> [a] with one token of lookahead. The HACK is to parse the context as a btype (more specifically as a tuple type), then check that it has the right form C a, or (C1 a, C2 b, ... Cn z) and convert it into a context. Blaach! > ctype :: { HsQualType } -> : context '=>' type { HsQualType $1 $3 } -> | type { HsQualType [] $1 } +> : context '=>' type { HsQualType $1 $3 } +> | type { HsQualType [] $1 } > context :: { HsContext } -> : btype {% checkContext $1 } +> : btype {% checkContext $1 } -> types :: { [HsType] } -> : types ',' type { $3 : $1 } -> | type ',' type { [$3, $1] } +> types :: { [HsType] } +> : types ',' type { $3 : $1 } +> | type ',' type { [$3, $1] } > simpletype :: { (HsName, [HsName]) } -> : tycon tyvars { ($1,reverse $2) } +> : tycon tyvars { ($1,reverse $2) } > tyvars :: { [HsName] } -> : tyvars tyvar { $2 : $1 } -> | {- empty -} { [] } +> : tyvars tyvar { $2 : $1 } +> | {- empty -} { [] } ----------------------------------------------------------------------------- Datatype declarations > constrs :: { [HsConDecl] } -> : constrs '|' constr { $3 : $1 } -> | constr { [$1] } +> : constrs '|' constr { $3 : $1 } +> | constr { [$1] } > constr :: { HsConDecl } -> : srcloc scontype { HsConDecl $1 (fst $2) (snd $2) } -> | srcloc sbtype conop sbtype { HsConDecl $1 $3 [$2,$4] } -> | srcloc con '{' '}' { HsRecDecl $1 $2 [] } -> | srcloc con '{' fielddecls '}' { HsRecDecl $1 $2 (reverse $4) } +> : srcloc scontype { HsConDecl $1 (fst $2) (snd $2) } +> | srcloc sbtype conop sbtype { HsConDecl $1 $3 [$2,$4] } +> | srcloc con '{' '}' { HsRecDecl $1 $2 [] } +> | srcloc con '{' fielddecls '}' { HsRecDecl $1 $2 (reverse $4) } > scontype :: { (HsName, [HsBangType]) } -> : btype {% do { (c,ts) <- splitTyConApp $1; -> return (c,map HsUnBangedTy ts) } } -> | scontype1 { $1 } +> : btype {% do { (c,ts) <- splitTyConApp $1; +> return (c,map HsUnBangedTy ts) } } +> | scontype1 { $1 } > scontype1 :: { (HsName, [HsBangType]) } -> : btype '!' atype {% do { (c,ts) <- splitTyConApp $1; -> return (c,map HsUnBangedTy ts++ -> [HsBangedTy $3]) } } -> | scontype1 satype { (fst $1, snd $1 ++ [$2] ) } +> : btype '!' atype {% do { (c,ts) <- splitTyConApp $1; +> return (c,map HsUnBangedTy ts++ +> [HsBangedTy $3]) } } +> | scontype1 satype { (fst $1, snd $1 ++ [$2] ) } > satype :: { HsBangType } -> : atype { HsUnBangedTy $1 } -> | '!' atype { HsBangedTy $2 } +> : atype { HsUnBangedTy $1 } +> | '!' atype { HsBangedTy $2 } > sbtype :: { HsBangType } -> : btype { HsUnBangedTy $1 } -> | '!' atype { HsBangedTy $2 } +> : btype { HsUnBangedTy $1 } +> | '!' atype { HsBangedTy $2 } > fielddecls :: { [([HsName],HsBangType)] } -> : fielddecls ',' fielddecl { $3 : $1 } -> | fielddecl { [$1] } +> : fielddecls ',' fielddecl { $3 : $1 } +> | fielddecl { [$1] } > fielddecl :: { ([HsName],HsBangType) } -> : vars '::' stype { (reverse $1, $3) } +> : vars '::' stype { (reverse $1, $3) } > stype :: { HsBangType } -> : type { HsUnBangedTy $1 } -> | '!' atype { HsBangedTy $2 } +> : type { HsUnBangedTy $1 } +> | '!' atype { HsBangedTy $2 } > deriving :: { [HsQName] } -> : {- empty -} { [] } -> | 'deriving' qtycls { [$2] } -> | 'deriving' '(' ')' { [] } -> | 'deriving' '(' dclasses ')' { reverse $3 } +> : {- empty -} { [] } +> | 'deriving' qtycls { [$2] } +> | 'deriving' '(' ')' { [] } +> | 'deriving' '(' dclasses ')' { reverse $3 } > dclasses :: { [HsQName] } -> : dclasses ',' qtycls { $3 : $1 } -> | qtycls { [$1] } +> : dclasses ',' qtycls { $3 : $1 } +> | qtycls { [$1] } ----------------------------------------------------------------------------- Class declarations > optcbody :: { [HsDecl] } -> : 'where' decllist {% checkClassBody $2 } -> | {- empty -} { [] } +> : 'where' decllist {% checkClassBody $2 } +> | {- empty -} { [] } ----------------------------------------------------------------------------- Instance declarations > optvaldefs :: { [HsDecl] } -> : 'where' '{' valdefs '}' {% checkClassBody $3 } -> | 'where' open valdefs close {% checkClassBody $3 } -> | {- empty -} { [] } +> : 'where' '{' valdefs '}' {% checkClassBody $3 } +> | 'where' open valdefs close {% checkClassBody $3 } +> | {- empty -} { [] } > valdefs :: { [HsDecl] } -> : optsemis valdefs1 optsemis {% checkRevDecls $2 } -> | optsemis { [] } +> : optsemis valdefs1 optsemis {% checkRevDecls $2 } +> | optsemis { [] } > valdefs1 :: { [HsDecl] } -> : valdefs1 semis valdef { $3 : $1 } -> | valdef { [$1] } +> : valdefs1 semis valdef { $3 : $1 } +> | valdef { [$1] } ----------------------------------------------------------------------------- Value definitions > valdef :: { HsDecl } -> : srcloc exp0b rhs optwhere {% checkValDef $1 $2 $3 $4 } +> : srcloc exp0b rhs optwhere {% checkValDef $1 $2 $3 $4 } > optwhere :: { [HsDecl] } -> : 'where' decllist { $2 } -> | {- empty -} { [] } +> : 'where' decllist { $2 } +> | {- empty -} { [] } -> rhs :: { HsRhs } -> : '=' exp {% do { e <- checkExpr $2; -> return (HsUnGuardedRhs e) } } -> | gdrhs { HsGuardedRhss (reverse $1) } +> rhs :: { HsRhs } +> : '=' exp {% do { e <- checkExpr $2; +> return (HsUnGuardedRhs e) } } +> | gdrhs { HsGuardedRhss (reverse $1) } > gdrhs :: { [HsGuardedRhs] } -> : gdrhs gdrh { $2 : $1 } -> | gdrh { [$1] } +> : gdrhs gdrh { $2 : $1 } +> | gdrh { [$1] } > gdrh :: { HsGuardedRhs } -> : srcloc '|' exp0 '=' exp {% do { g <- checkExpr $3; -> e <- checkExpr $5; -> return (HsGuardedRhs $1 g e) } } +> : srcloc '|' exp0 '=' exp {% do { g <- checkExpr $3; +> e <- checkExpr $5; +> return (HsGuardedRhs $1 g e) } } ----------------------------------------------------------------------------- Expressions @@ -516,42 +516,42 @@ the exp0 productions to distinguish these from the others (exp0a). > exp :: { HsExp } -> : exp0b '::' srcloc ctype { HsExpTypeSig $3 $1 $4 } -> | exp0 { $1 } +> : exp0b '::' srcloc ctype { HsExpTypeSig $3 $1 $4 } +> | exp0 { $1 } > exp0 :: { HsExp } -> : exp0a { $1 } -> | exp0b { $1 } +> : exp0a { $1 } +> | exp0b { $1 } > exp0a :: { HsExp } -> : exp0b qop exp10a { HsInfixApp $1 $2 $3 } -> | exp10a { $1 } +> : exp0b qop exp10a { HsInfixApp $1 $2 $3 } +> | exp10a { $1 } > exp0b :: { HsExp } -> : exp0b qop exp10b { HsInfixApp $1 $2 $3 } -> | exp10b { $1 } +> : exp0b qop exp10b { HsInfixApp $1 $2 $3 } +> | exp10b { $1 } > exp10a :: { HsExp } -> : '\\' srcloc apats '->' exp { HsLambda $2 (reverse $3) $5 } -> | 'let' decllist 'in' exp { HsLet $2 $4 } -> | 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 } +> : '\\' srcloc apats '->' exp { HsLambda $2 (reverse $3) $5 } +> | 'let' decllist 'in' exp { HsLet $2 $4 } +> | 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 } > exp10b :: { HsExp } -> : 'case' exp 'of' altslist { HsCase $2 $4 } -> | '-' fexp { HsNegApp $2 } -> | 'do' stmtlist { HsDo $2 } -> | fexp { $1 } +> : 'case' exp 'of' altslist { HsCase $2 $4 } +> | '-' fexp { HsNegApp $2 } +> | 'do' stmtlist { HsDo $2 } +> | fexp { $1 } > fexp :: { HsExp } -> : fexp aexp { HsApp $1 $2 } -> | aexp { $1 } +> : fexp aexp { HsApp $1 $2 } +> | aexp { $1 } > apats :: { [HsPat] } -> : apats apat { $2 : $1 } -> | apat { [$1] } +> : apats apat { $2 : $1 } +> | apat { [$1] } > apat :: { HsPat } -> : aexp {% checkPattern $1 } +> : aexp {% checkPattern $1 } UGLY: Because patterns and expressions are mixed, aexp has to be split into two rules: One right-recursive and one left-recursive. Otherwise we get two @@ -561,41 +561,41 @@ qvar here to avoid a shift/reduce conflict, and then check it ourselves (as for vars above). -> aexp :: { HsExp } -> : qvar '@' aexp {% do { n <- checkUnQual $1; -> return (HsAsPat n $3) } } -> | '~' aexp { HsIrrPat $2 } -> | aexp1 { $1 } +> aexp :: { HsExp } +> : qvar '@' aexp {% do { n <- checkUnQual $1; +> return (HsAsPat n $3) } } +> | '~' aexp { HsIrrPat $2 } +> | aexp1 { $1 } Note: The first two alternatives of aexp1 are not necessarily record updates: they could be labeled constructions. -> aexp1 :: { HsExp } -> : aexp1 '{' '}' {% mkRecConstrOrUpdate $1 [] } -> | aexp1 '{' fbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) } -> | aexp2 { $1 } +> aexp1 :: { HsExp } +> : aexp1 '{' '}' {% mkRecConstrOrUpdate $1 [] } +> | aexp1 '{' fbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) } +> | aexp2 { $1 } According to the Report, the left section (e op) is legal iff (e op x) parses equivalently to ((e) op x). Thus e must be an exp0b. -> aexp2 :: { HsExp } -> : qvar { HsVar $1 } -> | gcon { $1 } -> | literal { HsLit $1 } -> | '(' exp ')' { HsParen $2 } -> | '(' texps ')' { HsTuple (reverse $2) } -> | '[' list ']' { $2 } -> | '(' exp0b qop ')' { HsLeftSection $2 $3 } -> | '(' qopm exp0 ')' { HsRightSection $2 $3 } -> | '_' { HsWildCard } +> aexp2 :: { HsExp } +> : qvar { HsVar $1 } +> | gcon { $1 } +> | literal { HsLit $1 } +> | '(' exp ')' { HsParen $2 } +> | '(' texps ')' { HsTuple (reverse $2) } +> | '[' list ']' { $2 } +> | '(' exp0b qop ')' { HsLeftSection $2 $3 } +> | '(' qopm exp0 ')' { HsRightSection $2 $3 } +> | '_' { HsWildCard } > commas :: { Int } -> : commas ',' { $1 + 1 } -> | ',' { 1 } +> : commas ',' { $1 + 1 } +> | ',' { 1 } > texps :: { [HsExp] } -> : texps ',' exp { $3 : $1 } -> | exp ',' exp { [$3,$1] } +> : texps ',' exp { $3 : $1 } +> | exp ',' exp { [$3,$1] } ----------------------------------------------------------------------------- List expressions @@ -604,60 +604,60 @@ avoiding another shift/reduce-conflict. > list :: { HsExp } -> : exp { HsList [$1] } -> | lexps { HsList (reverse $1) } -> | exp '..' { HsEnumFrom $1 } -> | exp ',' exp '..' { HsEnumFromThen $1 $3 } -> | exp '..' exp { HsEnumFromTo $1 $3 } -> | exp ',' exp '..' exp { HsEnumFromThenTo $1 $3 $5 } -> | exp '|' quals { HsListComp $1 (reverse $3) } +> : exp { HsList [$1] } +> | lexps { HsList (reverse $1) } +> | exp '..' { HsEnumFrom $1 } +> | exp ',' exp '..' { HsEnumFromThen $1 $3 } +> | exp '..' exp { HsEnumFromTo $1 $3 } +> | exp ',' exp '..' exp { HsEnumFromThenTo $1 $3 $5 } +> | exp '|' quals { HsListComp $1 (reverse $3) } > lexps :: { [HsExp] } -> : lexps ',' exp { $3 : $1 } -> | exp ',' exp { [$3,$1] } +> : lexps ',' exp { $3 : $1 } +> | exp ',' exp { [$3,$1] } ----------------------------------------------------------------------------- List comprehensions > quals :: { [HsStmt] } -> : quals ',' qual { $3 : $1 } -> | qual { [$1] } +> : quals ',' qual { $3 : $1 } +> | qual { [$1] } > qual :: { HsStmt } -> : pat srcloc '<-' exp { HsGenerator $2 $1 $4 } -> | exp { HsQualifier $1 } -> | 'let' decllist { HsLetStmt $2 } +> : pat srcloc '<-' exp { HsGenerator $2 $1 $4 } +> | exp { HsQualifier $1 } +> | 'let' decllist { HsLetStmt $2 } ----------------------------------------------------------------------------- Case alternatives > altslist :: { [HsAlt] } -> : '{' alts '}' { $2 } -> | open alts close { $2 } +> : '{' alts '}' { $2 } +> | open alts close { $2 } > alts :: { [HsAlt] } -> : optsemis alts1 optsemis { reverse $2 } +> : optsemis alts1 optsemis { reverse $2 } > alts1 :: { [HsAlt] } -> : alts1 semis alt { $3 : $1 } -> | alt { [$1] } +> : alts1 semis alt { $3 : $1 } +> | alt { [$1] } > alt :: { HsAlt } -> : srcloc pat ralt optwhere { HsAlt $1 $2 $3 $4 } +> : srcloc pat ralt optwhere { HsAlt $1 $2 $3 $4 } > ralt :: { HsGuardedAlts } -> : '->' exp { HsUnGuardedAlt $2 } -> | gdpats { HsGuardedAlts (reverse $1) } +> : '->' exp { HsUnGuardedAlt $2 } +> | gdpats { HsGuardedAlts (reverse $1) } > gdpats :: { [HsGuardedAlt] } -> : gdpats gdpat { $2 : $1 } -> | gdpat { [$1] } +> : gdpats gdpat { $2 : $1 } +> | gdpat { [$1] } -> gdpat :: { HsGuardedAlt } -> : srcloc '|' exp0 '->' exp { HsGuardedAlt $1 $3 $5 } +> gdpat :: { HsGuardedAlt } +> : srcloc '|' exp0 '->' exp { HsGuardedAlt $1 $3 $5 } > pat :: { HsPat } -> : exp0b {% checkPattern $1 } +> : exp0b {% checkPattern $1 } ----------------------------------------------------------------------------- Statement sequences @@ -667,176 +667,176 @@ an expression. > stmtlist :: { [HsStmt] } -> : '{' stmts '}' { $2 } -> | open stmts close { $2 } +> : '{' stmts '}' { $2 } +> | open stmts close { $2 } > stmts :: { [HsStmt] } -> : 'let' decllist ';' stmts { HsLetStmt $2 : $4 } -> | pat srcloc '<-' exp ';' stmts { HsGenerator $2 $1 $4 : $6 } -> | exp ';' stmts { HsQualifier $1 : $3 } -> | ';' stmts { $2 } -> | exp ';' { [HsQualifier $1] } -> | exp { [HsQualifier $1] } +> : 'let' decllist ';' stmts { HsLetStmt $2 : $4 } +> | pat srcloc '<-' exp ';' stmts { HsGenerator $2 $1 $4 : $6 } +> | exp ';' stmts { HsQualifier $1 : $3 } +> | ';' stmts { $2 } +> | exp ';' { [HsQualifier $1] } +> | exp { [HsQualifier $1] } ----------------------------------------------------------------------------- Record Field Update/Construction > fbinds :: { [HsFieldUpdate] } -> : fbinds ',' fbind { $3 : $1 } -> | fbind { [$1] } +> : fbinds ',' fbind { $3 : $1 } +> | fbind { [$1] } -> fbind :: { HsFieldUpdate } -> : qvar '=' exp { HsFieldUpdate $1 $3 } +> fbind :: { HsFieldUpdate } +> : qvar '=' exp { HsFieldUpdate $1 $3 } ----------------------------------------------------------------------------- Variables, Constructors and Operators. > gcon :: { HsExp } -> : '(' ')' { unit_con } -> | '[' ']' { HsList [] } -> | '(' commas ')' { tuple_con $2 } -> | qcon { HsCon $1 } +> : '(' ')' { unit_con } +> | '[' ']' { HsList [] } +> | '(' commas ')' { tuple_con $2 } +> | qcon { HsCon $1 } -> var :: { HsName } -> : varid { $1 } -> | '(' varsym ')' { $2 } +> var :: { HsName } +> : varid { $1 } +> | '(' varsym ')' { $2 } -> qvar :: { HsQName } -> : qvarid { $1 } -> | '(' qvarsym ')' { $2 } +> qvar :: { HsQName } +> : qvarid { $1 } +> | '(' qvarsym ')' { $2 } -> con :: { HsName } -> : conid { $1 } -> | '(' consym ')' { $2 } +> con :: { HsName } +> : conid { $1 } +> | '(' consym ')' { $2 } -> qcon :: { HsQName } -> : qconid { $1 } -> | '(' gconsym ')' { $2 } +> qcon :: { HsQName } +> : qconid { $1 } +> | '(' gconsym ')' { $2 } -> varop :: { HsName } -> : varsym { $1 } -> | '`' varid '`' { $2 } +> varop :: { HsName } +> : varsym { $1 } +> | '`' varid '`' { $2 } > qvarop :: { HsQName } -> : qvarsym { $1 } -> | '`' qvarid '`' { $2 } +> : qvarsym { $1 } +> | '`' qvarid '`' { $2 } > qvaropm :: { HsQName } -> : qvarsymm { $1 } -> | '`' qvarid '`' { $2 } +> : qvarsymm { $1 } +> | '`' qvarid '`' { $2 } > conop :: { HsName } -> : consym { $1 } -> | '`' conid '`' { $2 } +> : consym { $1 } +> | '`' conid '`' { $2 } > qconop :: { HsQName } -> : gconsym { $1 } -> | '`' qconid '`' { $2 } +> : gconsym { $1 } +> | '`' qconid '`' { $2 } -> op :: { HsOp } -> : varop { HsVarOp $1 } -> | conop { HsConOp $1 } +> op :: { HsOp } +> : varop { HsVarOp $1 } +> | conop { HsConOp $1 } -> qop :: { HsQOp } -> : qvarop { HsQVarOp $1 } -> | qconop { HsQConOp $1 } +> qop :: { HsQOp } +> : qvarop { HsQVarOp $1 } +> | qconop { HsQConOp $1 } -> qopm :: { HsQOp } -> : qvaropm { HsQVarOp $1 } -> | qconop { HsQConOp $1 } +> qopm :: { HsQOp } +> : qvaropm { HsQVarOp $1 } +> | qconop { HsQConOp $1 } > gconsym :: { HsQName } -> : ':' { list_cons_name } -> | qconsym { $1 } +> : ':' { list_cons_name } +> | qconsym { $1 } ----------------------------------------------------------------------------- Identifiers and Symbols > qvarid :: { HsQName } -> : varid { UnQual $1 } -> | QVARID { Qual (Module (fst $1)) (HsIdent (snd $1)) } +> : varid { UnQual $1 } +> | QVARID { Qual (Module (fst $1)) (HsIdent (snd $1)) } > varid :: { HsName } -> : VARID { HsIdent $1 } -> | 'as' { HsIdent "as" } -> | 'export' { HsIdent "export" } -> | 'hiding' { HsIdent "hiding" } -> | 'qualified' { HsIdent "qualified" } -> | 'safe' { HsIdent "safe" } -> | 'unsafe' { HsIdent "unsafe" } +> : VARID { HsIdent $1 } +> | 'as' { HsIdent "as" } +> | 'export' { HsIdent "export" } +> | 'hiding' { HsIdent "hiding" } +> | 'qualified' { HsIdent "qualified" } +> | 'safe' { HsIdent "safe" } +> | 'unsafe' { HsIdent "unsafe" } > qconid :: { HsQName } -> : conid { UnQual $1 } -> | QCONID { Qual (Module (fst $1)) (HsIdent (snd $1)) } +> : conid { UnQual $1 } +> | QCONID { Qual (Module (fst $1)) (HsIdent (snd $1)) } > conid :: { HsName } -> : CONID { HsIdent $1 } +> : CONID { HsIdent $1 } > qconsym :: { HsQName } -> : consym { UnQual $1 } -> | QCONSYM { Qual (Module (fst $1)) (HsSymbol (snd $1)) } +> : consym { UnQual $1 } +> | QCONSYM { Qual (Module (fst $1)) (HsSymbol (snd $1)) } > consym :: { HsName } -> : CONSYM { HsSymbol $1 } +> : CONSYM { HsSymbol $1 } > qvarsym :: { HsQName } -> : varsym { UnQual $1 } -> | qvarsym1 { $1 } +> : varsym { UnQual $1 } +> | qvarsym1 { $1 } > qvarsymm :: { HsQName } -> : varsymm { UnQual $1 } -> | qvarsym1 { $1 } +> : varsymm { UnQual $1 } +> | qvarsym1 { $1 } > varsym :: { HsName } -> : VARSYM { HsSymbol $1 } -> | '-' { HsSymbol "-" } -> | '!' { HsSymbol "!" } +> : VARSYM { HsSymbol $1 } +> | '-' { HsSymbol "-" } +> | '!' { HsSymbol "!" } > varsymm :: { HsName } -- varsym not including '-' -> : VARSYM { HsSymbol $1 } -> | '!' { HsSymbol "!" } +> : VARSYM { HsSymbol $1 } +> | '!' { HsSymbol "!" } > qvarsym1 :: { HsQName } -> : QVARSYM { Qual (Module (fst $1)) (HsSymbol (snd $1)) } +> : QVARSYM { Qual (Module (fst $1)) (HsSymbol (snd $1)) } > literal :: { HsLiteral } -> : INT { HsInt $1 } -> | CHAR { HsChar $1 } -> | RATIONAL { HsFrac $1 } -> | STRING { HsString $1 } +> : INT { HsInt $1 } +> | CHAR { HsChar $1 } +> | RATIONAL { HsFrac $1 } +> | STRING { HsString $1 } -> srcloc :: { SrcLoc } : {% getSrcLoc } - +> srcloc :: { SrcLoc } : {% getSrcLoc } + ----------------------------------------------------------------------------- Layout -> open :: { () } : {% pushCurrentContext } +> open :: { () } : {% pushCurrentContext } > close :: { () } -> : vccurly { () } -- context popped in lexer. -> | error {% popContext } +> : vccurly { () } -- context popped in lexer. +> | error {% popContext } ----------------------------------------------------------------------------- Miscellaneous (mostly renamings) > modid :: { Module } -> : CONID { Module $1 } -> | QCONID { Module (fst $1 ++ '.':snd $1) } +> : CONID { Module $1 } +> | QCONID { Module (fst $1 ++ '.':snd $1) } > tyconorcls :: { HsName } -> : conid { $1 } +> : conid { $1 } > tycon :: { HsName } -> : conid { $1 } +> : conid { $1 } > qtyconorcls :: { HsQName } -> : qconid { $1 } +> : qconid { $1 } > qtycls :: { HsQName } -> : qconid { $1 } +> : qconid { $1 } > tyvar :: { HsName } -> : varid { $1 } +> : varid { $1 } ----------------------------------------------------------------------------- diff --git a/Language/Haskell/Pretty.hs b/Language/Haskell/Pretty.hs --- a/Language/Haskell/Pretty.hs +++ b/Language/Haskell/Pretty.hs @@ -1,41 +1,53 @@ -{-# OPTIONS_GHC -w #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Pretty -- Copyright : (c) The GHC Team, Noel Winstanley 1997-2000 --- License : BSD-style (see the file libraries/base/LICENSE) +-- License : BSD-3-Clause -- --- Maintainer : libraries@haskell.org --- Stability : experimental +-- Maintainer : Andreas Abel +-- Stability : stable -- Portability : portable -- -- Pretty printer for Haskell. -- ----------------------------------------------------------------------------- -module Language.Haskell.Pretty ( - -- * Pretty printing - Pretty, - prettyPrintStyleMode, prettyPrintWithMode, prettyPrint, - -- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ") - P.Style(..), P.style, P.Mode(..), - -- * Haskell formatting modes - PPHsMode(..), Indent, PPLayout(..), defaultMode) where +module Language.Haskell.Pretty + ( -- * Pretty printing + Pretty, + prettyPrintStyleMode, + prettyPrintWithMode, + prettyPrint, -import Language.Haskell.Syntax + -- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ") + P.Style(..), + P.style, + P.Mode(..), -import qualified Text.PrettyPrint as P + -- * Haskell formatting modes + PPHsMode(..), + Indent, + PPLayout(..), + defaultMode + ) where +import Language.Haskell.Syntax + +import Control.Applicative as App (Applicative (..)) +import Control.Monad (ap) + +import qualified Text.PrettyPrint as P + infixl 5 $$$ ----------------------------------------------------------------------------- -- | Varieties of layout we can use. -data PPLayout = PPOffsideRule -- ^ classical layout - | PPSemiColon -- ^ classical layout made explicit - | PPInLine -- ^ inline decls, with newlines between them - | PPNoLayout -- ^ everything on a single line - deriving Eq +data PPLayout = PPOffsideRule -- ^ Classical layout. + | PPSemiColon -- ^ Classical layout made explicit. + | PPInLine -- ^ Inline decls, with newlines between them. + | PPNoLayout -- ^ Everything on a single line. + deriving Eq type Indent = Int @@ -43,58 +55,64 @@ -- -- /Note:/ the 'onsideIndent' must be positive and less than all other indents. data PPHsMode = PPHsMode { - -- | indentation of a class or instance - classIndent :: Indent, - -- | indentation of a @do@-expression - doIndent :: Indent, - -- | indentation of the body of a - -- @case@ expression - caseIndent :: Indent, - -- | indentation of the declarations in a - -- @let@ expression - letIndent :: Indent, - -- | indentation of the declarations in a - -- @where@ clause - whereIndent :: Indent, - -- | indentation added for continuation - -- lines that would otherwise be offside - onsideIndent :: Indent, - -- | blank lines between statements? - spacing :: Bool, - -- | Pretty-printing style to use - layout :: PPLayout, - -- | add GHC-style @LINE@ pragmas to output? - linePragmas :: Bool, - -- | not implemented yet - comments :: Bool - } + -- | Indentation of a class or instance. + classIndent :: Indent, + -- | Indentation of a @do@-expression. + doIndent :: Indent, + -- | Indentation of the body of a + -- @case@ expression. + caseIndent :: Indent, + -- | Indentation of the declarations in a + -- @let@ expression. + letIndent :: Indent, + -- | Indentation of the declarations in a + -- @where@ clause. + whereIndent :: Indent, + -- | Indentation added for continuation + -- lines that would otherwise be offside. + onsideIndent :: Indent, + -- | Blank lines between statements? + spacing :: Bool, + -- | Pretty-printing style to use. + layout :: PPLayout, + -- | Add GHC-style @LINE@ pragmas to output? + linePragmas :: Bool, + -- | (not implemented yet) + comments :: Bool + } -- | The default mode: pretty-print using the offside rule and sensible -- defaults. defaultMode :: PPHsMode defaultMode = PPHsMode{ - classIndent = 8, - doIndent = 3, - caseIndent = 4, - letIndent = 4, - whereIndent = 6, - onsideIndent = 2, - spacing = True, - layout = PPOffsideRule, - linePragmas = False, - comments = True - } + classIndent = 8, + doIndent = 3, + caseIndent = 4, + letIndent = 4, + whereIndent = 6, + onsideIndent = 2, + spacing = True, + layout = PPOffsideRule, + linePragmas = False, + comments = True + } -- | Pretty printing monad newtype DocM s a = DocM (s -> a) instance Functor (DocM s) where - fmap f xs = do x <- xs; return (f x) + fmap f xs = do x <- xs; return (f x) +-- | @since 1.0.2.0 +instance App.Applicative (DocM s) where + pure = retDocM + (<*>) = ap + (*>) = then_DocM + instance Monad (DocM s) where - (>>=) = thenDocM - (>>) = then_DocM - return = retDocM + (>>=) = thenDocM + (>>) = (*>) + return = pure {-# INLINE thenDocM #-} {-# INLINE then_DocM #-} @@ -128,12 +146,12 @@ -- | Things that can be pretty-printed, including all the syntactic objects -- in "Language.Haskell.Syntax". class Pretty a where - -- | Pretty-print something in isolation. - pretty :: a -> Doc - -- | Pretty-print something in a precedence context. - prettyPrec :: Int -> a -> Doc - pretty = prettyPrec 0 - prettyPrec _ = pretty + -- | Pretty-print something in isolation. + pretty :: a -> Doc + -- | Pretty-print something in a precedence context. + prettyPrec :: Int -> a -> Doc + pretty = prettyPrec 0 + prettyPrec _ = pretty -- The pretty printing combinators @@ -146,9 +164,9 @@ -- Literals -text, ptext :: String -> Doc +text :: String -> Doc text = return . P.text -ptext = return . P.text +-- ptext = return . P.text char :: Char -> Doc char = return . P.char @@ -165,80 +183,80 @@ double :: Double -> Doc double = return . P.double -rational :: Rational -> Doc -rational = return . P.rational +-- rational :: Rational -> Doc +-- rational = return . P.rational -- Simple Combining Forms -parens, brackets, braces,quotes,doubleQuotes :: Doc -> Doc +parens, brackets, braces :: Doc -> Doc parens d = d >>= return . P.parens brackets d = d >>= return . P.brackets braces d = d >>= return . P.braces -quotes d = d >>= return . P.quotes -doubleQuotes d = d >>= return . P.doubleQuotes +-- quotes d = d >>= return . P.quotes +-- doubleQuotes d = d >>= return . P.doubleQuotes parensIf :: Bool -> Doc -> Doc -parensIf True = parens +parensIf True = parens parensIf False = id -- Constants -semi,comma,colon,space,equals :: Doc +semi,comma,space,equals :: Doc semi = return P.semi comma = return P.comma -colon = return P.colon +-- colon = return P.colon space = return P.space equals = return P.equals -lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc -lparen = return P.lparen -rparen = return P.rparen -lbrack = return P.lbrack -rbrack = return P.rbrack -lbrace = return P.lbrace -rbrace = return P.rbrace +-- lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc +-- lparen = return P.lparen +-- rparen = return P.rparen +-- lbrack = return P.lbrack +-- rbrack = return P.rbrack +-- lbrace = return P.lbrace +-- rbrace = return P.rbrace -- Combinators -(<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc -aM <> bM = do{a<-aM;b<-bM;return (a P.<> b)} +(<<>>),(<+>),($$) :: Doc -> Doc -> Doc +aM <<>> bM = do{a<-aM;b<-bM;return (a P.<> b)} aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)} aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)} -aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)} +-- aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)} -hcat,hsep,vcat,sep,cat,fsep,fcat :: [Doc] -> Doc +hcat,hsep,vcat,fsep :: [Doc] -> Doc hcat dl = sequence dl >>= return . P.hcat hsep dl = sequence dl >>= return . P.hsep vcat dl = sequence dl >>= return . P.vcat -sep dl = sequence dl >>= return . P.sep -cat dl = sequence dl >>= return . P.cat +-- sep dl = sequence dl >>= return . P.sep +-- cat dl = sequence dl >>= return . P.cat fsep dl = sequence dl >>= return . P.fsep -fcat dl = sequence dl >>= return . P.fcat +-- fcat dl = sequence dl >>= return . P.fcat -- Some More -hang :: Doc -> Int -> Doc -> Doc -hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r} +-- hang :: Doc -> Int -> Doc -> Doc +-- hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r} -- Yuk, had to cut-n-paste this one from Pretty.hs punctuate :: Doc -> [Doc] -> [Doc] punctuate _ [] = [] punctuate p (d1:ds) = go d1 ds where - go d [] = [d] - go d (e:es) = (d <> p) : go e es + go d [] = [d] + go d (e:es) = (d <<>> p) : go e es -- | render the document with a given style and mode. renderStyleMode :: P.Style -> PPHsMode -> Doc -> String renderStyleMode ppStyle ppMode d = P.renderStyle ppStyle . unDocM d $ ppMode --- | render the document with a given mode. -renderWithMode :: PPHsMode -> Doc -> String -renderWithMode = renderStyleMode P.style +-- --- | render the document with a given mode. +-- renderWithMode :: PPHsMode -> Doc -> String +-- renderWithMode = renderStyleMode P.style --- | render the document with 'defaultMode'. -render :: Doc -> String -render = renderWithMode defaultMode +-- -- | render the document with 'defaultMode'. +-- render :: Doc -> String +-- render = renderWithMode defaultMode -- | pretty-print with a given style and mode. prettyPrintStyleMode :: Pretty a => P.Style -> PPHsMode -> a -> String @@ -252,198 +270,198 @@ prettyPrint :: Pretty a => a -> String prettyPrint = prettyPrintWithMode defaultMode -fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float -> - (P.TextDetails -> a -> a) -> a -> Doc -> a -fullRenderWithMode ppMode m i f fn e mD = - P.fullRender m i f fn e $ (unDocM mD) ppMode - - -fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) - -> a -> Doc -> a -fullRender = fullRenderWithMode defaultMode +-- fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float -> +-- (P.TextDetails -> a -> a) -> a -> Doc -> a +-- fullRenderWithMode ppMode m i f fn e mD = +-- P.fullRender m i f fn e $ (unDocM mD) ppMode +-- +-- +-- fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) +-- -> a -> Doc -> a +-- fullRender = fullRenderWithMode defaultMode ------------------------- Pretty-Print a Module -------------------- instance Pretty HsModule where - pretty (HsModule pos m mbExports imp decls) = - markLine pos $ - topLevel (ppHsModuleHeader m mbExports) - (map pretty imp ++ map pretty decls) + pretty (HsModule pos m mbExports imp decls) = + markLine pos $ + topLevel (ppHsModuleHeader m mbExports) + (map pretty imp ++ map pretty decls) -------------------------- Module Header ------------------------------ ppHsModuleHeader :: Module -> Maybe [HsExportSpec] -> Doc ppHsModuleHeader m mbExportList = mySep [ - text "module", - pretty m, - maybePP (parenList . map pretty) mbExportList, - text "where"] + text "module", + pretty m, + maybePP (parenList . map pretty) mbExportList, + text "where"] instance Pretty Module where - pretty (Module modName) = text modName + pretty (Module modName) = text modName instance Pretty HsExportSpec where - pretty (HsEVar name) = pretty name - pretty (HsEAbs name) = pretty name - pretty (HsEThingAll name) = pretty name <> text "(..)" - pretty (HsEThingWith name nameList) = - pretty name <> (parenList . map pretty $ nameList) - pretty (HsEModuleContents m) = text "module" <+> pretty m + pretty (HsEVar name) = pretty name + pretty (HsEAbs name) = pretty name + pretty (HsEThingAll name) = pretty name <<>> text "(..)" + pretty (HsEThingWith name nameList) = + pretty name <<>> (parenList . map pretty $ nameList) + pretty (HsEModuleContents m) = text "module" <+> pretty m instance Pretty HsImportDecl where - pretty (HsImportDecl pos m qual mbName mbSpecs) = - markLine pos $ - mySep [text "import", - if qual then text "qualified" else empty, - pretty m, - maybePP (\m' -> text "as" <+> pretty m') mbName, - maybePP exports mbSpecs] - where - exports (b,specList) = - if b then text "hiding" <+> specs else specs - where specs = parenList . map pretty $ specList + pretty (HsImportDecl pos m qual mbName mbSpecs) = + markLine pos $ + mySep [text "import", + if qual then text "qualified" else empty, + pretty m, + maybePP (\m' -> text "as" <+> pretty m') mbName, + maybePP exports mbSpecs] + where + exports (b,specList) = + if b then text "hiding" <+> specs else specs + where specs = parenList . map pretty $ specList instance Pretty HsImportSpec where - pretty (HsIVar name) = pretty name - pretty (HsIAbs name) = pretty name - pretty (HsIThingAll name) = pretty name <> text "(..)" - pretty (HsIThingWith name nameList) = - pretty name <> (parenList . map pretty $ nameList) + pretty (HsIVar name) = pretty name + pretty (HsIAbs name) = pretty name + pretty (HsIThingAll name) = pretty name <<>> text "(..)" + pretty (HsIThingWith name nameList) = + pretty name <<>> (parenList . map pretty $ nameList) ------------------------- Declarations ------------------------------ instance Pretty HsDecl where - pretty (HsTypeDecl loc name nameList htype) = - blankline $ - markLine loc $ - mySep ( [text "type", pretty name] - ++ map pretty nameList - ++ [equals, pretty htype]) + pretty (HsTypeDecl loc name nameList htype) = + blankline $ + markLine loc $ + mySep ( [text "type", pretty name] + ++ map pretty nameList + ++ [equals, pretty htype]) - pretty (HsDataDecl loc context name nameList constrList derives) = - blankline $ - markLine loc $ - mySep ( [text "data", ppHsContext context, pretty name] - ++ map pretty nameList) - <+> (myVcat (zipWith (<+>) (equals : repeat (char '|')) - (map pretty constrList)) - $$$ ppHsDeriving derives) + pretty (HsDataDecl loc context name nameList constrList derives) = + blankline $ + markLine loc $ + mySep ( [text "data", ppHsContext context, pretty name] + ++ map pretty nameList) + <+> (myVcat (zipWith (<+>) (equals : repeat (char '|')) + (map pretty constrList)) + $$$ ppHsDeriving derives) - pretty (HsNewTypeDecl pos context name nameList constr derives) = - blankline $ - markLine pos $ - mySep ( [text "newtype", ppHsContext context, pretty name] - ++ map pretty nameList) - <+> equals <+> (pretty constr $$$ ppHsDeriving derives) + pretty (HsNewTypeDecl pos context name nameList constr derives) = + blankline $ + markLine pos $ + mySep ( [text "newtype", ppHsContext context, pretty name] + ++ map pretty nameList) + <+> equals <+> (pretty constr $$$ ppHsDeriving derives) - --m{spacing=False} - -- special case for empty class declaration - pretty (HsClassDecl pos context name nameList []) = - blankline $ - markLine pos $ - mySep ( [text "class", ppHsContext context, pretty name] - ++ map pretty nameList) - pretty (HsClassDecl pos context name nameList declList) = - blankline $ - markLine pos $ - mySep ( [text "class", ppHsContext context, pretty name] - ++ map pretty nameList ++ [text "where"]) - $$$ ppBody classIndent (map pretty declList) + --m{spacing=False} + -- special case for empty class declaration + pretty (HsClassDecl pos context name nameList []) = + blankline $ + markLine pos $ + mySep ( [text "class", ppHsContext context, pretty name] + ++ map pretty nameList) + pretty (HsClassDecl pos context name nameList declList) = + blankline $ + markLine pos $ + mySep ( [text "class", ppHsContext context, pretty name] + ++ map pretty nameList ++ [text "where"]) + $$$ ppBody classIndent (map pretty declList) - -- m{spacing=False} - -- special case for empty instance declaration - pretty (HsInstDecl pos context name args []) = - blankline $ - markLine pos $ - mySep ( [text "instance", ppHsContext context, pretty name] - ++ map ppHsAType args) - pretty (HsInstDecl pos context name args declList) = - blankline $ - markLine pos $ - mySep ( [text "instance", ppHsContext context, pretty name] - ++ map ppHsAType args ++ [text "where"]) - $$$ ppBody classIndent (map pretty declList) + -- m{spacing=False} + -- special case for empty instance declaration + pretty (HsInstDecl pos context name args []) = + blankline $ + markLine pos $ + mySep ( [text "instance", ppHsContext context, pretty name] + ++ map ppHsAType args) + pretty (HsInstDecl pos context name args declList) = + blankline $ + markLine pos $ + mySep ( [text "instance", ppHsContext context, pretty name] + ++ map ppHsAType args ++ [text "where"]) + $$$ ppBody classIndent (map pretty declList) - pretty (HsDefaultDecl pos htypes) = - blankline $ - markLine pos $ - text "default" <+> parenList (map pretty htypes) + pretty (HsDefaultDecl pos htypes) = + blankline $ + markLine pos $ + text "default" <+> parenList (map pretty htypes) - pretty (HsTypeSig pos nameList qualType) = - blankline $ - markLine pos $ - mySep ((punctuate comma . map pretty $ nameList) - ++ [text "::", pretty qualType]) + pretty (HsTypeSig pos nameList qualType) = + blankline $ + markLine pos $ + mySep ((punctuate comma . map pretty $ nameList) + ++ [text "::", pretty qualType]) - pretty (HsForeignImport pos conv safety entity name ty) = - blankline $ - markLine pos $ - mySep $ [text "foreign", text "import", text conv, pretty safety] ++ - (if null entity then [] else [text (show entity)]) ++ - [pretty name, text "::", pretty ty] + pretty (HsForeignImport pos conv safety entity name ty) = + blankline $ + markLine pos $ + mySep $ [text "foreign", text "import", text conv, pretty safety] ++ + (if null entity then [] else [text (show entity)]) ++ + [pretty name, text "::", pretty ty] - pretty (HsForeignExport pos conv entity name ty) = - blankline $ - markLine pos $ - mySep $ [text "foreign", text "export", text conv] ++ - (if null entity then [] else [text (show entity)]) ++ - [pretty name, text "::", pretty ty] + pretty (HsForeignExport pos conv entity name ty) = + blankline $ + markLine pos $ + mySep $ [text "foreign", text "export", text conv] ++ + (if null entity then [] else [text (show entity)]) ++ + [pretty name, text "::", pretty ty] - pretty (HsFunBind matches) = - ppBindings (map pretty matches) + pretty (HsFunBind matches) = + ppBindings (map pretty matches) - pretty (HsPatBind pos pat rhs whereDecls) = - markLine pos $ - myFsep [pretty pat, pretty rhs] $$$ ppWhere whereDecls + pretty (HsPatBind pos pat rhs whereDecls) = + markLine pos $ + myFsep [pretty pat, pretty rhs] $$$ ppWhere whereDecls - pretty (HsInfixDecl pos assoc prec opList) = - blankline $ - markLine pos $ - mySep ([pretty assoc, int prec] - ++ (punctuate comma . map pretty $ opList)) + pretty (HsInfixDecl pos assoc prec opList) = + blankline $ + markLine pos $ + mySep ([pretty assoc, int prec] + ++ (punctuate comma . map pretty $ opList)) instance Pretty HsAssoc where - pretty HsAssocNone = text "infix" - pretty HsAssocLeft = text "infixl" - pretty HsAssocRight = text "infixr" + pretty HsAssocNone = text "infix" + pretty HsAssocLeft = text "infixl" + pretty HsAssocRight = text "infixr" instance Pretty HsSafety where - pretty HsSafe = text "safe" - pretty HsUnsafe = text "unsafe" + pretty HsSafe = text "safe" + pretty HsUnsafe = text "unsafe" instance Pretty HsMatch where - pretty (HsMatch pos f ps rhs whereDecls) = - markLine pos $ - myFsep (lhs ++ [pretty rhs]) - $$$ ppWhere whereDecls - where - lhs = case ps of - l:r:ps' | isSymbolName f -> - let hd = [pretty l, ppHsName f, pretty r] in - if null ps' then hd - else parens (myFsep hd) : map (prettyPrec 2) ps' - _ -> pretty f : map (prettyPrec 2) ps + pretty (HsMatch pos f ps rhs whereDecls) = + markLine pos $ + myFsep (lhs ++ [pretty rhs]) + $$$ ppWhere whereDecls + where + lhs = case ps of + l:r:ps' | isSymbolName f -> + let hd = [pretty l, ppHsName f, pretty r] in + if null ps' then hd + else parens (myFsep hd) : map (prettyPrec 2) ps' + _ -> pretty f : map (prettyPrec 2) ps ppWhere :: [HsDecl] -> Doc ppWhere [] = empty -ppWhere l = nest 2 (text "where" $$$ ppBody whereIndent (map pretty l)) +ppWhere l = nest 2 (text "where" $$$ ppBody whereIndent (map pretty l)) ------------------------- Data & Newtype Bodies ------------------------- instance Pretty HsConDecl where - pretty (HsRecDecl _pos name fieldList) = - pretty name <> (braceList . map ppField $ fieldList) + pretty (HsRecDecl _pos name fieldList) = + pretty name <<>> (braceList . map ppField $ fieldList) - pretty (HsConDecl _pos name@(HsSymbol _) [l, r]) = - myFsep [prettyPrec prec_btype l, ppHsName name, - prettyPrec prec_btype r] - pretty (HsConDecl _pos name typeList) = - mySep $ ppHsName name : map (prettyPrec prec_atype) typeList + pretty (HsConDecl _pos name@(HsSymbol _) [l, r]) = + myFsep [prettyPrec prec_btype l, ppHsName name, + prettyPrec prec_btype r] + pretty (HsConDecl _pos name typeList) = + mySep $ ppHsName name : map (prettyPrec prec_atype) typeList ppField :: ([HsName],HsBangType) -> Doc ppField (names, ty) = - myFsepSimple $ (punctuate comma . map pretty $ names) ++ - [text "::", pretty ty] + myFsepSimple $ (punctuate comma . map pretty $ names) ++ + [text "::", pretty ty] instance Pretty HsBangType where - prettyPrec _ (HsBangedTy ty) = char '!' <> ppHsAType ty - prettyPrec p (HsUnBangedTy ty) = prettyPrec p ty + prettyPrec _ (HsBangedTy ty) = char '!' <<>> ppHsAType ty + prettyPrec p (HsUnBangedTy ty) = prettyPrec p ty ppHsDeriving :: [HsQName] -> Doc ppHsDeriving [] = empty @@ -452,8 +470,8 @@ ------------------------- Types ------------------------- instance Pretty HsQualType where - pretty (HsQualType context htype) = - myFsep [ppHsContext context, pretty htype] + pretty (HsQualType context htype) = + myFsep [ppHsContext context, pretty htype] ppHsBType :: HsType -> Doc ppHsBType = prettyPrec prec_btype @@ -463,209 +481,209 @@ -- precedences for types prec_btype, prec_atype :: Int -prec_btype = 1 -- left argument of ->, - -- or either argument of an infix data constructor -prec_atype = 2 -- argument of type or data constructor, or of a class +prec_btype = 1 -- left argument of ->, + -- or either argument of an infix data constructor +prec_atype = 2 -- argument of type or data constructor, or of a class instance Pretty HsType where - prettyPrec p (HsTyFun a b) = parensIf (p > 0) $ - myFsep [ppHsBType a, text "->", pretty b] - prettyPrec _ (HsTyTuple l) = parenList . map pretty $ l - prettyPrec p (HsTyApp a b) - | a == list_tycon = brackets $ pretty b -- special case - | otherwise = parensIf (p > prec_btype) $ - myFsep [pretty a, ppHsAType b] - prettyPrec _ (HsTyVar name) = pretty name - prettyPrec _ (HsTyCon name) = pretty name + prettyPrec p (HsTyFun a b) = parensIf (p > 0) $ + myFsep [ppHsBType a, text "->", pretty b] + prettyPrec _ (HsTyTuple l) = parenList . map pretty $ l + prettyPrec p (HsTyApp a b) + | a == list_tycon = brackets $ pretty b -- special case + | otherwise = parensIf (p > prec_btype) $ + myFsep [pretty a, ppHsAType b] + prettyPrec _ (HsTyVar name) = pretty name + prettyPrec _ (HsTyCon name) = pretty name ------------------------- Expressions ------------------------- instance Pretty HsRhs where - pretty (HsUnGuardedRhs e) = equals <+> pretty e - pretty (HsGuardedRhss guardList) = myVcat . map pretty $ guardList + pretty (HsUnGuardedRhs e) = equals <+> pretty e + pretty (HsGuardedRhss guardList) = myVcat . map pretty $ guardList instance Pretty HsGuardedRhs where - pretty (HsGuardedRhs _pos guard body) = - myFsep [char '|', pretty guard, equals, pretty body] + pretty (HsGuardedRhs _pos guard body) = + myFsep [char '|', pretty guard, equals, pretty body] instance Pretty HsLiteral where - pretty (HsInt i) = integer i - pretty (HsChar c) = text (show c) - pretty (HsString s) = text (show s) - pretty (HsFrac r) = double (fromRational r) - -- GHC unboxed literals: - pretty (HsCharPrim c) = text (show c) <> char '#' - pretty (HsStringPrim s) = text (show s) <> char '#' - pretty (HsIntPrim i) = integer i <> char '#' - pretty (HsFloatPrim r) = float (fromRational r) <> char '#' - pretty (HsDoublePrim r) = double (fromRational r) <> text "##" + pretty (HsInt i) = integer i + pretty (HsChar c) = text (show c) + pretty (HsString s) = text (show s) + pretty (HsFrac r) = double (fromRational r) + -- GHC unboxed literals: + pretty (HsCharPrim c) = text (show c) <<>> char '#' + pretty (HsStringPrim s) = text (show s) <<>> char '#' + pretty (HsIntPrim i) = integer i <<>> char '#' + pretty (HsFloatPrim r) = float (fromRational r) <<>> char '#' + pretty (HsDoublePrim r) = double (fromRational r) <<>> text "##" instance Pretty HsExp where - pretty (HsLit l) = pretty l - -- lambda stuff - pretty (HsInfixApp a op b) = myFsep [pretty a, pretty op, pretty b] - pretty (HsNegApp e) = myFsep [char '-', pretty e] - pretty (HsApp a b) = myFsep [pretty a, pretty b] - pretty (HsLambda _loc expList body) = myFsep $ - char '\\' : map pretty expList ++ [text "->", pretty body] - -- keywords - pretty (HsLet expList letBody) = - myFsep [text "let" <+> ppBody letIndent (map pretty expList), - text "in", pretty letBody] - pretty (HsIf cond thenexp elsexp) = - myFsep [text "if", pretty cond, - text "then", pretty thenexp, - text "else", pretty elsexp] - pretty (HsCase cond altList) = - myFsep [text "case", pretty cond, text "of"] - $$$ ppBody caseIndent (map pretty altList) - pretty (HsDo stmtList) = - text "do" $$$ ppBody doIndent (map pretty stmtList) - -- Constructors & Vars - pretty (HsVar name) = pretty name - pretty (HsCon name) = pretty name - pretty (HsTuple expList) = parenList . map pretty $ expList - -- weird stuff - pretty (HsParen e) = parens . pretty $ e - pretty (HsLeftSection e op) = parens (pretty e <+> pretty op) - pretty (HsRightSection op e) = parens (pretty op <+> pretty e) - pretty (HsRecConstr c fieldList) = - pretty c <> (braceList . map pretty $ fieldList) - pretty (HsRecUpdate e fieldList) = - pretty e <> (braceList . map pretty $ fieldList) - -- patterns - -- special case that would otherwise be buggy - pretty (HsAsPat name (HsIrrPat e)) = - myFsep [pretty name <> char '@', char '~' <> pretty e] - pretty (HsAsPat name e) = hcat [pretty name, char '@', pretty e] - pretty HsWildCard = char '_' - pretty (HsIrrPat e) = char '~' <> pretty e - -- Lists - pretty (HsList list) = - bracketList . punctuate comma . map pretty $ list - pretty (HsEnumFrom e) = - bracketList [pretty e, text ".."] - pretty (HsEnumFromTo from to) = - bracketList [pretty from, text "..", pretty to] - pretty (HsEnumFromThen from thenE) = - bracketList [pretty from <> comma, pretty thenE, text ".."] - pretty (HsEnumFromThenTo from thenE to) = - bracketList [pretty from <> comma, pretty thenE, - text "..", pretty to] - pretty (HsListComp e stmtList) = - bracketList ([pretty e, char '|'] - ++ (punctuate comma . map pretty $ stmtList)) - pretty (HsExpTypeSig _pos e ty) = - myFsep [pretty e, text "::", pretty ty] + pretty (HsLit l) = pretty l + -- lambda stuff + pretty (HsInfixApp a op b) = myFsep [pretty a, pretty op, pretty b] + pretty (HsNegApp e) = myFsep [char '-', pretty e] + pretty (HsApp a b) = myFsep [pretty a, pretty b] + pretty (HsLambda _loc expList body) = myFsep $ + char '\\' : map pretty expList ++ [text "->", pretty body] + -- keywords + pretty (HsLet expList letBody) = + myFsep [text "let" <+> ppBody letIndent (map pretty expList), + text "in", pretty letBody] + pretty (HsIf cond thenexp elsexp) = + myFsep [text "if", pretty cond, + text "then", pretty thenexp, + text "else", pretty elsexp] + pretty (HsCase cond altList) = + myFsep [text "case", pretty cond, text "of"] + $$$ ppBody caseIndent (map pretty altList) + pretty (HsDo stmtList) = + text "do" $$$ ppBody doIndent (map pretty stmtList) + -- Constructors & Vars + pretty (HsVar name) = pretty name + pretty (HsCon name) = pretty name + pretty (HsTuple expList) = parenList . map pretty $ expList + -- weird stuff + pretty (HsParen e) = parens . pretty $ e + pretty (HsLeftSection e op) = parens (pretty e <+> pretty op) + pretty (HsRightSection op e) = parens (pretty op <+> pretty e) + pretty (HsRecConstr c fieldList) = + pretty c <<>> (braceList . map pretty $ fieldList) + pretty (HsRecUpdate e fieldList) = + pretty e <<>> (braceList . map pretty $ fieldList) + -- patterns + -- special case that would otherwise be buggy + pretty (HsAsPat name (HsIrrPat e)) = + myFsep [pretty name <<>> char '@', char '~' <<>> pretty e] + pretty (HsAsPat name e) = hcat [pretty name, char '@', pretty e] + pretty HsWildCard = char '_' + pretty (HsIrrPat e) = char '~' <<>> pretty e + -- Lists + pretty (HsList list) = + bracketList . punctuate comma . map pretty $ list + pretty (HsEnumFrom e) = + bracketList [pretty e, text ".."] + pretty (HsEnumFromTo from to) = + bracketList [pretty from, text "..", pretty to] + pretty (HsEnumFromThen from thenE) = + bracketList [pretty from <<>> comma, pretty thenE, text ".."] + pretty (HsEnumFromThenTo from thenE to) = + bracketList [pretty from <<>> comma, pretty thenE, + text "..", pretty to] + pretty (HsListComp e stmtList) = + bracketList ([pretty e, char '|'] + ++ (punctuate comma . map pretty $ stmtList)) + pretty (HsExpTypeSig _pos e ty) = + myFsep [pretty e, text "::", pretty ty] ------------------------- Patterns ----------------------------- instance Pretty HsPat where - prettyPrec _ (HsPVar name) = pretty name - prettyPrec _ (HsPLit lit) = pretty lit - prettyPrec _ (HsPNeg p) = myFsep [char '-', pretty p] - prettyPrec p (HsPInfixApp a op b) = parensIf (p > 0) $ - myFsep [pretty a, pretty (HsQConOp op), pretty b] - prettyPrec p (HsPApp n ps) = parensIf (p > 1) $ - myFsep (pretty n : map pretty ps) - prettyPrec _ (HsPTuple ps) = parenList . map pretty $ ps - prettyPrec _ (HsPList ps) = - bracketList . punctuate comma . map pretty $ ps - prettyPrec _ (HsPParen p) = parens . pretty $ p - prettyPrec _ (HsPRec c fields) = - pretty c <> (braceList . map pretty $ fields) - -- special case that would otherwise be buggy - prettyPrec _ (HsPAsPat name (HsPIrrPat pat)) = - myFsep [pretty name <> char '@', char '~' <> pretty pat] - prettyPrec _ (HsPAsPat name pat) = - hcat [pretty name, char '@', pretty pat] - prettyPrec _ HsPWildCard = char '_' - prettyPrec _ (HsPIrrPat pat) = char '~' <> pretty pat + prettyPrec _ (HsPVar name) = pretty name + prettyPrec _ (HsPLit lit) = pretty lit + prettyPrec _ (HsPNeg p) = myFsep [char '-', pretty p] + prettyPrec p (HsPInfixApp a op b) = parensIf (p > 0) $ + myFsep [pretty a, pretty (HsQConOp op), pretty b] + prettyPrec p (HsPApp n ps) = parensIf (p > 1) $ + myFsep (pretty n : map pretty ps) + prettyPrec _ (HsPTuple ps) = parenList . map pretty $ ps + prettyPrec _ (HsPList ps) = + bracketList . punctuate comma . map pretty $ ps + prettyPrec _ (HsPParen p) = parens . pretty $ p + prettyPrec _ (HsPRec c fields) = + pretty c <<>> (braceList . map pretty $ fields) + -- special case that would otherwise be buggy + prettyPrec _ (HsPAsPat name (HsPIrrPat pat)) = + myFsep [pretty name <<>> char '@', char '~' <<>> pretty pat] + prettyPrec _ (HsPAsPat name pat) = + hcat [pretty name, char '@', pretty pat] + prettyPrec _ HsPWildCard = char '_' + prettyPrec _ (HsPIrrPat pat) = char '~' <<>> pretty pat instance Pretty HsPatField where - pretty (HsPFieldPat name pat) = - myFsep [pretty name, equals, pretty pat] + pretty (HsPFieldPat name pat) = + myFsep [pretty name, equals, pretty pat] ------------------------- Case bodies ------------------------- instance Pretty HsAlt where - pretty (HsAlt _pos e gAlts decls) = - myFsep [pretty e, pretty gAlts] $$$ ppWhere decls + pretty (HsAlt _pos e gAlts decls) = + myFsep [pretty e, pretty gAlts] $$$ ppWhere decls instance Pretty HsGuardedAlts where - pretty (HsUnGuardedAlt e) = text "->" <+> pretty e - pretty (HsGuardedAlts altList) = myVcat . map pretty $ altList + pretty (HsUnGuardedAlt e) = text "->" <+> pretty e + pretty (HsGuardedAlts altList) = myVcat . map pretty $ altList instance Pretty HsGuardedAlt where - pretty (HsGuardedAlt _pos e body) = - myFsep [char '|', pretty e, text "->", pretty body] + pretty (HsGuardedAlt _pos e body) = + myFsep [char '|', pretty e, text "->", pretty body] ------------------------- Statements in monads & list comprehensions ----- instance Pretty HsStmt where - pretty (HsGenerator _loc e from) = - pretty e <+> text "<-" <+> pretty from - pretty (HsQualifier e) = pretty e - pretty (HsLetStmt declList) = - text "let" $$$ ppBody letIndent (map pretty declList) + pretty (HsGenerator _loc e from) = + pretty e <+> text "<-" <+> pretty from + pretty (HsQualifier e) = pretty e + pretty (HsLetStmt declList) = + text "let" $$$ ppBody letIndent (map pretty declList) ------------------------- Record updates instance Pretty HsFieldUpdate where - pretty (HsFieldUpdate name e) = - myFsep [pretty name, equals, pretty e] + pretty (HsFieldUpdate name e) = + myFsep [pretty name, equals, pretty e] ------------------------- Names ------------------------- instance Pretty HsQOp where - pretty (HsQVarOp n) = ppHsQNameInfix n - pretty (HsQConOp n) = ppHsQNameInfix n + pretty (HsQVarOp n) = ppHsQNameInfix n + pretty (HsQConOp n) = ppHsQNameInfix n ppHsQNameInfix :: HsQName -> Doc ppHsQNameInfix name - | isSymbolName (getName name) = ppHsQName name - | otherwise = char '`' <> ppHsQName name <> char '`' + | isSymbolName (getName name) = ppHsQName name + | otherwise = char '`' <<>> ppHsQName name <<>> char '`' instance Pretty HsQName where - pretty name = parensIf (isSymbolName (getName name)) (ppHsQName name) + pretty name = parensIf (isSymbolName (getName name)) (ppHsQName name) ppHsQName :: HsQName -> Doc ppHsQName (UnQual name) = ppHsName name -ppHsQName (Qual m name) = pretty m <> char '.' <> ppHsName name +ppHsQName (Qual m name) = pretty m <<>> char '.' <<>> ppHsName name ppHsQName (Special sym) = text (specialName sym) instance Pretty HsOp where - pretty (HsVarOp n) = ppHsNameInfix n - pretty (HsConOp n) = ppHsNameInfix n + pretty (HsVarOp n) = ppHsNameInfix n + pretty (HsConOp n) = ppHsNameInfix n ppHsNameInfix :: HsName -> Doc ppHsNameInfix name - | isSymbolName name = ppHsName name - | otherwise = char '`' <> ppHsName name <> char '`' + | isSymbolName name = ppHsName name + | otherwise = char '`' <<>> ppHsName name <<>> char '`' instance Pretty HsName where - pretty name = parensIf (isSymbolName name) (ppHsName name) + pretty name = parensIf (isSymbolName name) (ppHsName name) ppHsName :: HsName -> Doc ppHsName (HsIdent s) = text s ppHsName (HsSymbol s) = text s instance Pretty HsCName where - pretty (HsVarName n) = pretty n - pretty (HsConName n) = pretty n + pretty (HsVarName n) = pretty n + pretty (HsConName n) = pretty n isSymbolName :: HsName -> Bool isSymbolName (HsSymbol _) = True -isSymbolName _ = False +isSymbolName _ = False getName :: HsQName -> HsName -getName (UnQual s) = s -getName (Qual _ s) = s -getName (Special HsCons) = HsSymbol ":" +getName (UnQual s) = s +getName (Qual _ s) = s +getName (Special HsCons) = HsSymbol ":" getName (Special HsFunCon) = HsSymbol "->" -getName (Special s) = HsIdent (specialName s) +getName (Special s) = HsIdent (specialName s) specialName :: HsSpecialCon -> String -specialName HsUnitCon = "()" -specialName HsListCon = "[]" -specialName HsFunCon = "->" +specialName HsUnitCon = "()" +specialName HsListCon = "[]" +specialName HsFunCon = "->" specialName (HsTupleCon n) = "(" ++ replicate (n-1) ',' ++ ")" -specialName HsCons = ":" +specialName HsCons = ":" ppHsContext :: HsContext -> Doc ppHsContext [] = empty @@ -678,7 +696,7 @@ ------------------------- pp utils ------------------------- maybePP :: (a -> Doc) -> Maybe a -> Doc -maybePP _ Nothing = empty +maybePP _ Nothing = empty maybePP pp (Just a) = pp a parenList :: [Doc] -> Doc @@ -693,53 +711,53 @@ -- Wrap in braces and semicolons, with an extra space at the start in -- case the first doc begins with "-", which would be scanned as {- flatBlock :: [Doc] -> Doc -flatBlock = braces . (space <>) . hsep . punctuate semi +flatBlock = braces . (space <<>>) . hsep . punctuate semi -- Same, but put each thing on a separate line prettyBlock :: [Doc] -> Doc -prettyBlock = braces . (space <>) . vcat . punctuate semi +prettyBlock = braces . (space <<>>) . vcat . punctuate semi -- Monadic PP Combinators -- these examine the env blankline :: Doc -> Doc blankline dl = do{e<-getPPEnv;if spacing e && layout e /= PPNoLayout - then space $$ dl else dl} + then space $$ dl else dl} topLevel :: Doc -> [Doc] -> Doc topLevel header dl = do - e <- fmap layout getPPEnv - case e of - PPOffsideRule -> header $$ vcat dl - PPSemiColon -> header $$ prettyBlock dl - PPInLine -> header $$ prettyBlock dl - PPNoLayout -> header <+> flatBlock dl + e <- fmap layout getPPEnv + case e of + PPOffsideRule -> header $$ vcat dl + PPSemiColon -> header $$ prettyBlock dl + PPInLine -> header $$ prettyBlock dl + PPNoLayout -> header <+> flatBlock dl ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc ppBody f dl = do - e <- fmap layout getPPEnv - i <- fmap f getPPEnv - case e of - PPOffsideRule -> nest i . vcat $ dl - PPSemiColon -> nest i . prettyBlock $ dl - _ -> flatBlock dl + e <- fmap layout getPPEnv + i <- fmap f getPPEnv + case e of + PPOffsideRule -> nest i . vcat $ dl + PPSemiColon -> nest i . prettyBlock $ dl + _ -> flatBlock dl ppBindings :: [Doc] -> Doc ppBindings dl = do - e <- fmap layout getPPEnv - case e of - PPOffsideRule -> vcat dl - PPSemiColon -> vcat . punctuate semi $ dl - _ -> hsep . punctuate semi $ dl + e <- fmap layout getPPEnv + case e of + PPOffsideRule -> vcat dl + PPSemiColon -> vcat . punctuate semi $ dl + _ -> hsep . punctuate semi $ dl ($$$) :: Doc -> Doc -> Doc a $$$ b = layoutChoice (a $$) (a <+>) b mySep :: [Doc] -> Doc mySep = layoutChoice mySep' hsep - where - -- ensure paragraph fills with indentation. - mySep' [x] = x - mySep' (x:xs) = x <+> fsep xs - mySep' [] = error "Internal error: mySep" + where + -- ensure paragraph fills with indentation. + mySep' [x] = x + mySep' (x:xs) = x <+> fsep xs + mySep' [] = error "Internal error: mySep" myVcat :: [Doc] -> Doc myVcat = layoutChoice vcat hsep @@ -751,11 +769,11 @@ -- which is necessary to avoid triggering the offside rule. myFsep :: [Doc] -> Doc myFsep = layoutChoice fsep' hsep - where fsep' [] = empty - fsep' (d:ds) = do - e <- getPPEnv - let n = onsideIndent e - nest n (fsep (nest (-n) d:ds)) + where fsep' [] = empty + fsep' (d:ds) = do + e <- getPPEnv + let n = onsideIndent e + nest n (fsep (nest (-n) d:ds)) layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc layoutChoice a b dl = do e <- getPPEnv @@ -770,9 +788,9 @@ markLine :: SrcLoc -> Doc -> Doc markLine loc doc = do - e <- getPPEnv - let y = srcLine loc - let line l = - text ("{-# LINE " ++ show l ++ " \"" ++ srcFilename loc ++ "\" #-}") - if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc - else doc + e <- getPPEnv + let y = srcLine loc + let line l = + text ("{-# LINE " ++ show l ++ " \"" ++ srcFilename loc ++ "\" #-}") + if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc + else doc diff --git a/Language/Haskell/Syntax.hs b/Language/Haskell/Syntax.hs --- a/Language/Haskell/Syntax.hs +++ b/Language/Haskell/Syntax.hs @@ -1,23 +1,24 @@ -{-# OPTIONS_GHC -fglasgow-exts -cpp #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} + ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Syntax -- Copyright : (c) The GHC Team, 1997-2000 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental +-- License : BSD-3-Clause +-- +-- Maintainer : Andreas Abel +-- Stability : stable -- Portability : portable -- --- A suite of datatypes describing the abstract syntax of Haskell 98 --- plus a few extensions: +-- A suite of datatypes describing the abstract syntax of +-- plus a few extensions: -- -- * multi-parameter type classes -- -- * parameters of type class assertions are unrestricted --- --- This module has been changed so that show is a real show. --- For GHC, we also derive Typeable and Data for all types. +-- +-- For GHC, we also derive 'Data' for all types. ----------------------------------------------------------------------------- @@ -63,18 +64,18 @@ #ifdef __GLASGOW_HASKELL__ -import Data.Generics.Basics -import Data.Generics.Instances() +import Data.Generics.Basics +import Data.Generics.Instances () #endif -- | A position in the source. data SrcLoc = SrcLoc { - srcFilename :: String, - srcLine :: Int, - srcColumn :: Int - } + srcFilename :: String, + srcLine :: Int, + srcColumn :: Int + } #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Ord,Show,Typeable,Data) + deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif @@ -82,7 +83,7 @@ -- | The name of a Haskell module. newtype Module = Module String #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Ord,Show,Typeable,Data) + deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif @@ -92,14 +93,14 @@ -- data constructors. data HsSpecialCon - = HsUnitCon -- ^ unit type and data constructor @()@ - | HsListCon -- ^ list type constructor @[]@ - | HsFunCon -- ^ function type constructor @->@ - | HsTupleCon Int -- ^ /n/-ary tuple type and data - -- constructors @(,)@ etc - | HsCons -- ^ list data constructor @(:)@ + = HsUnitCon -- ^ Unit type and data constructor @()@. + | HsListCon -- ^ List type constructor @[]@. + | HsFunCon -- ^ Function type constructor @->@. + | HsTupleCon Int -- ^ /n/-ary tuple type and data + -- constructors @(,)@ etc. + | HsCons -- ^ List data constructor @(:)@. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Ord,Show,Typeable,Data) + deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif @@ -107,41 +108,41 @@ -- | This type is used to represent qualified variables, and also -- qualified constructors. data HsQName - = Qual Module HsName -- ^ name qualified with a module name - | UnQual HsName -- ^ unqualified name - | Special HsSpecialCon -- ^ built-in constructor with special syntax + = Qual Module HsName -- ^ Name qualified with a module name. + | UnQual HsName -- ^ Unqualified name. + | Special HsSpecialCon -- ^ Built-in constructor with special syntax. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Ord,Show,Typeable,Data) + deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif -- | This type is used to represent variables, and also constructors. data HsName - = HsIdent String -- ^ /varid/ or /conid/ - | HsSymbol String -- ^ /varsym/ or /consym/ + = HsIdent String -- ^ /varid/ or /conid/. + | HsSymbol String -- ^ /varsym/ or /consym/. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Ord,Show,Typeable,Data) + deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif -- | Possibly qualified infix operators (/qop/), appearing in expressions. data HsQOp - = HsQVarOp HsQName -- ^ variable operator (/qvarop/) - | HsQConOp HsQName -- ^ constructor operator (/qconop/) + = HsQVarOp HsQName -- ^ Variable operator (/qvarop/). + | HsQConOp HsQName -- ^ Constructor operator (/qconop/). #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Ord,Show,Typeable,Data) + deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif -- | Operators, appearing in @infix@ declarations. data HsOp - = HsVarOp HsName -- ^ variable operator (/varop/) - | HsConOp HsName -- ^ constructor operator (/conop/) + = HsVarOp HsName -- ^ Variable operator (/varop/). + | HsConOp HsName -- ^ Constructor operator (/conop/). #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Ord,Show,Typeable,Data) + deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif @@ -149,10 +150,10 @@ -- | A name (/cname/) of a component of a class or data type in an @import@ -- or export specification. data HsCName - = HsVarName HsName -- ^ name of a method or field - | HsConName HsName -- ^ name of a data constructor + = HsVarName HsName -- ^ Name of a method or field. + | HsConName HsName -- ^ Name of a data constructor. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Ord,Show,Typeable,Data) + deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif @@ -161,113 +162,113 @@ data HsModule = HsModule SrcLoc Module (Maybe [HsExportSpec]) [HsImportDecl] [HsDecl] #ifdef __GLASGOW_HASKELL__ - deriving (Show,Typeable,Data) + deriving (Eq,Show,Data) #else - deriving (Show) + deriving (Eq,Show) #endif -- | Export specification. data HsExportSpec - = HsEVar HsQName -- ^ variable - | HsEAbs HsQName -- ^ @T@: - -- a class or datatype exported abstractly, - -- or a type synonym. - | HsEThingAll HsQName -- ^ @T(..)@: - -- a class exported with all of its methods, or - -- a datatype exported with all of its constructors. - | HsEThingWith HsQName [HsCName] -- ^ @T(C_1,...,C_n)@: - -- a class exported with some of its methods, or - -- a datatype exported with some of its constructors. - | HsEModuleContents Module -- ^ @module M@: - -- re-export a module. + = HsEVar HsQName -- ^ Variable. + | HsEAbs HsQName -- ^ @T@: + -- A class or datatype exported abstractly, + -- or a type synonym. + | HsEThingAll HsQName -- ^ @T(..)@: + -- A class exported with all of its methods, or + -- a datatype exported with all of its constructors. + | HsEThingWith HsQName [HsCName] -- ^ @T(C_1,...,C_n)@: + -- A class exported with some of its methods, or + -- a datatype exported with some of its constructors. + | HsEModuleContents Module -- ^ @module M@: + -- Re-export a module. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | Import declaration. data HsImportDecl = HsImportDecl - { importLoc :: SrcLoc -- ^ position of the @import@ keyword. - , importModule :: Module -- ^ name of the module imported. - , importQualified :: Bool -- ^ imported @qualified@? - , importAs :: Maybe Module -- ^ optional alias name in an - -- @as@ clause. - , importSpecs :: Maybe (Bool,[HsImportSpec]) - -- ^ optional list of import specifications. - -- The 'Bool' is 'True' if the names are excluded - -- by @hiding@. - } + { importLoc :: SrcLoc -- ^ Position of the @import@ keyword. + , importModule :: Module -- ^ Name of the module imported. + , importQualified :: Bool -- ^ Imported @qualified@? + , importAs :: Maybe Module + -- ^ Optional alias name in an @as@ clause. + , importSpecs :: Maybe (Bool,[HsImportSpec]) + -- ^ Optional list of import specifications. + -- The 'Bool' is 'True' if the names are excluded + -- by @hiding@. + } #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | Import specification. data HsImportSpec - = HsIVar HsName -- ^ variable - | HsIAbs HsName -- ^ @T@: - -- the name of a class, datatype or type synonym. - | HsIThingAll HsName -- ^ @T(..)@: - -- a class imported with all of its methods, or - -- a datatype imported with all of its constructors. - | HsIThingWith HsName [HsCName] -- ^ @T(C_1,...,C_n)@: - -- a class imported with some of its methods, or - -- a datatype imported with some of its constructors. + = HsIVar HsName -- ^ Variable. + | HsIAbs HsName -- ^ @T@: + -- The name of a class, datatype or type synonym. + | HsIThingAll HsName -- ^ @T(..)@: + -- A class imported with all of its methods, or + -- a datatype imported with all of its constructors. + | HsIThingWith HsName [HsCName] -- ^ @T(C_1,...,C_n)@: + -- A class imported with some of its methods, or + -- a datatype imported with some of its constructors. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | Associativity of an operator. data HsAssoc - = HsAssocNone -- ^ non-associative operator (declared with @infix@) - | HsAssocLeft -- ^ left-associative operator (declared with @infixl@). - | HsAssocRight -- ^ right-associative operator (declared with @infixr@) + = HsAssocNone -- ^ Non-associative operator (declared with @infix@). + | HsAssocLeft -- ^ Left-associative operator (declared with @infixl@). + | HsAssocRight -- ^ Right-associative operator (declared with @infixr@). #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif data HsDecl - = HsTypeDecl SrcLoc HsName [HsName] HsType - | HsDataDecl SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName] - | HsInfixDecl SrcLoc HsAssoc Int [HsOp] - | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName] - | HsClassDecl SrcLoc HsContext HsName [HsName] [HsDecl] - | HsInstDecl SrcLoc HsContext HsQName [HsType] [HsDecl] - | HsDefaultDecl SrcLoc [HsType] - | HsTypeSig SrcLoc [HsName] HsQualType - | HsFunBind [HsMatch] - | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl] - | HsForeignImport SrcLoc String HsSafety String HsName HsType - | HsForeignExport SrcLoc String String HsName HsType + = HsTypeDecl SrcLoc HsName [HsName] HsType + | HsDataDecl SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName] + | HsInfixDecl SrcLoc HsAssoc Int [HsOp] + | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName] + | HsClassDecl SrcLoc HsContext HsName [HsName] [HsDecl] + | HsInstDecl SrcLoc HsContext HsQName [HsType] [HsDecl] + | HsDefaultDecl SrcLoc [HsType] + | HsTypeSig SrcLoc [HsName] HsQualType + | HsFunBind [HsMatch] + | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl] + | HsForeignImport SrcLoc String HsSafety String HsName HsType + | HsForeignExport SrcLoc String String HsName HsType #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | Clauses of a function binding. data HsMatch - = HsMatch SrcLoc HsName [HsPat] HsRhs {-where-} [HsDecl] + = HsMatch SrcLoc HsName [HsPat] HsRhs {-where-} [HsDecl] #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | Declaration of a data constructor. data HsConDecl - = HsConDecl SrcLoc HsName [HsBangType] - -- ^ ordinary data constructor - | HsRecDecl SrcLoc HsName [([HsName],HsBangType)] - -- ^ record constructor + = HsConDecl SrcLoc HsName [HsBangType] + -- ^ Ordinary data constructor. + | HsRecDecl SrcLoc HsName [([HsName],HsBangType)] + -- ^ Record constructor. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif @@ -275,21 +276,21 @@ -- | The type of a constructor argument or field, optionally including -- a strictness annotation. data HsBangType - = HsBangedTy HsType -- ^ strict component, marked with \"@!@\" - | HsUnBangedTy HsType -- ^ non-strict component + = HsBangedTy HsType -- ^ Strict component, marked with \"@!@\". + | HsUnBangedTy HsType -- ^ Non-strict component. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | The right hand side of a function or pattern binding. data HsRhs - = HsUnGuardedRhs HsExp -- ^ unguarded right hand side (/exp/) - | HsGuardedRhss [HsGuardedRhs] - -- ^ guarded right hand side (/gdrhs/) + = HsUnGuardedRhs HsExp -- ^ Unguarded right hand side (/exp/). + | HsGuardedRhss [HsGuardedRhs] + -- ^ Guarded right hand side (/gdrhs/). #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif @@ -297,19 +298,19 @@ -- | A guarded right hand side @|@ /exp/ @=@ /exp/. -- The first expression will be Boolean-valued. data HsGuardedRhs - = HsGuardedRhs SrcLoc HsExp HsExp + = HsGuardedRhs SrcLoc HsExp HsExp #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif --- | Safety level for invoking a foreign entity +-- | Safety level for invoking a foreign entity. data HsSafety - = HsSafe -- ^ call may generate callbacks - | HsUnsafe -- ^ call will not generate callbacks + = HsSafe -- ^ Call may generate callbacks. + | HsUnsafe -- ^ Call will not generate callbacks. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Ord,Show,Typeable,Data) + deriving (Eq,Ord,Show,Data) #else deriving (Eq,Ord,Show) #endif @@ -317,22 +318,22 @@ -- | A type qualified with a context. -- An unqualified type has an empty context. data HsQualType - = HsQualType HsContext HsType + = HsQualType HsContext HsType #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | Haskell types and type constructors. data HsType - = HsTyFun HsType HsType -- ^ function type - | HsTyTuple [HsType] -- ^ tuple type - | HsTyApp HsType HsType -- ^ application of a type constructor - | HsTyVar HsName -- ^ type variable - | HsTyCon HsQName -- ^ named type or type constructor + = HsTyFun HsType HsType -- ^ Function type. + | HsTyTuple [HsType] -- ^ Tuple type. + | HsTyApp HsType HsType -- ^ Application of a type constructor. + | HsTyVar HsName -- ^ Type variable. + | HsTyCon HsQName -- ^ Named type or type constructor. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif @@ -349,17 +350,17 @@ -- precise string representation used. For example, @10@, @0o12@ and @0xa@ -- have the same representation. data HsLiteral - = HsChar Char -- ^ character literal - | HsString String -- ^ string literal - | HsInt Integer -- ^ integer literal - | HsFrac Rational -- ^ floating point literal - | HsCharPrim Char -- ^ GHC unboxed character literal - | HsStringPrim String -- ^ GHC unboxed string literal - | HsIntPrim Integer -- ^ GHC unboxed integer literal - | HsFloatPrim Rational -- ^ GHC unboxed float literal - | HsDoublePrim Rational -- ^ GHC unboxed double literal + = HsChar Char -- ^ Character literal. + | HsString String -- ^ String literal. + | HsInt Integer -- ^ Integer literal. + | HsFrac Rational -- ^ Floating point literal. + | HsCharPrim Char -- ^ GHC unboxed character literal. + | HsStringPrim String -- ^ GHC unboxed string literal. + | HsIntPrim Integer -- ^ GHC unboxed integer literal. + | HsFloatPrim Rational -- ^ GHC unboxed float literal. + | HsDoublePrim Rational -- ^ GHC unboxed double literal. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif @@ -381,76 +382,76 @@ -- add parentheses in printing. data HsExp - = HsVar HsQName -- ^ variable - | HsCon HsQName -- ^ data constructor - | HsLit HsLiteral -- ^ literal constant - | HsInfixApp HsExp HsQOp HsExp -- ^ infix application - | HsApp HsExp HsExp -- ^ ordinary application - | HsNegApp HsExp -- ^ negation expression @-@ /exp/ - | HsLambda SrcLoc [HsPat] HsExp -- ^ lambda expression - | HsLet [HsDecl] HsExp -- ^ local declarations with @let@ - | HsIf HsExp HsExp HsExp -- ^ @if@ /exp/ @then@ /exp/ @else@ /exp/ - | HsCase HsExp [HsAlt] -- ^ @case@ /exp/ @of@ /alts/ - | HsDo [HsStmt] -- ^ @do@-expression: - -- the last statement in the list - -- should be an expression. - | HsTuple [HsExp] -- ^ tuple expression - | HsList [HsExp] -- ^ list expression - | HsParen HsExp -- ^ parenthesized expression - | HsLeftSection HsExp HsQOp -- ^ left section @(@/exp/ /qop/@)@ - | HsRightSection HsQOp HsExp -- ^ right section @(@/qop/ /exp/@)@ - | HsRecConstr HsQName [HsFieldUpdate] - -- ^ record construction expression - | HsRecUpdate HsExp [HsFieldUpdate] - -- ^ record update expression - | HsEnumFrom HsExp -- ^ unbounded arithmetic sequence, - -- incrementing by 1 - | HsEnumFromTo HsExp HsExp -- ^ bounded arithmetic sequence, - -- incrementing by 1 - | HsEnumFromThen HsExp HsExp -- ^ unbounded arithmetic sequence, - -- with first two elements given - | HsEnumFromThenTo HsExp HsExp HsExp - -- ^ bounded arithmetic sequence, - -- with first two elements given - | HsListComp HsExp [HsStmt] -- ^ list comprehension - | HsExpTypeSig SrcLoc HsExp HsQualType - -- ^ expression type signature - | HsAsPat HsName HsExp -- ^ patterns only - | HsWildCard -- ^ patterns only - | HsIrrPat HsExp -- ^ patterns only + = HsVar HsQName -- ^ Variable. + | HsCon HsQName -- ^ Data constructor. + | HsLit HsLiteral -- ^ Literal constant. + | HsInfixApp HsExp HsQOp HsExp -- ^ Infix application. + | HsApp HsExp HsExp -- ^ Ordinary application. + | HsNegApp HsExp -- ^ Negation expression @-@ /exp/. + | HsLambda SrcLoc [HsPat] HsExp -- ^ Lambda expression. + | HsLet [HsDecl] HsExp -- ^ Local declarations with @let@. + | HsIf HsExp HsExp HsExp -- ^ @If@ /exp/ @then@ /exp/ @else@ /exp/. + | HsCase HsExp [HsAlt] -- ^ @Case@ /exp/ @of@ /alts/. + | HsDo [HsStmt] -- ^ @Do@-expression: + -- The last statement in the list + -- should be an expression. + | HsTuple [HsExp] -- ^ Tuple expression. + | HsList [HsExp] -- ^ List expression. + | HsParen HsExp -- ^ Parenthesized expression. + | HsLeftSection HsExp HsQOp -- ^ Left section @(@/exp/ /qop/@)@. + | HsRightSection HsQOp HsExp -- ^ Right section @(@/qop/ /exp/@)@. + | HsRecConstr HsQName [HsFieldUpdate] + -- ^ Record construction expression. + | HsRecUpdate HsExp [HsFieldUpdate] + -- ^ Record update expression. + | HsEnumFrom HsExp -- ^ Unbounded arithmetic sequence, + -- incrementing by 1. + | HsEnumFromTo HsExp HsExp -- ^ Bounded arithmetic sequence, + -- incrementing by 1. + | HsEnumFromThen HsExp HsExp -- ^ Unbounded arithmetic sequence, + -- with first two elements given. + | HsEnumFromThenTo HsExp HsExp HsExp + -- ^ Bounded arithmetic sequence, + -- with first two elements given. + | HsListComp HsExp [HsStmt] -- ^ List comprehension. + | HsExpTypeSig SrcLoc HsExp HsQualType + -- ^ Expression type signature. + | HsAsPat HsName HsExp -- ^ (patterns only) + | HsWildCard -- ^ (patterns only) + | HsIrrPat HsExp -- ^ (patterns only) #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | A pattern, to be matched against a value. data HsPat - = HsPVar HsName -- ^ variable - | HsPLit HsLiteral -- ^ literal constant - | HsPNeg HsPat -- ^ negated pattern - | HsPInfixApp HsPat HsQName HsPat - -- ^ pattern with infix data constructor - | HsPApp HsQName [HsPat] -- ^ data constructor and argument - -- patterns - | HsPTuple [HsPat] -- ^ tuple pattern - | HsPList [HsPat] -- ^ list pattern - | HsPParen HsPat -- ^ parenthesized pattern - | HsPRec HsQName [HsPatField] -- ^ labelled pattern - | HsPAsPat HsName HsPat -- ^ @\@@-pattern - | HsPWildCard -- ^ wildcard pattern (@_@) - | HsPIrrPat HsPat -- ^ irrefutable pattern (@~@) + = HsPVar HsName -- ^ Variable. + | HsPLit HsLiteral -- ^ Literal constant. + | HsPNeg HsPat -- ^ Negated pattern. + | HsPInfixApp HsPat HsQName HsPat + -- ^ Pattern with infix data constructor. + | HsPApp HsQName [HsPat] -- ^ Data constructor and argument + -- patterns. + | HsPTuple [HsPat] -- ^ Tuple pattern. + | HsPList [HsPat] -- ^ List pattern. + | HsPParen HsPat -- ^ Parenthesized pattern. + | HsPRec HsQName [HsPatField] -- ^ Labelled pattern. + | HsPAsPat HsName HsPat -- ^ @\@@-Pattern. + | HsPWildCard -- ^ Wildcard pattern (@_@). + | HsPIrrPat HsPat -- ^ Irrefutable pattern (@~@). #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | An /fpat/ in a labeled record pattern. data HsPatField - = HsPFieldPat HsQName HsPat + = HsPFieldPat HsQName HsPat #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif @@ -458,41 +459,41 @@ -- | This type represents both /stmt/ in a @do@-expression, -- and /qual/ in a list comprehension. data HsStmt - = HsGenerator SrcLoc HsPat HsExp - -- ^ a generator /pat/ @<-@ /exp/ - | HsQualifier HsExp -- ^ an /exp/ by itself: in a @do@-expression, - -- an action whose result is discarded; - -- in a list comprehension, a guard expression - | HsLetStmt [HsDecl] -- ^ local bindings + = HsGenerator SrcLoc HsPat HsExp + -- ^ A generator /pat/ @<-@ /exp/. + | HsQualifier HsExp -- ^ An /exp/ by itself: in a @do@-expression, + -- an action whose result is discarded; + -- in a list comprehension, a guard expression. + | HsLetStmt [HsDecl] -- ^ Local bindings. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | An /fbind/ in a labeled record construction or update expression. data HsFieldUpdate - = HsFieldUpdate HsQName HsExp + = HsFieldUpdate HsQName HsExp #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif -- | An /alt/ in a @case@ expression. data HsAlt - = HsAlt SrcLoc HsPat HsGuardedAlts [HsDecl] + = HsAlt SrcLoc HsPat HsGuardedAlts [HsDecl] #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif data HsGuardedAlts - = HsUnGuardedAlt HsExp -- ^ @->@ /exp/ - | HsGuardedAlts [HsGuardedAlt] -- ^ /gdpat/ + = HsUnGuardedAlt HsExp -- ^ @->@ /exp/. + | HsGuardedAlts [HsGuardedAlt] -- ^ /gdpat/. #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif @@ -500,9 +501,9 @@ -- | A guarded alternative @|@ /exp/ @->@ /exp/. -- The first expression will be Boolean-valued. data HsGuardedAlt - = HsGuardedAlt SrcLoc HsExp HsExp + = HsGuardedAlt SrcLoc HsExp HsExp #ifdef __GLASGOW_HASKELL__ - deriving (Eq,Show,Typeable,Data) + deriving (Eq,Show,Data) #else deriving (Eq,Show) #endif @@ -511,26 +512,26 @@ -- Builtin names. prelude_mod, main_mod :: Module -prelude_mod = Module "Prelude" -main_mod = Module "Main" +prelude_mod = Module "Prelude" +main_mod = Module "Main" main_name :: HsName -main_name = HsIdent "main" +main_name = HsIdent "main" unit_con_name :: HsQName -unit_con_name = Special HsUnitCon +unit_con_name = Special HsUnitCon tuple_con_name :: Int -> HsQName tuple_con_name i = Special (HsTupleCon (i+1)) list_cons_name :: HsQName -list_cons_name = Special HsCons +list_cons_name = Special HsCons unit_con :: HsExp -unit_con = HsCon unit_con_name +unit_con = HsCon unit_con_name tuple_con :: Int -> HsExp -tuple_con i = HsCon (tuple_con_name i) +tuple_con i = HsCon (tuple_con_name i) unit_tycon_name, fun_tycon_name, list_tycon_name :: HsQName unit_tycon_name = unit_con_name @@ -541,9 +542,9 @@ tuple_tycon_name i = tuple_con_name i unit_tycon, fun_tycon, list_tycon :: HsType -unit_tycon = HsTyCon unit_tycon_name -fun_tycon = HsTyCon fun_tycon_name -list_tycon = HsTyCon list_tycon_name +unit_tycon = HsTyCon unit_tycon_name +fun_tycon = HsTyCon fun_tycon_name +list_tycon = HsTyCon list_tycon_name tuple_tycon :: Int -> HsType -tuple_tycon i = HsTyCon (tuple_tycon_name i) +tuple_tycon i = HsTyCon (tuple_tycon_name i) diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,77 @@ +## 1.0.4.2 + +_Andreas Abel, 2025-08-28_ + + - Drop support for GHC 7. + - Tested with GHC 8.0 - 9.14 alpha1. + +## 1.0.4.1 + +_Andreas Abel, 2024-09-22_ + + - Replace use of `head` to pacify `-Wx-partial`. + - Remove upper bound on `happy`. + - Tested with GHC 8.0 - 9.10.1. + +## 1.0.4 Revision 1 + +_Andreas Abel, 2022-05-25_ + + - Support GHC 9.4, allow base-4.17 and higher. + +## 1.0.4 + +_Andreas Abel, 2022-02-07_ + + - Add `Eq` instance for `HsModule`. + +## 1.0.3.2 + +_Andreas Abel, 2022-02-07_ + + - Version tested with GHC 7.0 - 9.2. + - Silence warning `incomplete-uni-patterns` in module `ParseMonad` for GHC >= 9.2. + - Cosmetic documentation changes. + +## 1.0.3.1 Revision 5 + + - Support happy-1.21. + +## 1.0.3.1 Revision 4 + + - Support GHC 9.2 & base-4.16. + +## 1.0.3.1 Revision 3 + + - Support GHC 9.0 & base-4.15. + +## 1.0.3.0/1 Revision 2 + + - Support happy-1.20. + +## 1.0.3.1 + +_Herbert Valerio Riedel, 2019-11-09_ + + - Version for GHC 8.8 and 8.10. + +## 1.0.3.0 + +_Herbert Valerio Riedel, 2018-03-13_ + + - Version for GHC 7.10 - 8.6. + (Dropped support for GHC versions prior to GHC 7.0.) + + - Add support for `MonadFail` & `Semigroup` proposals by + adding respective instances for `P` and `Lex`. + + - Remove `-O2` from `ghc-options`. + +## 1.0.2.0 + +_Herbert Valerio Riedel, 2015-01-24_ + + - Add support for GHC 7.10 & base-4.8. + + - Add missing `Functor` & `Applicative` instances for `P` and `Lex` + monads needed for AMP compatibility. diff --git a/examples/Makefile b/examples/Makefile deleted file mode 100644 --- a/examples/Makefile +++ /dev/null @@ -1,18 +0,0 @@ -# ----------------------------------------------------------------------------- - -TOP = ../.. -include $(TOP)/mk/boilerplate.mk - -# ----------------------------------------------------------------------------- - -ifeq "$(way)" "" -HS_PROG = hsparser$(exeext) -endif - -HC = $(GHC_INPLACE) -MKDEPENDHS = $(GHC_INPLACE) -SRC_HC_OPTS += -package haskell-src - -# ----------------------------------------------------------------------------- - -include $(TOP)/mk/target.mk diff --git a/examples/hsparser.hs b/examples/hsparser.hs deleted file mode 100644 --- a/examples/hsparser.hs +++ /dev/null @@ -1,110 +0,0 @@ --- A simple test program for the Haskell parser, --- originally written by Sven Panne. - -module Main (main, mainArgs, testLexer) where - -import Data.List -import Language.Haskell.Lexer (lexer, Token(EOF)) -import Language.Haskell.ParseMonad (runParserWithMode) -import Language.Haskell.Parser -import Language.Haskell.Syntax -import Language.Haskell.Pretty -import System.Environment -import System.Console.GetOpt - -data Flag - = LexOnlyLength -- print number of tokens only - | LexOnlyRev -- print tokens in reverse order - | LexOnly -- print tokens - | ParseLength -- print number of declarations only - | ParseInternal -- print abstract syntax in internal format - | ParsePretty PPLayout -- pretty print in this style - | Help -- give short usage info - -title :: String -title = "A simple test program for the haskell-src package" - -usage :: String -usage = "usage: hsparser [option] [filename]\n" - -options :: [OptDescr Flag] -options = - [ Option ['n'] ["numtokens"] (NoArg LexOnlyLength) "print number of tokens only", - Option ['r'] ["revtokens"] (NoArg LexOnlyRev) "print tokens in reverse order", - Option ['t'] ["tokens"] (NoArg LexOnly) "print tokens", - Option ['d'] ["numdecls"] (NoArg ParseLength) "print number of declarations only", - Option ['a'] ["abstract"] (NoArg ParseInternal) "print abstract syntax in internal format", - Option ['p'] ["pretty"] (OptArg pStyle "STYLE") "pretty print in STYLE[(o)ffside|(s)emicolon|(i)nline|(n)one](default = offside)", - Option ['h','?'] ["help"] (NoArg Help) "display this help and exit"] - -pStyle :: Maybe String -> Flag -pStyle Nothing = ParsePretty PPOffsideRule -pStyle (Just s) = ParsePretty $ case s of - "o" -> PPOffsideRule - "offside" -> PPOffsideRule - "s" -> PPSemiColon - "semicolon" -> PPSemiColon - "i" -> PPInLine - "inline" -> PPInLine - "n" -> PPNoLayout - "none" -> PPNoLayout - _ -> PPOffsideRule - -main :: IO () -main = do - args <- getArgs - mainArgs args - -mainArgs :: [String] -> IO () -mainArgs cmdline = - case getOpt Permute options cmdline of - (flags, args, []) -> do - inp <- case args of - [] -> getContents - [f] -> readFile f - _ -> error usage - let parse_mode = case args of - [] -> defaultParseMode - [f] -> defaultParseMode {parseFilename = f} - putStrLn (handleFlag (getFlag flags) parse_mode inp) - (_, _, errors) -> - error (concat errors ++ usageInfo usage options) - -getFlag :: [Flag] -> Flag -getFlag [] = ParsePretty PPOffsideRule -getFlag [f] = f -getFlag _ = error usage - -handleFlag :: Flag -> ParseMode -> String -> String -handleFlag LexOnlyLength parse_mode = show . length . testLexerRev parse_mode -handleFlag LexOnlyRev parse_mode = - concat . intersperse "\n" . map show . testLexerRev parse_mode -handleFlag LexOnly parse_mode = - concat . intersperse "\n" . map show . testLexer parse_mode -handleFlag ParseLength parse_mode = - show . modLength . testParser parse_mode - where modLength (HsModule _ _ _ imp d) = length imp + length d -handleFlag ParseInternal parse_mode = show . testParser parse_mode -handleFlag (ParsePretty l) parse_mode = - prettyPrintStyleMode style{lineLength=80} defaultMode{layout=l} . - testParser parse_mode -handleFlag Help _parse_mode = const $ - usageInfo (title ++ "\n" ++ usage) options - -testLexerRev :: ParseMode -> String -> [Token] -testLexerRev parse_mode = getResult . runParserWithMode parse_mode (loop []) - where loop toks = lexer $ \t -> case t of - EOF -> return toks - _ -> loop (t:toks) - -testLexer :: ParseMode -> String -> [Token] -testLexer parse_mode = reverse . testLexerRev parse_mode - -testParser :: ParseMode -> String -> HsModule -testParser parse_mode = getResult . parseModuleWithMode parse_mode - -getResult :: ParseResult a -> a -getResult (ParseOk a) = a -getResult (ParseFailed loc err) = - error (srcFilename loc ++ ":" ++ show (srcLine loc) ++ ":" ++ - show (srcColumn loc) ++ ": " ++ err) diff --git a/haskell-src.cabal b/haskell-src.cabal --- a/haskell-src.cabal +++ b/haskell-src.cabal @@ -1,19 +1,46 @@ -name: haskell-src -version: 1.0.1.3 -license: BSD3 -license-file: LICENSE -author: Simon Marlow, Sven Panne and Noel Winstanley -maintainer: libraries@haskell.org -category: Language -synopsis: Manipulating Haskell source code -description: - Facilities for manipulating Haskell source code: - an abstract syntax, lexer, parser and pretty-printer. +cabal-version: 1.18 +name: haskell-src +-- don't forget to update the changelog.md! +version: 1.0.4.2 build-type: Simple -cabal-version: >=1.2 -flag split-base +license: BSD3 +license-file: LICENSE +author: Simon Marlow, Sven Panne and Noel Winstanley +maintainer: Andreas Abel +bug-reports: https://github.com/haskell-pkg-janitors/haskell-src/issues +stability: stable +category: Language +synopsis: Support for manipulating Haskell source code +description: + The @haskell-src@ package provides support for manipulating Haskell + source code. The package provides a lexer, parser and + pretty-printer, and a definition of a Haskell abstract syntax tree + (AST). Common uses of this package are to parse or generate + code. +tested-with: + GHC == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.2 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 + +extra-doc-files: changelog.md + +source-repository head + type: git + location: https://github.com/haskell-pkg-janitors/haskell-src.git + library exposed-modules: Language.Haskell.Lexer, @@ -22,12 +49,18 @@ Language.Haskell.Pretty, Language.Haskell.Syntax, Language.Haskell.ParseUtils - if flag(split-base) - build-depends: base >= 3 && < 4, pretty, array - else - build-depends: base < 3 - build-depends: haskell98 - -- The dependency on Haskell 98 is only because - -- Happy generates a parser that imports Array - extensions: CPP - nhc98-options: -K11M + + build-depends: base >= 4.9 && < 5 + -- no confirmed upper bound on base yet + , syb >= 0.1 && < 0.8 + , pretty >= 1.0.1.2 && < 1.2 + , array >= 0.3 && < 0.6 + + build-tools: happy >= 1.19 + + default-language: Haskell98 + + ghc-options: + -Wall + -Wcompat + -Wnoncanonical-monad-instances diff --git a/prologue.txt b/prologue.txt deleted file mode 100644 --- a/prologue.txt +++ /dev/null @@ -1,2 +0,0 @@ -Facilities for manipulating Haskell source code: an abstract syntax, -lexer, parser and pretty-printer.