aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaddockDB.hs2
-rw-r--r--src/HaddockHtml.hs22
-rw-r--r--src/HaddockLex.hs2
-rw-r--r--src/HaddockParse.y12
-rw-r--r--src/HaddockRename.hs4
-rw-r--r--src/HaddockUtil.hs8
-rw-r--r--src/HsParser.ly27
-rw-r--r--src/HsSyn.lhs7
-rw-r--r--src/Main.hs20
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 09:46:41 +0000