diff options
Diffstat (limited to 'src/HaddockUtil.hs')
| -rw-r--r-- | src/HaddockUtil.hs | 94 |
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 + |