[haddock @ 2002-04-26 11:18:56 by simonmar]

- support for fundeps (partially contributed by Brett Letner - thanks
  Brett).

- make it build with GHC 4.08.2

9 files changed, 72 insertions, 32 deletions

diff --git a/src/HaddockDB.hs b/src/HaddockDB.hs
index 446bce1d..80bc1b7c 100644
--- a/src/HaddockDB.hs
+++ b/src/HaddockDB.hs
@@ -70,7 +70,7 @@ ppIfaces mods
 	        ++ map ppHsName args)
             <+> vcat (zipWith (<+>) (equals : repeat (char '|'))
                                     (map ppHsConstr cons))
-     do_decl (HsClassDecl loc ty decl)
+     do_decl (HsClassDecl loc ty fds decl)
 	= hsep [text "class", ppHsType ty]
      do_decl decl
 	= empty
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 994b17e1..327d931e 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -445,7 +445,7 @@ doDecl doc_map summary decl = do_decl decl
      do_decl decl@(HsDataDecl loc ctx nm args cons drv) 
 	= ppHsDataDecl doc_map summary False{-not newtype-} decl
 
-     do_decl decl@(HsClassDecl _ _ _)
+     do_decl decl@(HsClassDecl _ _ _ _)
 	= ppHsClassDecl doc_map summary decl
 
      do_decl (HsDocGroup lev str) 
@@ -580,9 +580,15 @@ ppHsBangType (HsUnBangedTy ty) = ppHsAType ty
 -- -----------------------------------------------------------------------------
 -- Class declarations
 
-ppClassHdr ty = keyword "class" <+> ppHsType ty
+ppClassHdr ty fds = 
+  keyword "class" <+> ppHsType ty <+>
+  if null fds then noHtml else 
+	char '|' <+> hsep (punctuate comma (map fundep fds))
+  where
+	fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+>
+			       hsep (map ppHsName vars2)
 
-ppShortClassDecl doc_map summary decl@(HsClassDecl loc ty decls) = 
+ppShortClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls) = 
   if null decls
     then declBox hdr
     else td << (
@@ -596,10 +602,10 @@ ppShortClassDecl doc_map summary decl@(HsClassDecl loc ty decls) =
          ))
    where
 	Just c = declMainBinder decl
-	hdr | not summary = linkTarget c +++ ppClassHdr ty
-	    | otherwise   = ppClassHdr ty
+	hdr | not summary = linkTarget c +++ ppClassHdr ty fds
+	    | otherwise   = ppClassHdr ty fds
 
-ppHsClassDecl doc_map summary decl@(HsClassDecl loc ty decls)
+ppHsClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls)
   |  summary || (isNothing doc && all decl_has_no_doc kept_decls)
 	= ppShortClassDecl doc_map summary decl
 
@@ -611,8 +617,8 @@ ppHsClassDecl doc_map summary decl@(HsClassDecl loc ty decls)
 	Just c = declMainBinder decl
 
 	header
-	   | null decls = declBox (linkTarget c +++ ppClassHdr ty)
-	   | otherwise  = declBox (linkTarget c +++ ppClassHdr ty <+> 
+	   | null decls = declBox (linkTarget c +++ ppClassHdr ty fds)
+	   | otherwise  = declBox (linkTarget c +++ ppClassHdr ty fds <+> 
 					keyword "where")
 
 	classdoc
diff --git a/src/HaddockLex.hs b/src/HaddockLex.hs
index 15aa521d..84b369b3 100644
--- a/src/HaddockLex.hs
+++ b/src/HaddockLex.hs
@@ -73,4 +73,4 @@ tokenise_string_newline str cs =
   case dropWhile nonNewlineSpace cs  of
    '\n':cs -> TokString (reverse str) : TokPara : tokenise_para cs
    _other -> tokenise_string ('\n':str) cs  -- don't throw away whitespace
-      
+
diff --git a/src/HaddockParse.y b/src/HaddockParse.y
index 0c5ebf49..6e0f8b6f 100644
--- a/src/HaddockParse.y
+++ b/src/HaddockParse.y
@@ -3,8 +3,6 @@ module HaddockParse (parseParas, parseString) where
 
 import HaddockLex
 import HaddockTypes
-
-import MonadError
 }
 
 %tokentype { Token }
