haskell-src-1.0.4/0000755000000000000000000000000007346545000012115 5ustar0000000000000000haskell-src-1.0.4/LICENSE0000644000000000000000000000310707346545000013123 0ustar0000000000000000The 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. haskell-src-1.0.4/Language/Haskell/0000755000000000000000000000000007346545000015223 5ustar0000000000000000haskell-src-1.0.4/Language/Haskell/Lexer.hs0000644000000000000000000004313707346545000016646 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Lexer -- Copyright : (c) The GHC Team, 1997-2000 -- License : BSD-3-Clause -- -- Maintainer : Andreas Abel -- Stability : stable -- 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 (chr, digitToInt, isAlpha, isDigit, isHexDigit, isLower, isOctDigit, isSpace, isUpper, ord, toLower) import qualified Data.Char (isSymbol) import Data.Ratio data Token = VarId String | QVarId (String,String) | ConId String | 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_Case | KW_Class | KW_Data | KW_Default | KW_Deriving | KW_Do | KW_Else | KW_Foreign | KW_If | KW_Import | KW_In | KW_Infix | KW_InfixL | KW_InfixR | KW_Instance | KW_Let | KW_Module | KW_NewType | KW_Of | KW_Then | KW_Type | KW_Where -- Special Ids | KW_As | KW_Export | KW_Hiding | KW_Qualified | KW_Safe | KW_Unsafe | 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 ), ( "foreign", KW_Foreign ), ( "if", KW_If ), ( "import", KW_Import ), ( "in", KW_In ), ( "infix", KW_Infix ), ( "infixl", KW_InfixL ), ( "infixr", KW_InfixR ), ( "instance", KW_Instance ), ( "let", KW_Let ), ( "module", KW_Module ), ( "newtype", KW_NewType ), ( "of", KW_Of ), ( "then", KW_Then ), ( "type", KW_Type ), ( "where", KW_Where ) ] special_varids :: [(String,Token)] special_varids = [ ( "as", KW_As ), ( "export", KW_Export ), ( "hiding", KW_Hiding ), ( "qualified", KW_Qualified ), ( "safe", KW_Safe ), ( "unsafe", KW_Unsafe ) ] isIdent, isSymbol :: Char -> Bool isIdent c = isAlpha c || isDigit c || c == '\'' || c == '_' isSymbol c = c `elem` ":!#%&*./?@\\-" || (Data.Char.isSymbol c && not (c `elem` "(),;[]`{}_\"'")) 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 <= 0x10FFFF = return (chr (fromInteger n)) checkChar _ = fail "Character constant out of range" -- Production cntrl from section B.2 cntrl :: Char -> Lex a Char cntrl c | c >= '@' && c <= '_' = return (chr (ord c - ord '@')) cntrl _ = fail "Illegal control character" -- 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) haskell-src-1.0.4/Language/Haskell/ParseMonad.hs0000644000000000000000000002324307346545000017614 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.ParseMonad -- Copyright : (c) The GHC Team, 1997-2000 -- License : BSD-3-Clause -- -- Maintainer : Andreas Abel -- Stability : stable -- Portability : portable -- -- Monads for the Haskell parser and lexer. -- ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 902 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} #endif module Language.Haskell.ParseMonad( -- * Parsing P, ParseResult(..), atSrcLoc, LexContext(..), ParseMode(..), defaultParseMode, runParserWithMode, runParser, getSrcLoc, pushCurrentContext, popContext, -- * Lexing Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile, alternative, checkBOL, setBOL, startToken, getOffside, pushContextL, popContextL ) where import Control.Applicative as App import Control.Monad (ap, liftM) import qualified Control.Monad.Fail as Fail import Data.Semigroup as Semi import Language.Haskell.Syntax (SrcLoc (..)) -- | The result of a parse. data ParseResult a = ParseOk a -- ^ The parse succeeded, yielding a value. | ParseFailed SrcLoc String -- ^ The parse failed at the specified -- source location, with an error message. deriving Show instance Functor ParseResult where fmap f (ParseOk x) = ParseOk $ f x fmap _ (ParseFailed loc msg) = ParseFailed loc msg instance App.Applicative ParseResult where pure = ParseOk ParseOk f <*> x = f <$> x ParseFailed loc msg <*> _ = ParseFailed loc msg instance Monad ParseResult where return = pure ParseOk x >>= f = f x ParseFailed loc msg >>= _ = ParseFailed loc msg -- TODO: relax constraint to 'Semigroup s => Semigroup (ParseResult -- s)' in the long distant future -- | @since 1.0.3.0 instance Monoid m => Semi.Semigroup (ParseResult m) where ParseOk x <> ParseOk y = ParseOk $ x `mappend` y ParseOk _ <> err = err err <> _ = err -- left-biased instance Monoid m => Monoid (ParseResult m) where mempty = ParseOk mempty mappend = (<>) -- internal version data ParseStatus a = Ok ParseState a | Failed SrcLoc String deriving Show data LexContext = NoLayout | Layout Int deriving (Eq,Ord,Show) type ParseState = [LexContext] indentOfParseState :: ParseState -> Int indentOfParseState (Layout n:_) = n indentOfParseState _ = 0 -- | Static parameters governing a parse. -- More to come later, e.g. literate mode, language extensions. data ParseMode = ParseMode { -- | original name of the file being parsed parseFilename :: String } -- | Default parameters for a parse, -- currently just a marker for an unknown filename. defaultParseMode :: ParseMode defaultParseMode = ParseMode { parseFilename = "" } -- | Monad for parsing newtype P a = P { runP :: String -- input string -> Int -- current column -> Int -- current line -> SrcLoc -- location of last token read -> ParseState -- layout info. -> ParseMode -- parse parameters -> ParseStatus a } runParserWithMode :: ParseMode -> P a -> String -> ParseResult a runParserWithMode mode (P m) s = case m s 0 1 start [] mode of Ok _ a -> ParseOk a Failed loc msg -> ParseFailed loc msg where start = SrcLoc { srcFilename = parseFilename mode, srcLine = 1, srcColumn = 1 } runParser :: P a -> String -> ParseResult a runParser = runParserWithMode defaultParseMode -- | @since 1.0.2.0 instance Functor P where fmap = liftM -- | @since 1.0.2.0 instance Applicative P where pure a = P $ \_i _x _y _l s _m -> Ok s a (<*>) = ap instance Monad P where return = pure P m >>= k = P $ \i x y l s mode -> case m i x y l s mode of Failed loc msg -> Failed loc msg Ok s' a -> runP (k a) i x y l s' mode #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif -- | @since 1.0.3.0 instance Fail.MonadFail P where fail s = P $ \_r _col _line loc _stk _m -> Failed loc s atSrcLoc :: P a -> SrcLoc -> P a P m `atSrcLoc` loc = P $ \i x y _l -> m i x y loc 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 } -- | @since 1.0.2.0 instance Functor (Lex r) where fmap = liftM -- | @since 1.0.2.0 instance Applicative (Lex r) where pure a = Lex $ \k -> k a (<*>) = ap Lex v *> Lex w = Lex $ \k -> v (\_ -> w k) instance Monad (Lex r) where return = pure Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k) (>>) = (*>) #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif -- | @since 1.0.3.0 instance Fail.MonadFail (Lex r) where fail s = Lex $ \_ -> Fail.fail s -- Operations on this monad getInput :: Lex r String 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) haskell-src-1.0.4/Language/Haskell/ParseUtils.hs0000644000000000000000000003121607346545000017655 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.ParseUtils -- Copyright : (c) The GHC Team, 1997-2000 -- License : BSD-3-Clause -- -- Maintainer : Andreas Abel -- Stability : stable -- 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.ParseMonad import Language.Haskell.Pretty import Language.Haskell.Syntax splitTyConApp :: HsType -> P (HsName,[HsType]) splitTyConApp t0 = split t0 [] where split :: HsType -> [HsType] -> P (HsName,[HsType]) split (HsTyApp t u) ts = split t (u:ts) split (HsTyCon (UnQual t)) ts = return (t,ts) split _ _ = fail "Illegal data/newtype declaration" ----------------------------------------------------------------------------- -- 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 e1 -> check1Expr e1 HsNegApp HsLambda loc ps e1 -> check1Expr e1 (HsLambda loc ps) HsLet bs e1 -> check1Expr e1 (HsLet bs) HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf HsCase e1 alts -> do alts' <- mapM checkAlt alts e1' <- checkExpr e1 return (HsCase e1' alts') HsDo stmts -> do stmts' <- mapM checkStmt stmts return (HsDo stmts') HsTuple es -> checkManyExprs es HsTuple HsList es -> checkManyExprs es HsList HsParen e1 -> check1Expr e1 HsParen HsLeftSection e1 op -> check1Expr e1 (flip HsLeftSection op) HsRightSection op e1 -> check1Expr e1 (HsRightSection op) HsRecConstr c fields -> do fields' <- mapM checkField fields return (HsRecConstr c fields') HsRecUpdate e1 fields -> do fields' <- mapM checkField fields e1' <- checkExpr e1 return (HsRecUpdate e1' fields') HsEnumFrom e1 -> check1Expr e1 HsEnumFrom HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo HsListComp e1 stmts -> do stmts' <- mapM checkStmt stmts e1' <- checkExpr e1 return (HsListComp e1' stmts') HsExpTypeSig loc e1 ty -> do e1' <- checkExpr e1 return (HsExpTypeSig loc e1' ty) _ -> fail "Parse error in expression" -- type signature for polymorphic recursion!! check1Expr :: HsExp -> (HsExp -> a) -> P a check1Expr e1 f = do e1' <- checkExpr e1 return (f e1') 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 haskell-src-1.0.4/Language/Haskell/Parser.ly0000644000000000000000000007442007346545000017034 0ustar0000000000000000> { > ----------------------------------------------------------------------------- > -- | > -- 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 : stable > -- 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 > 'case' { KW_Case } > 'class' { KW_Class } > 'data' { KW_Data } > 'default' { KW_Default } > 'deriving' { KW_Deriving } > 'do' { KW_Do } > 'else' { KW_Else } > 'foreign' { KW_Foreign } > 'if' { KW_If } > 'import' { KW_Import } > 'in' { KW_In } > 'infix' { KW_Infix } > 'infixl' { KW_InfixL } > 'infixr' { KW_InfixR } > 'instance' { KW_Instance } > 'let' { KW_Let } > 'module' { KW_Module } > 'newtype' { KW_NewType } > 'of' { KW_Of } > 'then' { KW_Then } > 'type' { KW_Type } > 'where' { KW_Where } Special Ids > 'as' { KW_As } > 'export' { KW_Export } > 'hiding' { KW_Hiding } > 'qualified' { KW_Qualified } > 'safe' { KW_Safe } > 'unsafe' { KW_Unsafe } > %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 } > | foreigndecl { $1 } > | 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] } } Foreign declarations - calling conventions are uninterpreted - external entities are not parsed - special ids are not allowed as internal names > foreigndecl :: { HsDecl } > : srcloc 'foreign' 'import' VARID optsafety optentity fvar '::' type > { HsForeignImport $1 $4 $5 $6 $7 $9 } > | srcloc 'foreign' 'export' VARID optentity fvar '::' type > { HsForeignExport $1 $4 $5 $6 $8 } > optsafety :: { HsSafety } > : 'safe' { HsSafe } > | 'unsafe' { HsUnsafe } > | {- empty -} { HsSafe } > optentity :: { String } > : STRING { $1 } > | {- empty -} { "" } > fvar :: { HsName } > : VARID { HsIdent $1 } > | '(' varsym ')' { $2 } ----------------------------------------------------------------------------- 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' { HsIdent "as" } > | 'export' { HsIdent "export" } > | 'hiding' { HsIdent "hiding" } > | 'qualified' { HsIdent "qualified" } > | 'safe' { HsIdent "safe" } > | 'unsafe' { HsIdent "unsafe" } > qconid :: { HsQName } > : conid { UnQual $1 } > | QCONID { Qual (Module (fst $1)) (HsIdent (snd $1)) } > conid :: { 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 } > | '-' { HsSymbol "-" } > | '!' { HsSymbol "!" } > varsymm :: { HsName } -- varsym not including '-' > : VARSYM { HsSymbol $1 } > | '!' { HsSymbol "!" } > 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 > } haskell-src-1.0.4/Language/Haskell/Pretty.hs0000644000000000000000000007132207346545000017053 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Pretty -- Copyright : (c) The GHC Team, Noel Winstanley 1997-2000 -- License : BSD-3-Clause -- -- Maintainer : Andreas Abel -- Stability : stable -- Portability : portable -- -- Pretty printer for Haskell. -- ----------------------------------------------------------------------------- module Language.Haskell.Pretty ( -- * Pretty printing Pretty, prettyPrintStyleMode, prettyPrintWithMode, prettyPrint, -- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ") P.Style(..), P.style, P.Mode(..), -- * Haskell formatting modes PPHsMode(..), Indent, PPLayout(..), defaultMode ) where import Language.Haskell.Syntax import Control.Applicative as App (Applicative (..)) import Control.Monad (ap) import qualified Text.PrettyPrint as P infixl 5 $$$ ----------------------------------------------------------------------------- -- | Varieties of layout we can use. data PPLayout = PPOffsideRule -- ^ Classical layout. | PPSemiColon -- ^ Classical layout made explicit. | PPInLine -- ^ Inline decls, with newlines between them. | PPNoLayout -- ^ Everything on a single line. deriving Eq 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) -- | @since 1.0.2.0 instance App.Applicative (DocM s) where pure = retDocM (<*>) = ap (*>) = then_DocM instance Monad (DocM s) where (>>=) = thenDocM (>>) = (*>) return = pure {-# 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 :: 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 :: 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,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,fsep :: [Doc] -> Doc hcat dl = sequence dl >>= return . P.hcat hsep dl = sequence dl >>= return . P.hsep vcat dl = sequence dl >>= return . P.vcat -- sep dl = sequence dl >>= return . P.sep -- cat dl = sequence dl >>= return . P.cat 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 (HsForeignImport pos conv safety entity name ty) = blankline $ markLine pos $ mySep $ [text "foreign", text "import", text conv, pretty safety] ++ (if null entity then [] else [text (show entity)]) ++ [pretty name, text "::", pretty ty] pretty (HsForeignExport pos conv entity name ty) = blankline $ markLine pos $ mySep $ [text "foreign", text "export", text conv] ++ (if null entity then [] else [text (show entity)]) ++ [pretty name, text "::", pretty ty] pretty (HsFunBind matches) = ppBindings (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 HsSafety where pretty HsSafe = text "safe" pretty HsUnsafe = text "unsafe" instance Pretty HsMatch where pretty (HsMatch pos f ps rhs whereDecls) = markLine pos $ myFsep (lhs ++ [pretty rhs]) $$$ ppWhere whereDecls where lhs = case ps of l:r:ps' | isSymbolName f -> let hd = [pretty l, ppHsName f, pretty r] in if null ps' then hd else parens (myFsep hd) : map (prettyPrec 2) ps' _ -> pretty f : map (prettyPrec 2) ps 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) = myFsep [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 i <- fmap f getPPEnv case e of PPOffsideRule -> nest i . vcat $ dl PPSemiColon -> nest i . prettyBlock $ dl _ -> flatBlock dl ppBindings :: [Doc] -> Doc ppBindings dl = do e <- fmap layout getPPEnv case e of PPOffsideRule -> vcat dl PPSemiColon -> vcat . punctuate semi $ dl _ -> hsep . punctuate semi $ dl ($$$) :: 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 haskell-src-1.0.4/Language/Haskell/Syntax.hs0000644000000000000000000004611607346545000017055 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Syntax -- Copyright : (c) The GHC Team, 1997-2000 -- License : BSD-3-Clause -- -- Maintainer : Andreas Abel -- Stability : stable -- Portability : portable -- -- A suite of datatypes describing the abstract syntax of -- plus a few extensions: -- -- * multi-parameter type classes -- -- * parameters of type class assertions are unrestricted -- -- 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(..), HsSafety(..), -- * 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, -- ** 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 (Eq,Show,Typeable,Data) #else deriving (Eq,Show) #endif -- | Export specification. data HsExportSpec = HsEVar HsQName -- ^ Variable. | HsEAbs HsQName -- ^ @T@: -- A class or datatype exported abstractly, -- or a type synonym. | HsEThingAll HsQName -- ^ @T(..)@: -- A class exported with all of its methods, or -- a datatype exported with all of its constructors. | HsEThingWith HsQName [HsCName] -- ^ @T(C_1,...,C_n)@: -- A class exported with some of its methods, or -- a datatype exported with some of its constructors. | HsEModuleContents Module -- ^ @module M@: -- Re-export a module. #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] | HsForeignImport SrcLoc String HsSafety String HsName HsType | HsForeignExport SrcLoc String String HsName HsType #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 -- | Safety level for invoking a foreign entity. data HsSafety = HsSafe -- ^ Call may generate callbacks. | HsUnsafe -- ^ Call will not generate callbacks. #ifdef __GLASGOW_HASKELL__ deriving (Eq,Ord,Show,Typeable,Data) #else deriving (Eq,Ord,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) 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) haskell-src-1.0.4/Setup.hs0000644000000000000000000000012707346545000013551 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain haskell-src-1.0.4/changelog.md0000644000000000000000000000205307346545000014366 0ustar0000000000000000## 1.0.4 _Andreas Abel, 2022-02-07_ - Add `Eq` instance for `HsModule`. ## 1.0.3.2 _Andreas Abel, 2022-02-07_ - Version tested with GHC 7.0 - 9.2. - Silence warning `incomplete-uni-patterns` in module `ParseMonad` for GHC >= 9.2. - Cosmetic documentation changes. ## 1.0.3.1 Revision 5 - Support happy-1.21. ## 1.0.3.1 Revision 4 - Support GHC 9.2 & base-4.16. ## 1.0.3.1 Revision 3 - Support GHC 9.0 & base-4.15. ## 1.0.3.0/1 Revision 2 - Support happy-1.20. ## 1.0.3.1 _Herbert Valerio Riedel, 2019-11-09_ - Version for GHC 8.8 and 8.10. ## 1.0.3.0 _Herbert Valerio Riedel, 2018-03-13_ - Version for GHC 7.10 - 8.6. (Dropped support for GHC versions prior to GHC 7.0.) - Add support for `MonadFail` & `Semigroup` proposals by adding respective instances for `P` and `Lex`. - Remove `-O2` from `ghc-options`. ## 1.0.2.0 _Herbert Valerio Riedel, 2015-01-24_ - Add support for GHC 7.10 & base-4.8. - Add missing `Functor` & `Applicative` instances for `P` and `Lex` monads needed for AMP compatibility. haskell-src-1.0.4/haskell-src.cabal0000644000000000000000000000342007346545000015310 0ustar0000000000000000cabal-version: >=1.10 name: haskell-src -- don't forget to update the changelog.md! version: 1.0.4 build-type: Simple license: BSD3 license-file: LICENSE author: Simon Marlow, Sven Panne and Noel Winstanley maintainer: Andreas Abel bug-reports: https://github.com/haskell-pkg-janitors/haskell-src/issues stability: stable category: Language synopsis: Support for manipulating Haskell source code description: The @haskell-src@ package provides support for manipulating Haskell source code. The package provides a lexer, parser and pretty-printer, and a definition of a Haskell abstract syntax tree (AST). Common uses of this package are to parse or generate code. tested-with: GHC == 9.2.1 GHC == 9.0.2 GHC == 8.10.7 GHC == 8.8.4 GHC == 8.6.5 GHC == 8.4.4 GHC == 8.2.2 GHC == 8.0.2 GHC == 7.10.3 GHC == 7.8.4 GHC == 7.6.3 GHC == 7.4.2 GHC == 7.2.2 GHC == 7.0.4 extra-source-files: changelog.md source-repository head type: git location: https://github.com/haskell-pkg-janitors/haskell-src.git library exposed-modules: Language.Haskell.Lexer, Language.Haskell.Parser, Language.Haskell.ParseMonad, Language.Haskell.Pretty, Language.Haskell.Syntax, Language.Haskell.ParseUtils build-depends: base >= 4.3 && < 4.17 , syb >= 0.1 && < 0.8 , pretty >= 1.0.1.2 && < 1.2 , array >= 0.3 && < 0.6 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.*, fail == 4.9.* else ghc-options: -Wcompat -Wnoncanonical-monad-instances build-tools: happy >= 1.19 && < 1.22 default-language: Haskell98 ghc-options: -Wall