diff options
| -rw-r--r-- | examples/Test.hs | 3 | ||||
| -rw-r--r-- | haddock.cabal | 4 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 2 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 151 | ||||
| -rw-r--r-- | src/HsParseUtils.lhs | 326 | ||||
| -rw-r--r-- | src/HsParser.ly | 1024 | ||||
| -rw-r--r-- | src/Main.hs | 18 |
7 files changed, 16 insertions, 1512 deletions
diff --git a/examples/Test.hs b/examples/Test.hs index 2f6a50cf..5e8c5d03 100644 --- a/examples/Test.hs +++ b/examples/Test.hs @@ -101,6 +101,9 @@ module Test ( import Hidden import Visible +import Data.Maybe + +bla = Nothing --hej = visible diff --git a/haddock.cabal b/haddock.cabal index 3beb5d7c..469b3f31 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -68,17 +68,13 @@ other-modules: HaddockHH2 HaddockHoogle HaddockHtml - HaddockLex2 HaddockModuleTree - HaddockParse2 HaddockRename HaddockTypes HaddockUtil HaddockVersion HsLexer HsParseMonad - HsParseUtils - HsParser HsSyn2 Html Main diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index 172ef82a..f91c1ab1 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -83,7 +83,7 @@ data DocOption | OptIgnoreExports -- pretend everything is exported | OptNotHome -- not the best place to get docs for things -- exported by this module. - deriving (Eq) + deriving (Eq, Show) data ExportItem = ExportDecl diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 1d4eb29b..92d81ff6 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -9,7 +9,7 @@ module HaddockUtil ( -- * Misc utilities nameOfQName, collectNames, declBinders, declMainBinder, declSubBinders, - splitTyConApp, restrictTo, declDoc, parseModuleHeader, freeTyCons, unbang, + splitTyConApp, restrictTo, declDoc, freeTyCons, unbang, addFieldDoc, addFieldDocs, addConDoc, addConDocs,toDescription, unQual, -- * Filename utilities @@ -26,8 +26,6 @@ module HaddockUtil ( ) where import Binary2 -import HaddockLex2 -import HaddockParse2 import HaddockTypes import HsSyn2 import Map ( Map ) @@ -229,153 +227,6 @@ declDoc (HsForeignImport _ _ _ _ _ _ d) = d declDoc _ = Nothing -- ----------------------------------------------------------------------------- --- Parsing module headers - --- NB. The headers must be given in the order Module, Description, --- Copyright, License, Maintainer, Stability, Portability, except that --- any or all may be omitted. -parseModuleHeader :: String -> Either String (String,ModuleInfo) -parseModuleHeader str0 = - let - getKey :: String -> String -> (Maybe String,String) - getKey key str = case parseKey key str of - Nothing -> (Nothing,str) - Just (value,rest) -> (Just value,rest) - - (moduleOpt,str1) = getKey "Module" str0 - (descriptionOpt,str2) = getKey "Description" str1 - (copyrightOpt,str3) = getKey "Copyright" str2 - (licenseOpt,str4) = getKey "License" str3 - (licenceOpt,str5) = getKey "Licence" str4 - (maintainerOpt,str6) = getKey "Maintainer" str5 - (stabilityOpt,str7) = getKey "Stability" str6 - (portabilityOpt,str8) = getKey "Portability" str7 - - description1 :: Either String (Maybe Doc) - description1 = case descriptionOpt of - Nothing -> Right Nothing - Just description -> case parseString . tokenise $ description of - Left mess -> Left ("Cannot parse Description: " ++ mess) - Right doc -> Right (Just doc) - in - case description1 of - Left mess -> Left mess - Right docOpt -> Right (str8,ModuleInfo { - description = docOpt, - portability = portabilityOpt, - stability = stabilityOpt, - maintainer = maintainerOpt - }) - - --- | This function is how we read keys. --- --- all fields in the header are optional and have the form --- --- [spaces1][field name][spaces] ":" --- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")* --- where each [spaces2] should have [spaces1] as a prefix. --- --- Thus for the key "Description", --- --- > Description : this is a --- > rather long --- > --- > description --- > --- > The module comment starts here --- --- the value will be "this is a .. description" and the rest will begin --- at "The module comment". -parseKey :: String -> String -> Maybe (String,String) -parseKey key toParse0 = - do - let - (spaces0,toParse1) = extractLeadingSpaces toParse0 - - indentation = spaces0 - afterKey0 <- extractPrefix key toParse1 - let - afterKey1 = extractLeadingSpaces afterKey0 - afterColon0 <- case snd afterKey1 of - ':':afterColon -> return afterColon - _ -> Nothing - let - (_,afterColon1) = extractLeadingSpaces afterColon0 - - return (scanKey True indentation afterColon1) - where - scanKey :: Bool -> String -> String -> (String,String) - scanKey isFirst indentation [] = ([],[]) - scanKey isFirst indentation str = - let - (nextLine,rest1) = extractNextLine str - - accept = isFirst || sufficientIndentation || allSpaces - - sufficientIndentation = case extractPrefix indentation nextLine of - Just (c:_) | isSpace c -> True - _ -> False - - allSpaces = case extractLeadingSpaces nextLine of - (_,[]) -> True - _ -> False - in - if accept - then - let - (scanned1,rest2) = scanKey False indentation rest1 - - scanned2 = case scanned1 of - "" -> if allSpaces then "" else nextLine - _ -> nextLine ++ "\n" ++ scanned1 - in - (scanned2,rest2) - else - ([],str) - - extractLeadingSpaces :: String -> (String,String) - extractLeadingSpaces [] = ([],[]) - extractLeadingSpaces (s@(c:cs)) - | isSpace c = - let - (spaces1,cs1) = extractLeadingSpaces cs - in - (c:spaces1,cs1) - | True = ([],s) - - extractNextLine :: String -> (String,String) - extractNextLine [] = ([],[]) - extractNextLine (c:cs) - | c == '\n' = - ([],cs) - | True = - let - (line,rest) = extractNextLine cs - in - (c:line,rest) - - - -- indentation returns characters after last newline. - indentation :: String -> String - indentation s = fromMaybe s (indentation0 s) - where - indentation0 :: String -> Maybe String - indentation0 [] = Nothing - indentation0 (c:cs) = - case indentation0 cs of - Nothing -> if c == '\n' then Just cs else Nothing - in0 -> in0 - - -- comparison is case-insensitive. - extractPrefix :: String -> String -> Maybe String - extractPrefix [] s = Just s - extractPrefix s [] = Nothing - extractPrefix (c1:cs1) (c2:cs2) - | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | True = Nothing - --- ----------------------------------------------------------------------------- -- Filename mangling functions stolen from GHC's main/DriverUtil.lhs. type Suffix = String diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs deleted file mode 100644 index 29999588..00000000 --- a/src/HsParseUtils.lhs +++ /dev/null @@ -1,326 +0,0 @@ ------------------------------------------------------------------------------ --- $Id: HsParseUtils.lhs,v 1.6 2003/10/20 17:19:23 sof Exp $ --- --- (c) The GHC Team 1997-2000 --- --- Utilities for the Haskell parser. --- ------------------------------------------------------------------------------ - -ToDo: Polish readInteger, readRational - -\begin{code} -module HsParseUtils ( - parseError -- String -> Pa - , splitTyConApp -- HsType -> P (HsName,[HsType]) - , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp - , checkPrec -- String -> P String - , checkContext -- HsType -> P HsIPContext - , checkIPContext -- HsIPContext -> P HsContext - , checkAssertion -- HsType -> P HsAsst - , checkInstHeader -- HsType -> P (HsContext, HsAsst) - , checkClassHeader -- HsType -> P (HsContext, HsName, [HsType]) - , checkDataHeader -- HsType -> P (HsContext,HsName,[HsName]) - , checkPattern -- HsExp -> P HsPat - , checkPatterns -- [HsExp] -> P [HsPat] - , checkExpr -- HsExp -> P HsExp - , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl - , checkUnQual -- HsQName -> P HsName - , readInteger -- String -> Integer - , readRational -- String -> Rational - - , toVarHsName -- HsName -> HsName - , toTyClsHsName -- HsName -> HsName - ) where - -import HsSyn2 -import HsParseMonad - -import Char(isDigit,isOctDigit,isHexDigit,digitToInt) -import List(partition) -import Ratio -\end{code} - -\begin{code} -parseError :: String -> P a -parseError s = \r (SrcLoc y x f) -> - failP (show f ++ ": " ++ show y ++ ":" ++ show x ++ ": " ++ s) r (SrcLoc y x f) - -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 = returnP (t,ts) - -- to cope with data [] = [] | a:[a] - split (HsTyCon (Qual _ t)) ts = returnP (t,ts) - split _ _ = parseError "Illegal data/newtype declaration" - ------------------------------------------------------------------------------ --- Various Syntactic Checks - -checkContext :: HsType -> P HsIPContext -checkContext (HsTyTuple True ts) = mapP checkCtxt ts - where - checkCtxt (HsTyIP n ty) = returnP (HsIP n ty) - checkCtxt t0 = - checkAssertion t0 `thenP` \ c -> - returnP (HsAssump c) -checkContext (HsTyIP n t) = returnP [HsIP n t] -checkContext t = - checkAssertion t `thenP` \c -> - returnP [HsAssump c] - -checkIPContext :: HsIPContext -> P HsContext -checkIPContext ls = - case partition isIP ls of - ([],cs) -> returnP (map (\ (HsAssump c) -> c) cs) - (_,_) -> parseError "Unexpected implicit parameter in context" - where - isIP HsIP{} = True - isIP _ = False - --- Changed for multi-parameter type classes - -checkAssertion :: HsType -> P HsAsst -checkAssertion = checkAssertion' [] - where checkAssertion' ts (HsTyCon c) = returnP (c,ts) - checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a - checkAssertion' _ _ = parseError "Illegal class assertion" - -checkInstHeader :: HsType -> P (HsContext, HsAsst) -checkInstHeader (HsForAllType Nothing ctxt ty) = - checkAssertion ty `thenP` \asst -> - checkIPContext ctxt `thenP` \ctxt' -> - returnP (ctxt', asst) -checkInstHeader ty = - checkAssertion ty `thenP` \asst -> - returnP ([], asst) - -checkDataHeader :: HsType -> P (HsContext,HsName,[HsName]) -checkDataHeader (HsForAllType Nothing cs t) = - checkSimple "data/newtype" t [] `thenP` \(c,ts) -> - checkIPContext cs `thenP` \cs' -> - returnP (cs',c,ts) -checkDataHeader ty = - checkSimple "data/newtype" ty [] `thenP` \(c,ts) -> - returnP ([],c,ts) - -checkClassHeader :: HsType -> P (HsContext,HsName,[HsName]) -checkClassHeader (HsForAllType Nothing cs t) = - checkSimple "class" t [] `thenP` \(c,ts) -> - checkIPContext cs `thenP` \cs' -> - returnP (cs',c,ts) -checkClassHeader ty = - checkSimple "class" ty [] `thenP` \(c,ts) -> - returnP ([],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 = returnP (t,xs) -checkSimple _ (HsTyCon (Qual m t)) xs - | m == prelude_mod = returnP (t,xs) -- for "special" declarations -checkSimple kw _ _ = failP ("Illegal " ++ kw ++ " 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 [] - -checkPatterns :: [HsExp] -> P [HsPat] -checkPatterns es = mapP checkPattern es - -checkPat :: HsExp -> [HsPat] -> P HsPat -checkPat (HsCon c) args = returnP (HsPApp c args) -checkPat (HsApp f x0) args = checkPat x0 [] `thenP` \x -> checkPat f (x:args) -checkPat e0 [] = case e0 of - HsVar (UnQual x) -> returnP (HsPVar x) - HsLit l -> returnP (HsPLit l) - HsInfixApp l0 op r0 -> checkPat l0 [] `thenP` \l -> - checkPat r0 [] `thenP` \r -> - case op of - HsCon c -> returnP (HsPInfixApp l c r) - _ -> patFail - HsTuple b es -> mapP (\e -> checkPat e []) es `thenP` \ps -> - returnP (HsPTuple b ps) - HsList es -> mapP (\e -> checkPat e []) es `thenP` \ps -> - returnP (HsPList ps) - HsParen e -> checkPat e [] `thenP` (returnP . HsPParen) - HsAsPat n e -> checkPat e [] `thenP` (returnP . HsPAsPat n) - HsWildCard -> returnP HsPWildCard - HsIrrPat e -> checkPat e [] `thenP` (returnP . HsPIrrPat) - HsRecConstr c fs0 -> mapP checkPatField fs0 `thenP` \fs -> - returnP (HsPRec c fs) - HsNegApp (HsLit l) -> returnP (HsPNeg (HsPLit l)) - HsExpTypeSig _ e1 ty -> checkPat e1 [] `thenP` \e -> - returnP (HsPTypeSig e ty) - _ -> patFail - -checkPat _ _ = patFail - -checkPatField :: HsFieldUpdate -> P HsPatField -checkPatField (HsFieldUpdate n e) = - checkPat e [] `thenP` \p ->returnP (HsPFieldPat n p) - -patFail :: P a -patFail = parseError "Parse error in pattern" - ------------------------------------------------------------------------------ --- Check Expression Syntax - -checkExpr :: HsExp -> P HsExp -checkExpr e0 = case e0 of - HsVar _ -> returnP e0 - HsIPVar _ -> returnP e0 - HsCon _ -> returnP e0 - HsLit _ -> returnP e0 - HsInfixApp e1 e2 e3 -> check3Exprs e1 e2 e3 HsInfixApp - HsApp e1 e2 -> check2Exprs e1 e2 HsApp - HsNegApp e -> check1Expr e HsNegApp - HsLambda ps e -> check1Expr e (HsLambda ps) - HsLet bs e -> check1Expr e (HsLet bs) - HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf - HsCase e1 alts0 -> mapP checkAlt alts0 `thenP` \alts -> - checkExpr e1 `thenP` \e -> - returnP (HsCase e alts) - HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo) - HsTuple b es -> checkManyExprs es (HsTuple b) - HsList es -> checkManyExprs es HsList - HsParen e -> check1Expr e HsParen - HsLeftSection e1 e2 -> check2Exprs e1 e2 HsLeftSection - HsRightSection e1 e2 -> check2Exprs e1 e2 HsRightSection - HsRecConstr c fields0 -> mapP checkField fields0 `thenP` \fields -> - returnP (HsRecConstr c fields) - HsRecUpdate e1 fields0 -> mapP checkField fields0 `thenP` \fields -> - checkExpr e1 `thenP` \e -> - returnP (HsRecUpdate e fields) - HsEnumFrom e -> check1Expr e HsEnumFrom - HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo - HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen - HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo - HsListComp e1 stmts0 -> mapP checkStmt stmts0 `thenP` \stmts -> - checkExpr e1 `thenP` \e -> - returnP (HsListComp e stmts) - HsExpTypeSig loc e1 ty -> checkExpr e1 `thenP` \e -> - returnP (HsExpTypeSig loc e ty) - _ -> parseError "parse error in expression" - --- type signature for polymorphic recursion!! -check1Expr :: HsExp -> (HsExp -> a) -> P a -check1Expr e f = checkExpr e `thenP` (returnP . f) - -check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a -check2Exprs e1 e2 f = - checkExpr e1 `thenP` \e1' -> - checkExpr e2 `thenP` \e2' -> - returnP (f e1' e2') - -check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a -check3Exprs e1 e2 e3 f = - checkExpr e1 `thenP` \e1' -> - checkExpr e2 `thenP` \e2' -> - checkExpr e3 `thenP` \e3' -> - returnP (f e1' e2' e3') - -checkManyExprs :: [HsExp] -> ([HsExp] -> HsExp) -> P HsExp -checkManyExprs es0 f = - mapP checkExpr es0 `thenP` \es -> - returnP (f es) - -checkAlt :: HsAlt -> P HsAlt -checkAlt (HsAlt loc p galts0 bs) - = checkGAlts galts0 `thenP` \galts -> returnP (HsAlt loc p galts bs) - -checkGAlts :: HsGuardedAlts -> P HsGuardedAlts -checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt -checkGAlts (HsGuardedAlts galts) - = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts) - -checkGAlt :: HsGuardedAlt -> P HsGuardedAlt -checkGAlt (HsGuardedAlt loc stmts0 e0) = - mapP checkStmt stmts0 `thenP` \stmts -> - checkExpr e0 `thenP` \e -> - returnP (HsGuardedAlt loc stmts e) - -checkStmt :: HsStmt -> P HsStmt -checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p) -checkStmt (HsParStmt ss) = mapP checkStmt ss `thenP` \ ss1 -> returnP (HsParStmt ss1) -checkStmt (HsQualifier e) = check1Expr e HsQualifier -checkStmt s@(HsLetStmt _) = returnP 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, lhs0, rhs, whereBinds) = - case isFunLhs lhs0 [] of - Just (f,es) -> checkPatterns es `thenP` \ps -> - returnP (HsFunBind [HsMatch srcloc f ps rhs whereBinds]) - Nothing -> checkPattern lhs0 `thenP` \lhs -> - returnP (HsPatBind srcloc lhs rhs whereBinds) - --- A variable binding is parsed as an HsPatBind. - -isFunLhs :: HsExp -> [HsExp] -> Maybe (HsQName, [HsExp]) -isFunLhs (HsInfixApp l (HsVar op) r) es = Just (op, l:r:es) -isFunLhs (HsApp (HsVar 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 - ------------------------------------------------------------------------------ --- 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 _ _) = parseError "Illegal qualified name" -checkUnQual (UnQual n) = returnP n - ------------------------------------------------------------------------------ --- Miscellaneous utilities - -toVarHsName :: HsName -> HsName -toVarHsName (HsTyClsName n) = HsVarName n -toVarHsName n = n - -toTyClsHsName :: HsName -> HsName -toTyClsHsName (HsVarName n) = HsTyClsName n -toTyClsHsName n = n - -checkPrec :: Integer -> P () -checkPrec i | i >= 0 && i <= 9 = returnP () -checkPrec i = parseError ("Illegal precedence: " ++ show i) - --- Stolen from Hugs' Prelude - -readInteger :: String -> Integer -readInteger ('0':'o':ds) = readInteger2 8 isOctDigit ds -readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds -readInteger ds = readInteger2 10 isDigit ds - -readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer -readInteger2 radix isDig ds - | and $ map isDig ds - = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) ds) - | otherwise = error $ "readInteger2:expected all digits, got " ++ show ds - --- Hack... - -readRational :: String -> Rational -readRational xs = (readInteger (i++m))%1 * 10^^(case e of {[] -> 0; ('+':e2) -> read e2; _ -> read e} - length m) - where (i,r1) = span isDigit xs - (m,r2) = span isDigit (dropWhile (=='.') r1) - e = dropWhile (=='e') r2 - -mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp -mkRecConstrOrUpdate (HsCon c) fs = returnP (HsRecConstr c fs) -mkRecConstrOrUpdate exp0 fs@(_:_) = returnP (HsRecUpdate exp0 fs) -mkRecConstrOrUpdate _ _ = parseError "Empty record update" -\end{code} diff --git a/src/HsParser.ly b/src/HsParser.ly deleted file mode 100644 index c3edd3ce..00000000 --- a/src/HsParser.ly +++ /dev/null @@ -1,1024 +0,0 @@ ------------------------------------------------------------------------------ -$Id: HsParser.ly,v 1.21 2004/08/09 11:55:07 simonmar Exp $ - -(c) Simon Marlow, Sven Panne 1997-2002 - -Haskell grammar. ------------------------------------------------------------------------------ - -ToDo: Is (,) valid as exports? We don't allow it. -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. - -> { -> module HsParser (parse) where -> -> import Monad -> import HsSyn2 -> import HsParseMonad -> import HsLexer -> import HsParseUtils -> import HaddockLex2 hiding (Token) -> import HaddockParse2 -> import HaddockUtil hiding (splitTyConApp) -> import Char ( isSpace ) -> } - ------------------------------------------------------------------------------ -Conflicts: 3 shift/reduce - -2 for ambiguity in 'case x of y | let z = y in z :: a -> b' - (don't know whether to reduce 'True' as a btype or shift the '->'. - Similarly lambda and if. This is a rather arcane special case: - the default resolution in favour of the shift does what the Report - specifies, but the result will always fail to type-check.) - -1 for ambiguity in 'x @ Rec{..}'. - Only sensible parse is 'x @ (Rec{..})', which is what resolving - to shift gives us. - ------------------------------------------------------------------------------ - -> %token -> VARID { VarId $$ } -> IPVARID { IPVarId $$ } -> QVARID { QVarId $$ } -> CONID { ConId $$ } -> QCONID { QConId $$ } -> VARSYM { VarSym $$ } -> CONSYM { ConSym $$ } -> QVARSYM { QVarSym $$ } -> QCONSYM { QConSym $$ } -> INT { IntTok $$ } -> RATIONAL { FloatTok $$ } -> CHAR { Character $$ } -> STRING { StringTok $$ } - -> PRIMINT { PrimInt $$ } -> PRIMSTRING { PrimString $$ } -> PRIMFLOAT { PrimFloat $$ } -> PRIMDOUBLE { PrimDouble $$ } -> PRIMCHAR { PrimChar $$ } - -Docs - -> DOCNEXT { DocCommentNext $$ } -> DOCPREV { DocCommentPrev $$ } -> DOCNAMED { DocCommentNamed $$ } -> DOCSECTION { DocSection _ _ } -> DOCOPTIONS { DocOptions $$ } - -Symbols - -> '(' { LeftParen } -> ')' { RightParen } -> '(#' { LeftUT } -> '#)' { RightUT } -> ';' { SemiColon } -> '{' { LeftCurly } -> '}' { RightCurly } -> vccurly { VRightCurly } -- a virtual close brace -> '[' { LeftSquare } -> ']' { RightSquare } -> ',' { Comma } -> '_' { Underscore } -> '`' { BackQuote } - -Reserved operators - -> '.' { Dot } -> '..' { DotDot } -> '::' { DoubleColon } -> '=' { Equals } -> '\\' { Backslash } -> '|' { Bar } -> '<-' { LeftArrow } -> '->' { RightArrow } -> '@' { At } -> '~' { Tilde } -> '=>' { DoubleArrow } -> '-' { Minus } -> '!' { Exclamation } - -Reserved Ids - -> 'as' { KW_As } -> 'case' { KW_Case } -> 'ccall' { KW_CCall } -> 'class' { KW_Class } -> 'data' { KW_Data } -> 'default' { KW_Default } -> 'deriving' { KW_Deriving } -> 'do' { KW_Do } -> 'dotnet' { KW_DotNet } -> 'else' { KW_Else } -> 'export' { KW_Export } -> 'forall' { KW_Forall } -> 'foreign' { KW_Foreign } -> 'hiding' { KW_Hiding } -> 'if' { KW_If } -> 'import' { KW_Import } -> 'in' { KW_In } -> 'infix' { KW_Infix } -> 'infixl' { KW_InfixL } -> 'infixr' { KW_InfixR } -> 'instance' { KW_Instance } -> 'let' { KW_Let } -> 'module' { KW_Module } -> 'newtype' { KW_NewType } -> 'of' { KW_Of } -> 'safe' { KW_Safe } -> 'stdcall' { KW_StdCall } -> 'then' { KW_Then } -> 'threadsafe' { KW_ThreadSafe } -> 'type' { KW_Type } -> 'unsafe' { KW_Unsafe } -> 'where' { KW_Where } -> 'qualified' { KW_Qualified } - -> %monad { P } { thenP } { returnP } -> %lexer { lexer } { EOF } -> %name parse -> %tokentype { Token } -> %% - ------------------------------------------------------------------------------ -Module Header - -> module :: { HsModule } -> : optdoc 'module' srcloc modid maybeexports 'where' body -> { case $1 of { (opts,info,doc) -> -> HsModule $3 $4 $5 (reverse (fst $7)) (snd $7) -> opts info doc } } -> | body srcloc -> { HsModule $2 main_mod Nothing (reverse (fst $1)) (snd $1) -> Nothing emptyModuleInfo Nothing } - -> optdoc :: { (Maybe String,ModuleInfo,Maybe Doc) } -> : moduleheader { (Nothing, fst $1, snd $1) } -> | DOCOPTIONS { (Just $1, emptyModuleInfo,Nothing) } -> | DOCOPTIONS moduleheader { (Just $1, fst $2, snd $2) } -> | moduleheader DOCOPTIONS { (Just $2, fst $1, snd $1) } -> | {- empty -} { (Nothing, emptyModuleInfo,Nothing) } - -> body :: { ([HsImportDecl],[HsDecl]) } -> : '{' bodyaux '}' { $2 } -> | layout_on bodyaux close { $2 } - -> bodyaux :: { ([HsImportDecl],[HsDecl]) } -> : impdecls ';' topdecls { ($1, $3) } -> | topdecls { ([], $1) } -> | impdecls { ($1, []) } - -> optsemi :: { () } -> : ';' { () } -> | {- empty -} { () } - ------------------------------------------------------------------------------ -The Export List - -> maybeexports :: { Maybe [HsExportSpec] } -> : exports { Just $1 } -> | {- empty -} { Nothing } - -> exports :: { [HsExportSpec] } -> : '(' exportlist ')' { $2 } - -> exportlist :: { [HsExportSpec] } -> : export exportlist1 { $1 : $2 } -> | exp_doc exportlist { $1 : $2 } -> | {- empty -} { [] } - -> exportlist1 :: { [HsExportSpec] } -> : exp_doc exportlist1 { $1 : $2 } -> | ',' exportlist { $2 } -> | {- empty -} { [] } - -> exp_doc :: { HsExportSpec } -> : docsection { case $1 of { (i,s) -> HsEGroup i s } } -> | docnamed { HsEDocNamed (fst $1) } -> | docnext { HsEDoc $1 } - -> export :: { HsExportSpec } -> : qvar { HsEVar $1 } -> | qgtycon { HsEAbs $1 } -> | qgtycon '(' '..' ')' { HsEThingAll $1 } -> | qgtycon '(' ')' { HsEThingWith $1 [] } -> | qgtycon '(' qcnames ')' { HsEThingWith $1 (reverse $3) } -> | 'module' modid { HsEModuleContents $2 } - -> qcnames :: { [HsQName] } -> : qcnames ',' qcname { $3 : $1 } -> | qcname { [$1] } - -> qcname :: { HsQName } -> : qvar { $1 } -> | gcon { $1 } - ------------------------------------------------------------------------------ -Import Declarations - -> impdecls :: { [HsImportDecl] } -> : impdecls ';' impdecl { $3 : $1 } -> | impdecl { [$1] } - -> impdecl :: { HsImportDecl } -> : 'import' srcloc optqualified modid maybeas maybeimpspec -> { HsImportDecl $2 $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]) } -> : '(' importlist ')' { (False, reverse $2) } -> | 'hiding' '(' importlist ')' { (True, reverse $3) } - -> importlist :: { [HsImportSpec] } -> : importlist ',' import { $3 : $1 } -> | importlist ',' { $1 } -> | import { [$1] } -> | {- empty -} { [] } - -> import :: { HsImportSpec } -> : var { HsIVar $1 } -> | gtycon { HsIAbs $1 } -> | gtycon '(' '..' ')' { HsIThingAll $1 } -> | gtycon '(' ')' { HsIThingWith $1 [] } -> | gtycon '(' cnames ')' { HsIThingWith $1 (reverse $3) } - -> gtycon :: { HsName } -> : tyconorcls { $1 } -> | '(' ')' { unit_tycon_name } -> | '(' '->' ')' { fun_tycon_name } -> | '[' ']' { list_tycon_name } -> | '(' commas ')' { tuple_tycon_name $2 } - -> cnames :: { [HsName] } -> : cnames ',' cname { $3 : $1 } -> | cname { [$1] } - -> cname :: { HsName } -> : var { $1 } -> | con { $1 } - ------------------------------------------------------------------------------ -Fixity Declarations - -> fixdecl :: { HsDecl } -> : srcloc infix prec ops { HsInfixDecl $1 $2 $3 (reverse $4) } - -> prec :: { Int } -> : {- empty -} { 9 } -> | INT {% checkPrec $1 `thenP` \p -> -> returnP (fromIntegral $1) } - -> infix :: { HsAssoc } -> : 'infix' { HsAssocNone } -> | 'infixl' { HsAssocLeft } -> | 'infixr' { HsAssocRight } - -> ops :: { [HsName] } -> : ops ',' op { $3 : $1 } -> | op { [$1] } - ------------------------------------------------------------------------------ -Top-Level Declarations - -> topdecls :: { [HsDecl] } -> : topdecl ';' topdecls { $1 : $3 } -> | ';' topdecls { $2 } -> | docdecl topdecls { $1 : $2 } -> | topdecl { [$1] } -> | {- empty -} { [] } - -> topdecl :: { HsDecl } -> : 'type' simpletype srcloc '=' ctypedoc -> { HsTypeDecl $3 (fst $2) (snd $2) $5 Nothing } -> | 'data' ctype srcloc constrs deriving -> {% checkDataHeader $2 `thenP` \(cs,c,t) -> -> returnP (HsDataDecl $3 cs c t $4 $5 Nothing) } -> | 'newtype' ctype srcloc '=' constr deriving -> {% checkDataHeader $2 `thenP` \(cs,c,t) -> -> returnP (HsNewTypeDecl $3 cs c t $5 $6 Nothing) } -> | 'class' srcloc ctype fds optcbody -> {% checkClassHeader $3 `thenP` \(ctxt,n,tys) -> -> returnP (HsClassDecl $2 ctxt n tys $4 $5 Nothing) } -> | 'instance' srcloc ctype optvaldefs -> {% checkInstHeader $3 `thenP` \(ctxt,asst) -> -> returnP (HsInstDecl $2 ctxt asst $4) } -> | 'default' srcloc '(' typelist ')' -> { HsDefaultDecl $2 $4 } -> | 'foreign' fdecl { $2 } -> | decl { $1 } - -> typelist :: { [HsType] } -> : types { $1 } -> | type { [$1] } -> | {- empty -} { [] } - -> decls :: { [HsDecl] } -> : decl ';' decls { $1 : $3 } -> | docdecl decls { $1 : $2 } -> | ';' decls { $2 } -> | decl { [$1] } -> | {- empty -} { [] } - -> decl :: { HsDecl } -> : signdecl { $1 } -> | fixdecl { $1 } -> | valdef { $1 } - -> docdecl :: { HsDecl } -> : srcloc docnext { HsDocCommentNext $1 $2 } -> | srcloc docprev { HsDocCommentPrev $1 $2 } -> | srcloc docnamed { case $2 of { (n,s) -> -> HsDocCommentNamed $1 n s } } -> | srcloc docsection { case $2 of { (i,s) -> HsDocGroup $1 i s } } - -> decllist :: { [HsDecl] } -> : '{' decls '}' { $2 } -> | layout_on decls close { $2 } - -> signdecl :: { HsDecl } -> : vars srcloc '::' ctypedoc { HsTypeSig $2 (reverse $1) $4 Nothing } - -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 {% checkUnQual $1 `thenP` \n -> -> returnP [n] } - ------------------------------------------------------------------------------ -Foreign Declarations - -> fdecl :: { HsDecl } -> fdecl : srcloc 'import' callconv safety fspec -> { case $5 of (spec,nm,ty) -> HsForeignImport $1 $3 $4 spec nm ty Nothing } -> | srcloc 'import' callconv fspec -> { case $4 of (spec,nm,ty) -> HsForeignImport $1 $3 HsFISafe spec nm ty Nothing } -> | srcloc 'export' callconv fspec -> { case $4 of (spec,nm,ty) -> HsForeignExport $1 $3 spec nm ty } - -> callconv :: { HsCallConv } -> : 'stdcall' { HsStdCall } -> | 'ccall' { HsCCall } -> | 'dotnet' { HsDotNetCall } - -> safety :: { HsFISafety } -> : 'unsafe' { HsFIUnsafe } -> | 'safe' { HsFISafe } -> | 'threadsafe' { HsFIThreadSafe } - -> fspec :: { (String, HsName, HsType) } -> : STRING varid '::' ctypedoc { ($1, $2, $4) } -> | varid '::' ctypedoc { ("", $1, $3) } - ------------------------------------------------------------------------------ -Types - -> doctype :: { HsType } -> : tydoc '->' doctype { HsTyFun $1 $3 } -> | tydoc { $1 } - -> tydoc :: { HsType } -> : btype { $1 } -> | btype docprev { HsTyDoc $1 $2 } - -> type :: { HsType } -> : ipvar '::' type1 { HsTyIP $1 $3 } -> | type1 { $1 } - -> type1 :: { HsType } -> : btype { $1 } -> | btype '->' type1 { HsTyFun $1 $3 } - -> btype :: { HsType } -> : btype atype { HsTyApp $1 $2 } -> | atype { $1 } - -> atype :: { HsType } -> : qgtycon { HsTyCon $1 } -> | tyvar { HsTyVar $1 } -> | '(' types ')' { HsTyTuple True $2 } -> | '(#' type '#)' { HsTyTuple False [$2] } -> | '(#' types '#)' { HsTyTuple False $2 } -> | '[' type ']' { HsTyApp list_tycon $2 } -> | '(' ctype ')' { $2 } - -> qgtycon :: { HsQName } -> : qtycls { $1 } -> | '(' ')' { unit_tycon_qname } -> | '(' '->' ')' { fun_tycon_qname } -> | '[' ']' { list_tycon_qname } -> | '(' commas ')' { tuple_tycon_qname $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 :: { HsType } -> : 'forall' tyvars '.' ctype { mkHsForAllType (Just $2) [] $4 } -> | context '=>' type { mkHsForAllType Nothing $1 $3 } -> | type { $1 } - -> ctypedoc :: { HsType } -> : 'forall' tyvars '.' ctypedoc { mkHsForAllType (Just $2) [] $4 } -> | context '=>' doctype { mkHsForAllType Nothing $1 $3 } -> | doctype { $1 } - -> context :: { HsIPContext } -> : btype {% checkContext $1 } - -> types :: { [HsType] } -> : type ',' types { $1 : $3 } -> | type ',' type { [$1,$3] } - -> simpletype :: { (HsName, [HsName]) } -> : tycon tyvars { ($1,$2) } - -> tyvars :: { [HsName] } -> : tyvar tyvars { $1 : $2 } -> | {- empty -} { [] } - ------------------------------------------------------------------------------ -Datatype declarations - -> constrs :: { [HsConDecl] } -> : {- empty; a GHC extension -} { [] } -> | maybe_docnext '=' constrs1 { addConDocs $3 $1 } - -> constrs1 :: { [HsConDecl] } -> : constr maybe_docnext '|' maybe_docprev constrs1 -> { addConDoc $1 $4 : addConDocs $5 $2 } -> | constr { [$1] } - -> constr :: { HsConDecl } -> : srcloc maybe_docnext forall_stuff constr_stuff maybe_docprev -> { HsConDecl $1 (fst $4) $3 [] (snd $4) ($2 `mplus` $5) } -> | srcloc maybe_docnext forall_stuff context '=>' constr_stuff maybe_docprev -> {% checkIPContext $4 `thenP` \ ctxt -> returnP (HsConDecl $1 (fst $6) $3 ctxt (snd $6) ($2 `mplus` $7)) } -> | srcloc maybe_docnext forall_stuff con '{' fielddecls '}' maybe_docprev -> { HsRecDecl $1 $4 $3 [] $6 ($2 `mplus` $8) } -> | srcloc maybe_docnext forall_stuff context '=>' con '{' fielddecls '}' maybe_docprev -> {% checkIPContext $4 `thenP` \ ctxt -> returnP (HsRecDecl $1 $6 $3 ctxt $8 ($2 `mplus` $10)) } - -> forall_stuff :: { [HsName] } -> : 'forall' tyvars '.' { $2 } -> | {- empty -} { [] } - -> constr_stuff :: { (HsName, [HsBangType]) } -> : scontype { $1 } -> | sbtype conop sbtype { ($2, [$1,$3]) } - -> scontype :: { (HsName, [HsBangType]) } -> : btype {% splitTyConApp $1 `thenP` \(c,ts) -> -> returnP (toVarHsName c, -> map HsUnBangedTy ts) } -> | scontype1 { $1 } - -> scontype1 :: { (HsName, [HsBangType]) } -> : btype '!' atype {% splitTyConApp $1 `thenP` \(c,ts) -> -> returnP (toVarHsName 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 :: { [HsFieldDecl] } -> : fielddecl maybe_docnext ',' maybe_docprev fielddecls -> { addFieldDoc $1 $4 : addFieldDocs $5 $2 } -> | ',' fielddecls { $2 } -> | fielddecl { [$1] } -> | {- empty -} { [] } - -> fielddecl :: { HsFieldDecl } -> : maybe_docnext vars '::' stype maybe_docprev -> { HsFieldDecl (reverse $2) $4 ($1 `mplus` $5) } - -> stype :: { HsBangType } -> : ctype { 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 - -> fds :: { [HsFunDep] } -> : {- empty -} { [] } -> | '|' fds1 { reverse $2 } - -> fds1 :: { [HsFunDep] } -> : fds1 ',' fd { $3 : $1 } -> | fd { [$1] } - -> fd :: { HsFunDep } -> : varids0 '->' varids0 { (reverse $1, reverse $3) } - -> varids0 :: { [HsName] } -> : {- empty -} { [] } -> | varids0 tyvar { $2 : $1 } - -> optcbody :: { [HsDecl] } -> : 'where' decllist { $2 } -> | {- empty -} { [] } - -> dbinds :: { [HsDecl] } -> : dbinds ';' dbind { $3 : $1 } -> | dbinds ';' { $1 } -> | dbind { [$1] } -> -> dbind :: { HsDecl } -> dbind : ipvar '=' srcloc exp {% checkValDef ($3, HsVar (UnQual $1), HsUnGuardedRhs $4, []) } - -> binds :: { [HsDecl] } -> : decllist { $1 } -> | '{' dbinds '}' { $2 } -> | layout_on dbinds close { $2 } - - -> wherebinds :: { [HsDecl] } -> : 'where' binds { $2 } -> | {- empty -} { [] } - ------------------------------------------------------------------------------ -Instance declarations - -> optvaldefs :: { [HsDecl] } -> : 'where' '{' valdefs '}' { $3 } -> | 'where' layout_on valdefs close { $3 } -> | {- empty -} { [] } - -> valdefs :: { [HsDecl] } -> : valdefs ';' valdef { $3 : $1 } -> | valdefs ';' { $1 } -> | valdef { [$1] } -> | {- empty -} { [] } - ------------------------------------------------------------------------------ -Value definitions - -> valdef :: { HsDecl } -> : exp0b srcloc rhs -> {% checkValDef ($2, $1, $3, [])} - -> rhs :: { HsRhs } -> : '=' exp wherebinds {% checkExpr $2 `thenP` \e -> -> returnP (HsUnGuardedRhs e) } -> | gdrhs wherebinds { HsGuardedRhss (reverse $1) } - -> gdrhs :: { [HsGuardedRhs] } -> : gdrhs gdrh { $2 : $1 } -> | gdrh { [$1] } - -> gdrh :: { HsGuardedRhs } -> : '|' srcloc quals '=' exp {% checkExpr $5 `thenP` \e -> -> returnP (HsGuardedRhs $2 $3 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 } -> : '\\' aexps '->' exp {% checkPatterns (reverse $2) `thenP` \ps -> -> returnP (HsLambda ps $4) } -> | 'let' binds '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 } - -> aexps :: { [HsExp] } -> : aexps aexp { $2 : $1 } -> | aexp { [$1] } - -UGLY: Because patterns and expressions are mixed, aexp has to be split into -two rules: One left-recursive and one right-recursive. Otherwise we get two -reduce/reduce-errors (for as-patterns and irrefutable patters). - -Note: The first alternative of aexp is not neccessarily a record update, it -could be a labeled construction, too. - -> aexp :: { HsExp } -> : aexp '{' '}' {% mkRecConstrOrUpdate $1 [] } -> | aexp '{' fbinds '}' {% mkRecConstrOrUpdate $1 (reverse $3) } -> | aexp1 { $1 } - -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). - -Bug: according to the Report, left sections should be (exp0 qop), but -that would cause a shift/reduce conflict in which shifting would be no -different from specifying (exp0b qop). The only consolation is that -other implementations don't manage this either. - -> aexp1 :: { HsExp } -> : ipvar { HsIPVar (UnQual $1) } -> | qvar { HsVar $1 } -> | gcon { HsCon $1 } -> | literal { $1 } -> | '(' exp ')' { HsParen $2 } -> | '(' texps ')' { HsTuple True $2 } -> | '(#' exp '#)' { HsTuple False [$2] } -> | '(#' texps '#)' { HsTuple False $2 } -> | '[' list ']' { $2 } -> | '(' exp0b qop ')' { HsLeftSection $3 $2 } -> | '(' qopm exp0 ')' { HsRightSection $3 $2 } -> | qvar '@' aexp {% checkUnQual $1 `thenP` \n -> -> returnP (HsAsPat n $3) } -> | '_' { HsWildCard } -> | '~' aexp1 { HsIrrPat $2 } - -> commas :: { Int } -> : commas ',' { $1 + 1 } -> | ',' { 1 } - -> texps :: { [HsExp] } -> : exp ',' texps { $1 : $3 } -> | exp ',' exp { [$1,$3] } - ------------------------------------------------------------------------------ -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 pquals { HsListComp $1 (reverse $2) } - -> lexps :: { [HsExp] } -> : lexps ',' exp { $3 : $1 } -> | exp ',' exp { [$3,$1] } - ------------------------------------------------------------------------------ -List comprehensions - -> pquals :: { [HsStmt] } -> : pquals1 { case $1 of -> [qs] -> qs -> qss -> [HsParStmt (concat qss)] -> } - -> pquals1 :: { [[HsStmt]] } -> : pquals1 '|' quals { $3 : $1 } -> | '|' quals { [$2] } - -> quals :: { [HsStmt] } -> : quals ',' qual { $3 : $1 } -> | qual { [$1] } - -> qual :: { HsStmt } -> : pat '<-' exp { HsGenerator $1 $3 } -> | exp { HsQualifier $1 } -> | 'let' binds { HsLetStmt $2 } - ------------------------------------------------------------------------------ -Case alternatives - -> altslist :: { [HsAlt] } -> : '{' alts optsemi '}' { reverse $2 } -> | layout_on alts optsemi close { reverse $2 } - - -> alts :: { [HsAlt] } -> : alts ';' alt { $3 : $1 } -> | alt { [$1] } - -> alt :: { HsAlt } -> : pat srcloc ralt wherebinds -> { HsAlt $2 $1 $3 $4 } - -> ralt :: { HsGuardedAlts } -> : '->' exp { HsUnGuardedAlt $2 } -> | gdpats { HsGuardedAlts (reverse $1) } - -> gdpats :: { [HsGuardedAlt] } -> : gdpats gdpat { $2 : $1 } -> | gdpat { [$1] } - -> gdpat :: { HsGuardedAlt } -> : '|' srcloc quals '->' exp { HsGuardedAlt $2 $3 $5 } - -> pat :: { HsPat } -> : exp0b {% checkPattern $1 } - ------------------------------------------------------------------------------ -Statement sequences - -> stmtlist :: { [HsStmt] } -> : '{' stmts '}' { $2 } -> | layout_on stmts close { $2 } - -The last Stmt should be a HsQualifier, but that's hard to enforce here, -because we need too much lookahead if we see do { e ; }, so it has to -be checked for later. - -> stmts :: { [HsStmt] } -> : qual stmts1 { $1 : $2 } -> | ';' stmts { $2 } -> | {- empty -} { [] } - -> stmts1 :: { [HsStmt] } -> : ';' stmts { $2 } -> | {- empty -} { [] } - ------------------------------------------------------------------------------ -Record Field Update/Construction - -> fbinds :: { [HsFieldUpdate] } -> : fbinds ',' fbind { $3 : $1 } -> | fbind { [$1] } - -> fbind :: { HsFieldUpdate } -> : qvar '=' exp { HsFieldUpdate $1 $3 } - ------------------------------------------------------------------------------ -Variables, Constructors and Operators. - -> gcon :: { HsQName } -> : '(' ')' { unit_con_name } -> | '[' ']' { nil_con_name } -> | '(' commas ')' { tuple_con_name $2 } -> | qcon { $1 } - -> var :: { HsName } -> : varid { $1 } -> | '(' varsym ')' { $2 } - -> qvar :: { HsQName } -> : qvarid { $1 } -> | '(' qvarsym ')' { $2 } - -> con :: { HsName } -> : conid { $1 } -> | '(' consym ')' { $2 } - -> ipvar :: { HsName } -> : IPVARID { HsVarName (HsIdent $1) } - -> qcon :: { HsQName } -> : qconid { $1 } -> | '(' qconsym ')' { $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 } -> : qconsym { $1 } -> | '`' qconid '`' { $2 } - -> op :: { HsName } -> : varop { $1 } -> | conop { $1 } - -> qop :: { HsExp } -> : qvarop { HsVar $1 } -> | qconop { HsCon $1 } - -> qopm :: { HsExp } -> : qvaropm { HsVar $1 } -> | qconop { HsCon $1 } - -> qvarid :: { HsQName } -> : varid { UnQual $1 } -> | QVARID { Qual (Module (fst $1)) (HsVarName (HsIdent (snd $1))) } - -> varid :: { HsName } -> : 'forall' { forall_name } -> | varid_no_forall { $1 } - -> varid_no_forall :: { HsName } -> : VARID { HsVarName (HsIdent $1) } -> | 'as' { as_name } -> | 'unsafe' { unsafe_name } -> | 'safe' { safe_name } -> | 'threadsafe' { threadsafe_name } -> | 'qualified' { qualified_name } -> | 'hiding' { hiding_name } -> | 'export' { export_name } -> | 'stdcall' { stdcall_name } -> | 'ccall' { ccall_name } -> | 'dotnet' { dotnet_name } - -> qconid :: { HsQName } -> : conid { UnQual $1 } -> | QCONID { Qual (Module (fst $1)) (HsVarName (HsIdent (snd $1))) } - -> conid :: { HsName } -> : CONID { HsVarName (HsIdent $1) } - -> qconsym :: { HsQName } -> : consym { UnQual $1 } -> | QCONSYM { Qual (Module (fst $1)) (HsVarName (HsSymbol (snd $1))) } - -> consym :: { HsName } -> : CONSYM { HsVarName (HsSymbol $1) } - -> qvarsym :: { HsQName } -> : varsym { UnQual $1 } -> | qvarsym1 { $1 } - -> qvarsymm :: { HsQName } -> : varsymm { UnQual $1 } -> | qvarsym1 { $1 } - -> varsym :: { HsName } -> : VARSYM { HsVarName (HsSymbol $1) } -> | '.' { dot_name } -> | '-' { minus_name } -> | '!' { pling_name } - -> varsymm :: { HsName } -- varsym not including '-' -> : VARSYM { HsVarName (HsSymbol $1) } -> | '.' { dot_name } -> | '!' { pling_name } - -> qvarsym1 :: { HsQName } -> : QVARSYM { Qual (Module (fst $1)) (HsVarName (HsSymbol (snd $1))) } - -> literal :: { HsExp } -> : INT { HsLit (HsInt $1) } -> | CHAR { HsLit (HsChar $1) } -> | RATIONAL { HsLit (HsFrac (readRational $1)) } -> | STRING { HsLit (HsString $1) } -> | PRIMINT { HsLit (HsIntPrim $1) } -> | PRIMCHAR { HsLit (HsCharPrim $1) } -> | PRIMFLOAT { HsLit (HsFloatPrim (readRational $1)) } -> | PRIMDOUBLE { HsLit (HsDoublePrim (readRational $1)) } -> | PRIMSTRING { HsLit (HsStringPrim $1) } - -> srcloc :: { SrcLoc } : {% getSrcLoc } - ------------------------------------------------------------------------------ -Layout - -> close :: { () } -> : vccurly { () } -- context popped in lexer. -> | error {% popContext } - -> layout_on :: { () } : {% getSrcLoc `thenP` \(SrcLoc r c f) -> -> pushContext (Layout c) } - ------------------------------------------------------------------------------ -Miscellaneous (mostly renamings) - -> modid :: { Module } -> : CONID { Module $1 } -> | QCONID { Module (fst $1 ++ '.':snd $1) } - -> tyconorcls :: { HsName } -> : CONID { HsTyClsName (HsIdent $1) } - -> tycon :: { HsName } -> : CONID { HsTyClsName (HsIdent $1) } - -> qtycls :: { HsQName } -> : CONID { UnQual (HsTyClsName (HsIdent $1)) } -> | QCONID { Qual (Module (fst $1)) (HsTyClsName (HsIdent (snd $1))) } - -> tyvar :: { HsName } -> : varid_no_forall { $1 } - ------------------------------------------------------------------------------ -Documentation comments - -> docnext :: { Doc } -> : DOCNEXT {% case parseParas (tokenise $1) of { -> Left err -> parseError err; -> Right doc -> returnP doc } } - -> docprev :: { Doc } -> : DOCPREV {% case parseParas (tokenise $1) of { -> Left err -> parseError err; -> Right doc -> returnP doc } } - -> docnamed :: { (String,Doc) } -> : DOCNAMED {% let (name,rest) = break isSpace $1 in -> case parseParas (tokenise rest) of { -> Left err -> parseError err; -> Right doc -> returnP (name,doc) } } - -> docsection :: { (Int,Doc) } -> : DOCSECTION {% case $1 of { DocSection n s -> -> case parseString (tokenise s) of { -> Left err -> parseError err; -> Right doc -> returnP (n, doc) } } } - -> maybe_docprev :: { Maybe Doc } -> : docprev { Just $1 } -> | {- empty -} { Nothing } - -> maybe_docnext :: { Maybe Doc } -> : docnext { Just $1 } -> | {- empty -} { Nothing } - -> moduleheader :: { (ModuleInfo,Maybe Doc) } -> : DOCNEXT {% case parseModuleHeader $1 of { -> Right (str,info) -> -> case parseParas (tokenise str) of { -> Left err -> parseError err; -> Right doc -> returnP (info,Just doc); -> }; -> Left err -> parseError err -> } } - ------------------------------------------------------------------------------ - -> { -> happyError = parseError "Parse error" -> } diff --git a/src/Main.hs b/src/Main.hs index 8d0b6d1c..ad0c3313 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -18,7 +18,6 @@ import Set import Paths_haddock ( getDataDir ) import Binary2 import Digraph2 -import HsParser import HsParseMonad import Control.Exception ( bracket ) @@ -56,6 +55,7 @@ import SrcLoc import qualified Digraph as Digraph import Name import Module (moduleString)-- TODO: add an export to GHC API? +import qualified DynFlags as DynFlags ----------------------------------------------------------------------------- -- Top-level stuff @@ -275,7 +275,7 @@ run flags files = do when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format pkg_paths - GHC.init (Just "/home/davve/dev/lib/ghc-6.5.20060608") + GHC.init (Just "/home/davve/dev/local/lib/ghc-6.5") let ghcMode = GHC.JustTypecheck session <- GHC.newSession ghcMode ghcFlags <- GHC.getSessionDynFlags session @@ -284,9 +284,10 @@ run flags files = do let haddockGhcFlags = [ f | Flag_GHCFlag f <- flags ] (ghcFlags'', rest) <- GHC.parseDynamicFlags ghcFlags' haddockGhcFlags when (not (null rest)) (die $ "The following flags are not GHC flags: " ++ pprList rest ++ "\n") + let ghcFlags''' = DynFlags.dopt_set ghcFlags'' DynFlags.Opt_Haddock - sorted_checked_modules <- GHC.defaultErrorHandler ghcFlags'' $ do - GHC.setSessionDynFlags session ghcFlags'' + sorted_checked_modules <- GHC.defaultErrorHandler ghcFlags''' $ do + GHC.setSessionDynFlags session ghcFlags''' targets <- mapM (\s -> GHC.guessTarget s Nothing) files GHC.setTargets session targets @@ -295,7 +296,7 @@ run flags files = do Just module_graph -> return module_graph Nothing -> die "Failed to load modules\n" let sorted_modules = concatMap Digraph.flattenSCC (GHC.topSortModuleGraph False module_graph Nothing) - let modules = [ GHC.ms_mod modsum | modsum <- sorted_modules, GHC.ms_hspp_file modsum `elem` files ] + let modules = [ GHC.ms_mod modsum | modsum <- sorted_modules ] mb_checked_modules <- mapM (GHC.checkModule session) modules let checked_modules = catMaybes mb_checked_modules if length checked_modules /= length mb_checked_modules @@ -439,6 +440,8 @@ run flags files = do | otherwise = die "Missing checked module phase information\n" where modules' = [ (mod, (a,b,c,d)) | (mod, GHC.CheckedModule a (Just b) (Just c) (Just d)) <- modules ] +print_ x = printSDoc (ppr x) defaultUserStyle + instance Outputable ExportItem2 where ppr (ExportDecl2 n decl instns) = text "ExportDecl" <+> ppr n <+> ppr decl <+> text (show instns) ppr (ExportNoDecl2 n1 n2 ns) = text "ExportNoDecl (org name, link name, sub names)" <+> ppr n1 <+> ppr n2 <+> ppr ns @@ -481,6 +484,7 @@ pass1 modules flags = worker modules (Map.empty) flags (mb_doc_opts, haddock_mod_info, mb_mod_doc) = get_module_stuff parsed_source opts <- mk_doc_opts mb_doc_opts + tell [show mb_doc_opts] let exported_names = GHC.modInfoExports module_info (group, _, mb_exports) = renamed_source @@ -589,7 +593,7 @@ updateHTMLXRefs paths ifaces_s = | (fpath, ifaces) <- zip paths ifaces_s, iface <- ifaces ] - +{- parse_file :: FilePath -> IO HsModule parse_file file = do bracket @@ -600,7 +604,7 @@ parse_file file = do Ok _ e -> return e Failed err -> die (file ++ ':':err ++ "\n") ) - +-} {- getPrologue :: [Flag] -> IO (Maybe Doc) getPrologue flags |