More progress -- still on phase1

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