1----------------------------------------------------------------------------- 2-- | 3-- Module : Haddock.ModuleTree 4-- Copyright : (c) Simon Marlow 2003-2006, 5-- David Waern 2006 6-- License : BSD-like 7-- 8-- Maintainer : haddock@projects.haskell.org 9-- Stability : experimental 10-- Portability : portable 11----------------------------------------------------------------------------- 12module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where 13 14 15import Haddock.Types ( MDoc ) 16 17import GHC ( Name ) 18import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString ) 19import DynFlags ( DynFlags ) 20import Packages ( lookupPackage ) 21import PackageConfig ( sourcePackageIdString ) 22 23import qualified Control.Applicative as A 24 25 26data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] 27 28 29mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] 30mkModuleTree dflags showPkgs mods = 31 foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] 32 where 33 modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) 34 | otherwise = Nothing 35 modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString 36 (lookupPackage dflags (moduleUnitId mod_)) 37 | otherwise = Nothing 38 fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short 39 40 41addToTrees :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] 42addToTrees [] _ _ _ _ ts = ts 43addToTrees ss m pkg srcPkg short [] = mkSubTree ss m pkg srcPkg short 44addToTrees (s1:ss) m pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) 45 | s1 > s2 = t : addToTrees (s1:ss) m pkg srcPkg short ts 46 | s1 == s2 = Node s2 (leaf A.<|> (if null ss then Just m else Nothing)) this_pkg this_srcPkg this_short (addToTrees ss m pkg srcPkg short subs) : ts 47 | otherwise = mkSubTree (s1:ss) m pkg srcPkg short ++ t : ts 48 where 49 this_pkg = if null ss then pkg else node_pkg 50 this_srcPkg = if null ss then srcPkg else node_srcPkg 51 this_short = if null ss then short else node_short 52 53 54mkSubTree :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] 55mkSubTree [] _ _ _ _ = [] 56mkSubTree [s] m pkg srcPkg short = [Node s (Just m) pkg srcPkg short []] 57mkSubTree (s:s':ss) m pkg srcPkg short = [Node s Nothing Nothing Nothing Nothing (mkSubTree (s':ss) m pkg srcPkg short)] 58 59 60splitModule :: Module -> [String] 61splitModule mdl = split (moduleNameString (moduleName mdl)) 62 where split mod0 = case break (== '.') mod0 of 63 (s1, '.':s2) -> s1 : split s2 64 (s1, _) -> [s1] 65