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