[haddock @ 2002-04-10 13:26:09 by simonmar]

Lots of changes, including:

- add index support to the HTML backend
- clean up the renamer, put it into a monad
- propogate unresolved names to the top level and report them in a nicer way
- various bugfixes

1 files changed, 199 insertions, 0 deletions

diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
new file mode 100644
index 00000000..4c5a631b
--- /dev/null
+++ b/src/HaddockRename.hs
@@ -0,0 +1,199 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2002
+--
+
+module HaddockRename (
+	RnM, runRn, runRnFM,	-- the monad (instance of Monad)
+
+	renameExportList, 
+	renameDecl,
+	renameExportItems,
+	renameDoc, resolveDoc,
+  ) where
+
+import HaddockTypes
+import HsSyn
+
+import FiniteMap
+import Monad
+
+-- -----------------------------------------------------------------------------
+-- Monad for renaming
+
+-- The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in 
+-- the environment.
+
+newtype GenRnM n a = RnM {unRn :: (n -> Maybe HsQName) -> (a,[n])}
+
+type RnM a = GenRnM HsQName a
+
+instance Monad (GenRnM n) where
+  (>>=) = thenRn
+  return = returnRn   
+
+returnRn a   = RnM (\lkp -> (a,[]))
+m `thenRn` k = RnM (\lkp -> case unRn m lkp of 
+				(a,out1) -> case unRn (k a) lkp of
+						(b,out2) -> (b,out1++out2))
+
+getLookupRn = RnM (\lkp -> (lkp,[]))
+outRn name = RnM (\lkp -> ((),[name]))
+
+lookupRn :: (HsQName -> a) -> HsQName -> RnM a
+lookupRn and_then name = do
+  lkp <- getLookupRn
+  case lkp name of
+	Nothing -> do outRn name; return (and_then name)
+	Just maps_to -> return (and_then maps_to)
+
+runRnFM :: FiniteMap HsQName HsQName -> RnM a -> (a,[HsQName])
+runRnFM env rn = unRn rn (lookupFM env)
+
+runRn :: (n -> Maybe HsQName) -> GenRnM n a -> (a,[n])
+runRn lkp rn = unRn rn lkp
+
+-- -----------------------------------------------------------------------------
+-- Renaming source code & documentation
+
+renameExportList :: [HsExportSpec] -> RnM [HsExportSpec]
+renameExportList spec = mapM renameExport spec
+  where
+    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 (HsEModuleContents m) = return (HsEModuleContents m)
+    renameExport (HsEGroup lev str) = return (HsEGroup lev str)
+
+renameDecl :: HsDecl -> RnM HsDecl
+renameDecl decl
+  = case decl of
+	HsTypeDecl loc t args ty -> do
+	    ty <- renameType ty
+	    return (HsTypeDecl loc t args ty)
+	HsDataDecl loc ctx t args cons drv -> do
+	    cons <- mapM renameConDecl cons
+	    return (HsDataDecl loc ctx t args cons drv)
+        HsNewTypeDecl loc ctx t args con drv -> do
+	    con <- renameConDecl con
+	    return (HsNewTypeDecl loc ctx t args con drv)
+        HsClassDecl loc qt decls -> do
+	    qt <- renameClassHead qt
+	    decls <- mapM renameDecl decls
+	    return (HsClassDecl loc qt decls)
+	HsTypeSig loc fs qt -> do
+	    qt <- renameType qt
+	    return (HsTypeSig loc fs qt)
+	HsForeignImport loc cc safe ent n ty -> do
+	    ty <- renameType ty
+	    return (HsForeignImport loc cc safe ent n ty)
+	_ -> 
+	    return decl
+
+renameClassHead (HsForAllType tvs ctx ty) = do
+  ctx <- mapM renamePred ctx
+  return (HsForAllType tvs ctx ty)
+renameClassHead ty = do
+  return ty
+
+renameConDecl (HsConDecl loc nm tys maybe_doc) = do
+  tys <- mapM renameBangTy tys
+  return (HsConDecl loc nm tys maybe_doc)
+renameConDecl (HsRecDecl loc nm fields maybe_doc) = do
+  fields <- mapM renameField fields
+  return (HsRecDecl loc nm fields maybe_doc)
+
+renameField (HsFieldDecl ns ty doc) = do 
+  ty <- renameBangTy ty
+  return (HsFieldDecl ns ty doc)
+
+renameBangTy (HsBangedTy ty)   = HsBangedTy   `liftM` renameType ty
+renameBangTy (HsUnBangedTy ty) = HsUnBangedTy `liftM` renameType ty
+
+renamePred (c,tys) = do
+  tys <- mapM renameType tys
+  lookupRn (\c' -> (c',tys)) c
+
+renameType (HsForAllType tvs ctx ty) = do
+  ctx <- mapM renamePred ctx
+  ty <- renameType ty
+  return (HsForAllType tvs ctx ty)
+renameType (HsTyFun arg res) = do
+  arg <- renameType arg
+  res <- renameType res
+  return (HsTyFun arg res)
+renameType (HsTyTuple b tys) = do
+  tys <- mapM renameType tys
+  return (HsTyTuple b tys)
+renameType (HsTyApp ty arg) = do
+  ty <- renameType ty
+  arg <- renameType arg
+  return (HsTyApp ty arg)
+renameType (HsTyVar nm) =
+  return (HsTyVar nm)
+renameType (HsTyCon nm) =
+  lookupRn HsTyCon nm
+
+-- -----------------------------------------------------------------------------
+-- 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 = Markup {
+  markupEmpty         = return DocEmpty,
+  markupString        = return . DocString,
+  markupParagraph     = liftM DocParagraph,
+  markupAppend        = liftM2 DocAppend,
+  markupIdentifier    = lookupRn DocIdentifier,
+  markupModule        = return . DocModule,
+  markupEmphasis      = liftM DocEmphasis,
+  markupMonospaced    = liftM DocMonospaced,
+  markupUnorderedList = liftM DocUnorderedList . sequence,
+  markupOrderedList   = liftM DocOrderedList . sequence,
+  markupCodeBlock     = liftM DocCodeBlock,
+  markupURL	      = return . DocURL
+  }
+
+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
+
+lookupIdString :: String -> GenRnM String Doc
+lookupIdString str = do
+  fn <- getLookupRn
+  case fn str of
+	Nothing -> return (DocString str)
+	Just n  -> return (DocIdentifier n)
+
+-- -----------------------------------------------------------------------------
+
+renameExportItems items = mapM rn items
+  where
+ 	rn (ExportGroup lev doc) 
+	   = do doc <- renameDoc doc
+	        return (ExportGroup lev doc)
+	rn (ExportDecl decl)
+	   = do decl <- renameDecl decl
+		return (ExportDecl decl)