initial commit

README.md

@@ -0,0 +1,53 @@
+# ghcdoc
+
+## usage
+
+When you have a cabal package that supports `cabal configure --write-ghc-environment-files=always` (probably ghc8.4.4+):
+
+Generate local documentation setting the following in `~/.cabal/config`
+
+  haddock
+  hoogle: True
+  html: True
+  hyperlink-source: True
+  quickjump: True
+
+Then run it
+
+```shell
+>ls *.cabal
+portages.cabal
+
+# see all dependencies
+>ghcdoc
+```
+
+```
+# or if you know which packages
+>ghcdoc base JuicyPixels
+```
+
+
+### todo
+
+when you are not in a cabal project, open the most recent one used
+
+ghcdoc should only start a single server for each .cabal file. Additional calls to ghcdoc should
+just run the browser commands.
+
+## why
+
+It is inconvenient to navigate cabal/store/ghc-8.10.4/ which has directories like
+
+```
+active-0.2.0.14-654db471a95e22980fb0d3b3d7cec63011e700774c9c5a3211a049f9f528295a/
+active-0.2.0.14-6883a704d312a6ea3f081cd18a143566eb4c5fcd8fdfb6ccfefb7ed538b84cd8/
+adjunctions-4.4-3aabe59fdc0aecdac7fedfdfeddb7a224aeb48182eb612d08ac9c759810e58f9/
+adjunctions-4.4-78971b508863d00b0b99318bbcd79b8a5c2c4283c475502cdda830d02e38a42e/
+aeson-1.5.6.0-1400182fb6135a245119f175b183386c2e2643075c1b26232f7d33d7c4a0a1fd/
+aeson-1.5.6.0-2f2faf03923cd0fc0ab5211880ad2cdadd12bd5c666566be3af8ad1480e017d3/
+aeson-1.5.6.0-629873db2839631743eb375cd1eaea7f8e731ec4e104ea17d5149b368c58a486/
+aeson-1.5.6.0-6c0cb681b94efe7dcc84c9c01346ffb127b3e5fcc679006c658777bbceee143a/
+```
+
+Furthermore many browsers don't run `.js` on `file://` links, so we open the files through `http://localhost`

ghcdoc.cabal

@@ -0,0 +1,35 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.4.
+--
+-- see: https://github.com/sol/hpack
+
+name: ghcdoc
+version: 0.0.0
+build-type: Simple
+
+executable ghcdoc
+ main-is: main.hs
+ other-modules:
+ Paths_ghcdoc
+ build-depends:
+ Cabal
+ , Glob
+ , base
+ , binary
+ , blaze-html
+ , bytestring
+ , cmdargs
+ , containers
+ , directory
+ , edit-distance
+ , filepath
+ , happstack-server
+ , lens
+ , process
+ , process-extras
+ , split
+ , text
+ , unix
+ , zstd
+ default-language: Haskell2010

hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+ cabal:

main.hs

