[haddock @ 2002-05-15 13:03:01 by simonmar]

Reworking of the internals to support documenting function arguments
(the Most Wanted new feature by the punters).

The old method of keeping parsed documentation in a Name -> Doc
mapping wasn't going to cut it for anntations on type components,
where there's no name to attach the documentation to, so I've moved to
storing all the documentation in the abstract syntax.  Previously some
of the documentation was left in the abstract syntax by the parser,
but was later extracted into the mapping.

In order to avoid having to parameterise the abstract syntax over the
type of documentation stored in it, we have to parse the documentation
at the same time as we parse the Haskell source (well, I suppose we
could store 'Either String Doc' in the HsSyn, but that's clunky).  One
upshot is that documentation is now parsed eagerly, and documentation
parse errors are fatal (but have better line numbers in the error
message).

The new story simplifies matters for the code that processes the
source modules, because we don't have to maintain the extra Name->Doc
mapping, and it should improve efficiency a little too.

New features:

  - Function arguments and return values can now have doc annotations.

  - If you refer to a qualified name in a doc string, eg. 'IO.putStr',
    then Haddock will emit a hyperlink even if the identifier is not
    in scope, so you don't have to make sure everything referred to
    from the documentation is imported.

  - several bugs & minor infelicities fixed.

1 files changed, 71 insertions, 23 deletions

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
+