diff --git a/Distribution/Package/ModuleForest.hs b/Distribution/Package/ModuleForest.hs new file mode 100644 index 0000000..1ca3643 --- /dev/null +++ b/Distribution/Package/ModuleForest.hs @@ -0,0 +1,41 @@ +-- Adopted from https://github.com/haskell/hackage-server/blob/master/Distribution/Server/Packages/ModuleForest.hs + +module Distribution.Package.ModuleForest + ( moduleName + , moduleForest + , ModuleTree(..) + , ModuleForest + , NameComponent + ) where + +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Import + +type NameComponent = Text + +type ModuleForest = [ModuleTree] +data ModuleTree = Node { component :: NameComponent + , isModule :: Bool + , subModules :: ModuleForest + } + deriving (Show, Eq) + +moduleName :: Text -> ModuleName +moduleName = ModuleName.fromString . unpack + +moduleForest :: [ModuleName] -> ModuleForest +moduleForest = foldr (addToForest . map pack . ModuleName.components) [] + +addToForest :: [NameComponent] -> ModuleForest -> ModuleForest +addToForest [] trees = trees +addToForest comps [] = mkSubTree comps +addToForest comps@(comp1:cs) (t@(component -> comp2):ts) = case + compare comp1 comp2 of + GT -> t : addToForest comps ts + EQ -> Node comp2 (isModule t || null cs) (addToForest cs (subModules t)) : ts + LT -> mkSubTree comps ++ t : ts + +mkSubTree :: [Text] -> ModuleForest +mkSubTree [] = [] +mkSubTree (c:cs) = [Node c (null cs) (mkSubTree cs)] diff --git a/Handler/Package.hs b/Handler/Package.hs index 43c9fc3..719c822 100644 --- a/Handler/Package.hs +++ b/Handler/Package.hs @@ -14,10 +14,12 @@ import Data.Tag import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT +import Distribution.Package.ModuleForest import Database.Esqueleto ((^.)) import qualified Database.Esqueleto as E import qualified Database.Persist as P + import Formatting import Import import qualified Text.Blaze.Html.Renderer.Text as LT @@ -78,6 +80,26 @@ packagePage mversion pname = do toPkgVer x y = concat [x, "-", y] $(widgetFile "package") where enumerate = zip [0::Int ..] + renderModules sname version = renderForest [] . moduleForest . map moduleName + where + renderForest _ [] = mempty + renderForest pathRev trees = + [hamlet|