aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaddockDB.hs15
-rw-r--r--src/HaddockHtml.hs220
-rw-r--r--src/HaddockParse.y51
-rw-r--r--src/HaddockRename.hs112
-rw-r--r--src/HaddockTypes.hs121
-rw-r--r--src/HaddockUtil.hs94
-rw-r--r--src/HsLexer.lhs47
-rw-r--r--src/HsParser.ly147
-rw-r--r--src/HsSyn.lhs180
-rw-r--r--src/Main.hs355
10 files changed, 678 insertions, 664 deletions
diff --git a/src/HaddockDB.hs b/src/HaddockDB.hs
index a2a4a8e7..ebd0ccb2 100644
--- a/src/HaddockDB.hs
+++ b/src/HaddockDB.hs
@@ -6,7 +6,7 @@
module HaddockDB (ppDocBook) where
-import HaddockTypes hiding (Doc)
+import HaddockTypes
import HaddockUtil
import HsSyn
@@ -16,6 +16,8 @@ import FiniteMap
-----------------------------------------------------------------------------
-- Printing the results in DocBook format
+ppDocBook = error "not working"
+{-
ppDocBook :: FilePath -> [(Module, Interface)] -> String
ppDocBook odir mods = render (ppIfaces mods)
@@ -55,22 +57,22 @@ ppIfaces mods
$$ text "</varlistentry>"
do_export _ _ = empty
- do_decl (HsTypeSig _ [nm] ty)
+ do_decl (HsTypeSig _ [nm] ty _)
= ppHsName nm <> text " :: " <> ppHsType ty
- do_decl (HsTypeDecl _ nm args ty)
+ do_decl (HsTypeDecl _ nm args ty _)
= hsep ([text "type", ppHsName nm ]
++ map ppHsName args
++ [equals, ppHsType ty])
- do_decl (HsNewTypeDecl loc ctx nm args con drv)
+ do_decl (HsNewTypeDecl loc ctx nm args con drv _)
= hsep ([text "data", ppHsName nm] -- data, not newtype
++ map ppHsName args
) <+> equals <+> ppHsConstr con -- ToDo: derivings
- do_decl (HsDataDecl loc ctx nm args cons drv)
+ do_decl (HsDataDecl loc ctx nm args cons drv _)
= hsep ([text "data", {-ToDo: context-}ppHsName nm]
++ map ppHsName args)
<+> vcat (zipWith (<+>) (equals : repeat (char '|'))
(map ppHsConstr cons))
- do_decl (HsClassDecl loc ty fds decl)
+ do_decl (HsClassDecl loc ty fds decl _)
= hsep [text "class", ppHsType ty]
do_decl decl
= empty
@@ -158,3 +160,4 @@ ubxParenList :: [Doc] -> Doc
ubxParenList = ubxparens . fsep . punctuate comma
ubxparens p = text "(#" <> p <> text "#)"
+-}
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 2bd6b102..01d01d69 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -12,12 +12,13 @@ import HaddockTypes
import HaddockUtil
import HsSyn
+import IO
import Maybe ( fromJust, isNothing, isJust )
import FiniteMap
import List ( sortBy )
import Char ( toUpper, toLower )
import Monad ( when )
---import IOExts
+import IOExts
import Html
import qualified Html
@@ -79,8 +80,7 @@ src_button source_url mod file
| Just u <- source_url =
let src_url = if (last u == '/') then u ++ file else u ++ '/':file
in
- (tda [theclass "topbut", nowrap] <<
- anchor ! [href src_url] << toHtml "Source code")
+ topButBox (anchor ! [href src_url] << toHtml "Source code")
| otherwise =
Html.emptyTable
@@ -88,16 +88,15 @@ src_button source_url mod file
parent_button mod =
case span (/= '.') (reverse mod) of
(m, '.':rest) ->
- (tda [theclass "topbut", nowrap] <<
+ topButBox (
anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent")
_ ->
Html.emptyTable
-contentsButton = tda [theclass "topbut", nowrap] <<
- anchor ! [href contentsHtmlFile] << toHtml "Contents"
+contentsButton = topButBox (anchor ! [href contentsHtmlFile] <<
+ toHtml "Contents")
-indexButton = tda [theclass "topbut", nowrap] <<
- anchor ! [href indexHtmlFile] << toHtml "Index"
+indexButton = topButBox (anchor ! [href indexHtmlFile] << toHtml "Index")
simpleHeader title =
(tda [theclass "topbar"] <<
@@ -319,10 +318,8 @@ ifaceToHtml mod iface
(contents </> description </> synopsis </> maybe_hr </> body)
where
exports = numberSectionHeadings (iface_exports iface)
- doc_map = iface_name_docs iface
- has_doc (ExportDecl d)
- | Just x <- declMainBinder d = isJust (lookupFM doc_map x)
+ has_doc (ExportDecl d) = isJust (declDoc d)
has_doc (ExportModule _) = False
has_doc _ = True
@@ -344,14 +341,14 @@ ifaceToHtml mod iface
= (tda [theclass "section1"] << toHtml "Synopsis") </>
(tda [width "100%", theclass "synopsis"] <<
table ! [width "100%", cellpadding 0, cellspacing 8, border 0] <<
- aboves (map (processExport doc_map True) exports))
+ aboves (map (processExport True) exports))
maybe_hr
| not (no_doc_at_all), ExportGroup 1 _ _ <- head exports
= td << hr
| otherwise = Html.emptyTable
- body = aboves (map (processExport doc_map False) exports)
+ body = aboves (map (processExport False) exports)
ppModuleContents :: [ExportItem] -> HtmlTable
ppModuleContents exports
@@ -386,16 +383,16 @@ numberSectionHeadings exports = go 1 exports
go n (other:es)
= other : go n es
-processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> HtmlTable
-processExport doc_map summary (ExportGroup lev id doc)
+processExport :: Bool -> ExportItem -> HtmlTable
+processExport summary (ExportGroup lev id doc)
| summary = Html.emptyTable
| otherwise = ppDocGroup lev (anchor ! [name id] << markup htmlMarkup doc)
-processExport doc_map summary (ExportDecl decl)
- = doDecl doc_map summary decl
-processExport doc_map summary (ExportDoc doc)
+processExport summary (ExportDecl decl)
+ = doDecl summary decl
+processExport summary (ExportDoc doc)
| summary = Html.emptyTable
| otherwise = docBox (markup htmlMarkup doc)
-processExport doc_map summary (ExportModule (Module mod))
+processExport summary (ExportModule (Module mod))
= declBox (toHtml "module" <+> ppHsModule mod)
ppDocGroup lev doc
@@ -415,43 +412,36 @@ declWithDoc False (Just doc) html_decl =
vanillaTable <<
(declBox html_decl </> docBox (markup htmlMarkup doc))
-doDecl :: FiniteMap HsName Doc -> Bool -> HsDecl -> HtmlTable
-doDecl doc_map summary decl = do_decl decl
+doDecl :: Bool -> HsDecl -> HtmlTable
+doDecl summary decl = do_decl decl
where
- doc | Just n <- declMainBinder decl = lookupFM doc_map n
- | otherwise = Nothing
+ do_decl (HsTypeSig _ [nm] ty doc)
+ = ppFunSig summary nm ty doc
- do_decl (HsTypeSig _ [nm] ty) =
- declWithDoc summary doc (ppTypeSig summary nm ty)
-
- do_decl (HsTypeSig _ nms ty)
- = declWithDoc summary doc (
- vanillaTable << aboves (map do_one nms))
- where do_one nm = declBox (ppTypeSig summary nm ty)
-
- do_decl (HsForeignImport _ _ _ _ n ty)
+ do_decl (HsForeignImport _ _ _ _ n ty doc)
= declWithDoc summary doc (ppTypeSig summary n ty)
- do_decl (HsTypeDecl _ nm args ty)
+ do_decl (HsTypeDecl _ nm args ty doc)
= declWithDoc summary doc (
hsep ([keyword "type", ppHsBinder summary nm]
++ map ppHsName args) <+> equals <+> ppHsType ty)
- do_decl (HsNewTypeDecl loc ctx nm args con drv)
- = ppHsDataDecl doc_map summary True{-is newtype-}
- (HsDataDecl loc ctx nm args [con] drv)
+ do_decl (HsNewTypeDecl loc ctx nm args con drv doc)
+ = ppHsDataDecl summary True{-is newtype-}
+ (HsDataDecl loc ctx nm args [con] drv doc)
-- print it as a single-constructor datatype
- do_decl decl@(HsDataDecl loc ctx nm args cons drv)
- = ppHsDataDecl doc_map summary False{-not newtype-} decl
+ do_decl decl@(HsDataDecl loc ctx nm args cons drv doc)
+ = ppHsDataDecl summary False{-not newtype-} decl
- do_decl decl@(HsClassDecl _ _ _ _)
- = ppHsClassDecl doc_map summary decl
+ do_decl decl@(HsClassDecl _ _ _ _ _)
+ = ppHsClassDecl summary decl
- do_decl (HsDocGroup lev str)
- = if summary then Html.emptyTable else ppDocGroup lev str
+ do_decl (HsDocGroup loc lev str)
+ = if summary then Html.emptyTable
+ else ppDocGroup lev (markup htmlMarkup str)
- do_decl _ = error (show decl)
+ do_decl _ = error ("do_decl: " ++ show decl)
ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty
@@ -469,11 +459,11 @@ keepDecl _ = False
ppShortDataDecl :: Bool -> Bool -> HsDecl -> Html
ppShortDataDecl summary is_newty
- (HsDataDecl loc ctx nm args [con] drv) =
+ (HsDataDecl loc ctx nm args [con] drv _doc) =
ppHsDataHeader summary is_newty nm args
<+> equals <+> ppShortConstr summary con
ppShortDataDecl summary is_newty
- (HsDataDecl loc ctx nm args cons drv) =
+ (HsDataDecl loc ctx nm args cons drv _doc) =
vanillaTable << (
aboves (
(declBox (ppHsDataHeader summary is_newty nm args) :
@@ -486,16 +476,14 @@ ppShortDataDecl summary is_newty
-- First, the abstract case:
-ppHsDataDecl doc_map summary is_newty (HsDataDecl loc ctx nm args [] drv) =
- declWithDoc summary (lookupFM doc_map nm)
- (ppHsDataHeader summary is_newty nm args)
+ppHsDataDecl summary is_newty (HsDataDecl loc ctx nm args [] drv doc) =
+ declWithDoc summary doc (ppHsDataHeader summary is_newty nm args)
-- The rest of the cases:
-ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv)
+ppHsDataDecl summary is_newty decl@(HsDataDecl loc ctx nm args cons drv doc)
| summary || no_constr_docs
- = declWithDoc summary (lookupFM doc_map nm)
- (ppShortDataDecl summary is_newty decl)
+ = declWithDoc summary doc (ppShortDataDecl summary is_newty decl)
| otherwise
= td << vanillaTable << (header </> datadoc </> constrs)
@@ -516,20 +504,17 @@ ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv)
aboves (constr_hdr : map do_constr cons)
)
- do_constr con = ppHsFullConstr doc_map con
-
- Just c = declMainBinder decl
- doc = lookupFM doc_map c
+ do_constr con = ppHsFullConstr con
no_constr_docs = all constr_has_no_doc cons
- constr_has_no_doc (HsConDecl _ nm _ _ _ _)
- = isNothing (lookupFM doc_map nm)
- constr_has_no_doc (HsRecDecl _ nm _ _ fields _)
- = isNothing (lookupFM doc_map nm) && all field_has_no_doc fields
+ constr_has_no_doc (HsConDecl _ nm _ _ _ doc)
+ = isNothing doc
+ constr_has_no_doc (HsRecDecl _ nm _ _ fields doc)
+ = isNothing doc && all field_has_no_doc fields
- field_has_no_doc (HsFieldDecl nms _ _)
- = all isNothing (map (lookupFM doc_map) nms)
+ field_has_no_doc (HsFieldDecl nms _ doc)
+ = isNothing doc
ppShortConstr :: Bool -> HsConDecl -> Html
@@ -548,14 +533,12 @@ ppHsConstrHdr tvs ctxt
+++
(if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ")
-ppHsFullConstr doc_map (HsConDecl pos nm tvs ctxt typeList _maybe_doc) =
+ppHsFullConstr (HsConDecl pos nm tvs ctxt typeList doc) =
declWithDoc False doc (
hsep ((ppHsConstrHdr tvs ctxt +++
ppHsBinder False nm) : map ppHsBangType typeList)
)
- where
- doc = lookupFM doc_map nm
-ppHsFullConstr doc_map (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
+ppHsFullConstr (HsRecDecl pos nm tvs ctxt fields doc) =
td << vanillaTable << (
case doc of
Nothing -> aboves [hdr, fields_html]
@@ -571,10 +554,8 @@ ppHsFullConstr doc_map (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
fields_html =
td <<
table ! [width "100%", cellpadding 0, cellspacing 8] << (
- aboves (map (ppFullField doc_map)
- (concat (map expandField fields)))
+ aboves (map ppFullField (concat (map expandField fields)))
)
- doc = lookupFM doc_map nm
ppShortField summary (HsFieldDecl ns ty _doc)
@@ -583,11 +564,11 @@ ppShortField summary (HsFieldDecl ns ty _doc)
<+> toHtml "::" <+> ppHsBangType ty
)
-ppFullField doc_map (HsFieldDecl [n] ty _doc)
- = declWithDoc False (lookupFM doc_map n) (
+ppFullField (HsFieldDecl [n] ty doc)
+ = declWithDoc False doc (
ppHsBinder False n <+> toHtml "::" <+> ppHsBangType ty
)
-ppFullField _ _ = error "ppFullField"
+ppFullField _ = error "ppFullField"
expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
@@ -610,16 +591,16 @@ ppClassHdr ty fds =
fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+>
hsep (map ppHsName vars2)
-ppShortClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls) =
+ppShortClassDecl summary decl@(HsClassDecl loc ty fds decls doc) =
if null decls
then declBox hdr
else td << (
vanillaTable << (
declBox (hdr <+> keyword "where")
</>
- tda [theclass "cbody"] << (
+ tda [theclass "body"] << (
vanillaTable << (
- aboves (map (doDecl doc_map summary) (filter keepDecl decls))
+ aboves (map (doDecl summary) (filter keepDecl decls))
))
))
where
@@ -627,15 +608,14 @@ ppShortClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls) =
hdr | not summary = linkTarget c +++ ppClassHdr ty fds
| otherwise = ppClassHdr ty fds
-ppHsClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls)
+ppHsClassDecl summary decl@(HsClassDecl loc ty fds decls doc)
| summary || (isNothing doc && all decl_has_no_doc kept_decls)
- = ppShortClassDecl doc_map summary decl
+ = ppShortClassDecl summary decl
| otherwise
= td << vanillaTable << (header </> classdoc </> body)
where
- doc = lookupFM doc_map c
Just c = declMainBinder decl
header
@@ -654,14 +634,56 @@ ppHsClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls)
| otherwise =
td << table ! [width "100%", cellpadding 0, cellspacing 8] << (
meth_hdr </>
- aboves (map (doDecl doc_map False) kept_decls)
+ aboves (map (doDecl False) kept_decls)
)
kept_decls = filter keepDecl decls
- decl_has_no_doc decl
- | Just b <- declMainBinder decl = isNothing (lookupFM doc_map b)
- | otherwise = True
+ decl_has_no_doc decl = isNothing (declDoc decl)
+
+-- -----------------------------------------------------------------------------
+-- Type signatures
+
+ppFunSig summary nm ty doc
+ | summary || no_arg_docs ty =
+ declWithDoc summary doc (ppTypeSig summary nm ty)
+
+ | otherwise =
+ td << vanillaTable << (
+ declBox (ppHsBinder False nm) </>
+ (tda [theclass "body"] << narrowTable << (
+ (if (isJust doc)
+ then ndocBox (markup htmlMarkup (fromJust doc))
+ else Html.emptyTable) </>
+ do_args True ty
+ ))
+ )
+ where
+ no_arg_docs (HsForAllType _ _ ty) = no_arg_docs ty
+ no_arg_docs (HsTyFun (HsTyDoc _ _) _) = False
+ no_arg_docs (HsTyFun _ r) = no_arg_docs r
+ no_arg_docs (HsTyDoc _ _) = False
+ no_arg_docs _ = True
+
+ do_args :: Bool -> HsType -> HtmlTable
+ do_args first (HsForAllType maybe_tvs ctxt ty)
+ = declBox (leader first <+> ppHsForAll maybe_tvs ctxt) </>
+ do_args False ty
+ do_args first (HsTyFun (HsTyDoc ty doc) r)
+ = (declBox (leader first <+> ppHsBType ty) <->
+ rdocBox (markup htmlMarkup doc)) </>
+ do_args False r
+ do_args first (HsTyFun ty r)
+ = (declBox (leader first <+> ppHsBType ty) <->
+ rdocBox noHtml) </>
+ do_args False r
+ do_args first (HsTyDoc ty doc)
+ = (declBox (leader first <+> ppHsBType ty) <->
+ rdocBox (markup htmlMarkup doc))
+ do_args first _ = declBox (leader first <+> ppHsBType ty)
+
+ leader True = toHtml "::"
+ leader False = toHtml "->"
-- -----------------------------------------------------------------------------
-- Types and contexts
@@ -671,15 +693,19 @@ ppHsContext [] = empty
ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
hsep (map ppHsAType b)) context)
+ppHsForAll Nothing context =
+ hsep [ ppHsContext context, toHtml "=>" ]
+ppHsForAll (Just tvs) [] =
+ hsep (keyword "forall" : map ppHsName tvs ++ [toHtml "."])
+ppHsForAll (Just tvs) context =
+ hsep (keyword "forall" : map ppHsName tvs ++
+ [toHtml ".", ppHsContext context, toHtml "=>"])
+
ppHsType :: HsType -> Html
-ppHsType (HsForAllType Nothing context htype) =
- hsep [ ppHsContext context, toHtml "=>", ppHsType htype]
-ppHsType (HsForAllType (Just tvs) [] htype) =
- hsep (keyword "forall" : map ppHsName tvs ++ toHtml "." : [ppHsType htype])
-ppHsType (HsForAllType (Just tvs) context htype) =
- hsep (keyword "forall" : map ppHsName tvs ++ toHtml "." :
- ppHsContext context : toHtml "=>" : [ppHsType htype])
+ppHsType (HsForAllType maybe_tvs context htype) =
+ ppHsForAll maybe_tvs context <+> ppHsType htype
ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b]
+ppHsType (HsTyDoc ty doc) = ppHsBType ty
ppHsType t = ppHsBType t
ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
@@ -751,7 +777,7 @@ htmlMarkup = Markup {
markupEmpty = toHtml "",
markupString = toHtml,
markupAppend = (+++),
- markupIdentifier = ppHsQName,
+ markupIdentifier = ppHsQName . head,
markupModule = ppHsModule,
markupEmphasis = emphasize . toHtml,
markupMonospaced = tt . toHtml,
@@ -800,10 +826,26 @@ ubxparens p = toHtml "(#" +++ p +++ toHtml "#)"
text = strAttr "TEXT"
+-- a box for displaying code
declBox :: Html -> HtmlTable
declBox html = tda [theclass "decl"] << html
+-- a box for displaying documentation,
+-- indented and with a little padding at the top
docBox :: Html -> HtmlTable
docBox html = tda [theclass "doc"] << html
+-- a box for displaying documentation, not indented.
+ndocBox :: Html -> HtmlTable
+ndocBox html = tda [theclass "ndoc"] << html
+
+-- a box for displaying documentation, padded on the left a little
+rdocBox :: Html -> HtmlTable
+rdocBox html = tda [theclass "rdoc"] << html
+
+-- a box for the buttons at the top of the page
+topButBox html = tda [theclass "topbut"] << html
+
vanillaTable = table ! [width "100%", cellpadding 0, cellspacing 0, border 0]
+
+narrowTable = table ! [cellpadding 0, cellspacing 0, border 0]
diff --git a/src/HaddockParse.y b/src/HaddockParse.y
index 789f0d94..37ceff4f 100644
--- a/src/HaddockParse.y
+++ b/src/HaddockParse.y
@@ -2,7 +2,9 @@
module HaddockParse (parseParas, parseString) where
import HaddockLex
-import HaddockTypes
+import HsSyn
+import HsLexer hiding (Token)
+import HsParseMonad
}
%tokentype { Token }
@@ -26,48 +28,48 @@ import HaddockTypes
%%
-doc :: { ParsedDoc }
+doc :: { Doc }
: apara PARA doc { docAppend $1 $3 }
| PARA doc { $2 }
| apara { $1 }
| {- empty -} { DocEmpty }
-apara :: { ParsedDoc }
+apara :: { Doc }
: ulpara { DocUnorderedList [$1] }
| olpara { DocOrderedList [$1] }
| para { $1 }
-ulpara :: { ParsedDoc }
+ulpara :: { Doc }
: '*' para { $2 }
-olpara :: { ParsedDoc }
+olpara :: { Doc }
: '(n)' para { $2 }
-para :: { ParsedDoc }
+para :: { Doc }
: seq { docParagraph $1 }
| codepara { DocCodeBlock $1 }
-codepara :: { ParsedDoc }
+codepara :: { Doc }
: '>' seq codepara { docAppend $2 $3 }
| '>' seq { $2 }
-seq :: { ParsedDoc }
+seq :: { Doc }
: elem seq { docAppend $1 $2 }
| elem { $1 }
-elem :: { ParsedDoc }
+elem :: { Doc }
: elem1 { $1 }
| '@' seq1 '@' { DocMonospaced $2 }
-seq1 :: { ParsedDoc }
+seq1 :: { Doc }
: elem1 seq1 { docAppend $1 $2 }
| elem1 { $1 }
-elem1 :: { ParsedDoc }
+elem1 :: { Doc }
: STRING { DocString $1 }
| '/' STRING '/' { DocEmphasis (DocString $2) }
| URL { DocURL $1 }
- | squo STRING squo { DocIdentifier $2 }
+ | squo STRING squo { DocIdentifier (strToHsQNames $2) }
| DQUO STRING DQUO { DocModule $2 }
squo :: { () }
@@ -86,4 +88,29 @@ instance Monad (Either String) where
Left l >>= _ = Left l
Right r >>= k = k r
fail msg = Left msg
+
+strToHsQNames :: String -> [ HsQName ]
+strToHsQNames str
+ = case lexer (\t -> returnP t) str (SrcLoc 1 1) 1 1 [] of
+ Ok _ (VarId str)
+ -> [ UnQual (HsVarName (HsIdent str)) ]
+ Ok _ (QVarId (mod,str))
+ -> [ Qual (Module mod) (HsVarName (HsIdent str)) ]
+ Ok _ (ConId str)
+ -> [ UnQual (HsTyClsName (HsIdent str)),
+ UnQual (HsVarName (HsIdent str)) ]
+ Ok _ (QConId (mod,str))
+ -> [ Qual (Module mod) (HsTyClsName (HsIdent str)),
+ Qual (Module mod) (HsVarName (HsIdent str)) ]
+ Ok _ (VarSym str)
+ -> [ UnQual (HsVarName (HsSymbol str)) ]
+ Ok _ (ConSym str)
+ -> [ UnQual (HsTyClsName (HsSymbol str)),
+ UnQual (HsVarName (HsSymbol str)) ]
+ Ok _ (QVarSym (mod,str))
+ -> [ Qual (Module mod) (HsVarName (HsSymbol str)) ]
+ Ok _ (QConSym (mod,str))
+ -> [ Qual (Module mod) (HsTyClsName (HsSymbol str)),
+ Qual (Module mod) (HsVarName (HsSymbol str)) ]
+ other -> []
}
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 59d71bd5..02085e2e 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -10,7 +10,7 @@ module HaddockRename (
renameExportList,
renameDecl,
renameExportItems,
- renameDoc, resolveDoc,
+ renameDoc,
) where
import HaddockTypes
@@ -64,37 +64,47 @@ renameExportList spec = mapM renameExport spec
renameExport (HsEVar x) = lookupRn HsEVar x
renameExport (HsEAbs x) = lookupRn HsEAbs x
renameExport (HsEThingAll x) = lookupRn HsEThingAll x
- renameExport (HsEThingWith x cs)
- = do cs' <- mapM (lookupRn id) cs
- lookupRn (\x' -> HsEThingWith x' cs') x
+ renameExport (HsEThingWith x cs) = do
+ cs' <- mapM (lookupRn id) cs
+ lookupRn (\x' -> HsEThingWith x' cs') x
renameExport (HsEModuleContents m) = return (HsEModuleContents m)
- renameExport (HsEGroup lev str) = return (HsEGroup lev str)
- renameExport (HsEDoc str) = return (HsEDoc str)
+ renameExport (HsEGroup lev doc) = do
+ doc <- renameDoc doc
+ return (HsEGroup lev doc)
+ renameExport (HsEDoc doc) = do
+ doc <- renameDoc doc
+ return (HsEDoc doc)
renameExport (HsEDocNamed str) = return (HsEDocNamed str)
renameDecl :: HsDecl -> RnM HsDecl
renameDecl decl
= case decl of
- HsTypeDecl loc t args ty -> do
+ HsTypeDecl loc t args ty doc -> do
ty <- renameType ty
- return (HsTypeDecl loc t args ty)
- HsDataDecl loc ctx t args cons drv -> do
+ doc <- renameMaybeDoc doc
+ return (HsTypeDecl loc t args ty doc)
+ HsDataDecl loc ctx t args cons drv doc -> do
cons <- mapM renameConDecl cons
- return (HsDataDecl loc ctx t args cons drv)
- HsNewTypeDecl loc ctx t args con drv -> do
+ doc <- renameMaybeDoc doc
+ return (HsDataDecl loc ctx t args cons drv doc)
+ HsNewTypeDecl loc ctx t args con drv doc -> do
con <- renameConDecl con
- return (HsNewTypeDecl loc ctx t args con drv)
- HsClassDecl loc qt fds decls -> do
+ doc <- renameMaybeDoc doc
+ return (HsNewTypeDecl loc ctx t args con drv doc)
+ HsClassDecl loc qt fds decls doc -> do
qt <- renameClassHead qt
decls <- mapM renameDecl decls
- return (HsClassDecl loc qt fds decls)
- HsTypeSig loc fs qt -> do
+ doc <- renameMaybeDoc doc
+ return (HsClassDecl loc qt fds decls doc)
+ HsTypeSig loc fs qt doc -> do
qt <- renameType qt
- return (HsTypeSig loc fs qt)
- HsForeignImport loc cc safe ent n ty -> do
+ doc <- renameMaybeDoc doc
+ return (HsTypeSig loc fs qt doc)
+ HsForeignImport loc cc safe ent n ty doc -> do
ty <- renameType ty
- return (HsForeignImport loc cc safe ent n ty)
+ doc <- renameMaybeDoc doc
+ return (HsForeignImport loc cc safe ent n ty doc)
_ ->
return decl
@@ -104,15 +114,18 @@ renameClassHead (HsForAllType tvs ctx ty) = do
renameClassHead ty = do
return ty
-renameConDecl (HsConDecl loc nm tvs ctxt tys maybe_doc) = do
+renameConDecl (HsConDecl loc nm tvs ctxt tys doc) = do
tys <- mapM renameBangTy tys
- return (HsConDecl loc nm tvs ctxt tys maybe_doc)
-renameConDecl (HsRecDecl loc nm tvs ctxt fields maybe_doc) = do
+ doc <- renameMaybeDoc doc
+ return (HsConDecl loc nm tvs ctxt tys doc)
+renameConDecl (HsRecDecl loc nm tvs ctxt fields doc) = do
fields <- mapM renameField fields
- return (HsRecDecl loc nm tvs ctxt fields maybe_doc)
+ doc <- renameMaybeDoc doc
+ return (HsRecDecl loc nm tvs ctxt fields doc)
renameField (HsFieldDecl ns ty doc) = do
ty <- renameBangTy ty
+ doc <- renameMaybeDoc doc
return (HsFieldDecl ns ty doc)
renameBangTy (HsBangedTy ty) = HsBangedTy `liftM` renameType ty
@@ -141,19 +154,23 @@ renameType (HsTyVar nm) =
return (HsTyVar nm)
renameType (HsTyCon nm) =
lookupRn HsTyCon nm
+renameType (HsTyDoc ty doc) = do
+ ty <- renameType ty
+ doc <- renameDoc doc
+ return (HsTyDoc ty doc)
-- -----------------------------------------------------------------------------
-- Renaming documentation
-- Renaming documentation is done by "marking it up" from ordinary Doc
-- into (Rn Doc), which can then be renamed with runRn.
-markupRename :: DocMarkup HsQName (RnM Doc)
+markupRename :: DocMarkup [HsQName] (RnM Doc)
markupRename = Markup {
markupEmpty = return DocEmpty,
markupString = return . DocString,
markupParagraph = liftM DocParagraph,
markupAppend = liftM2 DocAppend,
- markupIdentifier = lookupRn DocIdentifier,
+ markupIdentifier = lookupForDoc,
markupModule = return . DocModule,
markupEmphasis = liftM DocEmphasis,
markupMonospaced = liftM DocMonospaced,
@@ -165,31 +182,32 @@ markupRename = Markup {
renameDoc = markup markupRename
-markupResolveDoc :: DocMarkup String (GenRnM String Doc)
-markupResolveDoc = Markup {
- markupEmpty = return DocEmpty,
- markupString = return . DocString,
- markupParagraph = liftM DocParagraph,
- markupAppend = liftM2 DocAppend,
- markupIdentifier = lookupIdString,
- markupModule = return . DocModule,
- markupEmphasis = liftM DocEmphasis,
- markupMonospaced = liftM DocMonospaced,
- markupUnorderedList = liftM DocUnorderedList . sequence,
- markupOrderedList = liftM DocOrderedList . sequence,
- markupCodeBlock = liftM DocCodeBlock,
- markupURL = return . DocURL
- }
-
-resolveDoc = markup markupResolveDoc
+renameMaybeDoc Nothing = return Nothing
+renameMaybeDoc (Just doc) = Just `liftM` renameDoc doc
-lookupIdString :: String -> GenRnM String Doc
-lookupIdString str = do
- fn <- getLookupRn
- case fn str of
- Nothing -> return (DocString str)
- Just n -> return (DocIdentifier n)
+-- ---------------------------------------------------------------------------
+-- Looking up names in documentation
+lookupForDoc :: [HsQName] -> RnM Doc
+lookupForDoc qns = do
+ lkp <- getLookupRn
+ case [ n | Just n <- map lkp qns ] of
+ ns@(_:_) -> return (DocIdentifier ns)
+ [] -> -- if we were given a qualified name, but there's nothing
+ -- matching that name in scope, then just assume its existence
+ -- (this means you can use qualified names in doc strings wihout
+ -- worrying about whether the entity is in scope).
+ let quals = filter isQualified qns in
+ if (not (null quals)) then
+ return (DocIdentifier quals)
+ else
+ -- no qualified names: just replace this name with its
+ -- string representation.
+ return (DocString (show (head qns)))
+ where
+ isQualified (Qual m i) = True
+ isQualified _ = False
+
-- -----------------------------------------------------------------------------
renameExportItems items = mapM rn items
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 5af102d4..9c957dd5 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -6,20 +6,14 @@
module HaddockTypes (
-- * Module interfaces
- NameEnv, Interface(..), ModuleInfo(..), ExportItem(..), ModuleMap,
+ NameEnv, Interface(..), ExportItem(..), ModuleMap,
DocOption(..),
- -- * User documentation strings
- DocString, GenDoc(..), Doc, ParsedDoc, DocMarkup(..),
- markup, mapIdent,
- docAppend, docParagraph,
) where
import FiniteMap
import HsSyn
-import Char (isSpace)
-
-- ---------------------------------------------------------------------------
-- Describing a module interface
@@ -45,11 +39,6 @@ data Interface
-- restricted to only those bits exported.
-- the map key is the "main name" of the decl.
- iface_name_docs :: FiniteMap HsName Doc,
- -- ^ maps names exported by this module to documentation.
- -- Includes not just "main names" but names of constructors,
- -- record fields, etc.
-
iface_info :: Maybe ModuleInfo,
-- ^ information from the module header
@@ -60,11 +49,6 @@ data Interface
-- ^ module-wide doc options
}
-data ModuleInfo = ModuleInfo
- { portability :: String,
- stability :: String,
- maintainer :: String }
-
data DocOption = OptHide | OptPrune | OptIgnoreExports
deriving (Eq)
@@ -72,7 +56,7 @@ type DocString = String
data ExportItem
= ExportDecl
- HsDecl -- a declaration
+ HsDecl -- a declaration (with doc annotations)
| ExportGroup -- a section heading
Int -- section level (1, 2, 3, ... )
@@ -87,104 +71,3 @@ data ExportItem
type ModuleMap = FiniteMap Module Interface
--- -----------------------------------------------------------------------------
--- Doc strings and formatting
-
-data GenDoc id
- = DocEmpty
- | DocAppend (GenDoc id) (GenDoc id)
- | DocString String
- | DocParagraph (GenDoc id)
- | DocIdentifier id
- | DocModule String
- | DocEmphasis (GenDoc id)
- | DocMonospaced (GenDoc id)
- | DocUnorderedList [GenDoc id]
- | DocOrderedList [GenDoc id]
- | DocCodeBlock (GenDoc id)
- | DocURL String
-
-type Doc = GenDoc HsQName
-type ParsedDoc = GenDoc String
-
--- | DocMarkup is a set of instructions for marking up documentation.
--- In fact, it's really just a mapping from 'GenDoc' to some other
--- type [a], where [a] is usually the type of the output (HTML, say).
-
-data DocMarkup id a = Markup {
- markupEmpty :: a,
- markupString :: String -> a,
- markupParagraph :: a -> a,
- markupAppend :: a -> a -> a,
- markupIdentifier :: id -> a,
- markupModule :: String -> a,
- markupEmphasis :: a -> a,
- markupMonospaced :: a -> a,
- markupUnorderedList :: [a] -> a,
- markupOrderedList :: [a] -> a,
- markupCodeBlock :: a -> a,
- markupURL :: String -> a
- }
-
-markup :: DocMarkup id a -> GenDoc id -> a
-markup m DocEmpty = markupEmpty m
-markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
-markup m (DocString s) = markupString m s
-markup m (DocParagraph d) = markupParagraph m (markup m d)
-markup m (DocIdentifier i) = markupIdentifier m i
-markup m (DocModule mod) = markupModule m mod
-markup m (DocEmphasis d) = markupEmphasis m (markup m d)
-markup m (DocMonospaced d) = markupMonospaced m (markup m d)
-markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
-markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
-markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
-markup m (DocURL url) = markupURL m url
-
--- | Since marking up is just a matter of mapping 'Doc' into some
--- other type, we can \'rename\' documentation by marking up 'Doc' into
--- the same thing, modifying only the identifiers embedded in it.
-mapIdent f = Markup {
- markupEmpty = DocEmpty,
- markupString = DocString,
- markupParagraph = DocParagraph,
- markupAppend = DocAppend,
- markupIdentifier = f,
- markupModule = DocModule,
- markupEmphasis = DocEmphasis,
- markupMonospaced = DocMonospaced,
- markupUnorderedList = DocUnorderedList,
- markupOrderedList = DocOrderedList,
- markupCodeBlock = DocCodeBlock,
- markupURL = DocURL
- }
-
--- -----------------------------------------------------------------------------
--- ** Smart constructors
-
--- used to make parsing easier; we group the list items later
-docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
- = DocUnorderedList (ds1++ds2)
-docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
- = DocAppend (DocUnorderedList (ds1++ds2)) d
-docAppend (DocOrderedList ds1) (DocOrderedList ds2)
- = DocOrderedList (ds1++ds2)
-docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
- = DocAppend (DocOrderedList (ds1++ds2)) d
-docAppend DocEmpty d = d
-docAppend d DocEmpty = d
-docAppend d1 d2
- = DocAppend d1 d2
-
--- again to make parsing easier - we spot a paragraph whose only item
--- is a DocMonospaced and make it into a DocCodeBlock
-docParagraph (DocMonospaced p)
- = DocCodeBlock p
-docParagraph (DocAppend (DocString s1) (DocMonospaced p))
- | all isSpace s1
- = DocCodeBlock p
-docParagraph (DocAppend (DocString s1)
- (DocAppend (DocMonospaced p) (DocString s2)))
- | all isSpace s1 && all isSpace s2
- = DocCodeBlock p
-docParagraph p
- = DocParagraph p
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index ef209f98..58033edc 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -9,7 +9,7 @@ module HaddockUtil (
-- * Misc utilities
nameOfQName, collectNames, declBinders, declMainBinder, splitTyConApp,
- restrictTo,
+ restrictTo, declDoc, parseModuleHeader,
-- * Filename utilities
basename, dirname, splitFilename3,
@@ -25,6 +25,7 @@ import HsSyn
import List ( intersect )
import IO ( hPutStr, stderr )
import System
+import RegexString
-- -----------------------------------------------------------------------------
-- Some Utilities
@@ -38,25 +39,25 @@ collectNames ds = concat (map declBinders ds)
declMainBinder :: HsDecl -> Maybe HsName
declMainBinder d =
case d of
- HsTypeDecl _ n _ _ -> Just n
- HsDataDecl _ _ n _ cons _ -> Just n
- HsNewTypeDecl _ _ n _ _ _ -> Just n
- HsClassDecl _ qt _ decls -> Just (exQtNm qt)
- HsTypeSig _ [n] _ -> Just n
- HsTypeSig _ ns _ -> error "declMainBinder"
- HsForeignImport _ _ _ _ n _ -> Just n
- _ -> Nothing
+ HsTypeDecl _ n _ _ _ -> Just n
+ HsDataDecl _ _ n _ cons _ _ -> Just n
+ HsNewTypeDecl _ _ n _ _ _ _ -> Just n
+ HsClassDecl _ qt _ decls _ -> Just (exQtNm qt)
+ HsTypeSig _ [n] _ _ -> Just n
+ HsTypeSig _ ns _ _ -> error "declMainBinder"
+ HsForeignImport _ _ _ _ n _ _ -> Just n
+ _ -> Nothing
declBinders :: HsDecl -> [HsName]
declBinders d =
case d of
- HsTypeDecl _ n _ _ -> [n]
- HsDataDecl _ _ n _ cons _ -> n : concat (map conDeclBinders cons)
- HsNewTypeDecl _ _ n _ con _ -> n : conDeclBinders con
- HsClassDecl _ qt _ decls -> exQtNm qt : collectNames decls
- HsTypeSig _ ns _ -> ns
- HsForeignImport _ _ _ _ n _ -> [n]
- _ -> []
+ HsTypeDecl _ n _ _ _ -> [n]
+ HsDataDecl _ _ n _ cons _ _ -> n : concat (map conDeclBinders cons)
+ HsNewTypeDecl _ _ n _ con _ _ -> n : conDeclBinders con
+ HsClassDecl _ qt _ decls _ -> exQtNm qt : collectNames decls
+ HsTypeSig _ ns _ _ -> ns
+ HsForeignImport _ _ _ _ n _ _ -> [n]
+ _ -> []
conDeclBinders (HsConDecl _ n _ _ _ _) = [n]
conDeclBinders (HsRecDecl _ n _ _ fields _) =
@@ -67,7 +68,7 @@ fieldDeclBinders (HsFieldDecl ns _ _) = ns
exQtNm (HsForAllType _ _ t) = nameOfQName (fst (splitTyConApp t))
exQtNm t = nameOfQName (fst (splitTyConApp t))
-splitTyConApp :: HsType -> (HsQName,[HsType])
+splitTyConApp :: HsType -> (HsQName, [HsType])
splitTyConApp t = split t []
where
split :: HsType -> [HsType] -> (HsQName,[HsType])
@@ -80,12 +81,12 @@ splitTyConApp t = split t []
restrictTo :: [HsName] -> HsDecl -> HsDecl
restrictTo names decl = case decl of
- HsDataDecl loc ctxt n xs cons drv ->
- 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 fds decls ->
- HsClassDecl loc qt fds (restrictDecls names decls)
+ HsDataDecl loc ctxt n xs cons drv doc ->
+ HsDataDecl loc ctxt n xs (restrictCons names cons) drv doc
+ HsNewTypeDecl loc ctxt n xs con drv doc ->
+ HsDataDecl loc ctxt n xs (restrictCons names [con]) drv doc
+ HsClassDecl loc qt fds decls doc ->
+ HsClassDecl loc qt fds (restrictDecls names decls) doc
_ -> decl
restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl]
@@ -100,6 +101,52 @@ restrictDecls names decls = filter keep decls
-- ToDo: not really correct
-- -----------------------------------------------------------------------------
+-- Extract documentation from a declaration
+
+declDoc (HsTypeDecl _ _ _ _ d) = d
+declDoc (HsDataDecl _ _ _ _ _ _ d) = d
+declDoc (HsNewTypeDecl _ _ _ _ _ _ d) = d
+declDoc (HsClassDecl _ _ _ _ d) = d
+declDoc (HsTypeSig _ _ _ d) = d
+declDoc (HsForeignImport _ _ _ _ _ _ d) = d
+declDoc _ = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Parsing module headers
+
+parseModuleHeader :: String -> (String, Maybe ModuleInfo)
+parseModuleHeader str =
+ case matchRegexAll moduleHeaderRE str of
+ Just (before, match, after, _, (_:_:_:s1:s2:s3:_)) ->
+ (after, Just (ModuleInfo {
+ portability = s3,
+ stability = s2,
+ maintainer = s1 }))
+ _other -> (str, Nothing)
+
+moduleHeaderRE = mkRegexWithOpts
+ "^([ \t\n]*Module[ \t]*:.*\n)?\
+ \([ \t\n]*Copyright[ \t]*:.*\n)?\
+ \([ \t\n]*License[ \t]*:.*\n)?\
+ \[ \t\n]*Maintainer[ \t]*:(.*)\n\
+ \[ \t\n]*Stability[ \t]*:(.*)\n\
+ \[ \t\n]*Portability[ \t]*:([^\n]*)\n"
+ True -- match "\n" with "."
+ False -- not case sensitive
+ -- All fields except the last (Portability) may be multi-line.
+ -- This is so that the portability field doesn't swallow up the
+ -- rest of the module documentation - we might want to revist
+ -- 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
+
+-- -----------------------------------------------------------------------------
-- Filename mangling functions stolen from GHC's main/DriverUtil.lhs.
type Suffix = String
@@ -159,3 +206,4 @@ mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
mapMaybeM f Nothing = return Nothing
mapMaybeM f (Just a) = f a >>= return . Just
+
diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs
index 505e07f8..c6026b67 100644
--- a/src/HsLexer.lhs
+++ b/src/HsLexer.lhs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: HsLexer.lhs,v 1.8 2002/05/09 12:45:19 simonmar Exp $
+-- $Id: HsLexer.lhs,v 1.9 2002/05/15 13:03:02 simonmar Exp $
--
-- (c) The GHC Team, 1997-2000
--
@@ -17,7 +17,7 @@ module HsLexer (Token(..), lexer, parseError,isSymbol) where
import HsParseMonad
import HsParseUtils
-import HsSyn(SrcLoc(..))
+import HsSyn
import Numeric ( readHex, readOct )
import Char
@@ -64,11 +64,11 @@ data Token
-- Documentation annotations
- | DocCommentNext String -- something beginning '-- |'
- | DocCommentPrev String -- something beginning '-- ^'
+ | DocCommentNext String -- something beginning '-- |'
+ | DocCommentPrev String -- something beginning '-- ^'
| DocCommentNamed String -- something beginning '-- $'
- | DocSection Int String -- a section heading
- | DocOptions String
+ | DocSection Int String -- a section heading
+ | DocOptions String -- attributes '-- #'
-- Reserved operators
@@ -280,10 +280,9 @@ lexToken cont s loc y x =
-- trace ("lexer: y="++show y++" x="++show x++"\n") $
case s of
-- First the doc comments
- '-':'-':' ':s -> do_doc s docComment
-
- '{':'-':' ':s -> do_doc s nestedDocComment
- '{':'-':s -> do_doc s nestedDocComment
+ '-':'-':' ':s -> do_doc s False
+ '{':'-':' ':s -> do_doc s True
+ '{':'-':s -> do_doc s True
-- Next the special symbols
'(':'#':s -> forward 2 LeftUT s
@@ -346,16 +345,21 @@ lexToken cont s loc y x =
where forward n t s = cont t s loc y (x+n)
- do_doc ('|':s) f = f DocCommentNext cont s loc y x
- do_doc ('/':s) f = f DocCommentNext cont s loc y x
- do_doc ('^':s) f = f DocCommentPrev cont s loc y x
- do_doc ('$':s) f = f DocCommentNamed cont s loc y x
- do_doc ('#':s) f = f DocOptions cont s loc y x
- do_doc ('*':s) f = section 1 s
+ -- this is all terribly ugly, sorry :(
+ do_doc ('|':s) nested = multi nested DocCommentNext cont s loc y x
+ do_doc ('/':s) nested = multi nested DocCommentNext cont s loc y x
+ do_doc ('^':s) nested = multi nested DocCommentPrev cont s loc y x
+ do_doc ('$':s) nested = multi nested DocCommentNamed cont s loc y x
+ do_doc ('#':s) nested = multi nested DocOptions cont s loc y x
+ do_doc ('*':s) nested = section 1 s
where section n ('*':s) = section (n+1) s
- section n s = f (DocSection n) cont s loc y x
+ section n s
+ | nested = nestedDocComment (DocSection n) cont s loc y x
+ | otherwise = oneLineDocComment (DocSection n) cont s loc y x
do_doc _ _ = error "Internal error: HsLexer.do_doc"
+multi True = nestedDocComment
+multi False = multiLineDocComment
afterNum cont i ('#':s) loc y x = cont (PrimInt i) s loc y (x+1)
afterNum cont i s loc y x = cont (IntTok i) s loc y x
@@ -593,10 +597,13 @@ nestedDocComment f cont s loc y x = go f cont "" y x s
c:s -> go f cont (c:acc) y (x+1) s
[] -> error "Internal error: nestedComment"
+oneLineDocComment f cont s loc y x
+ = cont (f line) rest loc y x -- continue with the newline char
+ where (line, rest) = break (== '\n') s
-docComment f cont s loc y x
- = let (s', comment, y') = slurpExtraCommentLines s [] y in
- cont (f comment) s' loc y' x -- continue with the newline char
+multiLineDocComment f cont s loc y x
+ = cont (f comment) s' loc y' x -- continue with the newline char
+ where (s', comment, y') = slurpExtraCommentLines s [] y
slurpExtraCommentLines s lines y
= case rest of
diff --git a/src/HsParser.ly b/src/HsParser.ly
index b2d4eea6..9b47f117 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.10 2002/05/09 12:43:06 simonmar Exp $
+$Id: HsParser.ly,v 1.11 2002/05/15 13:03:02 simonmar Exp $
-(c) Simon Marlow, Sven Panne 1997-2000
+(c) Simon Marlow, Sven Panne 1997-2002
Haskell grammar.
-----------------------------------------------------------------------------
@@ -21,14 +21,10 @@ ToDo: Differentiate between record updates and labeled construction.
> import HsParseMonad
> import HsLexer
> import HsParseUtils
->
-> #ifdef __HUGS__
-> {-
-> #endif
-> import GlaExts
-> #ifdef __HUGS__
-> -}
-> #endif
+> import HaddockLex hiding (Token)
+> import HaddockParse
+> import HaddockUtil ( parseModuleHeader )
+> import Char ( isSpace )
> }
-----------------------------------------------------------------------------
@@ -71,7 +67,7 @@ Docs
> DOCNEXT { DocCommentNext $$ }
> DOCPREV { DocCommentPrev $$ }
> DOCNAMED { DocCommentNamed $$ }
-> DOCGROUP { DocSection _ _ }
+> DOCSECTION { DocSection _ _ }
> DOCOPTIONS { DocOptions $$ }
Symbols
@@ -153,18 +149,19 @@ Module Header
> module :: { HsModule }
> : optdoc 'module' modid maybeexports 'where' body
-> { HsModule $3 $4 (reverse (fst $6)) (reverse (snd $6))
-> (fst $1) (snd $1) }
+> { case $1 of { (opts,info,doc) ->
+> HsModule $3 $4 (reverse (fst $6)) (reverse (snd $6))
+> opts info doc } }
> | body
> { HsModule main_mod Nothing (reverse (fst $1)) (reverse (snd $1))
-> Nothing Nothing }
+> Nothing Nothing Nothing }
-> optdoc :: { (Maybe String, Maybe String) }
-> : DOCNEXT { (Nothing, Just $1) }
-> | DOCOPTIONS { (Just $1, Nothing) }
-> | DOCOPTIONS DOCNEXT { (Just $1, Just $2) }
-> | DOCNEXT DOCOPTIONS { (Just $2, Just $1) }
-> | {- empty -} { (Nothing, Nothing) }
+> optdoc :: { (Maybe String, Maybe ModuleInfo, Maybe Doc) }
+> : moduleheader { (Nothing, fst $1, snd $1) }
+> | DOCOPTIONS { (Just $1, Nothing, Nothing) }
+> | DOCOPTIONS moduleheader { (Just $1, fst $2, snd $2) }
+> | moduleheader DOCOPTIONS { (Just $2, fst $1, snd $1) }
+> | {- empty -} { (Nothing, Nothing, Nothing) }
> body :: { ([HsImportDecl],[HsDecl]) }
> : '{' bodyaux '}' { $2 }
@@ -193,14 +190,14 @@ The Export List
> exportlist :: { [HsExportSpec] }
> : export ',' exportlist { $1 : $3 }
> | docgroup exportlist { $1 : $2 }
-> | DOCNAMED exportlist { HsEDocNamed $1 : $2 }
-> | DOCNEXT exportlist { HsEDoc $1 : $2 }
+> | docnamed exportlist { HsEDocNamed (fst $1) : $2 }
+> | docnext exportlist { HsEDoc $1 : $2 }
> | ',' exportlist { $2 }
> | export { [$1] }
> | {- empty -} { [] }
> docgroup :: { HsExportSpec }
-> : DOCGROUP { case $1 of { DocSection i s -> HsEGroup i s } }
+> : docsection { case $1 of { (i,s) -> HsEGroup i s } }
> export :: { HsExportSpec }
> : qvar { HsEVar $1 }
@@ -299,19 +296,19 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
> topdecl :: { HsDecl }
> : 'type' simpletype srcloc '=' ctype
-> { HsTypeDecl $3 (fst $2) (snd $2) $5 }
+> { 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 (reverse $4) $5) }
+> {% checkDataHeader $2 `thenP` \(cs,c,t) ->
+> returnP (HsDataDecl $3 cs c t (reverse $4) $5 Nothing) }
> | 'newtype' ctype srcloc '=' constr deriving
-> {% checkDataHeader $2 `thenP` \(cs,c,t) ->
-> returnP (HsNewTypeDecl $3 cs c t $5 $6) }
+> {% checkDataHeader $2 `thenP` \(cs,c,t) ->
+> returnP (HsNewTypeDecl $3 cs c t $5 $6 Nothing) }
> | 'class' srcloc ctype fds optcbody
-> { HsClassDecl $2 $3 $4 $5}
+> { HsClassDecl $2 $3 $4 $5 Nothing}
> | 'instance' srcloc ctype optvaldefs
-> { HsInstDecl $2 $3 $4 }
+> { HsInstDecl $2 $3 $4 }
> | 'default' srcloc '(' typelist ')'
-> { HsDefaultDecl $2 $4 }
+> { HsDefaultDecl $2 $4 }
> | 'foreign' fdecl { $2 }
> | decl { $1 }
@@ -329,21 +326,21 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
> | decl { [$1] }
> decl :: { HsDecl }
-> : signdecl { $1 }
-> | fixdecl { $1 }
-> | valdef { $1 }
-> | DOCNEXT { HsDocCommentNext $1 }
-> | DOCPREV { HsDocCommentPrev $1 }
-> | DOCNAMED { HsDocCommentNamed $1 }
-> | DOCGROUP { case $1 of { DocSection i s ->
-> HsDocGroup i s } }
+> : signdecl { $1 }
+> | fixdecl { $1 }
+> | valdef { $1 }
+> | 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 '::' ctype { HsTypeSig $2 (reverse $1) $4 }
+> : 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
@@ -366,9 +363,9 @@ Foreign Declarations
> fdecl :: { HsDecl }
> fdecl : srcloc 'import' callconv safety fspec
-> { case $5 of (spec,nm,ty) -> HsForeignImport $1 $3 $4 spec nm ty }
+> { 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 }
+> { 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 }
@@ -383,14 +380,22 @@ Foreign Declarations
> | 'threadsafe' { HsFIThreadSafe }
> fspec :: { (String, HsName, HsType) }
-> : STRING varid '::' ctype { ($1, $2, $4) }
-> | varid '::' ctype { ("", $1, $3) }
+> : 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 }
-> : btype '->' type { HsTyFun $1 $3 }
+> : btype '->' type { HsTyFun $1 $3 }
> | btype { $1 }
> btype :: { HsType }
@@ -429,6 +434,11 @@ C a, or (C1 a, C2 b, ... Cn z) and convert it into a context. Blaach!
> | 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 :: { HsContext }
> : btype {% checkContext $1 }
@@ -472,14 +482,6 @@ Datatype declarations
> : scontype { $1 }
> | sbtype conop sbtype { ($2, [$1,$3]) }
-> maybe_docprev :: { Maybe String }
-> : DOCPREV { Just $1 }
-> | {- empty -} { Nothing }
-
-> maybe_docnext :: { Maybe String }
-> : DOCNEXT { Just $1 }
-> | {- empty -} { Nothing }
-
> scontype :: { (HsName, [HsBangType]) }
> : btype {% splitTyConApp $1 `thenP` \(c,ts) ->
> returnP (toVarHsName c,
@@ -927,6 +929,45 @@ Miscellaneous (mostly renamings)
> : 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 :: { (Maybe ModuleInfo, Maybe Doc) }
+> : DOCNEXT {% let (str, info) = parseModuleHeader $1 in
+> case parseParas (tokenise str) of {
+> Left err -> parseError err;
+> Right doc -> returnP (info, Just doc); } }
+
+-----------------------------------------------------------------------------
> {
> happyError = parseError "Parse error"
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 069143f9..ecd2b0ce 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
% -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.8 2002/05/09 10:35:00 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.9 2002/05/15 13:03:02 simonmar Exp $
%
% (c) The GHC Team, 1997-2002
%
@@ -10,7 +10,7 @@
\begin{code}
module HsSyn (
SrcLoc(..), Module(..), HsQName(..), HsName(..), HsIdentifier(..),
- HsModule(..), HsExportSpec(..),
+ HsModule(..), HsExportSpec(..), ModuleInfo(..),
HsImportDecl(..), HsImportSpec(..), HsAssoc(..),
HsDecl(..), HsMatch(..), HsConDecl(..), HsFieldDecl(..),
HsBangType(..), HsRhs(..),
@@ -28,8 +28,13 @@ module HsSyn (
stdcall_name, ccall_name, dotnet_name,
unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name,
unit_tycon, fun_tycon, list_tycon, tuple_tycon,
+
+ GenDoc(..), Doc, DocMarkup(..),
+ markup, mapIdent,
+ docAppend, docParagraph,
) where
+import Char (isSpace)
data SrcLoc = SrcLoc Int Int -- (Line, Indentation)
deriving (Eq,Ord,Show)
@@ -72,8 +77,15 @@ instance Show HsIdentifier where
data HsModule = HsModule Module (Maybe [HsExportSpec])
[HsImportDecl] [HsDecl]
- (Maybe String) -- the doc options
- (Maybe String) -- the module doc
+ (Maybe String) -- the doc options
+ (Maybe ModuleInfo) -- the info (portability etc.)
+ (Maybe Doc) -- the module doc
+ deriving Show
+
+data ModuleInfo = ModuleInfo
+ { portability :: String,
+ stability :: String,
+ maintainer :: String }
deriving Show
-- Export/Import Specifications
@@ -84,8 +96,8 @@ data HsExportSpec
| HsEThingAll HsQName -- T(..)
| HsEThingWith HsQName [HsQName] -- T(C_1,...,C_n)
| HsEModuleContents Module -- module M (not for imports)
- | HsEGroup Int String -- a doc section heading
- | HsEDoc String -- some documentation
+ | HsEGroup Int Doc -- a doc section heading
+ | HsEDoc Doc -- some documentation
| HsEDocNamed String -- a reference to named doc
deriving (Eq,Show)
@@ -120,22 +132,37 @@ data HsCallConv
deriving (Eq,Show)
data HsDecl
- = HsTypeDecl SrcLoc HsName [HsName] HsType
- | HsDataDecl SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName]
- | HsInfixDecl SrcLoc HsAssoc Int [HsName]
- | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName]
- | HsClassDecl SrcLoc HsType [HsFunDep] [HsDecl]
- | HsInstDecl SrcLoc HsType [HsDecl]
- | HsDefaultDecl SrcLoc [HsType]
- | HsTypeSig SrcLoc [HsName] HsType
- | HsFunBind [HsMatch]
- | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl]
- | HsForeignImport SrcLoc HsCallConv HsFISafety String HsName HsType
- | HsForeignExport SrcLoc HsCallConv String HsName HsType
- | HsDocCommentNext String -- a documentation annotation
- | HsDocCommentPrev String -- a documentation annotation
- | HsDocCommentNamed String -- a documentation annotation
- | HsDocGroup Int String -- a documentation group
+ = HsTypeDecl SrcLoc HsName [HsName] HsType (Maybe Doc)
+
+ | HsDataDecl SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName]
+ (Maybe Doc)
+
+ | HsInfixDecl SrcLoc HsAssoc Int [HsName]
+
+ | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName]
+ (Maybe Doc)
+
+ | HsClassDecl SrcLoc HsType [HsFunDep] [HsDecl] (Maybe Doc)
+
+ | HsInstDecl SrcLoc HsType [HsDecl]
+
+ | HsDefaultDecl SrcLoc [HsType]
+
+ | HsTypeSig SrcLoc [HsName] HsType (Maybe Doc)
+
+ | HsFunBind [HsMatch]
+
+ | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl]
+
+ | HsForeignImport SrcLoc HsCallConv HsFISafety String HsName HsType
+ (Maybe Doc)
+
+ | HsForeignExport SrcLoc HsCallConv String HsName HsType
+
+ | HsDocCommentNext SrcLoc Doc -- a documentation annotation
+ | HsDocCommentPrev SrcLoc Doc -- a documentation annotation
+ | HsDocCommentNamed SrcLoc String Doc -- a documentation annotation
+ | HsDocGroup SrcLoc Int Doc -- a documentation group
deriving (Eq,Show)
data HsMatch
@@ -143,12 +170,12 @@ data HsMatch
deriving (Eq,Show)
data HsConDecl
- = HsConDecl SrcLoc HsName [HsName] HsContext [HsBangType] (Maybe String)
- | HsRecDecl SrcLoc HsName [HsName] HsContext [HsFieldDecl] (Maybe String)
+ = HsConDecl SrcLoc HsName [HsName] HsContext [HsBangType] (Maybe Doc)
+ | HsRecDecl SrcLoc HsName [HsName] HsContext [HsFieldDecl] (Maybe Doc)
deriving (Eq,Show)
data HsFieldDecl
- = HsFieldDecl [HsName] HsBangType (Maybe String)
+ = HsFieldDecl [HsName] HsBangType (Maybe Doc)
deriving (Eq,Show)
data HsBangType
@@ -172,6 +199,7 @@ data HsType
| HsTyApp HsType HsType
| HsTyVar HsName
| HsTyCon HsQName
+ | HsTyDoc HsType Doc
deriving (Eq,Show)
type HsFunDep = ([HsName], [HsName])
@@ -317,4 +345,106 @@ unit_tycon = HsTyCon unit_tycon_name
fun_tycon = HsTyCon fun_tycon_name
list_tycon = HsTyCon list_tycon_name
tuple_tycon i = HsTyCon (tuple_tycon_name i)
+
+-- -----------------------------------------------------------------------------
+-- Doc strings and formatting
+
+data GenDoc id
+ = DocEmpty
+ | DocAppend (GenDoc id) (GenDoc id)
+ | DocString String
+ | DocParagraph (GenDoc id)
+ | DocIdentifier id
+ | DocModule String
+ | DocEmphasis (GenDoc id)
+ | DocMonospaced (GenDoc id)
+ | DocUnorderedList [GenDoc id]
+ | DocOrderedList [GenDoc id]
+ | DocCodeBlock (GenDoc id)
+ | DocURL String
+ deriving (Eq, Show)
+
+type Doc = GenDoc [HsQName]
+
+-- | DocMarkup is a set of instructions for marking up documentation.
+-- In fact, it's really just a mapping from 'GenDoc' to some other
+-- type [a], where [a] is usually the type of the output (HTML, say).
+
+data DocMarkup id a = Markup {
+ markupEmpty :: a,
+ markupString :: String -> a,
+ markupParagraph :: a -> a,
+ markupAppend :: a -> a -> a,
+ markupIdentifier :: id -> a,
+ markupModule :: String -> a,
+ markupEmphasis :: a -> a,
+ markupMonospaced :: a -> a,
+ markupUnorderedList :: [a] -> a,
+ markupOrderedList :: [a] -> a,
+ markupCodeBlock :: a -> a,
+ markupURL :: String -> a
+ }
+
+markup :: DocMarkup id a -> GenDoc id -> a
+markup m DocEmpty = markupEmpty m
+markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
+markup m (DocString s) = markupString m s
+markup m (DocParagraph d) = markupParagraph m (markup m d)
+markup m (DocIdentifier i) = markupIdentifier m i
+markup m (DocModule mod) = markupModule m mod
+markup m (DocEmphasis d) = markupEmphasis m (markup m d)
+markup m (DocMonospaced d) = markupMonospaced m (markup m d)
+markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
+markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
+markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
+markup m (DocURL url) = markupURL m url
+
+-- | Since marking up is just a matter of mapping 'Doc' into some
+-- other type, we can \'rename\' documentation by marking up 'Doc' into
+-- the same thing, modifying only the identifiers embedded in it.
+mapIdent f = Markup {
+ markupEmpty = DocEmpty,
+ markupString = DocString,
+ markupParagraph = DocParagraph,
+ markupAppend = DocAppend,
+ markupIdentifier = f,
+ markupModule = DocModule,
+ markupEmphasis = DocEmphasis,
+ markupMonospaced = DocMonospaced,
+ markupUnorderedList = DocUnorderedList,
+ markupOrderedList = DocOrderedList,
+ markupCodeBlock = DocCodeBlock,
+ markupURL = DocURL
+ }
+
+-- -----------------------------------------------------------------------------
+-- ** Smart constructors
+
+-- used to make parsing easier; we group the list items later
+docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
+ = DocUnorderedList (ds1++ds2)
+docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
+ = DocAppend (DocUnorderedList (ds1++ds2)) d
+docAppend (DocOrderedList ds1) (DocOrderedList ds2)
+ = DocOrderedList (ds1++ds2)
+docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
+ = DocAppend (DocOrderedList (ds1++ds2)) d
+docAppend DocEmpty d = d
+docAppend d DocEmpty = d
+docAppend d1 d2
+ = DocAppend d1 d2
+
+-- again to make parsing easier - we spot a paragraph whose only item
+-- is a DocMonospaced and make it into a DocCodeBlock
+docParagraph (DocMonospaced p)
+ = DocCodeBlock p
+docParagraph (DocAppend (DocString s1) (DocMonospaced p))
+ | all isSpace s1
+ = DocCodeBlock p
+docParagraph (DocAppend (DocString s1)
+ (DocAppend (DocMonospaced p) (DocString s2)))
+ | all isSpace s1 && all isSpace s2
+ = DocCodeBlock p
+docParagraph p
+ = DocParagraph p
\end{code}
diff --git a/src/Main.hs b/src/Main.hs
index 7a2ad007..96425a46 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -8,14 +8,12 @@ module Main (main) where
import HaddockRename
import HaddockParse
-import HaddockLex
-import HaddockDB
+--import HaddockDB -- not compiling
import HaddockHtml
import HaddockTypes
import HaddockUtil
import Digraph
-import HsLexer hiding (Token)
import HsParser
import HsParseMonad
import HsSyn
@@ -25,8 +23,7 @@ import FiniteMap
--import Pretty
-import RegexString
-import Maybe ( maybeToList )
+import Maybe ( isJust, maybeToList )
import List ( nub )
import Monad ( when )
import Char ( isSpace )
@@ -126,8 +123,8 @@ run flags files = do
module_map <- loop emptyFM sorted_mods files
let mod_ifaces = fmToList module_map
- when (Flag_DocBook `elem` flags) $
- putStr (ppDocBook odir mod_ifaces)
+-- when (Flag_DocBook `elem` flags) $
+-- putStr (ppDocBook odir mod_ifaces)
when (Flag_Html `elem` flags) $
ppHtml title source_url mod_ifaces odir css_file libdir
@@ -155,7 +152,7 @@ mkInterface
)
mkInterface mod_map filename
- (HsModule mod exps imps decls maybe_opts maybe_doc) = do
+ (HsModule mod exps imps decls maybe_opts maybe_info maybe_doc) = do
-- Process the options, if available
options <- case maybe_opts of
@@ -163,13 +160,17 @@ mkInterface mod_map filename
Nothing -> return []
let
- locally_defined_names = collectNames decls
+ -- first, attach documentation to declarations
+ annotated_decls = collectDoc decls
+
+ -- now find the defined names
+ locally_defined_names = collectNames annotated_decls
qual_local_names = map (Qual mod) locally_defined_names
unqual_local_names = map UnQual locally_defined_names
local_env = listToFM (zip unqual_local_names qual_local_names ++
- zip qual_local_names qual_local_names)
+ zip qual_local_names qual_local_names)
-- both qualified and unqualifed names are in scope for local things
-- build the orig_env, which maps names to *original* names (so we can
@@ -184,7 +185,7 @@ mkInterface mod_map filename
= runRnFM orig_env (mapMaybeM renameExportList exps)
(orig_decls, missing_names2)
- = runRnFM orig_env (mapM renameDecl decls)
+ = runRnFM orig_env (mapM renameDecl annotated_decls)
orig_decl_map :: FiniteMap HsName HsDecl
orig_decl_map = listToFM [ (n,d) | d <- orig_decls, n <- declBinders d ]
@@ -194,45 +195,9 @@ mkInterface mod_map filename
locally_defined_names orig_exports
orig_decl_map options
- -- Parse the module header
- (module_doc, maybe_info, missing_names_doc1) <-
- case maybe_doc of
- Nothing -> return (Nothing, Nothing, [])
- Just doc -> do
- let (doc1, maybe_info) = parseModuleHeader doc
- (doc2,ns) <- formatDocString mod (lookupForDoc import_env) doc1
- return (Just doc2, maybe_info, ns)
-
let
final_decls = concat (map expandDecl orig_decls)
- -- match documentation to names, and resolve identifiers in the
- -- documentation
- local_docstrings :: [(HsName,DocString)]
- local_docstrings = collectDoc final_decls
-
- formatLocalDoc (n,doc) = do
- doc' <- formatDocString mod (lookupForDoc orig_env) doc
- return (n,doc')
-
- local_docs_formatted <- mapM formatLocalDoc local_docstrings
-
- let
- local_docs :: [(HsName,Doc)] -- with *original* names
- local_docs = [ (n,doc) | (n,(doc,_)) <- local_docs_formatted ]
-
- -- collect the list of names which we couldn't resolve in the documentation
- missing_names_doc2 = concat [ ns | (n,(doc,ns)) <- local_docs_formatted ]
-
- -- get the documentation associated with entities exported from this module
- -- ToDo: we should really store the documentation in both orig and imported
- -- forms, like the export items.
- doc_map :: FiniteMap HsName Doc -- with *imported* names
- doc_map = listToFM
- [ (nameOfQName n, doc)
- | n <- exported_names,
- Just doc <- [lookupDoc mod_map mod local_docs import_env n] ]
-
decl_map :: FiniteMap HsName HsDecl
decl_map = listToFM [ (n,d) | d <- final_decls, n <- declBinders d ]
@@ -244,23 +209,21 @@ mkInterface mod_map filename
-- prune the export list to just those declarations that have
-- documentation, if the 'prune' option is on.
pruned_export_list
- | OptPrune `elem` options = pruneExportItems doc_map orig_export_list
+ | OptPrune `elem` options = pruneExportItems orig_export_list
| otherwise = orig_export_list
-- rename names in the exported declarations to point to things that
-- are closer, or maybe even exported by, the current module.
- (renamed_export_list, missing_names3)
+ (renamed_export_list, _missing_names3)
= runRnFM import_env (renameExportItems pruned_export_list)
name_env = listToFM [ (nameOfQName n, n) | n <- exported_names ]
-- report any names we couldn't find/resolve
- let missing_names_doc = missing_names_doc1 ++ missing_names_doc2
- missing_names = missing_names1 ++ missing_names2
+ let missing_names = missing_names1 ++ missing_names2
--ignore missing_names3 for now,
-
- name_strings = nub (map show missing_names ++ missing_names_doc)
+ name_strings = nub (map show missing_names)
when (not (null name_strings)) $
tell ["Warning: in module " ++ show mod ++
@@ -269,40 +232,18 @@ mkInterface mod_map filename
]
return (mod, Interface {
- iface_filename = filename,
- iface_env = name_env,
- iface_exports = renamed_export_list,
+ iface_filename = filename,
+ iface_env = name_env,
+ iface_exports = renamed_export_list,
iface_orig_exports = pruned_export_list,
- iface_decls = decl_map,
- iface_info = maybe_info,
- iface_name_docs = doc_map,
- iface_doc = module_doc,
- iface_options = options
+ iface_decls = decl_map,
+ iface_info = maybe_info,
+ iface_doc = maybe_doc,
+ iface_options = options
}
)
-- -----------------------------------------------------------------------------
--- Find the documentation for a particular name, and rename the
--- original identifiers embedded in it to imported names.
-
-lookupDoc :: ModuleMap -> Module -> [(HsName,Doc)]
- -> FiniteMap HsQName HsQName -> HsQName -> Maybe Doc
-lookupDoc mod_map this_mod local_doc env name
- = case name of
- UnQual n -> Nothing
- Qual mod n
- | mod == this_mod ->
- fst (runRnFM env (mapMaybeM renameDoc (lookup n local_doc)))
- -- ToDo: report missing names
- | otherwise ->
- case lookupFM mod_map mod of
- Nothing -> Nothing
- Just iface ->
- fst (runRnFM env (mapMaybeM renameDoc
- (lookupFM (iface_name_docs iface) n)))
- -- ToDo: report missing names
-
--- -----------------------------------------------------------------------------
-- Build the list of items that will become the documentation, from the
-- export list. At the same time we rename *original* names in the declarations
-- to *imported* names.
@@ -327,8 +268,8 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
lookupExport (HsEVar x)
| Just decl <- findDecl x
- = let decl' | HsTypeSig loc ns ty <- decl
- = HsTypeSig loc [nameOfQName x] ty
+ = let decl' | HsTypeSig loc ns ty doc <- decl
+ = HsTypeSig loc [nameOfQName x] ty doc
| otherwise
= decl
in
@@ -344,21 +285,15 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
| Just decl <- findDecl t
= return [ ExportDecl (restrictTo (map nameOfQName cs) decl) ]
lookupExport (HsEModuleContents m) = fullContentsOf m
- lookupExport (HsEGroup lev str)
- = do (doc, _names) <- formatDocHeading mod (lookupForDoc env) str
- return [ ExportGroup lev "" doc ]
- -- ToDo: report the unresolved names
- lookupExport (HsEDoc str)
- = do (doc, _names) <- formatDocString mod (lookupForDoc env) str
- return [ ExportDoc doc ]
- -- ToDo: report the unresolved names
+ lookupExport (HsEGroup lev doc)
+ = return [ ExportGroup lev "" doc ]
+ lookupExport (HsEDoc doc)
+ = return [ ExportDoc doc ]
lookupExport (HsEDocNamed str)
= do r <- findNamedDoc str decls
case r of
Nothing -> return []
- Just found -> do
- (doc, _nms) <- formatDocString mod (lookupForDoc env) found
- return [ ExportDoc doc ]
+ Just found -> return [ ExportDoc found ]
lookupExport _ = return [] -- didn't find it?
@@ -385,12 +320,10 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
fullContentsOfThisModule mod decls env =
mapM mkExportItem (filter keepDecl decls)
- where mkExportItem (HsDocGroup lev str) = do
- (doc, _names) <- formatDocHeading mod (lookupForDoc env) str
+ where mkExportItem (HsDocGroup loc lev doc) =
return (ExportGroup lev "" doc)
- -- ToDo: report the unresolved names
- mkExportItem decl = return (ExportDecl decl)
-
+ mkExportItem decl =
+ return (ExportDecl decl)
keepDecl HsTypeSig{} = True
keepDecl HsTypeDecl{} = True
@@ -403,9 +336,9 @@ keepDecl _ = False
-- -----------------------------------------------------------------------------
-- Pruning
-pruneExportItems :: FiniteMap HsName Doc -> [ExportItem] -> [ExportItem]
-pruneExportItems doc_map items = filter has_doc items
- where has_doc (ExportDecl d) | Just n <- declMainBinder d = n `elemFM` doc_map
+pruneExportItems :: [ExportItem] -> [ExportItem]
+pruneExportItems items = filter has_doc items
+ where has_doc (ExportDecl d) = isJust (declDoc d)
has_doc _ = True
-- -----------------------------------------------------------------------------
@@ -487,190 +420,72 @@ buildEnv mod_map this_mod exported_names (HsImportDecl _ mod qual maybe_as _)
-- Expand multiple type signatures
expandDecl :: HsDecl -> [HsDecl]
-expandDecl (HsTypeSig loc fs qt) = [ HsTypeSig loc [f] qt | f <- fs ]
-expandDecl (HsClassDecl loc ty fds decls)
- = [ HsClassDecl loc ty fds (concat (map expandDecl decls)) ]
+expandDecl (HsTypeSig loc fs qt doc) = [ HsTypeSig loc [f] qt doc | f <- fs ]
+expandDecl (HsClassDecl loc ty fds decls doc)
+ = [ HsClassDecl loc ty fds (concat (map expandDecl decls)) doc ]
expandDecl d = [ d ]
-----------------------------------------------------------------------------
--- Collecting documentation and associating it with declarations
+-- Collecting documentation and attach it to the right declarations
-collectDoc :: [HsDecl] -> [(HsName, DocString)]
-collectDoc decls = collect Nothing "" decls
+collectDoc :: [HsDecl] -> [HsDecl]
+collectDoc decls = collect Nothing DocEmpty decls
-collect name doc_so_far [] =
- case name of
+collect d doc_so_far [] =
+ case d of
Nothing -> []
- Just n -> finishedDoc n doc_so_far []
+ Just d -> finishedDoc d doc_so_far []
-collect name doc_so_far (decl:ds) =
+collect d doc_so_far (decl:ds) =
case decl of
- HsDocCommentNext str ->
- case name of
- Nothing -> collect name (doc_so_far ++ str) ds
- Just n -> finishedDoc n doc_so_far (collect Nothing str ds)
+ HsDocCommentNext loc str ->
+ case d of
+ Nothing -> collect d (docAppend doc_so_far str) ds
+ Just d -> finishedDoc d doc_so_far (collect Nothing str ds)
- HsDocCommentPrev str -> collect name (doc_so_far ++ str) ds
+ HsDocCommentPrev loc str -> collect d (docAppend doc_so_far str) ds
_other ->
- docsFromDecl decl ++
- case name of
- Nothing -> collect bndr doc_so_far ds
- Just n -> finishedDoc n doc_so_far (collect bndr "" ds)
- where
- bndr = declMainBinder decl
-
-finishedDoc n s rest | all isSpace s = rest
- | otherwise = (n,s) : rest
-
--- look inside a declaration and get docs for the bits
--- (constructors, record fields, class methods)
-docsFromDecl :: HsDecl -> [(HsName, DocString)]
-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 fds decls)
- = collect Nothing "" decls
-docsFromDecl _
- = []
-
-docsFromConDecl :: HsConDecl -> [(HsName, DocString)]
-docsFromConDecl (HsConDecl loc nm tvs ctxt tys (Just doc))
- = finishedDoc nm doc []
-docsFromConDecl (HsRecDecl loc nm tvs ctxt fields (Just doc))
- = finishedDoc nm doc (foldr docsFromField [] fields)
-docsFromConDecl (HsRecDecl loc nm tvs ctxt fields Nothing)
- = foldr docsFromField [] fields
-docsFromConDecl _
- = []
-
-docsFromField (HsFieldDecl nms ty (Just doc)) rest
- = foldr (\n -> finishedDoc n doc) rest nms
-docsFromField (HsFieldDecl nms ty Nothing) rest
- = rest
-
------------------------------------------------------------------------------
--- formatting is done in two stages. Firstly we partially apply
--- formatDocString to the lookup function and the DocString to get a
--- markup-independent string. Finally the back ends apply the markup
--- description to this function to get the marked-up text.
-
--- this one formats a heading
-formatDocHeading :: Module -> (String -> Maybe HsQName) -> DocString
- -> ErrMsgM (Doc,[String])
-formatDocHeading mod lookup string = format mod parseString lookup string
-
--- this one formats a sequence of paragraphs
-formatDocString :: Module -> (String -> Maybe HsQName) -> DocString
- -> ErrMsgM (Doc,[String])
-formatDocString mod lookup string = format mod parseParas lookup string
-
-format :: Module -- for error messages only
- -> ([Token] -> Either String ParsedDoc)
- -> (String -> Maybe HsQName)
- -> DocString
- -> ErrMsgM (Doc, [String])
-format mod parse lookup string
- = case parse (tokenise string) of
- Left error -> do
- tell ["Warning: in " ++ show mod ++
- ", parse error in doc string beginning:\n\
- \ " ++ take 40 string]
- return (DocEmpty, [])
- Right doc ->
- return (runRn lookup (resolveDoc doc))
-
--- ---------------------------------------------------------------------------
--- Looking up names in documentation
-
-lookupForDoc :: FiniteMap HsQName HsQName -> (String -> Maybe HsQName)
-lookupForDoc fm str
- = case [ n | Just n <- map (lookupFM fm) (strToHsQNames str) ] of
- (n:_) -> Just n
- [] -> Nothing
-
-strToHsQNames :: String -> [ HsQName ]
-strToHsQNames str
- = case lexer (\t -> returnP t) str (SrcLoc 1 1) 1 1 [] of
- Ok _ (VarId str)
- -> [ UnQual (HsVarName (HsIdent str)) ]
- Ok _ (QVarId (mod,str))
- -> [ Qual (Module mod) (HsVarName (HsIdent str)) ]
- Ok _ (ConId str)
- -> [ UnQual (HsTyClsName (HsIdent str)),
- UnQual (HsVarName (HsIdent str)) ]
- Ok _ (QConId (mod,str))
- -> [ Qual (Module mod) (HsTyClsName (HsIdent str)),
- Qual (Module mod) (HsVarName (HsIdent str)) ]
- Ok _ (VarSym str)
- -> [ UnQual (HsVarName (HsSymbol str)) ]
- Ok _ (ConSym str)
- -> [ UnQual (HsTyClsName (HsSymbol str)),
- UnQual (HsVarName (HsSymbol str)) ]
- Ok _ (QVarSym (mod,str))
- -> [ Qual (Module mod) (HsVarName (HsSymbol str)) ]
- Ok _ (QConSym (mod,str))
- -> [ Qual (Module mod) (HsTyClsName (HsSymbol str)),
- Qual (Module mod) (HsVarName (HsSymbol str)) ]
- other -> []
-
--- -----------------------------------------------------------------------------
--- Parsing module headers
-
-parseModuleHeader :: String -> (String, Maybe ModuleInfo)
-parseModuleHeader str =
- case matchRegexAll moduleHeaderRE str of
- Just (before, match, after, _, (_:_:_:s1:s2:s3:_)) ->
- (after, Just (ModuleInfo {
- portability = s3,
- stability = s2,
- maintainer = s1 }))
- _other -> (str, Nothing)
-
-moduleHeaderRE = mkRegexWithOpts
- "^([ \t\n]*Module[ \t]*:.*\n)?\
- \([ \t\n]*Copyright[ \t]*:.*\n)?\
- \([ \t\n]*License[ \t]*:.*\n)?\
- \[ \t\n]*Maintainer[ \t]*:(.*)\n\
- \[ \t\n]*Stability[ \t]*:(.*)\n\
- \[ \t\n]*Portability[ \t]*:([^\n]*)\n"
- True -- match "\n" with "."
- False -- not case sensitive
- -- All fields except the last (Portability) may be multi-line.
- -- This is so that the portability field doesn't swallow up the
- -- rest of the module documentation - we might want to revist
- -- 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
+ let decl' = collectInDecl decl in
+ case d of
+ Nothing -> collect (Just decl') doc_so_far ds
+ Just d -> finishedDoc d doc_so_far (collect (Just decl') DocEmpty ds)
+
+finishedDoc d DocEmpty rest = d : rest
+finishedDoc d doc rest = d' : rest
+ where d' =
+ case d of
+ HsTypeDecl loc n ns ty _ ->
+ HsTypeDecl loc n ns ty (Just doc)
+ HsDataDecl loc ctxt n ns cons drv _ ->
+ HsDataDecl loc ctxt n ns cons drv (Just doc)
+ HsNewTypeDecl loc ctxt n ns con drv _ ->
+ HsNewTypeDecl loc ctxt n ns con drv (Just doc)
+ HsClassDecl loc ty fds meths _ ->
+ HsClassDecl loc ty fds meths (Just doc)
+ HsTypeSig loc ns ty _ ->
+ HsTypeSig loc ns ty (Just doc)
+ HsForeignImport loc cc sf str n ty _ ->
+ HsForeignImport loc cc sf str n ty (Just doc)
+ _other -> d
+
+collectInDecl (HsClassDecl loc ty fds meths doc)
+ = HsClassDecl loc ty fds (collect Nothing DocEmpty meths) doc
+collectInDecl decl
+ = decl
-- -----------------------------------------------------------------------------
-- Named documentation
-findNamedDoc :: String -> [HsDecl] -> ErrMsgM (Maybe String)
-findNamedDoc str decls =
- case matchRegex docNameRE str of
- Just (name:_) -> search decls
+findNamedDoc :: String -> [HsDecl] -> ErrMsgM (Maybe Doc)
+findNamedDoc name decls = search decls
where search [] = do
tell ["Cannot find documentation for: $" ++ name]
return Nothing
- search (HsDocCommentNamed str : rest) =
- case matchRegexAll docNameRE str of
- Just (_, _, after, _, name':_)
- | name == name' -> return (Just after)
- _otherwise -> search rest
+ search (HsDocCommentNamed loc name' doc : rest)
+ | name == name' = return (Just doc)
+ | otherwise = search rest
search (_other_decl : rest) = search rest
- _other -> do
- tell ["Invalid documentation name: $" ++ str]
- return Nothing
-
-docNameRE = mkRegex "[ \t]*([A-Za-z0-9_]*)"
-- -----------------------------------------------------------------------------
-- Haddock options embedded in the source file
@@ -702,13 +517,13 @@ sortModules hsmodules = mapM for_each_scc sccs
edges :: [(HsModule, Module, [Module])]
edges = [ (hsmod, mod, [ imp | HsImportDecl _ imp _ _ _ <- impdecls ])
- | hsmod@(HsModule mod _ impdecls _ _ _) <- hsmodules
+ | hsmod@(HsModule mod _ impdecls _ _ _ _) <- hsmodules
]
for_each_scc (AcyclicSCC hsmodule) = return hsmodule
for_each_scc (CyclicSCC hsmodules) =
dieMsg ("modules are recursive: " ++
- unwords (map show [ mod | HsModule mod _ _ _ _ _
+ unwords (map show [ mod | HsModule mod _ _ _ _ _ _
<- hsmodules ]))
-- -----------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-04 21:10:22 +0000