content: -----------------------------------------------------------------------------
  
  -----------------------------------------------------------------------------
  
  -- |
  -- Module      :  Haddock.ModuleTree
  -- Copyright   :  (c) Simon Marlow 2003-2006,
  --                    David Waern  2006
  -- License     :  BSD-like
  --
  -- Maintainer  :  haddock@projects.haskell.org
  -- Stability   :  experimental
  -- Portability :  portable
  module Haddock.ModuleTree (ModuleTree (..), mkModuleTree) where
  
  import qualified Control.Applicative as A
  import GHC (Name)
  import GHC.Unit.Module (Module, moduleName, moduleNameString, moduleUnit, unitString)
  import GHC.Unit.State (UnitState, lookupUnit, unitPackageIdString)
  
  import Haddock.Types (MDoc)
  
  data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree]
  
  mkModuleTree :: UnitState -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]
  mkModuleTree state showPkgs mods =
    foldr fn [] [(mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods]
    where
      modPkg mod_
        | showPkgs = Just (unitString (moduleUnit mod_))
        | otherwise = Nothing
      modSrcPkg mod_
        | showPkgs =
            fmap
              unitPackageIdString
              (lookupUnit state (moduleUnit mod_))
        | otherwise = Nothing
      fn (m, mod_, pkg, srcPkg, short) = addToTrees mod_ m pkg srcPkg short
  
  addToTrees :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree]
  addToTrees [] _ _ _ _ ts = ts
  addToTrees ss m pkg srcPkg short [] = mkSubTree ss m pkg srcPkg short
  addToTrees (s1 : ss) m pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts)
    | s1 > s2 = t : addToTrees (s1 : ss) m pkg srcPkg short ts
    | 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
    | otherwise = mkSubTree (s1 : ss) m pkg srcPkg short ++ t : ts
    where
      this_pkg = if null ss then pkg else node_pkg
      this_srcPkg = if null ss then srcPkg else node_srcPkg
      this_short = if null ss then short else node_short
  
  mkSubTree :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree]
  mkSubTree [] _ _ _ _ = []
  mkSubTree [s] m pkg srcPkg short = [Node s (Just m) pkg srcPkg short []]
  mkSubTree (s : s' : ss) m pkg srcPkg short = [Node s Nothing Nothing Nothing Nothing (mkSubTree (s' : ss) m pkg srcPkg short)]
  
  splitModule :: Module -> [String]
  splitModule mdl = split (moduleNameString (moduleName mdl))
    where
      split mod0 = case break (== '.') mod0 of
        (s1, '.' : s2) -> s1 : split s2
        (s1, _) -> [s1]
  