@@ -0,0 +1,162 @@
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, RecordWildCards, TupleSections #-}
+{-# OPTIONS_GHC -Wno-typed-holes #-}
+module Main where
+
+import Data.String (fromString)
+import Codec.Compression.Zstd
+import Control.Lens
+import Control.Monad
+import Data.Binary
+import Data.Char
+import Data.Either
+import Data.List
+import Data.List.Split as LS
+import Data.Maybe
+import Data.Ord
+import Data.Text (Text)
+import Data.Version
+import Distribution.InstalledPackageInfo
+import Distribution.System
+import Distribution.Types.PackageId
+import Distribution.Types.PackageName
+import GHC.Generics
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map as M
+import qualified Data.Set as S
+import qualified Data.Text as T
+import System.Console.CmdArgs
+import System.Directory
+import System.Environment
+import System.FilePath
+import System.FilePath.Glob
+import System.Info
+import System.Posix.Files
+import System.Process
+import System.Process.ByteString as BS
+import Text.EditDistance
+
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as H
+import Happstack.Server.FileServe
+import Happstack.Server
+import qualified Paths_ghcdoc
+
+data Ghcdoc = Ghcdoc { envFile :: String,
+ packageQuery :: [String],
+ browser :: String,
+ port :: Int } deriving (Data, Eq, Generic)
+
+instance Binary Ghcdoc
+
+
+globMt pat = do
+ fs <- glob pat
+ ts <- mapM (fmap modificationTime . getFileStatus) fs
+ return $ zip ts fs
+
+globMtGhcEnv = globMt (".ghc.environment." ++ arch ++ "-" ++ os ++ "-*")
+
+getGhcEnvFiles :: IO (Maybe (Bool, FilePath)) -- (newest cabal file is older than the .ghc.environment,
+ -- ".ghc.environment.arch-os-8.10.4")
+getGhcEnvFiles = do
+ (cabalFst , _) : _ <- sortOn (negate . fst) <$> globMt "*.cabal"
+ fmap (_1 %~ (cabalFst <)) . listToMaybe . sortOn (negate . fst) <$> globMtGhcEnv
+
+-- I should use shake?
+-- it takes 0.8s to run ghc-pkg etc.
+-- catch errors from decode and then just run (f a) and cache again
+cacheResult :: (Eq a, Binary a, Binary b) => FilePath -> (a -> IO b) -> a -> IO b
+cacheResult file f a = do
+ let redo = do
+ b <- f a
+ BS.writeFile file $ compress maxCLevel $ BL.toStrict $ encode (a,b)
+ return b
+
+ e <- doesFileExist file
+ if e then do
+ (a', b') <- (\ (Decompress x) -> decode (BL.fromStrict x) ) . decompress <$> BS.readFile file
+ if a' == a then return b'
+ else redo
+ else redo
+
+generateEnvFile = system "cabal configure --write-ghc-environment-files=always"
+
+main = do
+ do x<- globMtGhcEnv
+ when (null x) $ void generateEnvFile
+
+ -- get the .ghc.environment file with largest modifiction time
+ Just envFileNewest <- do
+ maybe (do generateEnvFile
+ fmap snd <$> getGhcEnvFiles)
+ (\ (ok, f) ->
+ if ok then return (Just f)
+ else do
+ generateEnvFile
+ return (Just f)) =<< getGhcEnvFiles
+
+ ghcdoc@ Ghcdoc{..} <- cmdArgs $ Ghcdoc {
+ envFile = envFileNewest,
+ packageQuery = [] &= args,
+ browser = "firefox",
+ port = 8000 }
+
+ envFileMtime <- show <$> getModificationTime envFileNewest
+ -- cache based on the envFile filename&mtime...but not ghcdoc version
+ pkgs <- cacheResult ".ghc.environmentCache" (getPkgs . view _1) (envFile, envFileMtime, Paths_ghcdoc.version)
+
+ let openLinks ps = case ps of
+ [] -> open ["http://localhost:" ++ show port]
+ _ -> open [ "http://localhost:" ++ show port </> p </> "index.html" | p <- ps]
+ where open = void . createProcess . proc browser
+ -- not sure if we want to wait like with `callProcess`
+
+ -- make a better table of contents
+ -- https://www.haskell.org/haddock/doc/html/invoking.html
+ -- haddock --gen-contents -- "interface files"
+ case packageQuery of
+ [] -> openLinks []
+ qs -> case partitionEithers [ maybe (Left q) (\bs -> Right (q,bs))
+ (M.lookup q pkgs) | q <- qs ] of
+ (qs_, good) ->do
+ let addIndex (a,bs) = zipWith (\i _ -> a ++ show i) [1 .. ] bs
+ openLinks $ concatMap addIndex $ [ lookupED q fst (M.toList pkgs) | q <- qs_ ] ++ good
+ return ()
+
+ let rootLinkList = H.ul $ mconcat
+ [ H.li (H.a H.! H.href (fromString n') $ H.toHtml n) | (n,hrefs) <- M.toList pkgs,
+ let nhref = length hrefs,
+ (href, i) <- hrefs `zip` [1 .. ],
+ let n' = n ++ show i ]
+ rootPage = H.body (H.h1 (fromString "ghcdoc packages") <> rootLinkList)
+
+ -- doc-index.json is missing even though I changed the options
+ haddockPages = msum $ [ dir (d ++ show i) $ serveDirectory EnableBrowsing ["index.html"] p | (d,ps) <- M.toList pkgs,
+ (p,i) <- ps `zip` [1 .. ]]
+
+ simpleHTTP nullConf{Happstack.Server.port=port} $ msum [
+ haddockPages ,
+ ok (toResponse rootPage) ]
+
+getPkgs envFile = do
+ ev <- dropWhile (\ x -> not $ "package" `isPrefixOf` x) . lines
+ <$> readFile envFile
+ let dbs = [ f | e <- ev, Just f <- [stripPrefix "package-db " e] ]
+ pkgids = S.fromList [ f| e <- ev, Just f <- [stripPrefix "package-id " e] ]
+
+ setDbEnv = setEnv "GHC_PACKAGE_PATH" (intercalate ":" dbs ++ ":")
+ setDbEnv
+ (_, out, _) <- BS.readCreateProcessWithExitCode (proc "ghc-pkg" ["dump"]) mempty
+
+ let pkgsAndErrs = map (fmap (fmap getPackageInfoFields) . parseInstalledPackageInfo . B8.unlines) $ LS.splitOn [B8.pack "---"] $ B8.lines out
+ return $ M.fromListWith (++) [ (pn, haddock) | Right (_, (pn, compat, haddock) ) <- pkgsAndErrs,
+ compat `S.member` pkgids ]
+
+lookupED :: String -> (a -> String) -> [a] -> a
+lookupED q f xs = snd $ head $ sortOn fst $ map (\x -> (levenshteinDistance defaultEditCosts q (f x), x)) xs
+
+getPackageInfoFields x = ( unPackageName (pkgName (sourcePackageId x)),
+ compatPackageKey x,
+ haddockHTMLs x)

package.yaml

@@ -0,0 +1,26 @@
+name: ghcdoc
+
+dependencies:
+ - base
+ - binary
+ - bytestring
+ - Cabal
+ - cmdargs
+ - containers
+ - edit-distance
+ - filepath
+ - Glob
+ - lens
+ - process
+ - process-extras
+ - split
+ - text
+ - unix
+ - zstd
+ - directory
+ - happstack-server
+ - blaze-html
+
+executables:
+ ghcdoc:
+ main: main.hs