@@ -59,5 +57,13 @@ elem	:: { ParsedDoc }
 {
 happyError :: [Token] -> Either String a
 happyError toks = 
-  throwError ("parse error in doc string: "  ++ show (take 3 toks))
+  Left ("parse error in doc string: "  ++ show (take 3 toks))
+
+-- Either monad (we can't use MonadError because GHC < 5.00 has
+-- an older incompatible version).
+instance Monad (Either String) where
+	return        = Right
+	Left  l >>= _ = Left l
+	Right r >>= k = k r
+	fail msg      = Left msg
 }
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 9dfa7147..ce954a52 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -85,10 +85,10 @@ renameDecl decl
         HsNewTypeDecl loc ctx t args con drv -> do
 	    con <- renameConDecl con
 	    return (HsNewTypeDecl loc ctx t args con drv)
-        HsClassDecl loc qt decls -> do
+        HsClassDecl loc qt fds decls -> do
 	    qt <- renameClassHead qt
 	    decls <- mapM renameDecl decls
-	    return (HsClassDecl loc qt decls)
+	    return (HsClassDecl loc qt fds decls)
 	HsTypeSig loc fs qt -> do
 	    qt <- renameType qt
 	    return (HsTypeSig loc fs qt)
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 8173cedf..ae246553 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -41,7 +41,7 @@ declMainBinder d =
      HsTypeDecl _ n _ _          -> Just n
      HsDataDecl _ _ n _ cons _   -> Just n
      HsNewTypeDecl _ _ n _ _ _   -> Just n
-     HsClassDecl _ qt decls      -> Just (exQtNm qt)
+     HsClassDecl _ qt _ decls    -> Just (exQtNm qt)
      HsTypeSig _ [n] _           -> Just n
      HsTypeSig _ ns _            -> error "declMainBinder"
      HsForeignImport _ _ _ _ n _ -> Just n
@@ -53,7 +53,7 @@ declBinders d =
      HsTypeDecl _ n _ _          -> [n]
      HsDataDecl _ _ n _ cons _   -> n : concat (map conDeclBinders cons)
      HsNewTypeDecl _ _ n _ _ _   -> [n]
-     HsClassDecl _ qt decls      -> exQtNm qt : collectNames decls
+     HsClassDecl _ qt _ decls    -> exQtNm qt : collectNames decls
      HsTypeSig _ ns _            -> ns
      HsForeignImport _ _ _ _ n _ -> [n]
      _                           -> []
@@ -83,8 +83,8 @@ restrictTo names decl = case decl of
 	HsDataDecl loc ctxt n xs (restrictCons names cons) drv
      HsNewTypeDecl loc ctxt n xs con drv ->
 	HsDataDecl loc ctxt n xs (restrictCons names [con]) drv	
-     HsClassDecl loc qt decls  ->
-	HsClassDecl loc qt (restrictDecls names decls)
+     HsClassDecl loc qt fds decls  ->
+	HsClassDecl loc qt fds (restrictDecls names decls)
      _ -> decl
    
 restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl]
diff --git a/src/HsParser.ly b/src/HsParser.ly
index c7833bf2..bae26ce6 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,5 +1,5 @@
-q-----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.4 2002/04/25 14:40:05 simonmar Exp $
+-----------------------------------------------------------------------------
+$Id: HsParser.ly,v 1.5 2002/04/26 11:18:57 simonmar Exp $
 
 (c) Simon Marlow, Sven Panne 1997-2000
 
@@ -299,8 +299,8 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
 >	| 'newtype' ctype srcloc '=' constr deriving
 >			{% checkDataHeader $2 `thenP` \(cs,c,t) ->
 >			   returnP (HsNewTypeDecl $3 cs c t $5 $6) }
->	| 'class' srcloc ctype optcbody	
->			{ HsClassDecl $2 $3 $4 }
+>	| 'class' srcloc ctype fds optcbody
+>			{ HsClassDecl $2 $3 $4 $5}
 >	| 'instance' srcloc ctype optvaldefs
 >			{ HsInstDecl $2 $3 $4 }
 >	| 'default' srcloc '(' typelist ')'
@@ -500,9 +500,24 @@ Datatype declarations
 -----------------------------------------------------------------------------
 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 -}				{ [] }
