aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordavve <davve@dtek.chalmers.se>2006-07-20 17:48:30 +0000
committerdavve <davve@dtek.chalmers.se>2006-07-20 17:48:30 +0000
commitde580ba29f412239c2f922e9bd67eea2ccdd8bc7 (patch)
tree9c2176220825037424f79b848e9ff65d7bcedd15 /src
parentbbf12d02cb9fc17624bab24ba9c3ab0bfb2804d5 (diff)
More progress -- still on phase1
Diffstat (limited to 'src')
-rw-r--r--src/HaddockTypes.hs2
-rw-r--r--src/HaddockUtil.hs151
-rw-r--r--src/HsParseUtils.lhs326
-rw-r--r--src/HsParser.ly1024
-rw-r--r--src/Main.hs18
5 files changed, 13 insertions, 1508 deletions
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