packages feed

dash-haskell 1.0.0.5 → 1.1.0.0

raw patch · 27 files changed

+930/−1233 lines, 27 filesdep +filepathdep −system-filepathdep ~Cabaldep ~basedep ~optparse-applicative

Dependencies added: filepath

Dependencies removed: system-filepath

Dependency ranges changed: Cabal, base, optparse-applicative, transformers

Files

README.md view
@@ -1,6 +1,6 @@ dash-haskell ============-**local and approximate package docs for your Haskell project dependencies**+*Never Google for Hackage Results Again* - [ian, barnacles.blackfriday](https://barnacles.blackfriday/)    **direct to browser lookup:**   ![look-up](/img/lookup.png?raw=true)@@ -37,89 +37,54 @@     [dash docsets](http://kapeli.com/dash) are an open, easily assimilated standard, and     are used across many IDE(s). -Summary-=======-```-  Usage: dash-haskell [-p|--dbprovider <provider,args>] [-o|--output <dir>]-                      [-q|--quiet] [-c|--cabal <file.cabal>]-                      [-r|--cabal-constraints executable=name, ..] [packages]-    additional help is available with "dash-haskell help <topic|option>"--  Available options:-    -h,--help                Show this help text-    -p,--dbprovider <provider,args>-                             a ghc package db provider: cabal|ghc|dir-    -o,--output <dir>        the directory to write created docsets to-    -q,--quiet               set to quiet output-    -c,--cabal <file.cabal>  the cabal file to retrieve package dependencies from -    -r,--cabal-constraints executable=name, ..-                             limit package results from a cabal file source, see-                             documentation-    packages                 a list of packages to specifically build, e.g.-                             either-1.0.1 text-1.2.0-```--Usage Example-=============-The following example shows how to use **dash-haskell** to generate-docsets for a **cabal sandbox project**.--```-  $ cd foo-1.2.0/ -  $ dash-haskell -c foo.cabal -o docsets -  db provider:-    lookup strategy: cabal sandbox db index-    cmd: cabal-    args: sandbox hc-pkg list+Usage Examples+==============+```dash-haskell -c foo.cabal -s``` -  processing: system-filepath-0.4.12-    writing files..-    writing plist..-    populating database..-    finished populating sqlite database..+builds all packages listed as dependencies in ```foo.cabal```, using atleast the cabal sandbox db -  processing: system-fileio-0.3.14-    writing files..-    writing plist..-    populating database..-    finished populating sqlite database..+```dash-haskell parsec-3.1.5 ``` -  processing: pipes-4.1.2-    writing files..-    writing plist..-    populating database..-    finished populating sqlite database..+builds ```docsets/parsec-3.1.5.docset``` using the default db ordering (global, sandbox, user).  -  warning: failed to process: parsec-3.1.5-  warning: path errors in pkg conf file:-   /home/jpf/local/cabal-sandboxes/dash-haskell/x86_64-linux-ghc-7.8.3-packages.conf.d/parsec-3.1.5-abf7e89cafe4e74712f678cea843c1c8.conf-  with problem(s):-   missing: haddock interface file-   missing: html doc dir+Note: haddock documentation for the package must first be built prior to calling dash-haskell on it, e.g.+```+$ cabal install --only-dependencies --enable-documentation+``` -  processing: sqlite-simple-0.4.8.0-    writing files..-    writing plist..-    populating database..-    finished populating sqlite database..+**dash-haskell** tries to be as self-documenting as possible. Please see: -  $+```dash-haskell --help``` and ```dash-haskell help [option|topic]``` +Summary+======= ```+dash-haskell v1.1.0.0, a dash docset construction tool for Haskell packages -Notice, the failure of ```parsec-3.1.5``` is illustrated here to show that-in this case, dash-haskell depends on **haddock documentation** being built for-the requested package.-A possible resolution in this case, if using a sandbox, is:+Usage: dash-haskell [-o|--output <dir>] [-q|--quiet] [-c|--cabal <file.cabal>]+                    [-x|--cabal-excludes ghc,lens..] [-s|--sandbox]+                    [-n|--no-user] [--db <path-to-package-db>]+                    [-d|--ordering user,sandbox..] [packages]+  additional help is available with "dash-haskell help <topic|option>" -```-$ cabal install --reinstall parsec-3.1.5 --enable-documentation-$ dash-haskell parsec-3.1.5 -o docsets-```+Available options:+  -h,--help                Show this help text+  -o,--output <dir>        the directory to write created docsets to+  -q,--quiet               set to quiet output+  -c,--cabal <file.cabal>  the cabal file to retrieve package dependencies from+  -x,--cabal-excludes ghc,lens..+                           limit package results from a cabal file source+  -s,--sandbox             use cabal sandbox+  -n,--no-user             don't source packages from user db+  --db <path-to-package-db>+                           package db directory+  -d,--ordering user,sandbox..+                           ordering of user, dir, and sandbox db's+  packages                 a list of packages to specifically build, e.g.+                           either-1.0.1 text -**dash-haskell** tries to be as self-documenting as possible. Please see:-```-$ dash-haskell help [option|topic]+http://www.github.com/jfeltz/dash-haskell (C) John P. Feltz 2014, 2015+ ```  Installation@@ -137,26 +102,13 @@  Package Resolution ==================-When dependency sourcing from a cabal file, dash-haskell does not (yet) select versioned packages from the build-dependency version bounds, only the package names. As a general rule, try to **be version specific** when providing package arguments, unless you're judicious about which packages are stored in your *cabal sandbox* or *ghc package db*. There is a lot of hidden behavior that goes into how dash-haskell resolves packages, -for example, consider the hypothetical package arguments:-```-$ dash-haskell either parsec-1.2 parsec-```-This chooses by default:--* ```either``` and ```parsec-1.2``` as the parameter packages. -  If for example ```parsec``` were sourced from a cabal file, with ```-c```, -  ```parsec-1.2``` would still be chosen instead. -* cabal as a package db provider:-  implicitly calling ```cabal sandbox hc-pkg list```.-  By convention the first db that provides the unversioned package is chosen.-* ```either-4.1.0``` and ```parsec-1.2``` are then selected from the package db,-where their config files are parsed for the documentation sources to be converted. -+For best results, try to **be version specific** when providing+package arguments, unless you're judicious about which packages are+stored, for example, in your *cabal sandbox db* or *ghc package db*.  IDE Configuration =================-To use the generated docsets , you will need a plugin for your particular IDE which can access+To use the generated docsets, you will need a plugin for your particular IDE which can access them.  * **Emacs**@@ -191,18 +143,19 @@  Features slated for V2 ======================-* handle **docset pre-builts**+* handle **docset pre-builts and project synchronization** -    set pre-built criteria, pre-built skipping, and provide a ```--rebuild``` to force rebuild of a docset+  set pre-built criteria, pre-built skipping, project package sync.+  and provide a ```--rebuild``` to force rebuild of a docset -* **summaries**+* **version biasing**  -    provide summary information to help users better understand which-    packages failed and succeeded+  provide option to bias package version to highest when it is otherwise ambiguous -* **version biasing** +* **summaries** -    provide option to bias package version to highest when it is otherwise ambiguous+  provide summary information to help users better understand which+  packages failed and succeeded  * ```conf``` argument support
dash-haskell.cabal view
@@ -1,94 +1,48 @@ name:                dash-haskell-version:             1.0.0.5-synopsis:            Command line tool to generate Dash docsets (IDE docs) from package haddock+version:             1.1.0.0+synopsis:            Convert package Haddock to Dash docsets (IDE docs) homepage:            http://www.github.com/jfeltz/dash-haskell Bug-reports:         https://github.com/jfeltz/dash-haskell/issues license:             LGPL-3 license-file:        LICENSE author:              John P. Feltz maintainer:          jfeltz@gmail.com-copyright:           (c) 2014 John P. Feltz +copyright:           (c) 2014, 2015 John P. Feltz  category:            Documentation build-type:          Simple-cabal-version:       >= 1.18+cabal-version:       >= 1.22 extra-source-files:  README.md   description: -  Dash is a framework and file format for allowing easy lookup and indexing of-  programming docs, e.g. API functions and modules. A number of plugins offer dash docset-  lookup in editors such as Emacs and Vim.  By using this tool, one can-  convert haskell package haddock(s) to docsets. +  A Dash.app docset is a file-layout for allowing easy lookup and+  indexing of programming docs, e.g. API functions and modules. A+  number of plugins offer docset lookup in editors such as Emacs and+  Vim.  By using this tool, one can convert haskell package haddock(s)+  to docsets.   .-  The major benefit of dash-haskell, is that once these docsets are built, dash tools-  provide one of the few, if only solutions for offline, contextual, and project dependency-  approximate IDE documentation for Haskell. +  The major benefit of dash-haskell, is that once these docsets are+  built, dash tools provide one of the few, if only solutions for+  offline, contextual, and project dependency approximate IDE+  documentation for Haskell.   .-  Summary:+  Usage Examples:   .-  > $ dash-haskell --help -  > Usage: dash-haskell [-p|--dbprovider <provider,args>] [-o|--output <dir>]-  >                     [-q|--quiet] [-c|--cabal <file.cabal>]-  >                     [-r|--cabal-constraints executable=name, ..] [packages]-  >   additional help is also available on arguments with "dash-haskell help arg"--  > Available options:-  >   -h,--help                Show this help text-  >   -p,--dbprovider <provider,args>-  >                            a ghc package db provider: cabal|ghc|dir-  >   -o,--output <dir>        the directory to write created docsets to-  >   -q,--quiet               set to quiet output-  >   -c,--cabal <file.cabal>  the cabal file to source package dependencies from -  >   -r,--cabal-constraints executable=name, ..-  >                            limit package results from a cabal file source, see-  >                            documentation-  >   packages                 a list of packages to specifically build, e.g.-  >                            either-1.0.1 text-1.2.0+  >$ dash-haskell parsec-3.1.5   .-  > $ cd foo-1.2.0/ -  > $ dash-haskell -c foo.cabal -o docsets -  > db provider:-  >   lookup strategy: cabal sandbox db index-  >   cmd: cabal-  >   args: sandbox hc-pkg list-  >-  > processing: system-filepath-0.4.12-  >   writing files..-  >   writing plist..-  >   populating database..-  >   finished populating sqlite database..-  >-  > processing: system-fileio-0.3.14-  >   writing files..-  >   writing plist..-  >   populating database..-  >   finished populating sqlite database..-  >-  > processing: pipes-4.1.2-  >   writing files..-  >   writing plist..-  >   populating database..-  >   finished populating sqlite database..-  >-  > warning: failed to process: parsec-3.1.5-  > warning: path errors in pkg conf file:-  >  /home/jpf/local/cabal-sandboxes/dash-haskell/x86_64-linux-ghc-7.8.3-packages.conf.d/parsec-3.1.5-abf7e89cafe4e74712f678cea843c1c8.conf-  > with problem(s):-  >  missing: haddock interface file-  >  missing: html doc dir-  >-  > processing: sqlite-simple-0.4.8.0-  >   writing files..-  >   writing plist..-  >   populating database..-  >   finished populating sqlite database..-  >-  > $+  builds:   .-  Notice, the failure of parsec-3.1.5 is illustrated here to show that in this case, dash-haskell depends on haddock documentation being built for the requested package. A possible resolution in this case, if using a sandbox, is:+  >./docsets/parsec-3.1.5.docset   .-  > $ cabal install --reinstall parsec-3.1.5 --enable-documentation-  > $ dash-haskell parsec-3.1.5 -o docsets+  >$ dash-haskell -c foo.cabal -s+  .           +  builds all packages listed as dependencies in the cabal file using atleast the cabal sandbox db   .+  using the default db ordering (global, sandbox, user).+  .+  Note: haddock documentation for the package must first be built prior to calling dash-haskell on it, e.g.+  .+  >$ cabal install --only-dependencies --enable-documentation+  .   Versions:   .   The version numbering scheme for this package is defined as follows, given: @@ -102,45 +56,43 @@   executable dash-haskell-  main-is:             Main.hs-  other-modules:       Pipes.Db-                       Pipes.Conf-                       Pipes.FileSystem-                       Options-                       Package-                       Control.Monad.M -                       Data.String.Util-                       Data.String.Indent-                       Haddock-                       Options.CabalConstraints-                       Options.Documentation-                       Options.Cabal-                       Options.DbProvider-                       Haddock.Sqlite-                       Haddock.Artifact-                       PackageId-                       Package.Conf+  main-is:        Main.hs+  other-modules:  FilePath+                  Options.Documentation+                  Options.Db+                  Options.Cabal+                  Data.Maybe.Util+                  Data.String.Util+                  PackageConf+                  Options+                  Control.Monad.M+                  Db+                  Haddock.Sqlite+                  Haddock.Artifact+                  Pipe.Conf+                  Pipe.FileSystem+                  PackageId -  build-depends:       Cabal                >= 1.18-                     , base                 >= 4.7 && < 4.9-                     , bytestring           >= 0.10.0.1-                     , containers           >= 0.5.5.1-                     , direct-sqlite >= 2.3.13-                     , directory            >= 1.2.1.0-                     , either               >= 4.3-                     , ghc                  >= 7.10.1-                     , mtl                  >= 2.1.3.1-                     , optparse-applicative >= 0.11.0 && < 0.12.0-                     , pipes                >= 4.1.0-                     , process              >= 1.2.0.0-                     , sqlite-simple        >= 0.4.5.0-                     , system-fileio        >= 0.3.12 && < 0.4.0-                     , system-filepath      >= 0.3.1 && < 0.5-                     , tagsoup              >= 0.12.7-                     , text                 >= 0.7.1-                     , transformers         >= 0.3 && < 0.5-                     , parsec               >= 3.1.5-                     , haddock-api          >= 2.15.0+  build-depends:  Cabal                  >= 1.18.0+                  , base                 >= 4.7 && <= 4.9+                  , bytestring           >= 0.10.0.1+                  , containers           >= 0.5.5.1+                  , direct-sqlite >= 2.3.13+                  , directory            >= 1.2.1.0+                  , either               >= 4.3+                  , filepath             >= 1.4.0.0+                  , ghc                  >= 7.10.1+                  , mtl                  >= 2.1.3.1+                  , optparse-applicative >= 0.11.0.1+                  , pipes                >= 4.1.0+                  , process              >= 1.2.0.0+                  , sqlite-simple        >= 0.4.5.0+                  , system-fileio        >= 0.3.12 && < 0.4.0+                  , tagsoup              >= 0.12.7+                  , text                 >= 0.7.1+                  , transformers         >= 0.2 && < 0.5+                  , parsec               >= 3.1.5+                  , haddock-api          >= 2.15.0   ghc-options:         -Wall -rtsopts   hs-source-dirs:      src   default-language:    Haskell2010
src/Control/Monad/M.hs view
@@ -1,13 +1,11 @@ module Control.Monad.M where+import Control.Monad+import Control.Monad.IO.Class import Control.Monad.Trans.Either import Control.Monad.Trans.Reader-import Control.Monad.IO.Class-import Control.Monad-import Control.Applicative ((<$>))-import System.Exit+import Data.String.Util import Pipes--import Data.String.Indent+import System.Exit  type M r = ReaderT Env (EitherT String IO) r @@ -22,7 +20,9 @@ warning :: String -> M ()  warning str = do    i <- indention <$> env -  liftIO . putStr $ fromIndent ("warning: " ++ str) i+  liftIO $ do+    putStr $ indenting i ("warning: " ++ str)+    putStr "\n"  indent :: Int -> Env -> Env indent amount (Env i v) = Env (i + amount) v@@ -33,17 +33,21 @@ msg :: (MonadIO m) => String -> ReaderT Env m ()  msg str = do   e <- ask -  when (verbosity e) . liftIO . putStr . fromIndent str $ indention e+  when (verbosity e) . liftIO . putStr . indenting (indention e) $ str  err :: String -> M r err = lift . left +fromE :: (Unquoted b) => Either b a -> M a+fromE (Left  er)  = err . toString $ er +fromE (Right val) = return val + runM :: Env -> M () -> IO ()  runM env' comp = do    result <- runEitherT (runReaderT comp env')   case result of     Left e -> do -      liftIO . putStrLn $ "fatal error:\n\n" ++ e+      liftIO . putStrLn $ "fatal error:\n" ++ e       exitFailure     Right ()  ->        exitSuccess
+ src/Data/Maybe/Util.hs view
@@ -0,0 +1,5 @@+module Data.Maybe.Util where++toMaybe :: Bool -> a -> Maybe a+toMaybe True a  = Just a+toMaybe False _ = Nothing
− src/Data/String/Indent.hs 
@@ -1,6 +0,0 @@-module Data.String.Indent (fromIndent) where-import qualified Data.List as L--fromIndent ::  String -> Int -> String-fromIndent orig margin = -  L.unlines . L.map (L.replicate margin ' ' ++)  . L.lines $ orig
src/Data/String/Util.hs view
@@ -1,10 +1,29 @@-module Data.String.Util (preposition) where-import Data.String.Indent+{-# LANGUAGE +  UndecidableInstances, FlexibleInstances, TypeSynonymInstances+  #-}+module Data.String.Util where import qualified Data.List as L +-- Nasty workaround for handling (Show a) uniformly with strings+class Unquoted a where+  toString :: a -> String+instance {-# OVERLAPPING #-} Unquoted String where+  toString = id+instance {-# OVERLAPPING #-} Unquoted Char where+  toString x = [x]+instance Show a => Unquoted a where+  toString = show   ++listing :: (Unquoted u) => [u] -> String +listing = L.intercalate "\n" . map toString+ preposition :: String -> String -> String -> String -> [String] -> String  preposition problem prep subjectLabel subject problems = -  L.intercalate "\n" $+  listing $     (problem ++ ' ':prep ++ ' ':subjectLabel ++ ":")      : (' ':subject)-    : "with problem(s):" : L.lines (fromIndent (L.unlines problems) 1)+    : "with problem(s):" : L.lines (indenting 1 $ L.unlines problems)++indenting ::  Int -> String -> String+indenting margin orig = +  L.unlines . L.map (L.replicate margin ' ' ++)  . L.lines $ orig
+ src/Db.hs view
@@ -0,0 +1,41 @@+module Db where++data Db = +  -- A cabal sandbox db, with optional path to sandbox configuration file  + Sandbox+  -- The global ghc package database+ | Global                 +  -- The user package database, as defined by cabal + | User                   +  -- A direct database path+ | Dir FilePath+ +instance (Show Db) where+  show (Sandbox) = "cabal sandbox" +  show (Global ) = "ghc distribution (global db)" +  show (User   ) = "system user" +  show (Dir  p)  = "db directory: " ++ p++instance (Ord Db) where+  compare Sandbox Sandbox   = EQ +  compare Global  Global    = EQ +  compare User    User      = EQ +  compare (Dir _) (Dir _) = EQ++  compare (Dir _) Global   = LT +  compare (Dir _) User     = LT +  compare (Dir _) Sandbox  = LT +  compare User Global       = LT +  compare User Sandbox      = LT +  compare Global Sandbox    = LT ++  -- Just reversing the above for l != r+  compare Global  (Dir _)  = GT+  compare User    (Dir _)  = GT+  compare Sandbox (Dir _)  = GT+  compare Global  User      = GT+  compare Sandbox Global    = GT+  compare Sandbox User      = GT++instance (Eq Db) where+  l == r = compare l r == EQ
+ src/FilePath.hs view
@@ -0,0 +1,18 @@+module FilePath where+import qualified System.Directory as D++checkPath :: Bool -> FilePath -> String -> IO (Maybe String) +checkPath dir path name = do +  exists <- predicate path +  return $+    if exists then Nothing else Just $+    "missing " ++ path_type ++ " of " ++ name+  where +    (predicate, path_type) =+      if dir then (D.doesDirectoryExist, "dir") else (D.doesFileExist, "file")++checkDir :: FilePath -> String -> IO (Maybe String)+checkDir = checkPath True  ++checkFile :: FilePath -> String -> IO (Maybe String)+checkFile = checkPath False
− src/Haddock.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Haddock where-import qualified Filesystem.Path.CurrentOS as FPC-import Documentation.Haddock--data HaddockArg = HaddockArg { name :: String, value :: Maybe String } --instance Show HaddockArg where-  show arg = "--" ++ name arg ++ maybe [] (\v -> '=':v) (value arg) --runHaddock :: [HaddockArg] -> IO () -runHaddock = haddock . map show --flag :: String -> HaddockArg-flag = flip HaddockArg Nothing--readInterface :: FPC.FilePath -> HaddockArg -readInterface ipath = -  HaddockArg "read-interface" . Just $ -    (FPC.encodeString . FPC.filename . FPC.dropExtension $ ipath) ++ ',': FPC.encodeString ipath---- | Given a directory with .haddock interface specs, --- write index files and TOC for those to the document directory. -runHaddockIndex :: FPC.FilePath -> FPC.FilePath -> IO ()-runHaddockIndex interface document_dir =-  runHaddock $ [-    -- generate html index file(s)-    flag "gen-index", -    -- generate the html contents file-    flag "gen-contents",-    -- output directory for index file(s) is same as document dir -    HaddockArg "odir" . Just . FPC.encodeString $ document_dir-   ] ++ [readInterface interface]
src/Haddock/Artifact.hs view
@@ -3,7 +3,6 @@ import           Control.Monad.M import           Data.String.Util import           Documentation.Haddock-import qualified Filesystem.Path.CurrentOS as P import qualified Module as Ghc import qualified Name as Ghc @@ -11,14 +10,14 @@ -- https://github.com/philopon/haddocset  data Artifact-  = Haddock  P.FilePath -- Note, this is not yet honored. TODO+  = Haddock  FilePath -- Note, this is not yet honored. TODO   | Package     | Module   Ghc.Module   | Function Ghc.Module Ghc.Name -parseError :: String -> P.FilePath -> M r+parseError :: String -> FilePath -> M r parseError e p = -  err $ preposition "parser error" "in" "haddock interface" (P.encodeString p) [e]+  err $ preposition "parser error" "in" "haddock interface" p [e]  fromInterfaces :: Ghc.PackageKey -> [InstalledInterface] -> [Artifact] fromInterfaces _   []       = []  @@ -34,9 +33,9 @@      else        fromInterfaces pkg rest     -toArtifacts :: Ghc.PackageKey -> P.FilePath -> M [Artifact]+toArtifacts :: Ghc.PackageKey -> FilePath -> M [Artifact] toArtifacts pkg haddock' = do -  interface_file <- liftIO $ readInterfaceFile freshNameCache (P.encodeString haddock')+  interface_file <- liftIO $ readInterfaceFile freshNameCache haddock'   case interface_file of     Left e -> parseError e haddock'     Right (InterfaceFile _ installed_ifaces) ->
src/Haddock/Sqlite.hs view
@@ -2,7 +2,6 @@ module Haddock.Sqlite where import           Control.Monad.IO.Class import           Control.Monad.M-import           Data.Monoid import qualified Data.Text as T import           Database.SQLite.Simple import           Haddock.Artifact
src/Main.hs view
@@ -1,39 +1,50 @@-import qualified Filesystem.Path.CurrentOS as P import           Control.Monad.M-import           Pipes-import           Pipes.FileSystem-import           Pipes.Conf-import           Pipes.Db+import qualified Data.List as L+import qualified Data.Set as S+import qualified Distribution.Package as C+import qualified Options as O import           Options.Applicative+import           Options.Cabal import           Options.Documentation-import           Options--import qualified Data.List as L+import           Pipe.Conf+import           Pipe.FileSystem+import           Pipes import           System.Environment+    +-- | This yields requested packages from command line and cabal file, if any.+prod_Dependencies :: O.Options -> ProducerM C.Dependency () +prod_Dependencies options = do+  cabal_deps <- lift cabalDeps+  let deps = cabal_deps ++ O.packages options+  if L.null deps then +    liftIO $ putStrLn "quitting due to no package dependencies evaluated"+  else+    each . nub' $ deps+  where+    -- This produces a version disjoint package list from the cabal file.+    cabalDeps :: M [C.Dependency]+    cabalDeps =  +      maybe +        (return []) (`readPackages` (S.fromList $ O.cabalExclusions options)) $+        O.cabalFile options  main :: IO () main = do -  -- Check for help mode arg first. There doesn't seem to be a good way to do this-  -- otherwise with opt-parse applicative.   args <- getArgs-  case L.partition (== "help") args of +  case L.partition (== "help") args of     ([], args') -> do       options <- handleParseResult $ execParserPure (prefs idm) parserInfo args'-      -      -- Run the package processing pipeline. Packages that can't be completed due-      -- to either conversion error or user error, should, if necessary, leave a safe partially-      -- completed state on the FS that can be handled by dependant tools, e.g. Emacs helm-dash. -      runM (newEnv (not . quiet $ options)) . runEffect $-       cons_writeFiles (P.decodeString $ outputDir options) -- writes converted html, haddock, and sql db-       <-< pipe_Conf              -- yields vetted package configurations-       <-< pipe_ConfFp (dbprovider options)  -- yields GHC package config files-       <-< prod_Packages options+      runM (newEnv (not . O.quiet $ options)) . runEffect $+        -- writes converted html, haddock, and sql db+        cons_writeFiles (O.outputDir options) +        <-< pipe_PackageConf options  -- yields vetted package configs+        <-< prod_Dependencies options -- produces dependencies from options      (_, rest) -> toHelp docs rest      where -   parserInfo :: ParserInfo Options-   parserInfo = info (helper <*> parser)  $-     header "dash-haskell v1.0.0.5, a dash docset construction tool for Haskell packages"+   parserInfo :: ParserInfo O.Options+   parserInfo = info (helper <*> O.parser)  $+     header "dash-haskell v1.1.0.0, a dash docset construction tool for Haskell packages"      <> progDesc "additional help is available with \"dash-haskell help <topic|option>\""-     <> footer "http://www.github.com/jfeltz/dash-haskell (C) John P. Feltz 2014"+     <> footer "http://www.github.com/jfeltz/dash-haskell (C) John P. Feltz 2014, 2015"
src/Options.hs view
@@ -1,113 +1,108 @@-{-# LANGUAGE TupleSections #-}-+{-# LANGUAGE FlexibleContexts #-} module Options where--import           Control.Applicative-import           Control.Monad.M-import qualified Data.List as L- import           Data.Monoid import qualified Distribution.Package as C-import qualified Distribution.Version as CV import           Distribution.Text-import           Options.Applicative.Types (readerAsk)+import qualified Distribution.Version as V++import           Options.Applicative.Types (readerAsk, fromM, manyM) import           Options.Applicative.Builder import           Options.Applicative.Common-import           Options.Cabal-import           Options.CabalConstraints (toConstraints, none, CabalConstraints)-import           Options.DbProvider-import           PackageId-import           Pipes-import qualified Data.Set as S+import qualified Text.ParserCombinators.Parsec as P+import           Db+import           Options.Db+import qualified Data.List as L  data Options = Options { -  dbprovider :: DbProvider,-  outputDir  :: FilePath,-  quiet    :: Bool,-  cabal :: Maybe FilePath,-  cabalConstraints :: CabalConstraints, -  packages :: [C.PackageId]+  outputDir        :: FilePath,+  quiet            :: Bool,+  cabalFile        :: Maybe FilePath,+  cabalExclusions  :: [String], +  sandbox          :: Bool, +  nouser           :: Bool,+  db               :: Maybe FilePath,+  dbOrdering       :: [Db], +  packages         :: [C.Dependency] } deriving Show -packageReadM :: Text a => ReadM a-packageReadM = do-  s <- readerAsk-  maybe -   (readerError $ "failed parsing packages:\n " ++ s)-   return -   -- Qualified, as simpleParse is a little obscure.-   (Distribution.Text.simpleParse s) - parser :: Parser Options-parser = -  Options <$> -    option toProvider -      (long "dbprovider" -      <> short 'p'-      <> metavar "<provider,args>"-      <> value (CabalSandbox Nothing) -      <> help "a ghc package db provider: cabal|ghc|dir\n")-    <*>-    strOption (-     long "output" -     <> short 'o'-     <> metavar "<dir>" -     <> value "./docsets" -     <> help "the directory to write created docsets to")-    <*>-    switch (long "quiet" <> short 'q' <> help "set to quiet output")-    <*>-    option (Just <$> readerAsk)-     (long "cabal"-     <> short 'c'  -     <> metavar "<file.cabal>" -     <> value Nothing-     <> help "the cabal file to retrieve package dependencies from")-    <*>-    option toConstraints-      (long "cabal-constraints"-      <> short 'r'-      <> value none -      <> metavar "executable=name, .."-      <> help "limit package results from a cabal file source, see documentation")-    <*>-    many (-     argument packageReadM (metavar "packages" <>-     help "a list of packages to specifically build, e.g. either-1.0.1 text"-     ))+parser = Options <$> +  (strOption $ +    long "output" +    <> short 'o'+    <> metavar "<dir>" +    <> value "./docsets" +    <> help "the directory to write created docsets to")+  <*>+  switch (long "quiet" <> short 'q' <> help "set to quiet output")+  <*>+  option (Just <$> readerAsk)+    (long "cabal"+    <> short 'c'  +    <> metavar "<file.cabal>" +    <> value Nothing+    <> help "the cabal file to retrieve package dependencies from")+  <*>+  option toPackageL+    (long "cabal-excludes"+      <> short 'x'+      <> value []+      <> metavar "ghc,lens.."+      <> help "limit package results from a cabal file source")+  <*>+  switch (long "sandbox" <> short 's' <> help "use cabal sandbox")+  <*>+  switch (long "no-user" <> short 'n' <> help "don't source packages from user db")+  <*>+  option fp+    (long "db"+    <> metavar "<path-to-package-db>"+    <> value Nothing+    <> help "package db directory")+  <*>+  option toOrdering+    (long "ordering"+      <> short    'd'+      <> value    defaultOrdering +      <> metavar "user,sandbox.."+      <> help    "ordering of user, dir, and sandbox db's")+  <*>+  (fromM . manyM $ (+    argument dep +    (metavar "packages" <>+     help "a list of packages to specifically build, e.g. either-1.0.1 text")))+  where+    fp :: ReadM (Maybe FilePath)+    fp = do+      str' <- str  +      return $ if (L.null str') then Nothing else (Just str') --- | Given two lists of package satisfying strings, --- return a list that is non-duplicate, the most versioned of the two.--- e.g. if 'either-4.1.0' is in one, and 'either' is the other, --- the versioned is chosen. If both are versioned, both appear in--- the final result.-reduce :: [C.PackageId] -> [C.PackageId]-reduce = fromAsc . L.sort where-  -- Here we exploit the fact that you only need to examine the next member of -  -- an ascending list to determine a version-  fromAsc :: [C.PackageId] -> [C.PackageId]-  fromAsc []      = []-  fromAsc ([p])  = [p]-  fromAsc (p:nxt:rest)-    | p == nxt = -- duplicate -      fromAsc (nxt:rest) -    | unversioned p == unversioned nxt = -      if unversioned p == p then-        fromAsc $ nxt:rest-      else -- both are versioned by list ordering-        p : nxt : fromAsc rest -    | otherwise = -- they're different packages-        p : fromAsc ( nxt : rest )+    versionless :: C.PackageIdentifier -> Bool +    versionless p = C.packageVersion p == V.Version [] [] -versionless :: String -> C.PackageId-versionless n = C.PackageIdentifier (C.PackageName n) $ CV.Version [] [] +    dep :: ReadM C.Dependency +    dep = do+      pkg_str <- readerAsk+      case simpleParse pkg_str of +        Nothing                  ->+          readerError $ "failed parsing package: "+        Just pkg ->+          return $ +            if versionless pkg then+              C.Dependency (C.packageName pkg) V.anyVersion +            else+              C.thisPackageVersion pkg -prod_Packages :: Options -> ProducerM (S.Set String) () -prod_Packages options = do-  cabal_dependencies <--    lift $ case cabal options of -      Nothing -> return [] -      Just fp -> (S.toList . S.map versionless) -                 <$> readPackages fp (cabalConstraints options)-  yield . S.fromList . map (show . disp) $ -    reduce (packages options ++ cabal_dependencies)+toPackageL :: ReadM [String]+toPackageL = do+    expr <- readerAsk+    case P.parse parser' [] expr of +      Left err -> readerError . show $ err+      Right pkgs -> return pkgs +    where+      parser' :: P.Parser [String]+      parser' =+        P.sepBy+          (P.many1 (P.notFollowedBy (P.char ',') >> P.letter))+          (P.char ',') +
src/Options/Cabal.hs view
@@ -4,135 +4,82 @@ module Options.Cabal where import qualified Data.Set as S import           Control.Monad.M-import           Data.Monoid-import qualified Data.Map as M+ import qualified Data.List as L-import           Control.Applicative import           Control.Monad import qualified Distribution.PackageDescription.Parse as C import qualified Distribution.Package as C+import qualified Distribution.Version as C import qualified Distribution.PackageDescription as C-import           Data.Either import           Data.String.Util import           Control.Monad.IO.Class-import qualified Options.CabalConstraints as OC+import           Data.Function (on)+import           Data.Maybe -type Package = String-newtype Targets = Targets { mapping :: M.Map String (S.Set Package) }+toPkgName :: C.Dependency -> String+toPkgName (C.Dependency (C.PackageName name) _) = name -fromTargets :: Targets -> S.Set Package-fromTargets = S.unions . M.elems . mapping -    -data DependencyDescription =-  DependencyDescription { -    library :: Maybe (S.Set Package),-    execs :: Targets,-    suites :: Targets, -    benchmarks :: Targets- } +vintersection :: C.Dependency -> C.Dependency -> Bool+vintersection (C.Dependency _ lv) (C.Dependency _ rv) = + not $ C.intersectVersionRanges lv rv == C.noVersion --- | Return the packages to use from the target type, or fail with unfound targets.-fromTargetType :: S.Set String -> Targets -> Either [String] (S.Set String) -fromTargetType narrowing tgts = do-  used_targets <- -- return a list of used targets -    if S.null narrowing then-       return . M.keysSet . mapping $ tgts -    else -- error check narrowed packages-      let found   = S.intersection narrowing $ M.keysSet (mapping tgts)-          unfound = S.difference narrowing found-      in if not . S.null $ unfound then-        Left . S.toList $ unfound -      else -        return found -  -- accumulate dependencies from found keys-  return $-    S.unions -    . map snd-    . M.toList-    . M.intersection (mapping tgts)-    . M.fromList $ zip (S.toList used_targets) (replicate (S.size used_targets) ())+-- | Post-condition: no version overlap+nub' :: [C.Dependency] -> [C.Dependency]+nub' = L.nubBy (\l r -> toPkgName l == toPkgName r && vintersection l r) -toPackages :: FilePath -> DependencyDescription -> OC.CabalConstraints -> M (S.Set Package) -toPackages cabal desc constraints = -  case toPkgs pairings of-    Left unfound ->-      err $ -        preposition -          "failed to find targets" -          "in"-          "cabal file"-          cabal -          unfound-    Right set  ->-      let -        matched_excluded = S.intersection set (OC.excluded constraints)-        remainder = S.difference (OC.excluded constraints) matched_excluded -      in do-      unless (S.null remainder) . -        warning . -          L.intercalate "\n" $-          "packages to exclude were not found:" : S.toList remainder -      return $ S.difference set (OC.excluded constraints)+fromExclusions ::  S.Set String -> [C.Dependency] -> M [C.Dependency] +fromExclusions exclusions deps = do +  -- Print packages which were intended to be excluded, but+  -- weren't found anyway.  +  unless (S.null unfound_exclusions) $+    warning+      . listing+      . ("packages to exclude were not found:":)+      . map toString+      . S.toList+      $ excluded +  -- Print version overlapped (removed packages) if any.+  unless (L.null overlapped) $+    warning $ +      ("removed the following packages from processing due version" +      ++ " range overlap:\n") ++ (indenting 2 . listing $ overlapped)+  return disjoint +            where-    -- | Produce a list of targets to evaluate based off selection, e.g.-    -- if any fst member of tuple is non-empty, the subset is returned.-    -- if all are non-empty, all are considered -    toPkgs :: [(S.Set String, Targets)] -> Either [String] (S.Set Package) -    toPkgs list =-      case L.partition (S.null . fst) list of-        (non_selections, []) -> -          Right . S.unions . map (fromTargets . snd) $ non_selections  -        (_, selections)      -> -          case partitionEithers (L.map (uncurry fromTargetType) selections) of -            ([],sets)   -> Right . S.unions $ sets -            (unfound,_) -> Left . concat $ unfound -      -    -- | Return pairings of expected cabal targets to actual cabal targets-    pairings :: [(S.Set String, Targets)] -    pairings = -      let -        lib_pairing :: (S.Set Package, Targets)-        lib_pairing = -          (if OC.lib constraints then S.singleton "library" else mempty,-           Targets $ maybe mempty (M.singleton "library") (library desc)) -      in-      lib_pairing :-        zip (map ($ constraints) [OC.execs, OC.suites, OC.benchmarks])-            (map ($ desc)   [execs, suites, benchmarks]) --toStrName :: C.Dependency -> String-toStrName (C.Dependency (C.PackageName name) _) = name-  -toTargets :: [(String, C.CondTree a [C.Dependency] b)] -> Targets-toTargets = -  let -    toStrDeps target tree = (target, S.fromList . map toStrName $ C.condTreeConstraints tree) -  in-    Targets . M.fromList . map (uncurry toStrDeps)+    excluded = S.intersection (S.fromList $ map toPkgName deps) exclusions+    unfound_exclusions = S.difference exclusions excluded+    unexcluded = L.filter (not . flip S.member excluded . toPkgName) deps+    sorted     = L.sortBy (on compare toPkgName) unexcluded -- for readability+    disjoint   = nub' sorted+    -- | Calculate the packages with overlapped ranges +    overlapped = sorted L.\\ disjoint  --- | Given the defined constraints, return packages satisfying from the cabal file.-readPackages :: FilePath -> OC.CabalConstraints -> M (S.Set Package)-readPackages cabal constraints = do -  parse_result <- liftIO $ C.parsePackageDescription <$> readFile cabal+-- | Given the defined exclusion set, return a list with the+-- following properties: +-- 1 version overlap is not a relation for deps's taken as a set +-- 2 unversioned packageId's satisfy cabal constraints +readPackages :: FilePath -> S.Set String -> M [C.Dependency]+readPackages cabal_path exclusions = do +  parse_result <- liftIO $ C.parsePackageDescription <$> readFile cabal_path   case parse_result of     (C.ParseFailed fail_msg) ->       err . show $ fail_msg-    (C.ParseOk warnings desc) ->	do+    (C.ParseOk warnings desc) -> do       unless (L.null warnings) . warning $          preposition -          "warnings during parse" -          "of"-          "cabal file"-          "warnings"+          "warnings during parse" "of" "cabal file" "warnings"           (map show warnings)-      -      toPackages cabal (toDescription desc) constraints +      msg $ "parsing cabal file: " ++ cabal_path+      fromExclusions exclusions . toDeps $ desc    where-    -- Produce a simplified description of the cabal file for processing.-    toDescription :: C.GenericPackageDescription -> DependencyDescription -    toDescription gpd =  -     DependencyDescription-       (S.fromList . map toStrName . C.condTreeConstraints <$> C.condLibrary gpd)-       (toTargets . C.condExecutables $ gpd)-       (toTargets . C.condTestSuites $ gpd)-       (toTargets . C.condBenchmarks $ gpd)+    toDeps :: C.GenericPackageDescription -> [C.Dependency] +    toDeps gpd =+      concatMap ($ gpd) [+        concatDeps . maybeToList . C.condLibrary,+        concatDeps . map snd . C.condExecutables,+        concatDeps . map snd . C.condTestSuites,+        concatDeps . map snd . C.condBenchmarks +        ]+      where+        concatDeps :: [C.CondTree v [C.Dependency] a] -> [C.Dependency]+        concatDeps = concatMap C.condTreeConstraints
− src/Options/CabalConstraints.hs 
@@ -1,92 +0,0 @@-module Options.CabalConstraints where--import qualified Data.Set as S-import Data.Monoid-import Text.ParserCombinators.Parsec-import Control.Applicative hiding ((<|>), many, optional)-import Control.Monad-import qualified Options.Applicative.Types as O--data CabalConstraints = -  CabalConstraints {-    lib :: Bool,-    execs :: S.Set String, -- The execs to limit to-    suites :: S.Set String, -- The suites to limit to-    benchmarks :: S.Set String, -- The benchmarks to limit to-    excluded :: S.Set String -- Packages to exclude-  } deriving (Show, Eq)--instance Monoid CabalConstraints where -  mempty = CabalConstraints False mempty mempty mempty  mempty-  mappend l r = -    CabalConstraints -      (lib r || lib l)  -- This just biases to True -      (mappend (execs l) (execs r))-      (mappend (suites l) (suites r))-      (mappend (benchmarks l) (benchmarks r))-      (mappend (excluded l) (excluded r))--none :: CabalConstraints -none = mempty --type Constructor = S.Set String -> CabalConstraints--excluded',benchmarks',suites',execs' :: Constructor -excluded' s   = none { excluded = s } -benchmarks' s = none { benchmarks = s } -execs' s      = none { execs = s } -suites' s     = none { suites = s } ---- | Parser for the cabal constraints option.--- Note: I don't think this can be simplified with sepBy since the --- non-sep parser may fail, causing input and positioning to be lost.--- If someone knows a better way, please advise/patch.-constraints :: Maybe Constructor -> Parser CabalConstraints -constraints Nothing =-  -- parse a lhs binding or lib -  choice $ map try [-    -- lib as leader-    do  -      c <- string "library" >> return (none { lib = True })-      choice [-        char ',' >> mappend c <$> constraints Nothing, -        eof >> return c-        ]-    , do -        ctor <- binding-        constraints (Just ctor) -    ]-  where-    binding :: Parser Constructor -    binding = do -      ctor <- choice $ map try [ -        string "executables" >> return execs',-        string "suites" >> return suites',-        string "benchmarks" >> return benchmarks',-        string "excluded" >> return excluded'-        ]-      void . char $ '=' -      return ctor-constraints (Just ctor) = do-  -- parse the next value-  v <- value  -  -- the next is either eol, or a deliminated binding/value -  c <- choice [-    eof >> return none,-    try (char ',' >> constraints Nothing), -- binding pre-empts value-    try (char ',' >> constraints (Just ctor))-    ]-  return $ mappend (ctor . S.singleton $ v) c-  where-    value :: Parser String-    value = do -      var <- many1 (alphaNum  <|> char '-')-      notFollowedBy (char '=')-      return var--toConstraints :: O.ReadM CabalConstraints-toConstraints = do-    expr <- O.readerAsk-    case parse (constraints Nothing) [] expr of -      Left err -> O.readerError . show $ err-      Right c -> return c
+ src/Options/Db.hs view
@@ -0,0 +1,38 @@+module Options.Db where+import qualified Data.List as L+import           Data.Maybe+import           Db+import qualified Options.Applicative.Types as O+import           Text.ParserCombinators.Parsec++dbStrings :: [String] +dbStrings = ["sandbox", "user", "dir"]++dbPaths :: [Db] +dbPaths = [Sandbox, User, Dir []]+        +fromString :: String -> Db+fromString str = fromJust . L.lookup str $ zip dbStrings dbPaths ++valid :: [Db] -> Bool +valid []  = False +valid dbs = L.length (L.nub dbs) == L.length dbs +  +quasiOrdering :: Parser [Db] +quasiOrdering =+  map fromString <$> sepBy (choice $ map string dbStrings) (char ',') ++defaultOrdering :: [Db]+defaultOrdering = dbPaths ++toOrdering :: O.ReadM [Db]+toOrdering = do +  expr <- O.readerAsk+  case parse quasiOrdering [] expr of +    Left err -> O.readerError . show $ err+    Right qo ->+      if valid qo then+        return qo+      else +        O.readerError "invalid (possibly containing duplicates)"+
− src/Options/DbProvider.hs 
@@ -1,72 +0,0 @@-module Options.DbProvider where-import qualified Data.List as L-import Options.Applicative.Types-import Control.Applicative-import Control.Monad-import Data.Maybe--data DbProvider = -  CabalSandbox (Maybe String)-  | Ghc (Maybe String) -  | Db FilePath  --instance (Show DbProvider) where-  show dbp = -    let (cmd, args) = toExec dbp in -      L.intercalate "\n"-       ["lookup strategy: " ++  desc, "cmd: " ++ cmd ++ "\nargs: " ++ unwords args] -    where-      desc = -        case dbp of -          CabalSandbox _ -> "cabal sandbox db index" -          Ghc _          -> "ghc db index" -          Db _           -> "ghc db index with directory narrowing" --fromSplit :: Char -> String -> ReadM (String, Maybe String)-fromSplit c opt = -  case opt of -    []         -> return ([], Nothing) -    (s:str) ->-     if s == c then do-      param <- fromParam str -      return ([], param)-     else do -      (l, r) <- fromSplit c str-      return (s:l, r)-  where -    fromParam []      =  return Nothing-    fromParam (c':str)=-      if c' == c then-        readerError $ "encountered delimeter(" ++ c:") twice"-      else-        Just . maybe [c'] (c':) <$> fromParam str--toExec :: DbProvider -> (String, [String])-toExec (CabalSandbox args) = -  (,) "cabal" $ ["sandbox", "hc-pkg", "list"] ++ maybeToList args-toExec (Ghc args)          = -  (,) "ghc-pkg" $ "list" : maybeToList args-toExec (Db fp)             = -  (,) "ghc-pkg" ("list":["--package-db=" ++ fp]) --toProvider :: ReadM DbProvider-toProvider = do-  expr <- readerAsk-  (prov, arg) <- fromSplit ',' expr-  join $ constructor prov <*> pure arg-  where -    constructor :: String -> ReadM (Maybe String -> ReadM DbProvider) -    constructor prov =-     maybe (readerError "invalid db provider") return f-     where -      f :: Maybe (Maybe String -> ReadM DbProvider)-      f = -        -- return a constructor given an arg-        L.lookup prov-         [("ghc"   , return . Ghc),-          ("cabal" , return . CabalSandbox),-          ("dir"   , -            maybe -              (readerError "requires directory path")-              (return . Db))-          ]
src/Options/Documentation.hs view
@@ -1,8 +1,9 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Options.Documentation where import qualified Data.Set as S import qualified Data.List as L import qualified Data.Map as M-import Data.String.Indent+import Data.String.Util  data Topic = Topic { title :: String, content :: String }  instance Eq Topic where@@ -17,58 +18,51 @@ tags :: Documentation -> [String]  tags = M.keys  -cabalTopic, providerTopic, outputTopic, packageTopic :: Topic-cabalTopic = -  Topic "cabal constraints" $-    L.intercalate "\n" [-      "These are constraints on packages pulled from a cabal file source.",-      "These constraints allow one to simply select subsets of cabal targets to use",-      "and subsets of packages to avoid sourcing.\n",-      "Some options support multivalue bindings, and are of the form:",-      " -r <var=value>,<var2=value1,value2>",-      "e.g. \"-r executables=foo,excluded=base,ghc\"",-      "\npossible variables:\n",-      " executables : the executable targets to limit to",-      " suites      : the suite targets to limit to",-      " benchmarks  : the benchmark targets to limit to",-      " library     : limit to library, this takes no arguments\n",-      " excluded    : unversioned packages to avoid using"-   ]+cabalSourcingTopic = +  Topic "cabal sourcing" $+    listing [+      "This command pulls package selections from a cabal file",+      "  e.g. -c <project.cabal>\n",+      "Note:",+      "This command is not the same as a db provider.", +      "Note:",+      "If the package occurs more than once in the cabal file", +      "with different range, neither package is taken.\n", +      "Pulled packages can be constrained, see: cabal-constraints." +      ] -providerTopic = Topic "package database provider" $-  L.intercalate "\n" [-    "The external program to call to produce package databases\n"-    , "options are the form <var,args>" -    , "e.g:" -    , "    -p ghc,'--user'"-    , " or -p dir,/home/jpf/.ghc/x86_64-linux-7.8.3/package.conf.d\n"-    , "Note, only one provider at once is supported at this time.\n"-    , "pairings for <var,args>:"-    , " var                                      args "-    , "----------------------------------------- --------------------------------"-    , " cabal : use cabal sandbox package db(s)  flag string to pass to cabal"-    , " ghc   : use ghc's package db(s),         flag string to pass to ghc"-    , " dir   : use package db dir directory     the package db directory"-    +outputTopic =+  Topic "output" $ listing [+     "For each package sourced by dash-haskell, a matching docset"+   , "will be written under this directory in its version, e.g:"+   , " \"output/package-1.2.3.docset\""+  ]++nouserTopic =+  Topic "no-user" $ listing [+    "the no-user flag removes the user package db, e.g. :"+    , "~/.ghc/x86_64-linux-7.10.1/package.conf.d/"+    , "from db consideration"     ] -outputTopic= Topic "output" $ - L.intercalate "\n" [-   "The directory root of which to write .docset directories to\n"-   , "For each package sourced by dash-haskell, a matching docset"-   , "will be written to that directory in its full version form, e.g:\n"-   , "  \"output/package-1.2.3.docset\""- ]+dbTopic   =+  Topic "package database directory" $ listing [+    "a db directory to directly use as the package database,",+    "this is ordered as a \'dir\' in the db stack"+    ] -packageTopic= Topic "package" $- L.intercalate "\n" -  ["a ghc package, e.g. either, or either-4.1.0" ,-  "1. dash-haskell will choose the versioned package if provided", -  "both unversioned and versioned",-  "2. If the package is unversioned it will choose the first as located by",-  " the package db provider."-  ]+orderingTopic   =+  Topic "ordering" $ listing [+    "an ordering of package db's, in that this is the order in which",+    "dbs are examined for packages to use for documentation conversion",+    "\n",+    "Note: The global db must always appear, and it always first. This",+    "is due to upstream constraints in ghc right now. (05/30/205)."+    ] +packageTopic =+  Topic "package" $ "a ghc package, e.g. either, or either-4.1.0"+ toEntry :: S.Set String -> Topic -> Documentation -> Documentation  toEntry s t doc = L.foldl (\m' k -> M.insert k t m') doc $ S.toList s  @@ -76,14 +70,16 @@ docs =    let fromListing m (t,l) = toEntry (S.fromList l) t m in      L.foldl fromListing M.empty [-      (cabalTopic    , ["r", "cabal-constraints"]),-      (providerTopic , ["p", "dbprovider", "provider"]),-      (outputTopic   , ["o", "outputdir", "output", "docset"]),-      (packageTopic  , ["packages", "package"])-    ]+      (cabalSourcingTopic    , ["c", "cabal"]),+      (outputTopic           , ["o", "outputdir", "output", "docset"]),+      (packageTopic          , ["packages", "package"]),+      (nouserTopic           , ["n", "no-user", "user"]),+      (dbTopic               , ["db", "dir"]),+      (orderingTopic         , ["d", "ordering"])+      ]  -- | Given an arbitrary stream of options,--- convert to possible topic indexes for documenation lookup.+-- convert to possible topic indexes for documentation look-up. toIndexes :: [String] -> [String]  toIndexes = S.toList . S.fromList . map toTopic     where@@ -102,13 +98,12 @@     putStrLn "Sorry, no documentation available for expressions given.\n"     toHelp docs []    else do-    putStrLn "accessing help on topics, \n"-    putStr . L.intercalate "\n" . L.map headed $ S.toList topic_set-    putStr "\n"+    putStrLn "accessing help on topics,"+    putStrLn $ indenting 2 (listing . L.map headed $ S.toList topic_set)   where      headed :: Topic -> String -    headed topic = ' ':title topic ++ ':':'\n':'\n': -      fromIndent (content topic) 2+    headed topic =+      ' ':title topic ++ ':':'\n':'\n': indenting 2 (content topic)      folded :: S.Set Topic -> String -> S.Set Topic     folded s index = maybe s (`S.insert` s) $ M.lookup index d
− src/Package.hs 
@@ -1,10 +0,0 @@-module Package where-import Data.Char--unversioned :: String -> String-unversioned [] = -  [] -unversioned ('-':c:rest) =-  if isDigit c then [] else '-':c:unversioned rest -unversioned (c:rest) = -  c:unversioned rest
− src/Package/Conf.hs 
@@ -1,10 +0,0 @@-module Package.Conf where-import qualified Module as Ghc-import qualified Filesystem.Path.CurrentOS as P--data Conf = Conf-  { pkg  :: Ghc.PackageKey-  , interfaceFile :: P.FilePath -- interface, i.e. .haddock file-  , htmlDir   :: P.FilePath -- root html source directory-  , exposed  :: Bool -- module exposure flag-  }
+ src/PackageConf.hs view
@@ -0,0 +1,18 @@+module PackageConf where+import qualified Module as Ghc+import FilePath +import Data.Maybe (catMaybes) ++data PackageConf = PackageConf+  { pkg           :: Ghc.PackageKey+  , interfaceFile :: FilePath -- interface, i.e. .haddock file+  , htmlDir       :: FilePath -- root html source directory+  , exposed       :: Bool     -- module exposure flag+  }++problems :: PackageConf -> IO [String]+problems conf =+  catMaybes <$> sequence [+    checkDir (htmlDir conf) "haddock html" +    , checkFile (interfaceFile conf) "haddock interface" +    ]
src/PackageId.hs view
@@ -1,9 +1,12 @@ module PackageId where-import qualified Distribution.Package as C-import qualified Distribution.Version as CV+import Distribution.Package+import Distribution.Version -emptyVersion :: CV.Version-emptyVersion = CV.Version [] []+emptyVersion :: Version+emptyVersion = Version [] []               -unversioned :: C.PackageId -> C.PackageId-unversioned p = p { C.pkgVersion = emptyVersion } +unversioned :: PackageId -> PackageId+unversioned p = p { pkgVersion = emptyVersion } ++versionless :: String -> PackageId+versionless n = PackageIdentifier (PackageName n) emptyVersion
+ src/Pipe/Conf.hs view
@@ -0,0 +1,169 @@+module Pipe.Conf where+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.M+import PackageConf+import FilePath       +import Text.ParserCombinators.Parsec hiding (State)+import qualified Distribution.InstalledPackageInfo   as CI+import qualified Distribution.Simple.Compiler        as CC+import qualified Distribution.Simple.GHC             as CG+import qualified Distribution.Simple.PackageIndex    as CI+import qualified Distribution.Simple.Program.Builtin as CP+import qualified Distribution.Simple.Program.Db      as CP+import qualified Distribution.Simple.Program         as CP+import qualified Distribution.Package as C+import qualified Distribution.Verbosity           as CVB+import qualified Distribution.Version             as CV+import qualified Distribution.Text        as CT+import Db+import qualified Options as O+import           Data.Maybe+import           Data.Maybe.Util+import qualified Data.List as L+import qualified Data.Set  as S+import Pipes+import qualified Module as Ghc+import Data.String.Util++field :: String -> Parser String+field str =+  string str +  >> char ':'+  >> many (char ' ') +  >> manyTill anyToken (void (char '\n') <|> eof)++singleField :: String -> Parser String +singleField str = try (field str) <|> (anyToken >> singleField str) + +parsedDbPath :: String -> M String +parsedDbPath path = do+  buf <- liftIO $ readFile path+  fromE $ runParser (singleField "package-db") () path buf++cabalSandboxConfig :: FilePath+cabalSandboxConfig = "./cabal.sandbox.config"       ++cabalDb :: Db -> M CC.PackageDB+cabalDb db = +  case db of+    (Global   ) -> return CC.GlobalPackageDB+    (User     ) -> return CC.UserPackageDB+    (Dir  p) ->+      fromCheck =<< liftIO (checkDir p "b") +    s@(Sandbox) ->+      fromCheck =<< liftIO (checkFile cabalSandboxConfig (show s)) +  where+    fromCheck Nothing        =+      CC.SpecificPackageDB <$> parsedDbPath cabalSandboxConfig +    fromCheck (Just err_str) =+      err err_str +        +ghcVersionRange :: CV.VersionRange+ghcVersionRange = + CV.intersectVersionRanges +   (CV.orLaterVersion (CV.Version [7,10]   [])) +   (CV.earlierVersion (CV.Version [7,10,2] [])) ++toIndex :: [CC.PackageDB] -> M CI.InstalledPackageIndex +toIndex stack = do +  version <- liftIO $ CP.programFindVersion CP.ghcPkgProgram CVB.normal "ghc-pkg"+  case version of+    Nothing ->+      warning $+        "unable to determine ghc-pkg version, \n" ++ clause+    Just v ->+      unless (CV.withinRange v ghcVersionRange) $ +        warning $+          "ghc-pkg version: "+          ++ show (CT.disp v) ++ " not within allowable range,\n"+          ++ clause+  liftIO $ do+    minimal_programs <- CP.configureAllKnownPrograms CVB.normal $ +      CP.restoreProgramDb [CP.ghcPkgProgram, CP.ghcProgram] CP.emptyProgramDb++    CG.getInstalledPackages CVB.silent stack minimal_programs+  where+    clause :: String+    clause = +      "results may not match current supported haddock: " +      ++ show (CT.disp ghcVersionRange) ++fromIndex :: C.Dependency -> CI.InstalledPackageIndex -> Maybe PackageConf +fromIndex dep index = +  let +    -- For clarity:+    versions :: [(CV.Version, [CI.InstalledPackageInfo])]+    versions = CI.lookupDependency index dep+  in+    listToMaybe . catMaybes . concatMap (map toConf . snd) $ versions +  where+    toConf :: CI.InstalledPackageInfo -> Maybe PackageConf +    toConf info = do +      interfaceFile' <- listToMaybe $ CI.haddockInterfaces info+      htmlDir'       <- listToMaybe $ CI.haddockHTMLs info+      return $ +        PackageConf +          (Ghc.stringToPackageKey . show . CT.disp $ CI.sourcePackageId info)+          interfaceFile' htmlDir' +          (CI.exposed info)++toOptionDbs :: O.Options -> S.Set Db+toOptionDbs options = +  S.fromList . catMaybes $ +    (Dir <$> O.db options) +    : map (uncurry toMaybe)+        [ (not $ O.nouser options, User), (O.sandbox options, Sandbox) ]++-- | Produce remaining db's given total ordering of dbs and possibly+-- smaller list of dbs.+fromOrdering :: [Db] -> S.Set Db -> Either String [Db]+fromOrdering []           s =+  if S.null s then+    Right []+  else+    Left $ "failed to match package db(s) with defined ordering, dbs:\n" ++ +           (indenting 2 . listing $ S.toList s)+fromOrdering (o:ordering) s =  +  if not $ S.member o s then +    fromOrdering ordering s+  else+    case L.find (o ==) (S.elems s) of+       Nothing -> Left "failed to find matched db in ordering"+       Just e  -> (e :) <$> fromOrdering ordering (S.delete o s)++pipe_PackageConf :: O.Options -> PipeM C.Dependency PackageConf ()+pipe_PackageConf options = do+  index <- lift $ do +    dbs <- -- Right now the cabal API requires a global db,+          -- and for that to be first.+      (Global:)+      <$>+      fromE (fromOrdering (O.dbOrdering options) $ toOptionDbs options)+    liftIO . putStr $+      "using package db stack:\n"+      ++ (listing $ map ((++) " > " . show) dbs)+      ++ "\n\n"+    toIndex =<< stackreverse <$> mapM cabalDb dbs+  forever $ do+    dep <- await+    case fromIndex dep index of +      Nothing -> +        lift . warning $ +          "failed to find suitable documentation candidate for package:\n " +          ++ (show . CT.disp $ dep) +      Just conf -> do+        strings <- liftIO $ problems conf+        if L.null strings then+          yield conf+        else do+          lift . warning $ +            "skipping package: " ++ show (CT.disp dep) ++ ", with conf problems:\n" +             ++ indenting 2 (listing strings)+          return ()+  where+    -- | Counter-intuitively,+    -- Cabal right now actually evaluates the stack from right to left.+    -- not left to right.. and we still have to preserve the first member+    -- (Global)+    stackreverse s = head s : L.reverse (drop 1 s)
+ src/Pipe/FileSystem.hs view
@@ -0,0 +1,237 @@+-- TODO repl test file path methods.++{-# LANGUAGE OverloadedStrings #-}+module Pipe.FileSystem where+import           Control.Monad+import           Control.Monad.M+import qualified Data.ByteString as BS+import           Data.ByteString.Char8 (unpack, pack)+import qualified Data.List as L+import           Data.String.Util+import qualified Data.Text as T+import           Data.Text.Encoding+import           Database.SQLite.Simple+import           System.FilePath+import           PackageConf+import           Pipes+import           System.Directory ( doesDirectoryExist, getDirectoryContents )+import qualified System.Directory as D+import           Text.HTML.TagSoup+import           Text.HTML.TagSoup.Match+import           Haddock.Artifact+import           Haddock.Sqlite+import qualified Module as Ghc++-- TODO the utility of some of these fields is still unclear to me,+-- at the moment they are filled simply to satisfy the docset spec.+plist :: String -> BS.ByteString+plist str = pack . unlines $+  [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+  , "<!DOCTYPE plist PUBLIC \"-//Apple//DTD PLIST 1.0//EN\" \"http://www.apple.com/DTDs/PropertyList-1.0.dtd\">"+  , "<plist version=\"1.0\">"+  , "<dict>"+  , "<key>CFBundleIdentifier</key>"+  , "<string>" ++ str ++ "</string>"+  , "<key>CFBundleName</key>"+  , "<string>docset for Haskell package " ++ str ++ "</string>"+  , "<key>DocSetPlatformFamily</key>"+  , "<string>haskell</string>" +  , "<key>isDashDocset</key>"+  , "<true/>"+  , "<key>dashIndexFilePath</key>"+  , "<string>index.html</string>"+  , "</dict>"+  , "</plist>"+  ]++docsetDir :: Ghc.PackageKey -> FilePath+docsetDir k = Ghc.packageKeyString k ++ ".docset" ++leafs :: (FilePath -> Bool) -> FilePath -> ProducerM FilePath ()+leafs incPred p = do+  names <- liftIO $ getDirectoryContents p+  forM_ (filter (`notElem` [".", ".."]) names) $ \name' -> do+    let path = p </> name'+    dir <- liftIO . doesDirectoryExist $ path+    (if dir then +      leafs incPred +     else if not . incPred $ path then const (return ()) else yield)+      path++type Tag' = Tag T.Text ++remoteUrl :: T.Text -> Bool +remoteUrl url = any (T.isPrefixOf url) ["http://", "https://"]++-- toStripped :: FilePath -> FilePath -> Either String FilePath+-- toStripped pfx original =+         +common :: FilePath -> FilePath -> FilePath+common l r = fst . unzip . takeWhile (uncurry (==)) $ zip (normalise l) (normalise r)++parent :: FilePath -> FilePath+parent = takeDirectory  +       +stripPrefix :: FilePath -> FilePath -> Either String FilePath +stripPrefix prefix path = +  if L.isPrefixOf prefix path then+    Right $ L.drop (L.length prefix + 1) path+  else +    Left $ "prefix: " ++ prefix ++ " doesn't agree with:\n  " ++ path++toRelativePath :: FilePath -> FilePath -> Either String FilePath+toRelativePath base path = do+  let sharedPfx = common base path+  relative <- relativePath sharedPfx+  (</>) relative <$> stripPrefix sharedPfx path +  where +    relativePath :: FilePath -> Either String FilePath+    relativePath pfx = +      joinPath +       . flip replicate ".." +       . length +       . splitPath <$> stripPrefix pfx base ++relativize :: Ghc.PackageKey -> FilePath -> Either String T.Text +relativize package p = +  let filename'      = takeFileName p+      packageSubpath = Ghc.packageKeyString package+      matches        = +        filter (packageSubpath ==) . reverse $ splitPath (parent p)+  in +    T.pack <$> +      if L.null matches then +        return p -- preserve the path so that it still can be used +      else -- assume as a package doc file and make relative+        toRelativePath packageSubpath $ L.head matches </> filename'++convertUrl ::  Ghc.PackageKey -> T.Text -> Either String T.Text +convertUrl p urlExp +  | T.null urlExp = Right T.empty+  | otherwise     =  +    if T.isPrefixOf "file:///" urlExp then +      relativize p (T.unpack . T.drop 7 $ urlExp)+    else if T.isPrefixOf "/" urlExp then +      relativize p $ T.unpack urlExp+    else+      Right urlExp+      +attributes :: FilePath -> Tag T.Text -> Either String [Attribute T.Text] +attributes _ (TagOpen _ list) = +  Right list+attributes src other            =    +  Left $+    "failed to retrieve expected attributes from tag:\n "+    ++ show other  ++ "\n in: \n" ++ src +    +-- | Convert local package-compiled haddock links to local relative. +convertLink :: Ghc.PackageKey -> FilePath -> Tag' -> Either String Tag'+convertLink package src tag =+  -- We're only interested in processing links             +  if not $ tagOpenLit "a" (anyAttrNameLit "href") tag then  +    Right tag+  else do+    preserved <- filter (\(n,_) -> n /= "href") <$> attributes src tag +    let url = fromAttrib "href" tag+    +    if remoteUrl url +      then +        Right tag -- ignore remote links+      else do+        url' <- convertUrl package url +        Right . TagOpen "a" $ ("href", url') : preserved ++pipe_htmlConvert :: +  Ghc.PackageKey -> PipeM FilePath (FilePath, Maybe BS.ByteString) ()+pipe_htmlConvert p = +  forever $ do+    src <- await+    if Just (takeExtension src) /= Just "html" +      then  +        yield (src, Nothing)+      else do +        buf <- T.pack <$> liftIO (readFile src)+        -- Link conversion errors are non-fatal.+        case mapM (convertLink p src) . parseTags $ buf of+          Left e -> do +            lift . warning $ +              preposition "failed to convert links" "for" "file" src [e]+            yield (src, Nothing) +          Right tags ->+            yield (src, Just . encodeUtf8 . renderTags $ tags) ++-- | This consumes a doc file and copies it to a path in 'dstRoot'. +-- By pre-condition: +--   path has src_root as an ancestor +-- By post-condition: +--   written dst is the difference of path and src_root,+--   with by the concatenation of dst_root as it's parent. +cons_writeFile :: +  FilePath -> FilePath -> ConsumerM (FilePath, Maybe BS.ByteString) () +cons_writeFile src_root dst_root = forever $ do +  (path, buf) <- await+  dst_relative_path <- lift . fromE $ stripPrefix src_root path ++  -- liftIO . putStrLn $ "src_root: " ++ show src_root+  -- liftIO . putStrLn $ "relative path: " ++ show dst_relative_path+  -- liftIO . putStrLn $ "path: " ++ show path++  liftIO $ do +    let dst_path = dst_root </> dst_relative_path+    --liftIO . putStrLn $ "dst path: " ++ dst_path+    -- create requisite parent directories for the file at the destination+    D.createDirectoryIfMissing True $ parent dst_path +    case buf of +      Nothing   -> D.copyFile path dst_path +      Just buf' -> writeFile dst_path $ unpack buf'+  +cons_writeFiles :: FilePath -> ConsumerM PackageConf ()+cons_writeFiles docsets_root = forever $ do+  conf <- await+  +  lift . msg $ "processing: " ++ (Ghc.packageKeyString . pkg $ conf)+  let docset_folder = docsetDir (pkg conf) +      dst_root      = docsets_root </> docset_folder +      dst_doc_root  = dst_root </> "Contents/Resources/Documents/"++  liftIO . D.createDirectoryIfMissing True $ dst_doc_root + +  -- Copy all files and convert if necessary +  lift . indentM 2 $ msg "writing files.."+  +  lift . runEffect $ +    cons_writeFile (htmlDir conf) dst_doc_root +    <-< pipe_htmlConvert (pkg conf)+    <-< leafs (\p -> Just (takeExtension p) /= Just "haddock") (htmlDir conf)+  +  -- TODO Since the haddock index is already produced in source docs+  -- with latest packaging systems, this is likely unnecessary +  -- liftIO $ do +  --    putStrLn "running haddock indexes"+  --    runHaddockIndex (interfaceFile conf) dst_doc_root+  lift . indentM 2 $ msg "writing plist.."+  liftIO . writeFile (dst_root </> "Contents/Info.plist") . unpack . plist . +    Ghc.packageKeyString . pkg $ conf ++  let db_path = dst_root </> "Contents/Resources/docSet.dsidx" ++  liftIO $ do+    db_exists <- D.doesFileExist db_path +    when db_exists $ D.removeFile db_path++  -- Initialize the SQlite Db+  c' <- liftIO $ do +        c <- open db_path +        createTable c+        return c++  lift . indentM 2 $ msg "populating database.."++  -- Populate the SQlite Db +  liftIO $ execute_ c' "BEGIN;"+  artifacts <- lift $ toArtifacts (pkg conf) (interfaceFile conf) +  lift $ mapM_ (fromArtifact (pkg conf) c') artifacts+  liftIO $ execute_ c' "COMMIT;"+  liftIO . close $ c'+  lift . indentM 2 $ msg "finished populating sqlite database.."+  lift $ msg "\n"
− src/Pipes/Conf.hs 
@@ -1,77 +0,0 @@-module Pipes.Conf where-import           Control.Applicative-import           Control.Monad-import           Control.Monad.M-import           Control.Monad.Trans.Either-import qualified Data.List as L-import           Data.Maybe-import           Data.String.Util-import           Distribution.InstalledPackageInfo as DIP-import           Distribution.Text (display)-import qualified Filesystem.Path.CurrentOS as P-import qualified Module as Ghc-import           Package.Conf-import qualified PackageConfig as Ghc-import           Pipes-import qualified System.Directory as D--checkPath :: Bool -> P.FilePath -> String -> IO (Maybe String) -checkPath dir path name = do -  exists <- predicate . P.encodeString $ path -  return $ if exists then Nothing else Just $ "missing: " ++ name ++ ' ':msg'-  where -    (predicate, msg') =-      if dir then (D.doesDirectoryExist, "dir") else (D.doesFileExist, "file")--confError :: FilePath -> String -> M r-confError path fatal = -  err $ preposition "parse errors" "in" "conf file" path [fatal] -    -fromParseResults :: FilePath -> ParseResult InstalledPackageInfo -> M Conf-fromParseResults conf (ParseFailed _) = -  confError conf "package conf file parse failed"-fromParseResults conf (ParseOk cabalWarnings fields)-  | null (haddockHTMLs fields)      =-    confError conf "failed to extract html field from conf file"-  | null (haddockInterfaces fields) = -    confError conf "failed to extract haddock interface field from conf file"-  | otherwise = do-    unless (L.null cabalWarnings) $-      liftIO . putStr $-        "parse of:\n " ++ conf ++ "\n completed with warnings: " -        ++ L.intercalate "\n" (map show cabalWarnings) -    lift . right $-      Conf -        -- We're not using Cabal's type information beyond just-        -- extracting package data. Ghc types are used for the rest.-        (Ghc.stringToPackageKey . display . sourcePackageId $ fields)-        -- TODO Respect multiple interfaces, however -        -- this is not the common consensus for use of haddock interfaces. -        (P.decodeString (head $ haddockInterfaces fields))-        (P.decodeString $ head (haddockHTMLs fields) ++ "/")-        (DIP.exposed fields)--diagnosePaths :: Conf -> M [String]-diagnosePaths conf = do-  (html_doc_warnings, interface_warnings) <- liftIO $  -    liftM2 (,)-      (checkPath True (htmlDir conf) "html doc")-      (checkPath False (interfaceFile conf) "haddock interface")-  return $ catMaybes [interface_warnings, html_doc_warnings] --pipe_Conf :: PipeM FilePath Conf ()-pipe_Conf = forever $ do-  pkg_db_conf <- await-  -- Retrieve the package conf file from the package db-  parse_results <- liftIO $ DIP.parseInstalledPackageInfo <$> Prelude.readFile pkg_db_conf-  c <- lift $ fromParseResults pkg_db_conf parse_results--  errors <- lift $ diagnosePaths c-  if L.null errors then-    yield c-  else -    lift $-      do msg "\n"-         warning $ "failed to process: " ++ Ghc.packageKeyString (pkg c)-         warning $ preposition "path errors" "in" "pkg conf file" pkg_db_conf errors-         msg "\n"
− src/Pipes/Db.hs 
@@ -1,175 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Pipes.Db (pipe_ConfFp) where-import           Control.Applicative-import           Control.Monad-import           Control.Monad.M-import           Control.Monad.State-import           Data.Either-import qualified Data.List as L-import qualified Data.Set as S-import qualified Data.Text as T-import           Filesystem-import qualified Filesystem.Path.CurrentOS as P-import qualified Module as Ghc-import           Options.DbProvider-import           Package (unversioned)-import           Pipes-import           System.Exit-import           System.Process--isPackage :: String -> Bool-isPackage str = str /= "    (no packages)" && "   " `L.isPrefixOf` str ---- | If parsed matches a member of the set by version first, return,--- otherwise return unversioned match.-toPkgMatch :: String -> State (S.Set String) (Maybe (String, Ghc.PackageKey))-toPkgMatch parsed = do-  unassigned <- get -  if S.member parsed unassigned -- found versioned -    then fromFound parsed-  else -    let parsed' = unversioned parsed in-      if S.member parsed' unassigned -        then fromFound parsed'-        else return Nothing -  where-    fromFound :: String -> State (S.Set String) (Maybe (String, Ghc.PackageKey))-    fromFound p = do-      modify (S.delete p)-      return . Just $ (p, Ghc.stringToPackageKey parsed)---- | A crude parser that extracts db -> package set relations based--- on whitespace indentation -accumPaths :: -  [String] -- output of ghc-pkg or ghc-pkg like listing-  -> S.Set String -- set of packages not yet associated to a db -  -> [(FilePath, [(String, Ghc.PackageKey)])]-  -> M [(FilePath, [(String, Ghc.PackageKey)])]-accumPaths [] _ assigned = -  return assigned -accumPaths (l:rest) unassigned assigned = -  if S.null unassigned then -- we're done -    return assigned-  else-    case assigned of -      []     -> -        if isPath l then-          accumPaths rest unassigned [(toPath l, [])] -        else-          err "parse error on package list output, check program used" -      ((db, members):dbs) ->-        uncurry (accumPaths rest) $ -          if isPath l then -- it's another db-            (,) unassigned ((toPath l, []):assigned)-          else -- it could be a package -            if isPackage l then-              let -                (r, unassigned') =-                  runState (toPkgMatch (unhide $ drop 4 l)) unassigned-              in (,) unassigned' $ -                   maybe -                     assigned -- no change -                     (\p -> (db, p : members) : dbs) -- at to members -                     r-            else-              (unassigned, assigned)-  where-    unhide :: String -> String-    unhide ('(':str) = L.take (L.length str - 1) str -    unhide s         = s --    -- | remove last ':' and junk -    -- Interestingly, when running cabal and ghc proc, it's stdout actually -    -- appends colons to paths, instead of what appears on console.-    -- So we're stripping them blindly for now.-    toPath :: String -> String-    toPath s = L.take (L.length s - 1) s--    isPath :: String -> Bool-    isPath [] = False-    isPath s  = head s `L.notElem`  ("\n\r\t " :: String)--toMapping :: String -> [String] -> S.Set String -> M [(FilePath, [(String, Ghc.PackageKey)])]-toMapping cmd args pkgs = do-  res <- liftIO $ readProcessWithExitCode cmd args []-  case res of -    (ExitFailure _, out, err') ->-      err $ -        "failed to retrieve package db's from " ++ cmd ++", output:"-        ++ out ++ '\n':err' -    (ExitSuccess, out, _) ->-      accumPaths (L.lines out) pkgs []---- | This returns a non-empty list of package db's, or failure.-fromProvider :: DbProvider -> S.Set String -> M [(FilePath, [(String, Ghc.PackageKey)])]-fromProvider prov pkgs = do-  case prov of -    (Ghc _)          -> toMapping cmd extra_args pkgs -    (CabalSandbox _) -> toMapping cmd extra_args pkgs-    (Db fp)          -> fromProvider (Ghc . Just $ "--package-db=" ++ fp) pkgs-  where-    (cmd , extra_args) = toExec prov--isConf :: Ghc.PackageKey -> P.FilePath -> Bool-isConf p f = P.hasExtension f "conf" && pkgRelated p f-  -findConf :: Ghc.PackageKey -> State (S.Set P.FilePath) (Either Ghc.PackageKey P.FilePath)-findConf package = do-  files <- get -  let matching = S.filter (isConf package) files-  if not . S.null $ matching-    then let found = S.findMin matching in do-      modify (S.delete (S.findMin matching))-      return $ Right found -    else-      return $ Left package -  --- | Return a list of package configurations for the given--- db and handled packages-fromPair :: FilePath -> [Ghc.PackageKey] -> M [FilePath]-fromPair _ []      =-  return [] -fromPair db members = do -  confs <- S.fromList <$> liftIO (listDirectory (P.decodeString db))-  let (remainder, confs') = partitionEithers $ evalState (mapM findConf members) confs -  unless (L.null remainder) . warning $ -    "The following packages were not found in the pkg db dir: \n" ++  -    L.intercalate "\n" (map Ghc.packageKeyString remainder)-  mapM (return . P.encodeString) confs'--pkgRelated :: Ghc.PackageKey -> P.FilePath -> Bool-pkgRelated p = -  T.isPrefixOf (T.pack . Ghc.packageKeyString $ p) -    . T.pack -    . P.encodeString -    . P.filename--pipe_ConfFp :: DbProvider -> PipeM (S.Set String) FilePath ()-pipe_ConfFp prov = do -  packages <- await -  if S.null packages -    then  -      lift . err $ "no results possible due to no packages provided"  -    else do-      lift $ do-        msg "db provider:"-        indentM 2 $ msg . show $ prov -        msg "\n"-      pairings <- lift $ fromProvider prov packages--      let found = S.unions $ map (S.fromList . map fst . snd) pairings -          unfound = S.difference packages found --      if not . S.null $ unfound then-        lift . err $ -          L.intercalate "\n"  -            ("The following packages were not found in searched package db's:" -            : S.toList unfound)--      else -- yield over each returned file,-           --  types are added to make this _much_ easier to understand  -        let -          mapped :: (FilePath, [(String, Ghc.PackageKey)]) -> M [FilePath]-          mapped = uncurry fromPair . (\(db, members) -> (db, map snd members))-        in -          mapM_ yield =<< lift (L.concat <$> mapM mapped pairings)
− src/Pipes/FileSystem.hs 
@@ -1,231 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Pipes.FileSystem where-import           Control.Applicative-import           Control.Monad-import           Control.Monad.M-import qualified Data.ByteString as BS-import           Data.ByteString.Char8 (pack)-import qualified Data.List as L-import           Data.String.Util-import qualified Data.Text as T-import           Data.Text.Encoding-import           Database.SQLite.Simple-import           Filesystem as F-import           Filesystem.Path.CurrentOS ((</>))-import qualified Filesystem.Path.CurrentOS as P-import qualified Module as Ghc-import           Package.Conf-import           Pipes-import           System.Directory ( doesDirectoryExist, getDirectoryContents )-import qualified System.Directory as D-import           Text.HTML.TagSoup-import           Text.HTML.TagSoup.Match-import           Haddock.Artifact-import           Haddock.Sqlite---- TODO the utility of some of these fields is still unclear to me,--- at the moment they are filled simply to satisfy the docset spec.-plist :: Ghc.PackageKey -> BS.ByteString-plist p = Data.ByteString.Char8.pack . unlines $-  [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"-  , "<!DOCTYPE plist PUBLIC \"-//Apple//DTD PLIST 1.0//EN\" \"http://www.apple.com/DTDs/PropertyList-1.0.dtd\">"-  , "<plist version=\"1.0\">"-  , "<dict>"-  , "<key>CFBundleIdentifier</key>"-  , "<string>" ++ Ghc.packageKeyString p ++ "</string>"-  , "<key>CFBundleName</key>"-  , "<string>docset for Haskell package " ++ Ghc.packageKeyString p ++ "</string>"-  , "<key>DocSetPlatformFamily</key>"-  , "<string>haskell</string>" -  , "<key>isDashDocset</key>"-  , "<true/>"-  , "<key>dashIndexFilePath</key>"-  , "<string>index.html</string>"-  , "</dict>"-  , "</plist>"-  ]--docsetDir :: Ghc.PackageKey -> P.FilePath-docsetDir p = P.decodeString $ Ghc.packageKeyString p ++ ".docset" --leafs :: (P.FilePath -> Bool) -> P.FilePath -> ProducerM P.FilePath ()-leafs incPred p = do-  names <- liftIO . getDirectoryContents $ P.encodeString p-  forM_ (filter (`notElem` [".", ".."]) names) $ \name' -> do-    let path = p </> P.decodeString name'-    dir <- liftIO . doesDirectoryExist $ P.encodeString path-    (if dir then -      leafs incPred -     else if not . incPred $ path then const (return ()) else yield)-      path--type Tag' = Tag T.Text --remoteUrl :: T.Text -> Bool -remoteUrl url = any (T.isPrefixOf url) ["http://", "https://"]--toStripped :: P.FilePath -> P.FilePath -> Either String P.FilePath-toStripped pfx original =-  -- I don't understand why System.FilePath.CurrentOS necessitates-  -- additional checking after the prefix has already been determined.-  case P.stripPrefix pfx original of -    Nothing ->-      Left $-        "attempted to strip prefix: \n " -        ++ P.encodeString pfx ++ " from: \n " ++ P.encodeString original-    Just remainder ->  -      Right remainder--toRelativePath :: P.FilePath -> P.FilePath -> Either String P.FilePath-toRelativePath base path = do-  let sharedPfx = P.commonPrefix [base, path]-  relative <- relativePath sharedPfx -  (</>) relative <$> toStripped sharedPfx path -  where -    relativePath :: P.FilePath -> Either String P.FilePath-    relativePath pfx = -      P.concat -       . flip replicate ".." -       . length -       . P.splitDirectories <$> toStripped pfx base --relativize :: Ghc.PackageKey -> P.FilePath -> Either String T.Text-relativize package p = -  let filename  = P.filename p-      packageSubpath = P.decodeString $ Ghc.packageKeyString package-      matches = filter (packageSubpath ==) . reverse $ P.splitDirectories (P.parent p)-  in -    T.pack . P.encodeString <$> -      if L.null matches then -        return p -- preserve the path so that it still can be used -      else -- assume as a package doc file and make relative-        toRelativePath packageSubpath $ L.head matches </> filename--convertUrl ::  Ghc.PackageKey -> T.Text -> Either String T.Text-convertUrl p urlExp -  | T.null urlExp = Right T.empty-  | otherwise     =  -    if T.isPrefixOf "file:///" urlExp then -      relativize p (P.fromText . T.drop 7 $ urlExp)-    else if T.isPrefixOf "/" urlExp then -      relativize p $ P.fromText urlExp-    else-      Right urlExp-      -attributes :: P.FilePath -> Tag T.Text -> Either String [Attribute T.Text] -attributes _ (TagOpen _ list) = -  Right list-attributes src other            =    -  Left $-    "failed to retrieve expected attributes from tag:\n "-    ++ show other  ++ "\n in: \n" ++ P.encodeString src -    --- | Convert local package-compiled haddock links to local relative. -convertLink :: Ghc.PackageKey -> P.FilePath -> Tag' -> Either String Tag'-convertLink package src tag =-  -- We're only interested in processing links             -  if not $ tagOpenLit "a" (anyAttrNameLit "href") tag then  -    Right tag-  else do-    preserved <- filter (\(n,_) -> n /= "href") <$> attributes src tag -    let url = fromAttrib "href" tag-    -    if remoteUrl url -      then -        Right tag -- ignore remote links-      else do-        url' <- convertUrl package url -        Right . TagOpen "a" $ ("href", url') : preserved --pipe_htmlConvert :: Ghc.PackageKey -> PipeM P.FilePath (P.FilePath, Maybe BS.ByteString) ()-pipe_htmlConvert p = -  forever $ do-    src <- await-    if P.extension src /= Just "html" -      then  -        yield (src, Nothing)-      else do -        buf <- liftIO $ F.readTextFile src-        -- Link conversion errors are non-fatal.-        case mapM (convertLink p src) . parseTags $ buf of-          Left e -> do -            lift . warning $ -              preposition "failed to convert links" "for" "file" (P.encodeString src) [e]-            yield (src, Nothing) -          Right tags ->-            yield (src, Just . encodeUtf8 . renderTags $ tags) ---- | This consumes a doc file and copies it to a path in 'dstRoot'. --- By pre-condition: ---   path has src_root as an ancestor --- By post-condition: ---   written dst is the difference of path and src_root,---   with by the concatenation of dst_root as it's parent. -cons_writeFile :: P.FilePath -> P.FilePath -> ConsumerM (P.FilePath, Maybe BS.ByteString) () -cons_writeFile src_root dst_root = forever $ do -  (path, buf) <- await-  case P.stripPrefix src_root path of-    Nothing -> lift . err $ -       "filepath error when attempting to find common prefix between src: \n" -       ++ P.encodeString path ++ "\n and: \n" ++ P.encodeString src_root-    Just dst_relative_path ->-      -- Yes, this could be shorter, but I try not to unnecessarily obfuscate-      liftIO $ do -        let dst_path = dst_root </> dst_relative_path-        -- create requisite parent directories for the file at the destination-        F.createTree $ P.parent dst_path -        case buf of -          Nothing   -> F.copyFile path dst_path -          Just buf' -> F.writeFile dst_path buf'-  -cons_writeFiles :: P.FilePath -> ConsumerM Conf ()-cons_writeFiles docsets_root = forever $ do-  conf <- await-  -  lift . msg $ "processing: " ++ (Ghc.packageKeyString . pkg $ conf)-  let docset_folder = docsetDir (pkg conf) -      dst_root      = docsets_root </> docset_folder -      dst_doc_root  = dst_root </> P.decodeString "Contents/Resources/Documents/"--  liftIO . F.createTree $ dst_doc_root - -  -- Copy all files and convert if necessary -  lift . indentM 2 $ msg "writing files.."-  -  lift . runEffect $ -    cons_writeFile (htmlDir conf) dst_doc_root -    <-< pipe_htmlConvert (pkg conf)-    <-< leafs (\p -> P.extension p /= Just "haddock") (htmlDir conf)-  -  -- TODO Since the haddock index is already produced in source docs-  -- with latest packaging systems, this is likely unnecessary -  -- liftIO $ do -  --    putStrLn "running haddock indexes"-  --    runHaddockIndex (interfaceFile conf) dst_doc_root--  lift . indentM 2 $ msg "writing plist.."--  liftIO . F.writeFile (dst_root </> "Contents/Info.plist") $ plist (pkg conf) --  lift . indentM 2 $ msg "populating database.."--  let db_path = dst_root </> P.decodeString "Contents/Resources/docSet.dsidx" --  liftIO $ do-    db_exists <- D.doesFileExist . P.encodeString $ db_path -    when db_exists $ F.removeFile db_path--  -- Initialize the SQlite Db-  c' <- liftIO $ do -        c <- open . P.encodeString $ db_path -        createTable c-        return c--  -- Populate the SQlite Db -  liftIO $ execute_ c' "BEGIN;"-  artifacts <- lift $ toArtifacts (pkg conf) (interfaceFile conf) -  lift $ mapM_ (fromArtifact (pkg conf) c') artifacts-  liftIO $ execute_ c' "COMMIT;"-  liftIO . close $ c'-  lift . indentM 2 $ msg "finished populating sqlite database.."-  lift $ msg "\n"