+>	: 'where' decllist		{ $2 }
+>	| {- empty -}			{ [] }
 
 -----------------------------------------------------------------------------
 Instance declarations
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 7abf4454..e732f2f8 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.4 2002/04/25 14:40:05 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.5 2002/04/26 11:18:57 simonmar Exp $
 %
 % (c) The GHC Team, 1997-2002
 %
@@ -17,7 +17,7 @@ module HsSyn (
     HsGuardedRhs(..), HsType(..), HsContext, HsAsst,
     HsLiteral(..), HsExp(..), HsPat(..), HsPatField(..), HsStmt(..),
     HsFieldUpdate(..), HsAlt(..), HsGuardedAlts(..), HsGuardedAlt(..),
-    HsCallConv(..), HsFISafety(..),
+    HsCallConv(..), HsFISafety(..), HsFunDep,
 
     mkHsForAllType,
 
@@ -119,7 +119,7 @@ data HsDecl
 	 | HsDataDecl	 SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName]
 	 | HsInfixDecl   SrcLoc HsAssoc Int [HsName]
 	 | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName]
-	 | HsClassDecl	 SrcLoc HsType [HsDecl]
+	 | HsClassDecl	 SrcLoc HsType [HsFunDep] [HsDecl]
 	 | HsInstDecl	 SrcLoc HsType [HsDecl]
 	 | HsDefaultDecl SrcLoc [HsType]
 	 | HsTypeSig	 SrcLoc [HsName] HsType
@@ -169,6 +169,7 @@ data HsType
 	 | HsTyCon   HsQName
   deriving (Eq,Show)
 
+type HsFunDep  = ([HsName], [HsName])
 type HsContext = [HsAsst]
 type HsAsst    = (HsQName,[HsType])	-- for multi-parameter type classes
 
diff --git a/src/Main.hs b/src/Main.hs
index 0b8ac7d0..dd7aac64 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -31,6 +31,11 @@ import Char	( isSpace )
 import IO
 import IOExts
 
+#if __GLASGOW_HASKELL__ < 500
+import Regex
+import PackedString
+#endif
+
 -----------------------------------------------------------------------------
 -- Top-level stuff
 
@@ -64,7 +69,7 @@ options =
 	"directory in which to put the output files",
     Option ['s']  ["source"]   (ReqArg Flag_SourceURL "URL") 
 	"base URL for links to source code",
-    Option ['t']  ["heading"]  (ReqArg Flag_Heading "HEADING")
+    Option ['t']  ["title"]  (ReqArg Flag_Heading "TITLE")
 	"page heading",
     Option ['v']  ["verbose"]  (NoArg Flag_Verbose)
 	"be verbose",
@@ -418,8 +423,8 @@ buildEnv mod_map this_mod exported_names (HsImportDecl _ mod qual _ _)
 
 expandDecl :: HsDecl -> [HsDecl]
 expandDecl (HsTypeSig loc fs qt) = [ HsTypeSig loc [f] qt | f <- fs ]
-expandDecl (HsClassDecl loc ty decls)
-  = [ HsClassDecl loc ty (concat (map expandDecl decls)) ]
+expandDecl (HsClassDecl loc ty fds decls)
+  = [ HsClassDecl loc ty fds (concat (map expandDecl decls)) ]
 expandDecl d = [ d ]
 
 -----------------------------------------------------------------------------
@@ -460,7 +465,7 @@ docsFromDecl (HsDataDecl loc ctxt nm tvs cons drvs)
   = concat (map docsFromConDecl cons)
 docsFromDecl (HsNewTypeDecl loc ctxt nm tvs con drvs)
   = docsFromConDecl con
-docsFromDecl (HsClassDecl loc ty decls)
+docsFromDecl (HsClassDecl loc ty fds decls)
   = collect Nothing "" decls
 docsFromDecl _
   = []
@@ -569,6 +574,13 @@ moduleHeaderRE = mkRegexWithOpts
 	-- this at some point (perhaps have a separator between the 
 	-- portability field and the module documentation?).
 
+#if __GLASGOW_HASKELL__ < 500
+mkRegexWithOpts :: String -> Bool -> Bool -> Regex
+mkRegexWithOpts s single_line case_sensitive
+      = unsafePerformIO (re_compile_pattern (packString s) 
+                              single_line case_sensitive)
+#endif
+
 -- -----------------------------------------------------------------------------
 -- Named documentation