diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- 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. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/Language/Haskell/Lexer.hs b/Language/Haskell/Lexer.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Lexer.hs @@ -0,0 +1,527 @@ +-- #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 +-- Portability : portable +-- +-- Lexer for Haskell. +-- +----------------------------------------------------------------------------- + +-- ToDo: Introduce different tokens for decimal, octal and hexadecimal (?) +-- ToDo: FloatTok should have three parts (integer part, fraction, exponent) (?) +-- ToDo: Use a lexical analyser generator (lx?) + +module Language.Haskell.Lexer (Token(..), lexer) where + +import Language.Haskell.ParseMonad + +import Data.Char (isAlpha, isLower, isUpper, toLower, + isDigit, isHexDigit, isOctDigit, isSpace, + ord, chr, digitToInt) +import Data.Ratio + +data Token + = VarId String + | QVarId (String,String) + | ConId String + | QConId (String,String) + | VarSym String + | ConSym String + | QVarSym (String,String) + | QConSym (String,String) + | IntTok Integer + | FloatTok Rational + | Character Char + | StringTok String + +-- Symbols + + | LeftParen + | RightParen + | SemiColon + | LeftCurly + | RightCurly + | 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 + +-- Reserved Ids + + | KW_As + | KW_Case + | KW_Class + | KW_Data + | KW_Default + | KW_Deriving + | KW_Do + | KW_Else + | KW_Hiding + | 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_Qualified + + | EOF + deriving (Eq,Show) + +reserved_ops :: [(String,Token)] +reserved_ops = [ + ( "..", DotDot ), + ( ":", Colon ), + ( "::", DoubleColon ), + ( "=", Equals ), + ( "\\", Backslash ), + ( "|", Bar ), + ( "<-", LeftArrow ), + ( "->", RightArrow ), + ( "@", At ), + ( "~", Tilde ), + ( "=>", DoubleArrow ) + ] + +special_varops :: [(String,Token)] +special_varops = [ + ( "-", Minus ), --ToDo: shouldn't be here + ( "!", Exclamation ) --ditto + ] + +reserved_ids :: [(String,Token)] +reserved_ids = [ + ( "_", Underscore ), + ( "case", KW_Case ), + ( "class", KW_Class ), + ( "data", KW_Data ), + ( "default", KW_Default ), + ( "deriving", KW_Deriving ), + ( "do", KW_Do ), + ( "else", KW_Else ), + ( "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_varids :: [(String,Token)] +special_varids = [ + ( "as", KW_As ), + ( "qualified", KW_Qualified ), + ( "hiding", KW_Hiding ) + ] + +isIdent, isSymbol :: Char -> Bool +isIdent c = isAlpha c || isDigit c || c == '\'' || c == '_' +isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~" + +matchChar :: Char -> String -> Lex a () +matchChar c msg = do + s <- getInput + if null s || head s /= c then fail msg else discard 1 + +-- The top-level lexer. +-- We need to know whether we are at the beginning of the line to decide +-- whether to insert layout tokens. + +lexer :: (Token -> P a) -> P a +lexer = runL $ do + 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 + +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" + +-- 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 + -- 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 -> + -- trace "layout: inserting ';'\n" $ + return SemiColon + GT -> + lexToken + +lexToken :: Lex a Token +lexToken = do + s <- getInput + 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) + + c:_ | isDigit c -> lexDecimalOrFloat + + | 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 + + | 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 + + -- 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) + + '"' -> lexString + + _ -> 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)) + + 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" + +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)) + + | 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) + + _ -> 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" + +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" + + 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 + +-- 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 '\'' + +-- 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' + +-- 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 + + _ -> fail "Illegal escape sequence" + + where + checkChar n | n <= 0x01FFFF = 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" + +-- assumes at least one octal digit +lexOctal :: Lex a Integer +lexOctal = do + 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) + +-- assumes at least one decimal digit +lexDecimal :: Lex a Integer +lexDecimal = do + 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) diff --git a/Language/Haskell/ParseMonad.hs b/Language/Haskell/ParseMonad.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/ParseMonad.hs @@ -0,0 +1,234 @@ +-- #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 +-- Portability : portable +-- +-- Monads for the Haskell parser and lexer. +-- +----------------------------------------------------------------------------- + +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 + +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 + +-- internal version +data ParseStatus a = Ok ParseState a | Failed SrcLoc String + deriving Show + +data LexContext = NoLayout | Layout Int + deriving (Eq,Ord,Show) + +type ParseState = [LexContext] + +indentOfParseState :: ParseState -> Int +indentOfParseState (Layout n:_) = n +indentOfParseState _ = 0 + +-- | Static parameters governing a parse. +-- More to come later, e.g. literate mode, language extensions. + +data ParseMode = ParseMode { + -- | 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 = "" + } + +-- | 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 + } + +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 + where start = SrcLoc { + srcFilename = parseFilename mode, + srcLine = 1, + srcColumn = 1 + } + +runParser :: P a -> String -> ParseResult a +runParser = runParserWithMode defaultParseMode + +instance Monad P where + return a = P $ \_i _x _y _l s _m -> Ok s a + P m >>= k = P $ \i x y l s mode -> + case m i x y l s mode of + Failed loc msg -> Failed loc msg + Ok s' a -> runP (k a) i x y l s' mode + fail s = P $ \_r _col _line loc _stk _m -> Failed loc s + +atSrcLoc :: P a -> SrcLoc -> P a +P m `atSrcLoc` loc = P $ \i x y _l -> m i x y loc + +getSrcLoc :: P SrcLoc +getSrcLoc = P $ \_i _x _y l s _m -> Ok s l + +-- Enter a new layout context. If we are already in a layout context, +-- ensure that the new indent is greater than the indent of that context. +-- (So if the source loc is not to the right of the current indent, an +-- empty list {} will be inserted.) + +pushCurrentContext :: P () +pushCurrentContext = do + 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) + +pushContext :: LexContext -> P () +pushContext ctxt = +--trace ("pushing lexical scope: " ++ show ctxt ++"\n") $ + 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") $ + Ok s () + [] -> error "Internal error: empty context in popContext" + +-- Monad for lexical analysis: +-- a continuation-passing version of the parsing monad + +newtype Lex r a = Lex { runL :: (a -> P r) -> P r } + +instance Monad (Lex r) where + return a = Lex $ \k -> k a + Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k) + Lex v >> Lex w = Lex $ \k -> v (\_ -> w k) + fail s = Lex $ \_ -> fail s + +-- Operations on this monad + +getInput :: Lex r String +getInput = Lex $ \cont -> P $ \r -> runP (cont r) r + +-- | Discard some input characters (these must not include tabs or newlines). + +discard :: Int -> Lex r () +discard n = Lex $ \cont -> P $ \r x -> runP (cont ()) (drop n r) (x+n) + +-- | Discard the next character, which must be a newline. + +lexNewline :: Lex a () +lexNewline = Lex $ \cont -> P $ \(_:r) _x y -> runP (cont ()) r 1 (y+1) + +-- | Discard the next character, which must be a tab. + +lexTab :: Lex a () +lexTab = Lex $ \cont -> P $ \(_:r) x -> runP (cont ()) r (nextTab x) + +nextTab :: Int -> Int +nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH) + +tAB_LENGTH :: Int +tAB_LENGTH = 8 + +-- Consume and return the largest string of characters satisfying p + +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) + +-- 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 + +-- The source location is the coordinates of the previous token, +-- or, while scanning a token, the start of the current token. + +-- col is the current column in the source file. +-- We also need to remember between scanning tokens whether we are +-- somewhere at the beginning of the line before the first token. +-- This could be done with an extra Bool argument to the P monad, +-- but as a hack we use a col value of 0 to indicate this situation. + +-- Setting col to 0 is used in two places: just after emitting a virtual +-- close brace due to layout, so that next time through we check whether +-- we also need to emit a semi-colon, and at the beginning of the file, +-- by runParser, to kick off the lexer. +-- Thus when col is zero, the true column can be taken from the loc. + +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 + +setBOL :: Lex a () +setBOL = Lex $ \cont -> P $ \r _ -> runP (cont ()) r 0 + +-- Set the loc to the current position + +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 + +-- Current status with respect to the offside (layout) rule: +-- LT: we are to the left of the current indent (if any) +-- EQ: we are at the current indent (if any) +-- GT: we are to the right of the current indent, or not subject to layout + +getOffside :: Lex a Ordering +getOffside = Lex $ \cont -> P $ \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) + +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) diff --git a/Language/Haskell/ParseUtils.hs b/Language/Haskell/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/ParseUtils.hs @@ -0,0 +1,312 @@ +-- #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 +-- Portability : portable +-- +-- Utilities for the Haskell parser. +-- +----------------------------------------------------------------------------- + +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] + ) where + +import Language.Haskell.Syntax +import Language.Haskell.ParseMonad +import Language.Haskell.Pretty + +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" + +----------------------------------------------------------------------------- +-- Various Syntactic Checks + +checkContext :: HsType -> P HsContext +checkContext (HsTyTuple ts) = + mapM checkAssertion ts +checkContext t = do + 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" + + +checkDataHeader :: HsQualType -> P (HsContext,HsName,[HsName]) +checkDataHeader (HsQualType cs t) = do + (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) + +checkSimple :: String -> HsType -> [HsName] -> P ((HsName,[HsName])) +checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs) +checkSimple _kw (HsTyCon (UnQual t)) xs = return (t,xs) +checkSimple kw _ _ = fail ("Illegal " ++ kw ++ " declaration") + +checkInstHeader :: HsQualType -> P (HsContext,HsQName,[HsType]) +checkInstHeader (HsQualType cs t) = do + (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" + +----------------------------------------------------------------------------- +-- Checking Patterns. + +-- We parse patterns as expressions and check for valid patterns below, +-- converting the expression into a pattern at the same time. + +checkPattern :: HsExp -> P HsPat +checkPattern e = checkPat e [] + +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) +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 + +checkPat _ _ = patFail + +checkPatField :: HsFieldUpdate -> P HsPatField +checkPatField (HsFieldUpdate n e) = do + p <- checkPat e [] + return (HsPFieldPat n p) + +patFail :: P a +patFail = fail "Parse error in pattern" + +----------------------------------------------------------------------------- +-- Check Expression Syntax + +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" + +-- type signature for polymorphic recursion!! +check1Expr :: HsExp -> (HsExp -> a) -> P a +check1Expr e1 f = do + 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) + +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) + +checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a +checkManyExprs es f = do + 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) + +checkGAlts :: HsGuardedAlts -> P HsGuardedAlts +checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt +checkGAlts (HsGuardedAlts galts) = do + 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 + +checkField :: HsFieldUpdate -> P HsFieldUpdate +checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n) + +----------------------------------------------------------------------------- +-- Check Equation Syntax + +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]) + Nothing -> do + 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 + +----------------------------------------------------------------------------- +-- 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 + +checkMethodDef :: HsDecl -> P () +checkMethodDef (HsPatBind _ (HsPVar _) _ _) = return () +checkMethodDef (HsPatBind loc _ _ _) = + fail "illegal method definition" `atSrcLoc` loc +checkMethodDef _ = return () + +----------------------------------------------------------------------------- +-- Check that an identifier or symbol is unqualified. +-- 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 (Special _) = fail "Illegal special name" + +----------------------------------------------------------------------------- +-- Miscellaneous utilities + +checkPrec :: Integer -> P Int +checkPrec i | 0 <= i && i <= 9 = return (fromInteger i) +checkPrec i | otherwise = fail ("Illegal precedence " ++ show i) + +mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp +mkRecConstrOrUpdate (HsCon c) fs = return (HsRecConstr c fs) +mkRecConstrOrUpdate e fs@(_:_) = return (HsRecUpdate e fs) +mkRecConstrOrUpdate _ _ = fail "Empty record update" + +----------------------------------------------------------------------------- +-- Reverse a list of declarations, merging adjacent HsFunBinds of the +-- same name and checking that their arities match. + +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 diff --git a/Language/Haskell/Parser.ly b/Language/Haskell/Parser.ly new file mode 100644 --- /dev/null +++ b/Language/Haskell/Parser.ly @@ -0,0 +1,819 @@ +> { +> ----------------------------------------------------------------------------- +> -- | +> -- Module : Language.Haskell.Parser +> -- Copyright : (c) Simon Marlow, Sven Panne 1997-2000 +> -- License : BSD-style (see the file libraries/base/LICENSE) +> -- +> -- Maintainer : libraries@haskell.org +> -- Stability : experimental +> -- Portability : portable +> -- +> -- Haskell parser. +> -- +> ----------------------------------------------------------------------------- +> +> module Language.Haskell.Parser ( +> parseModule, parseModuleWithMode, +> ParseMode(..), defaultParseMode, ParseResult(..)) where +> +> import Language.Haskell.Syntax +> import Language.Haskell.ParseMonad +> import Language.Haskell.Lexer +> import Language.Haskell.ParseUtils +> } + +ToDo: Check exactly which names must be qualified with Prelude (commas and friends) +ToDo: Inst (MPCs?) +ToDo: Polish constr a bit +ToDo: Ugly: exp0b is used for lhs, pat, exp0, ... +ToDo: Differentiate between record updates and labeled construction. + +----------------------------------------------------------------------------- +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). + +----------------------------------------------------------------------------- + +> %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 $$ } + +Symbols + +> '(' { 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 } + +Reserved Ids + +> 'as' { KW_As } +> 'case' { KW_Case } +> 'class' { KW_Class } +> 'data' { KW_Data } +> 'default' { KW_Default } +> 'deriving' { KW_Deriving } +> 'do' { KW_Do } +> 'else' { KW_Else } +> 'hiding' { KW_Hiding } +> '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 } +> 'qualified' { KW_Qualified } + +> %monad { P } +> %lexer { lexer } { EOF } +> %name parse +> %tokentype { Token } +> %% + +----------------------------------------------------------------------------- +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) } + +> body :: { ([HsImportDecl],[HsDecl]) } +> : '{' 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 { ([], []) } + +> semis :: { () } +> : optsemis ';' { () } + +> optsemis :: { () } +> : semis { () } +> | {- empty -} { () } + +----------------------------------------------------------------------------- +The Export List + +> maybeexports :: { Maybe [HsExportSpec] } +> : exports { Just $1 } +> | {- empty -} { Nothing } + +> exports :: { [HsExportSpec] } +> : '(' exportlist optcomma ')' { reverse $2 } +> | '(' optcomma ')' { [] } + +> optcomma :: { () } +> : ',' { () } +> | {- empty -} { () } + +> exportlist :: { [HsExportSpec] } +> : 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 } + +----------------------------------------------------------------------------- +Import Declarations + +> impdecls :: { [HsImportDecl] } +> : impdecls semis impdecl { $3 : $1 } +> | impdecl { [$1] } + +> impdecl :: { HsImportDecl } +> : srcloc 'import' optqualified modid maybeas maybeimpspec +> { HsImportDecl $1 $4 $3 $5 $6 } + +> optqualified :: { Bool } +> : 'qualified' { True } +> | {- empty -} { False } + +> maybeas :: { Maybe Module } +> : 'as' modid { Just $2 } +> | {- empty -} { Nothing } + + +> maybeimpspec :: { Maybe (Bool, [HsImportSpec]) } +> : impspec { Just $1 } +> | {- empty -} { Nothing } + +> impspec :: { (Bool, [HsImportSpec]) } +> : opthiding '(' importlist optcomma ')' { ($1, reverse $3) } +> | opthiding '(' optcomma ')' { ($1, []) } + +> opthiding :: { Bool } +> : 'hiding' { True } +> | {- empty -} { False } + +> importlist :: { [HsImportSpec] } +> : 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) } + +> cnames :: { [HsCName] } +> : cnames ',' cname { $3 : $1 } +> | cname { [$1] } + +> cname :: { HsCName } +> : var { HsVarName $1 } +> | con { HsConName $1 } + +----------------------------------------------------------------------------- +Fixity Declarations + +> fixdecl :: { HsDecl } +> : srcloc infix prec ops { HsInfixDecl $1 $2 $3 (reverse $4) } + +> prec :: { Int } +> : {- empty -} { 9 } +> | INT {% checkPrec $1 } + +> infix :: { HsAssoc } +> : 'infix' { HsAssocNone } +> | 'infixl' { HsAssocLeft } +> | 'infixr' { HsAssocRight } + +> ops :: { [HsOp] } +> : ops ',' op { $3 : $1 } +> | op { [$1] } + +----------------------------------------------------------------------------- +Top-Level Declarations + +Note: The report allows topdecls to be empty. This would result in another +shift/reduce-conflict, so we don't handle this case here, but in bodyaux. + +> topdecls :: { [HsDecl] } +> : topdecls1 optsemis {% checkRevDecls $1 } + +> topdecls1 :: { [HsDecl] } +> : 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 } +> | decl { $1 } + +> typelist :: { [HsType] } +> : types { reverse $1 } +> | type { [$1] } +> | {- empty -} { [] } + +> decls :: { [HsDecl] } +> : optsemis decls1 optsemis {% checkRevDecls $2 } +> | optsemis { [] } + +> decls1 :: { [HsDecl] } +> : decls1 semis decl { $3 : $1 } +> | decl { [$1] } + +> decl :: { HsDecl } +> : signdecl { $1 } +> | fixdecl { $1 } +> | valdef { $1 } + +> decllist :: { [HsDecl] } +> : '{' decls '}' { $2 } +> | open decls close { $2 } + +> signdecl :: { HsDecl } +> : 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 +following programs: + + { (+) :: ... } only var + { (+) x y = ... } could (incorrectly) be qvar + +We re-use expressions for patterns, so a qvar would be allowed in patterns +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] } } + +----------------------------------------------------------------------------- +Types + +> type :: { HsType } +> : btype '->' type { HsTyFun $1 $3 } +> | btype { $1 } + +> btype :: { HsType } +> : 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 :: { HsQName } +> : 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] + +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 :: { HsContext } +> : btype {% checkContext $1 } + +> types :: { [HsType] } +> : types ',' type { $3 : $1 } +> | type ',' type { [$3, $1] } + +> simpletype :: { (HsName, [HsName]) } +> : tycon tyvars { ($1,reverse $2) } + +> tyvars :: { [HsName] } +> : tyvars tyvar { $2 : $1 } +> | {- empty -} { [] } + +----------------------------------------------------------------------------- +Datatype declarations + +> constrs :: { [HsConDecl] } +> : 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) } + +> scontype :: { (HsName, [HsBangType]) } +> : 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] ) } + +> satype :: { HsBangType } +> : atype { HsUnBangedTy $1 } +> | '!' atype { HsBangedTy $2 } + +> sbtype :: { HsBangType } +> : btype { HsUnBangedTy $1 } +> | '!' atype { HsBangedTy $2 } + +> fielddecls :: { [([HsName],HsBangType)] } +> : fielddecls ',' fielddecl { $3 : $1 } +> | fielddecl { [$1] } + +> fielddecl :: { ([HsName],HsBangType) } +> : vars '::' stype { (reverse $1, $3) } + +> stype :: { HsBangType } +> : type { HsUnBangedTy $1 } +> | '!' atype { HsBangedTy $2 } + +> deriving :: { [HsQName] } +> : {- empty -} { [] } +> | 'deriving' qtycls { [$2] } +> | 'deriving' '(' ')' { [] } +> | 'deriving' '(' dclasses ')' { reverse $3 } + +> dclasses :: { [HsQName] } +> : dclasses ',' qtycls { $3 : $1 } +> | qtycls { [$1] } + +----------------------------------------------------------------------------- +Class declarations + +> optcbody :: { [HsDecl] } +> : 'where' decllist {% checkClassBody $2 } +> | {- empty -} { [] } + +----------------------------------------------------------------------------- +Instance declarations + +> optvaldefs :: { [HsDecl] } +> : 'where' '{' valdefs '}' {% checkClassBody $3 } +> | 'where' open valdefs close {% checkClassBody $3 } +> | {- empty -} { [] } + +> valdefs :: { [HsDecl] } +> : optsemis valdefs1 optsemis {% checkRevDecls $2 } +> | optsemis { [] } + +> valdefs1 :: { [HsDecl] } +> : valdefs1 semis valdef { $3 : $1 } +> | valdef { [$1] } + +----------------------------------------------------------------------------- +Value definitions + +> valdef :: { HsDecl } +> : srcloc exp0b rhs optwhere {% checkValDef $1 $2 $3 $4 } + +> optwhere :: { [HsDecl] } +> : 'where' decllist { $2 } +> | {- empty -} { [] } + +> rhs :: { HsRhs } +> : '=' exp {% do { e <- checkExpr $2; +> return (HsUnGuardedRhs e) } } +> | gdrhs { HsGuardedRhss (reverse $1) } + +> gdrhs :: { [HsGuardedRhs] } +> : gdrhs gdrh { $2 : $1 } +> | gdrh { [$1] } + +> gdrh :: { HsGuardedRhs } +> : srcloc '|' exp0 '=' exp {% do { g <- checkExpr $3; +> e <- checkExpr $5; +> return (HsGuardedRhs $1 g e) } } + +----------------------------------------------------------------------------- +Expressions + +Note: The Report specifies a meta-rule for lambda, let and if expressions +(the exp's that end with a subordinate exp): they extend as far to +the right as possible. That means they cannot be followed by a type +signature or infix application. To implement this without shift/reduce +conflicts, we split exp10 into these expressions (exp10a) and the others +(exp10b). That also means that only an exp0 ending in an exp10b (an exp0b) +can followed by a type signature or infix application. So we duplicate +the exp0 productions to distinguish these from the others (exp0a). + +> exp :: { HsExp } +> : exp0b '::' srcloc ctype { HsExpTypeSig $3 $1 $4 } +> | exp0 { $1 } + +> exp0 :: { HsExp } +> : exp0a { $1 } +> | exp0b { $1 } + +> exp0a :: { HsExp } +> : exp0b qop exp10a { HsInfixApp $1 $2 $3 } +> | exp10a { $1 } + +> exp0b :: { HsExp } +> : 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 } + +> exp10b :: { HsExp } +> : '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 } + +> apats :: { [HsPat] } +> : apats apat { $2 : $1 } +> | apat { [$1] } + +> apat :: { HsPat } +> : 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 +reduce/reduce-errors (for as-patterns and irrefutable patters). + +Even though the variable in an as-pattern cannot be qualified, we use +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 } + +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 } + +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 } + +> commas :: { Int } +> : commas ',' { $1 + 1 } +> | ',' { 1 } + +> texps :: { [HsExp] } +> : texps ',' exp { $3 : $1 } +> | exp ',' exp { [$3,$1] } + +----------------------------------------------------------------------------- +List expressions + +The rules below are little bit contorted to keep lexps left-recursive while +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) } + +> lexps :: { [HsExp] } +> : lexps ',' exp { $3 : $1 } +> | exp ',' exp { [$3,$1] } + +----------------------------------------------------------------------------- +List comprehensions + +> quals :: { [HsStmt] } +> : quals ',' qual { $3 : $1 } +> | qual { [$1] } + +> qual :: { HsStmt } +> : 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 :: { [HsAlt] } +> : optsemis alts1 optsemis { reverse $2 } + +> alts1 :: { [HsAlt] } +> : alts1 semis alt { $3 : $1 } +> | alt { [$1] } + +> alt :: { HsAlt } +> : srcloc pat ralt optwhere { HsAlt $1 $2 $3 $4 } + +> ralt :: { HsGuardedAlts } +> : '->' exp { HsUnGuardedAlt $2 } +> | gdpats { HsGuardedAlts (reverse $1) } + +> gdpats :: { [HsGuardedAlt] } +> : gdpats gdpat { $2 : $1 } +> | gdpat { [$1] } + +> gdpat :: { HsGuardedAlt } +> : srcloc '|' exp0 '->' exp { HsGuardedAlt $1 $3 $5 } + +> pat :: { HsPat } +> : exp0b {% checkPattern $1 } + +----------------------------------------------------------------------------- +Statement sequences + +As per the Report, but with stmt expanded to simplify building the list +without introducing conflicts. This also ensures that the last stmt is +an expression. + +> stmtlist :: { [HsStmt] } +> : '{' 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] } + +----------------------------------------------------------------------------- +Record Field Update/Construction + +> fbinds :: { [HsFieldUpdate] } +> : fbinds ',' fbind { $3 : $1 } +> | fbind { [$1] } + +> fbind :: { HsFieldUpdate } +> : qvar '=' exp { HsFieldUpdate $1 $3 } + +----------------------------------------------------------------------------- +Variables, Constructors and Operators. + +> gcon :: { HsExp } +> : '(' ')' { unit_con } +> | '[' ']' { HsList [] } +> | '(' commas ')' { tuple_con $2 } +> | qcon { HsCon $1 } + +> var :: { HsName } +> : varid { $1 } +> | '(' varsym ')' { $2 } + +> qvar :: { HsQName } +> : qvarid { $1 } +> | '(' qvarsym ')' { $2 } + +> con :: { HsName } +> : conid { $1 } +> | '(' consym ')' { $2 } + +> qcon :: { HsQName } +> : qconid { $1 } +> | '(' gconsym ')' { $2 } + +> varop :: { HsName } +> : varsym { $1 } +> | '`' varid '`' { $2 } + +> qvarop :: { HsQName } +> : qvarsym { $1 } +> | '`' qvarid '`' { $2 } + +> qvaropm :: { HsQName } +> : qvarsymm { $1 } +> | '`' qvarid '`' { $2 } + +> conop :: { HsName } +> : consym { $1 } +> | '`' conid '`' { $2 } + +> qconop :: { HsQName } +> : gconsym { $1 } +> | '`' qconid '`' { $2 } + +> op :: { HsOp } +> : varop { HsVarOp $1 } +> | conop { HsConOp $1 } + +> qop :: { HsQOp } +> : qvarop { HsQVarOp $1 } +> | qconop { HsQConOp $1 } + +> qopm :: { HsQOp } +> : qvaropm { HsQVarOp $1 } +> | qconop { HsQConOp $1 } + +> gconsym :: { HsQName } +> : ':' { list_cons_name } +> | qconsym { $1 } + +----------------------------------------------------------------------------- +Identifiers and Symbols + +> qvarid :: { HsQName } +> : varid { UnQual $1 } +> | QVARID { Qual (Module (fst $1)) (HsIdent (snd $1)) } + +> varid :: { HsName } +> : VARID { HsIdent $1 } +> | 'as' { as_name } +> | 'qualified' { qualified_name } +> | 'hiding' { hiding_name } + +> qconid :: { HsQName } +> : conid { UnQual $1 } +> | QCONID { Qual (Module (fst $1)) (HsIdent (snd $1)) } + +> conid :: { HsName } +> : CONID { HsIdent $1 } + +> qconsym :: { HsQName } +> : consym { UnQual $1 } +> | QCONSYM { Qual (Module (fst $1)) (HsSymbol (snd $1)) } + +> consym :: { HsName } +> : CONSYM { HsSymbol $1 } + +> qvarsym :: { HsQName } +> : varsym { UnQual $1 } +> | qvarsym1 { $1 } + +> qvarsymm :: { HsQName } +> : varsymm { UnQual $1 } +> | qvarsym1 { $1 } + +> varsym :: { HsName } +> : VARSYM { HsSymbol $1 } +> | '-' { minus_name } +> | '!' { pling_name } + +> varsymm :: { HsName } -- varsym not including '-' +> : VARSYM { HsSymbol $1 } +> | '!' { pling_name } + +> qvarsym1 :: { HsQName } +> : QVARSYM { Qual (Module (fst $1)) (HsSymbol (snd $1)) } + +> literal :: { HsLiteral } +> : INT { HsInt $1 } +> | CHAR { HsChar $1 } +> | RATIONAL { HsFrac $1 } +> | STRING { HsString $1 } + +> srcloc :: { SrcLoc } : {% getSrcLoc } + +----------------------------------------------------------------------------- +Layout + +> open :: { () } : {% pushCurrentContext } + +> close :: { () } +> : vccurly { () } -- context popped in lexer. +> | error {% popContext } + +----------------------------------------------------------------------------- +Miscellaneous (mostly renamings) + +> modid :: { Module } +> : CONID { Module $1 } +> | QCONID { Module (fst $1 ++ '.':snd $1) } + +> tyconorcls :: { HsName } +> : conid { $1 } + +> tycon :: { HsName } +> : conid { $1 } + +> qtyconorcls :: { HsQName } +> : qconid { $1 } + +> qtycls :: { HsQName } +> : qconid { $1 } + +> tyvar :: { HsName } +> : varid { $1 } + +----------------------------------------------------------------------------- + +> { +> happyError :: P a +> happyError = fail "Parse error" + +> -- | Parse of a string, which should contain a complete Haskell 98 module. +> parseModule :: String -> ParseResult HsModule +> parseModule = runParser parse + +> -- | Parse of a string, which should contain a complete Haskell 98 module. +> parseModuleWithMode :: ParseMode -> String -> ParseResult HsModule +> parseModuleWithMode mode = runParserWithMode mode parse +> } diff --git a/Language/Haskell/Pretty.hs b/Language/Haskell/Pretty.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Pretty.hs @@ -0,0 +1,754 @@ +{-# 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) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- 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 + +import Language.Haskell.Syntax + +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 + +type Indent = Int + +-- | Pretty-printing parameters. +-- +-- /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 + } + +-- | 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 + } + +-- | Pretty printing monad +newtype DocM s a = DocM (s -> a) + +instance Functor (DocM s) where + fmap f xs = do x <- xs; return (f x) + +instance Monad (DocM s) where + (>>=) = thenDocM + (>>) = then_DocM + return = retDocM + +{-# INLINE thenDocM #-} +{-# INLINE then_DocM #-} +{-# INLINE retDocM #-} +{-# INLINE unDocM #-} +{-# INLINE getPPEnv #-} + +thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b +thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s) + +then_DocM :: DocM s a -> DocM s b -> DocM s b +then_DocM m k = DocM $ (\s -> case unDocM m $ s of _ -> unDocM k $ s) + +retDocM :: a -> DocM s a +retDocM a = DocM (\_s -> a) + +unDocM :: DocM s a -> (s -> a) +unDocM (DocM f) = f + +-- all this extra stuff, just for this one function. +getPPEnv :: DocM s s +getPPEnv = DocM id + +-- So that pp code still looks the same +-- this means we lose some generality though + +-- | The document type produced by these pretty printers uses a 'PPHsMode' +-- environment. +type Doc = DocM PPHsMode P.Doc + +-- | 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 + +-- The pretty printing combinators + +empty :: Doc +empty = return P.empty + +nest :: Int -> Doc -> Doc +nest i m = m >>= return . P.nest i + + +-- Literals + +text, ptext :: String -> Doc +text = return . P.text +ptext = return . P.text + +char :: Char -> Doc +char = return . P.char + +int :: Int -> Doc +int = return . P.int + +integer :: Integer -> Doc +integer = return . P.integer + +float :: Float -> Doc +float = return . P.float + +double :: Double -> Doc +double = return . P.double + +rational :: Rational -> Doc +rational = return . P.rational + +-- Simple Combining Forms + +parens, brackets, braces,quotes,doubleQuotes :: 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 + +parensIf :: Bool -> Doc -> Doc +parensIf True = parens +parensIf False = id + +-- Constants + +semi,comma,colon,space,equals :: Doc +semi = return P.semi +comma = return P.comma +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 + +-- Combinators + +(<>),(<+>),($$),($+$) :: 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)} + +hcat,hsep,vcat,sep,cat,fsep,fcat :: [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 +fsep dl = sequence dl >>= return . P.fsep +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} + +-- 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 + +-- | 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 'defaultMode'. +render :: Doc -> String +render = renderWithMode defaultMode + +-- | pretty-print with a given style and mode. +prettyPrintStyleMode :: Pretty a => P.Style -> PPHsMode -> a -> String +prettyPrintStyleMode ppStyle ppMode = renderStyleMode ppStyle ppMode . pretty + +-- | pretty-print with the default style and a given mode. +prettyPrintWithMode :: Pretty a => PPHsMode -> a -> String +prettyPrintWithMode = prettyPrintStyleMode P.style + +-- | pretty-print with the default style and 'defaultMode'. +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 + +------------------------- 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) + +-------------------------- Module Header ------------------------------ +ppHsModuleHeader :: Module -> Maybe [HsExportSpec] -> Doc +ppHsModuleHeader m mbExportList = mySep [ + text "module", + pretty m, + maybePP (parenList . map pretty) mbExportList, + text "where"] + +instance Pretty Module where + 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 + +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 + +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) + +------------------------- 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 (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) + + --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) + + 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 (HsFunBind matches) = + foldr ($$$) empty (map pretty matches) + + 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)) + +instance Pretty HsAssoc where + pretty HsAssocNone = text "infix" + pretty HsAssocLeft = text "infixl" + pretty HsAssocRight = text "infixr" + +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 + +ppWhere :: [HsDecl] -> Doc +ppWhere [] = empty +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 (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] + +instance Pretty HsBangType where + prettyPrec _ (HsBangedTy ty) = char '!' <> ppHsAType ty + prettyPrec p (HsUnBangedTy ty) = prettyPrec p ty + +ppHsDeriving :: [HsQName] -> Doc +ppHsDeriving [] = empty +ppHsDeriving [d] = text "deriving" <+> ppHsQName d +ppHsDeriving ds = text "deriving" <+> parenList (map ppHsQName ds) + +------------------------- Types ------------------------- +instance Pretty HsQualType where + pretty (HsQualType context htype) = + myFsep [ppHsContext context, pretty htype] + +ppHsBType :: HsType -> Doc +ppHsBType = prettyPrec prec_btype + +ppHsAType :: HsType -> Doc +ppHsAType = prettyPrec prec_atype + +-- 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 + +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 + +------------------------- Expressions ------------------------- +instance Pretty HsRhs where + 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] + +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 "##" + +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] + +------------------------- 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 + +instance Pretty HsPatField where + pretty (HsPFieldPat name pat) = + myFsep [pretty name, equals, pretty pat] + +------------------------- Case bodies ------------------------- +instance Pretty HsAlt where + pretty (HsAlt _pos e gAlts decls) = + pretty e <+> pretty gAlts $$$ ppWhere decls + +instance Pretty HsGuardedAlts where + 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] + +------------------------- 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) + +------------------------- Record updates +instance Pretty HsFieldUpdate where + 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 + +ppHsQNameInfix :: HsQName -> Doc +ppHsQNameInfix name + | isSymbolName (getName name) = ppHsQName name + | otherwise = char '`' <> ppHsQName name <> char '`' + +instance Pretty HsQName where + 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 (Special sym) = text (specialName sym) + +instance Pretty HsOp where + pretty (HsVarOp n) = ppHsNameInfix n + pretty (HsConOp n) = ppHsNameInfix n + +ppHsNameInfix :: HsName -> Doc +ppHsNameInfix name + | isSymbolName name = ppHsName name + | otherwise = char '`' <> ppHsName name <> char '`' + +instance Pretty HsName where + 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 + +isSymbolName :: HsName -> Bool +isSymbolName (HsSymbol _) = True +isSymbolName _ = False + +getName :: HsQName -> HsName +getName (UnQual s) = s +getName (Qual _ s) = s +getName (Special HsCons) = HsSymbol ":" +getName (Special HsFunCon) = HsSymbol "->" +getName (Special s) = HsIdent (specialName s) + +specialName :: HsSpecialCon -> String +specialName HsUnitCon = "()" +specialName HsListCon = "[]" +specialName HsFunCon = "->" +specialName (HsTupleCon n) = "(" ++ replicate (n-1) ',' ++ ")" +specialName HsCons = ":" + +ppHsContext :: HsContext -> Doc +ppHsContext [] = empty +ppHsContext context = mySep [parenList (map ppHsAsst context), text "=>"] + +-- hacked for multi-parameter type classes + +ppHsAsst :: HsAsst -> Doc +ppHsAsst (a,ts) = myFsep (ppHsQName a : map ppHsAType ts) + +------------------------- pp utils ------------------------- +maybePP :: (a -> Doc) -> Maybe a -> Doc +maybePP _ Nothing = empty +maybePP pp (Just a) = pp a + +parenList :: [Doc] -> Doc +parenList = parens . myFsepSimple . punctuate comma + +braceList :: [Doc] -> Doc +braceList = braces . myFsepSimple . punctuate comma + +bracketList :: [Doc] -> Doc +bracketList = brackets . myFsepSimple + +-- 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 + +-- Same, but put each thing on a separate line +prettyBlock :: [Doc] -> Doc +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} +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 + +ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc +ppBody f dl = do + e <- fmap layout getPPEnv + case e of PPOffsideRule -> indent + PPSemiColon -> indentExplicit + _ -> flatBlock dl + where + indent = do{i <-fmap f getPPEnv;nest i . vcat $ dl} + indentExplicit = do {i <- fmap f getPPEnv; + nest i . prettyBlock $ 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" + +myVcat :: [Doc] -> Doc +myVcat = layoutChoice vcat hsep + +myFsepSimple :: [Doc] -> Doc +myFsepSimple = layoutChoice fsep hsep + +-- same, except that continuation lines are indented, +-- 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)) + +layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc +layoutChoice a b dl = do e <- getPPEnv + if layout e == PPOffsideRule || + layout e == PPSemiColon + then a dl else b dl + +-- Prefix something with a LINE pragma, if requested. +-- GHC's LINE pragma actually sets the current line number to n-1, so +-- that the following line is line n. But if there's no newline before +-- the line we're talking about, we need to compensate by adding 1. + +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 diff --git a/Language/Haskell/Syntax.hs b/Language/Haskell/Syntax.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax.hs @@ -0,0 +1,545 @@ +{-# OPTIONS_GHC -fglasgow-exts -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.Syntax +-- Copyright : (c) The GHC Team, 1997-2000 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- A suite of datatypes describing the abstract syntax of Haskell 98 +-- plus a few extensions: +-- +-- * multi-parameter type classes +-- +-- * parameters of type class assertions are unrestricted +-- +-- This module has been changed so that show is a real show. +-- For GHC, we also derive Typeable and Data for all types. + +----------------------------------------------------------------------------- + +module Language.Haskell.Syntax ( + -- * Modules + HsModule(..), HsExportSpec(..), + HsImportDecl(..), HsImportSpec(..), HsAssoc(..), + -- * Declarations + HsDecl(..), HsConDecl(..), HsBangType(..), + HsMatch(..), HsRhs(..), HsGuardedRhs(..), + -- * Class Assertions and Contexts + HsQualType(..), HsContext, HsAsst, + -- * Types + HsType(..), + -- * Expressions + HsExp(..), HsStmt(..), HsFieldUpdate(..), + HsAlt(..), HsGuardedAlts(..), HsGuardedAlt(..), + -- * Patterns + HsPat(..), HsPatField(..), + -- * Literals + HsLiteral(..), + -- * Variables, Constructors and Operators + Module(..), HsQName(..), HsName(..), HsQOp(..), HsOp(..), + HsSpecialCon(..), HsCName(..), + + -- * Builtin names + + -- ** Modules + prelude_mod, main_mod, + -- ** Main function of a program + main_name, + -- ** Constructors + unit_con_name, tuple_con_name, list_cons_name, + unit_con, tuple_con, + -- ** Special identifiers + as_name, qualified_name, hiding_name, minus_name, pling_name, + -- ** Type constructors + unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name, + unit_tycon, fun_tycon, list_tycon, tuple_tycon, + + -- * Source coordinates + SrcLoc(..), + ) where + + +#ifdef __GLASGOW_HASKELL__ +import Data.Generics.Basics +import Data.Generics.Instances +#endif + +-- | A position in the source. +data SrcLoc = SrcLoc { + srcFilename :: String, + srcLine :: Int, + srcColumn :: Int + } +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Ord,Show,Typeable,Data) +#else + deriving (Eq,Ord,Show) +#endif + +-- | The name of a Haskell module. +newtype Module = Module String +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Ord,Show,Typeable,Data) +#else + deriving (Eq,Ord,Show) +#endif + +-- | Constructors with special syntax. +-- These names are never qualified, and always refer to builtin type or +-- 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 @(:)@ +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Ord,Show,Typeable,Data) +#else + deriving (Eq,Ord,Show) +#endif + +-- | 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 +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Ord,Show,Typeable,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/ +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Ord,Show,Typeable,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/) +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Ord,Show,Typeable,Data) +#else + deriving (Eq,Ord,Show) +#endif + +-- | Operators, appearing in @infix@ declarations. +data HsOp + = HsVarOp HsName -- ^ variable operator (/varop/) + | HsConOp HsName -- ^ constructor operator (/conop/) +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Ord,Show,Typeable,Data) +#else + deriving (Eq,Ord,Show) +#endif + +-- | 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 +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Ord,Show,Typeable,Data) +#else + deriving (Eq,Ord,Show) +#endif + +-- | A Haskell source module. +data HsModule = HsModule SrcLoc Module (Maybe [HsExportSpec]) + [HsImportDecl] [HsDecl] +#ifdef __GLASGOW_HASKELL__ + deriving (Show,Typeable,Data) +#else + deriving (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. +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,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@. + } +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,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. +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,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@) +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,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] +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +-- | Clauses of a function binding. +data HsMatch + = HsMatch SrcLoc HsName [HsPat] HsRhs {-where-} [HsDecl] +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,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 +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +-- | 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 +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,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/) +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +-- | A guarded right hand side @|@ /exp/ @=@ /exp/. +-- The first expression will be Boolean-valued. +data HsGuardedRhs + = HsGuardedRhs SrcLoc HsExp HsExp +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +-- | A type qualified with a context. +-- An unqualified type has an empty context. +data HsQualType + = HsQualType HsContext HsType +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,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 +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +type HsContext = [HsAsst] + +-- | Class assertions. +-- In Haskell 98, the argument would be a /tyvar/, but this definition +-- allows multiple parameters, and allows them to be /type/s. +type HsAsst = (HsQName,[HsType]) + +-- | /literal/. +-- Values of this type hold the abstract value of the literal, not the +-- 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 +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +-- | Haskell expressions. +-- +-- /Notes:/ +-- +-- * Because it is difficult for parsers to distinguish patterns from +-- expressions, they typically parse them in the same way and then check +-- that they have the appropriate form. Hence the expression type +-- includes some forms that are found only in patterns. After these +-- checks, these constructors should not be used. +-- +-- * The parser does not take precedence and associativity into account, +-- so it will leave 'HsInfixApp's associated to the left. +-- +-- * The 'Language.Haskell.Pretty.Pretty' instance for 'HsExp' does not +-- 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 +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,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 (@~@) +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +-- | An /fpat/ in a labeled record pattern. +data HsPatField + = HsPFieldPat HsQName HsPat +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +-- | 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 +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +-- | An /fbind/ in a labeled record construction or update expression. +data HsFieldUpdate + = HsFieldUpdate HsQName HsExp +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +-- | An /alt/ in a @case@ expression. +data HsAlt + = HsAlt SrcLoc HsPat HsGuardedAlts [HsDecl] +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +data HsGuardedAlts + = HsUnGuardedAlt HsExp -- ^ @->@ /exp/ + | HsGuardedAlts [HsGuardedAlt] -- ^ /gdpat/ +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +-- | A guarded alternative @|@ /exp/ @->@ /exp/. +-- The first expression will be Boolean-valued. +data HsGuardedAlt + = HsGuardedAlt SrcLoc HsExp HsExp +#ifdef __GLASGOW_HASKELL__ + deriving (Eq,Show,Typeable,Data) +#else + deriving (Eq,Show) +#endif + +----------------------------------------------------------------------------- +-- Builtin names. + +prelude_mod, main_mod :: Module +prelude_mod = Module "Prelude" +main_mod = Module "Main" + +main_name :: HsName +main_name = HsIdent "main" + +unit_con_name :: HsQName +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 + +unit_con :: HsExp +unit_con = HsCon unit_con_name + +tuple_con :: Int -> HsExp +tuple_con i = HsCon (tuple_con_name i) + +as_name, qualified_name, hiding_name, minus_name, pling_name :: HsName +as_name = HsIdent "as" +qualified_name = HsIdent "qualified" +hiding_name = HsIdent "hiding" +minus_name = HsSymbol "-" +pling_name = HsSymbol "!" + +unit_tycon_name, fun_tycon_name, list_tycon_name :: HsQName +unit_tycon_name = unit_con_name +fun_tycon_name = Special HsFunCon +list_tycon_name = Special HsListCon + +tuple_tycon_name :: Int -> HsQName +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 + +tuple_tycon :: Int -> HsType +tuple_tycon i = HsTyCon (tuple_tycon_name i) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-src.cabal b/haskell-src.cabal new file mode 100644 --- /dev/null +++ b/haskell-src.cabal @@ -0,0 +1,22 @@ +name: haskell-src +version: 1.0 +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. +exposed-modules: + Language.Haskell.Lexer, + Language.Haskell.Parser, + Language.Haskell.ParseMonad, + Language.Haskell.Pretty, + Language.Haskell.Syntax + Language.Haskell.ParseUtils +build-depends: base, haskell98 + -- The dependency on Haskell 98 is only because + -- Happy generates a parser that imports Array +extensions: CPP