haskell-src (empty) → 1.0
raw patch · 9 files changed
+3246/−0 lines, 9 filesdep +basedep +haskell98build-type:Customsetup-changed
Dependencies added: base, haskell98
Files
- LICENSE +31/−0
- Language/Haskell/Lexer.hs +527/−0
- Language/Haskell/ParseMonad.hs +234/−0
- Language/Haskell/ParseUtils.hs +312/−0
- Language/Haskell/Parser.ly +819/−0
- Language/Haskell/Pretty.hs +754/−0
- Language/Haskell/Syntax.hs +545/−0
- Setup.hs +2/−0
- haskell-src.cabal +22/−0
+ LICENSE view
@@ -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.
+ Language/Haskell/Lexer.hs view
@@ -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)
+ Language/Haskell/ParseMonad.hs view
@@ -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 = "<unknown>"+ }++-- | Monad for parsing++newtype P a = P { runP ::+ String -- input string+ -> Int -- current column+ -> Int -- current line+ -> SrcLoc -- location of last token read+ -> ParseState -- layout info.+ -> ParseMode -- parse parameters+ -> ParseStatus a+ }++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)
+ Language/Haskell/ParseUtils.hs view
@@ -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
+ Language/Haskell/Parser.ly view
@@ -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+> }
+ Language/Haskell/Pretty.hs view
@@ -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
+ Language/Haskell/Syntax.hs view
@@ -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+-- <http://www.haskell.org/onlinereport/> 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)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskell-src.cabal view
@@ -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