packages feed

docidx 1.0.0 → 1.0.1

raw patch · 5 files changed

+409/−1 lines, 5 files

Files

docidx.cabal view
@@ -1,5 +1,5 @@ name:                   docidx-version:                1.0.0+version:                1.0.1 license:                BSD3 license-file:           LICENSE category:               Documentation@@ -38,6 +38,9 @@                         directory >= 1.0, filepath >= 1.1, html >= 1.0,                         MissingH >= 1.1, mtl >= 2, old-locale, tagsoup >= 0.11,                         time >= 1.1+  other-modules:   Distribution.DocIdx.Common,+                        Distribution.DocIdx.Config, Distribution.DocIdx.Html,+                        Distribution.GhcPkgList   ghc-options:          -fwarn-tabs -Wall  source-repository head
+ src/Distribution/DocIdx/Common.hs view
@@ -0,0 +1,27 @@+module Distribution.DocIdx.Common where++import qualified Control.Exception as C+import System.IO++-- | Application name, used to construct path to data directory, and+-- in footer of constructed page.+appName :: String+appName = "docidx"++-- | Data type for elements of the table of contents.+data TocItem = TocItem String String+             | TocSeparator+             | TocNewline+               deriving (Eq, Ord, Show)++-- | Try to read the contents of a file, but if it can't be opened,+-- print an informative warning to stderr and return Nothing.+tryReadFile :: FilePath -> IO (Maybe String)+tryReadFile p =+  C.catch+    (do d <- readFile p+        return $ Just d)+    (\e -> do let err = show (e :: C.IOException)+              hPutStrLn stderr ("Warning: Couldn't open " ++ p ++ ": " ++ err)+              return Nothing)+
+ src/Distribution/DocIdx/Config.hs view
@@ -0,0 +1,79 @@+-- Configuration for docidx.++module Distribution.DocIdx.Config where++import Control.Monad+import Control.Monad.Writer+import Data.Maybe+import System.Directory+import System.FilePath++import Distribution.DocIdx.Common++-- | Name of configuration file within user's application data+-- directory.+cfgFile :: FilePath+cfgFile = "config"++-- | Configuration information for docidx; at present only the+-- tocExtras part is exposed via the config file, however.+data DocIdxCfg = DocIdxCfg {+    pageTitle :: String+  , pageCss :: [String]+  , favIcon :: String+  , tocExtras :: [TocItem]+  } deriving Show++-- | Default configuration.+defaultConfig :: DocIdxCfg+defaultConfig = DocIdxCfg {+    pageTitle = "Local Haskell package docs"+  , pageCss = ["http://hackage.haskell.org/packages/hackage.css"+              ,"file:///Library/Frameworks/GHC.framework/Versions/Current/usr/share/doc/ghc/html/libraries/haddock.css"]+  , favIcon = "http://hackage.haskell.org/images/Cabal-tiny.png"+  , tocExtras = []+  }++-- | Read configuration file if present.+getConfig :: IO DocIdxCfg+getConfig = do+  appDir <- getAppUserDataDirectory appName+  let cfgPath = joinPath [appDir, cfgFile]+  there <- doesFileExist cfgPath+  extras <- if not there+              then return []+              else do dm <- tryReadFile cfgPath+                      case dm of+                        Nothing -> return []+                        Just d -> readConfig d+  return $ defaultConfig { tocExtras = extras }++-- | Read a config file's contents.  At present we're only looking for+-- TocItems, but other things could be there in the future+-- (e.g. alternative CSS, etc.)+readConfig :: String -> IO [TocItem]+readConfig d = do+  let (extras, l) = runWriter $ (liftM catMaybes . mapM readConfigLine) $ lines d+  forM_ l putStrLn+  return extras++-- | Try to read a single line from the config file.+readConfigLine :: String -> Writer [String] (Maybe TocItem)+readConfigLine line = do+  let ws = words line+  case ws of+    [] -> return Nothing+    ("--":_) -> return Nothing+    ("extraSeparator":_) -> return $ Just TocSeparator+    ("extraNewline":_) -> return $ Just TocNewline+    ("extra":xs) -> if length xs > 1+                      then let name = unlines $ init xs+                               url = last xs+                           in return $ Just $ TocItem name url+                      else warn "malformed extra" line+    _ -> warn "unrecognised config line" line++-- | Moan gently about any weird looking lines.+warn :: String -> String -> Writer [String] (Maybe a)+warn msg line = do tell ["Warning: " ++ msg ++ ": \"" ++ line ++ "\""]+                   return Nothing
+ src/Distribution/DocIdx/Html.hs view
@@ -0,0 +1,160 @@+-- | HTML output for documentation package index.++module Distribution.DocIdx.Html (+  htmlPage+) where++import Control.Monad+import Data.Char (isAlpha, toUpper)+import Data.List+import Data.Ord+import Data.Time+import Data.Version+import qualified Data.Map as M+import System.FilePath+import System.Locale+import Text.Html++import Distribution.DocIdx.Common+import Distribution.DocIdx.Config+import Distribution.GhcPkgList++-- | Project homepage, for footer.+homePage :: String+homePage = "http://hackage.haskell.org/package/docidx"++-- | Create and render entire page.+htmlPage :: DocIdxCfg -> PackageMap HaddockInfo -> UTCTime -> String+htmlPage config pkgs now = renderHtml [htmlHeader, htmlBody]+  where htmlHeader = header << ((thetitle << pageTitle config) : fav : css)+        fav = thelink ![rel "shortcut icon", href $ favIcon config] << noHtml+        css = map oneCss (pageCss config)+        oneCss cp = thelink ![rel "stylesheet",+                              thetype "text/css", href cp] << noHtml+        htmlBody = body << (title' ++ toc ++ secs ++ nowFoot)+          where title' = [h2 << "Local packages with docs"]+                toc = [htmlToc config am]+                secs = concatMap (uncurry htmlPkgsAlpha) $ M.assocs am+                am = alphabetize pkgs+                now' = formatTime defaultTimeLocale rfc822DateFormat now+                nowFoot = [p ![theclass "toc"] $+                           stringToHtml ("Page rendered " ++ now' ++ " by ")+                           +++ (anchor ![href homePage] <<+                                         stringToHtml appName)]++-- | An AlphaMap groups packages together by their name's first character.+type AlphaMap = M.Map Char (PackageMap HaddockInfo)++-- | Group packages together by their name's first character.+alphabetize :: PackageMap HaddockInfo -> AlphaMap+alphabetize = foldr addAlpha M.empty+  where addAlpha (n, vs) = M.insertWith (++) c [(n, vs)]+          where c = if isAlpha c' then c' else '\0'+                c' = toUpper $ head n++-- | Generate the table of contents.+htmlToc :: DocIdxCfg -> AlphaMap -> Html+htmlToc config am =+  p ![theclass "toc"] << tocHtml (alphaItems ++ tocExtras config)+    where tocHtml = intersperse bull . concatMap tocItemHtml+          alphaItems = map (\k -> TocItem [k] ('#':[k])) $ sort $ M.keys am++-- | Render toc elements to HTML.+tocItemHtml :: TocItem -> [Html]+tocItemHtml (TocItem nm path) = [anchor ![href path] << nm]+tocItemHtml TocSeparator = [mdash]+tocItemHtml TocNewline = [br] -- Hmmm... you still get the bullets?++-- | Render a collection of packages with the same first character.+htmlPkgsAlpha :: Char -> PackageMap HaddockInfo -> [Html]+htmlPkgsAlpha c pm = [heading, packages]+  where heading = h3 ![theclass "category"] << anchor ![name [c]] << [c]+        packages = ulist ![theclass "packages"] <<+                     map (uncurry htmlPkg) pm'+        pm' = sortBy (comparing (map toUpper . fst)) pm++-- | Render a particularly-named package (all versions of it).+htmlPkg :: String -> VersionMap HaddockInfo -> Html+htmlPkg nm vs = li << pvsHtml (flattenPkgVersions nm vs)++-- | Everything we want to know about a particular version of a+-- package, nicely flattened and ready to use.  (Actually, we'd also+-- like to use the synopsis, but this isn't exposed through the Cabal+-- library, sadly.  We could conceivably grab it from the haddock docs+-- (and hackage for packages with no local docs)  but this+-- seems excessive so for now we forget about it.+data PkgVersion = PkgVersion {+    pvName ::String+  , pvSynopsis :: Maybe String+  , pvVersion :: Version+  , pvExposed :: Bool+  , pvHaddocks :: Maybe FilePath+  } deriving (Eq, Ord, Show)++-- | Flatten a given package's various versions into a list of+-- PkgVersion values, which is much nicer to iterate over when+-- building the HTML for this package.+flattenPkgVersions :: String -> VersionMap HaddockInfo -> [PkgVersion]+flattenPkgVersions nm vs = concatMap (uncurry flatten') $ reverse vs+  where flatten' :: Version -> [VersionInfo HaddockInfo] -> [PkgVersion]+        -- We reverse here to put user versions of pkgs before+        -- identically versioned global versions.+        flatten' v = concatMap (uncurry flatten3) . reverse+          where flatten3 :: Bool -> [HaddockInfo] -> [PkgVersion]+                flatten3 ex [] = [PkgVersion nm Nothing v ex Nothing]+                flatten3 ex ps = map (mkPv nm v ex) ps++-- | Construct a PkgVersion from information about a single version of+-- a package.+mkPv :: String -> Version -> Bool -> HaddockInfo -> PkgVersion+mkPv nm v ex Nothing = PkgVersion nm Nothing v ex Nothing+mkPv nm v ex (Just (hp, syn)) = PkgVersion nm (Just syn) v ex (Just hp)++-- | Render the HTML for a list of versions of (we presume) the same+-- package.+pvsHtml :: [PkgVersion] -> Html+pvsHtml pvs = pvHeader (head pvs) +++ spaceHtml +++ pvVersions pvs ++++                pvSyn pvs++-- | Render the "header" part of some package's HTML: name (with link+-- to default version of local docs if available) and hackage link.+pvHeader :: PkgVersion -> [Html]+pvHeader pv = [maybeURL nme (pvHaddocks pv)+              ,spaceHtml+              ,anchor ![href $ hackagePath pv] << extLinkArrow+              ]+  where nme = if not (pvExposed pv) then "(" ++ nm ++ ")" else nm+        nm = pvName pv++-- | Render HTML linking to the various versions of a package+-- installed, listed by version number only (name is implicit).+pvVersions :: [PkgVersion] -> Html+pvVersions [_] = noHtml -- Don't bother if there's only one version.+pvVersions pvs = stringToHtml "[" ++++                  intersperse comma (map pvOneVer pvs) ++++                  stringToHtml "]"+  where pvOneVer pv = maybeURL (showVersion $ pvVersion pv) (pvHaddocks pv)++-- | Render the synopsis of a package, if present in any of its versions.+pvSyn :: [PkgVersion] -> Html+pvSyn = maybe noHtml (\x -> mdash +++ stringToHtml x) . msum . map pvSynopsis++-- | Render a URL if there's a path; otherwise, just render some text.+-- (Useful in cases where a package is installed but no documentation+-- was found: you'll still get the hackage link.)+maybeURL :: String -> Maybe String -> Html+maybeURL nm Nothing = stringToHtml nm+maybeURL nm (Just path) = anchor ![href $ joinPath [path, "index.html"]] << nm++-- | Compute the URL to a package's page on hackage.+hackagePath :: PkgVersion -> String+hackagePath pv = "http://hackage.haskell.org/package/" ++ pvTag+  where pvTag = pvName pv ++ "-" ++ showVersion (pvVersion pv)++-- Some primitives.++bull, comma, extLinkArrow, mdash :: Html+bull = primHtml " &bull; "+comma = stringToHtml ", "+extLinkArrow = primHtml "&#x2b08;"+mdash = primHtml " &mdash; "
+ src/Distribution/GhcPkgList.hs view
@@ -0,0 +1,139 @@+-- | Get contents of installed packages by querying "ghc-pkg" via+-- Cabal.++module Distribution.GhcPkgList (+  PackageMap,+  VersionMap,+  VersionInfo,+  HaddockInfo,+  installedPackages+) where++import Control.Arrow+import Data.List+import Data.List.Utils (addToAL)+import Data.Maybe (fromMaybe)+import qualified Distribution.InstalledPackageInfo as I+import qualified Distribution.Package as P+import Distribution.Simple.Compiler (PackageDB(GlobalPackageDB,+                                               UserPackageDB))+import Distribution.Simple.GHC (getInstalledPackages)+import Distribution.Simple.PackageIndex (PackageIndex, allPackagesByName)+import Distribution.Simple.Program (ghcProgram, ghcPkgProgram)+import Distribution.Simple.Program.Db (addKnownPrograms,+                                       configureAllKnownPrograms,+                                       emptyProgramDb)+import Distribution.Verbosity (normal)+import Distribution.Version (Version)+import System.FilePath+import Text.HTML.TagSoup++-- XXX Slightly nasty that we import this here, as otherwise this+-- module stands pleasantly independent of the rest of docidx.+import Distribution.DocIdx.Common++-- | A package map maps package names to information about the+-- versions installed.+type PackageMap a = [(String, VersionMap a)]++-- | A version map maps version numbers to information about the+-- various installations of that version.+type VersionMap a = [(Version, [VersionInfo a])]++-- | Information about a particular version of a package; at a minimum+-- this is whether it is exposed; other information may be attached+-- (in particular we will attach paths to Haddock docs and, later,+-- whether those docs exist and are readable, and their synopses).+type VersionInfo a = (Bool, [a])++-- | Cabal tells us about locations of Haddock docs, but they might+-- not actually exist or be readable.  If they do, we're interested in+-- their path and the package synopsis extracted from the title tag of+-- their index.html.+type HaddockInfo = Maybe (FilePath, String)++-- | Get exposure/haddock information about all versions of all+-- installed packages.+installedPackages :: IO (PackageMap HaddockInfo)+installedPackages = fmap groupPackages listInstalledPackages >>= checkHaddocks++-- Nothing from here down is exposed.++-- | Get the list of installed packages, via Cabal's existing+-- machinery.+listInstalledPackages :: IO PackageIndex+listInstalledPackages =+  let pdb = addKnownPrograms [ghcProgram,ghcPkgProgram] emptyProgramDb+  in configureAllKnownPrograms normal pdb >>=+         getInstalledPackages normal [GlobalPackageDB, UserPackageDB]++-- | Group installed package information together by package name and+-- version number.  At this stage all we know about the Haddock docs+-- are where Cabal says they are (not whether they exist), so+-- PackageMap is parameterised over such paths.+groupPackages :: PackageIndex -> PackageMap FilePath+groupPackages = foldr groupPackages' [] . allPackagesByName++groupPackages' :: [I.InstalledPackageInfo] -> PackageMap FilePath ->+                  PackageMap FilePath+groupPackages' ps pm = foldr groupPackages'' pm ps++groupPackages'' :: I.InstalledPackageInfo -> PackageMap FilePath ->+                   PackageMap FilePath+groupPackages'' ipi pm =+  addToAL pm nm $ addToVersionMap vs' ver (ex, had)+    where vs' = fromMaybe [] (nm `lookup` pm)+          pid = I.sourcePackageId ipi+          (P.PackageName nm) = P.pkgName pid+          ver = P.pkgVersion pid+          ex = I.exposed ipi+          had = I.haddockHTMLs ipi++addToVersionMap :: Eq a => VersionMap a -> Version -> VersionInfo a ->+                   VersionMap a+addToVersionMap vm v vi = addToAL vm v xs'+  where xs' = case v `lookup` vm of+                -- No duplicates please.+                Just xs -> if vi `elem` xs then xs else xs ++ [vi]+                Nothing -> [vi]++-- Checking existence of Haddock docs, and reading synopses from them.++-- | Given a PackageMap over paths to Haddock directories, turn it+-- into one over HaddockInfo values (checking if the Haddocks exist+-- and are readable, and if so, extracting the package synopsis from+-- each).+checkHaddocks :: PackageMap FilePath -> IO (PackageMap HaddockInfo)+checkHaddocks = pmMegaLift checkHaddock++-- Try to read the index.html file of some Haddock directory, and+-- extract the package synopsis.+checkHaddock :: FilePath -> IO HaddockInfo+checkHaddock hp = do+  result <- tryReadFile $ joinPath [hp, "index.html"]+  case result of+    Just x -> return $ Just (hp, parsePackageSynopsis x)+    Nothing -> return Nothing++-- | Parses a Haddock index.html to find the package's synopsis (in+-- the title tag).+parsePackageSynopsis :: String -> String+parsePackageSynopsis s = if null w then t else unwords $ tail w+  where w = words t+        t = findTitleTag $ canonicalizeTags $ parseTags s+        findTitleTag ts = maybe "" (fromTagText . snd) $ seekT ts+        seekT ts = find (isTagOpenName "title" . fst) (zip ts $ tail ts)++-- | Lift a function on the second element of a VersionInfo into a+-- function on a PackageMap.  Sorry this is so wild - it's just+-- digging deep into the (fairly repetitive) PackageMap structure; I+-- expect that if I understood, say, Control.Arrow, better, this could+-- be written more sensibly.+pmMegaLift :: (a -> IO b) -> PackageMap a -> IO (PackageMap b)+pmMegaLift = mapSndM . mapSndM . mapSndM . mapM+  where mapSndM = mapM . sndM+        -- | Weird monadic second-ish combinator.  Modified from answers on+        -- http://stackoverflow.com/questions/3998133/+        --   does-this-simple-haskell-function-already-have-a-well-known-name+        sndM :: (Functor m, Monad m) => (a -> m b) -> (c, a) -> m (c, b)+        sndM f = uncurry (fmap . (,)) . second f