diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ] [-o|--output ] - [-q|--quiet] [-c|--cabal ] - [-r|--cabal-constraints executable=name, ..] [packages] - additional help is available with "dash-haskell help " - - Available options: - -h,--help Show this help text - -p,--dbprovider - a ghc package db provider: cabal|ghc|dir - -o,--output the directory to write created docsets to - -q,--quiet set to quiet output - -c,--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 ] [-q|--quiet] [-c|--cabal ] + [-x|--cabal-excludes ghc,lens..] [-s|--sandbox] + [-n|--no-user] [--db ] + [-d|--ordering user,sandbox..] [packages] + additional help is available with "dash-haskell help " -``` -$ 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 the directory to write created docsets to + -q,--quiet set to quiet output + -c,--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 + 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 diff --git a/dash-haskell.cabal b/dash-haskell.cabal --- a/dash-haskell.cabal +++ b/dash-haskell.cabal @@ -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 ] [-o|--output ] - > [-q|--quiet] [-c|--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 - > a ghc package db provider: cabal|ghc|dir - > -o,--output the directory to write created docsets to - > -q,--quiet set to quiet output - > -c,--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 diff --git a/src/Control/Monad/M.hs b/src/Control/Monad/M.hs --- a/src/Control/Monad/M.hs +++ b/src/Control/Monad/M.hs @@ -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 diff --git a/src/Data/Maybe/Util.hs b/src/Data/Maybe/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe/Util.hs @@ -0,0 +1,5 @@ +module Data.Maybe.Util where + +toMaybe :: Bool -> a -> Maybe a +toMaybe True a = Just a +toMaybe False _ = Nothing diff --git a/src/Data/String/Indent.hs b/src/Data/String/Indent.hs deleted file mode 100644 --- a/src/Data/String/Indent.hs +++ /dev/null @@ -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 diff --git a/src/Data/String/Util.hs b/src/Data/String/Util.hs --- a/src/Data/String/Util.hs +++ b/src/Data/String/Util.hs @@ -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 diff --git a/src/Db.hs b/src/Db.hs new file mode 100644 --- /dev/null +++ b/src/Db.hs @@ -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 diff --git a/src/FilePath.hs b/src/FilePath.hs new file mode 100644 --- /dev/null +++ b/src/FilePath.hs @@ -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 diff --git a/src/Haddock.hs b/src/Haddock.hs deleted file mode 100644 --- a/src/Haddock.hs +++ /dev/null @@ -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] diff --git a/src/Haddock/Artifact.hs b/src/Haddock/Artifact.hs --- a/src/Haddock/Artifact.hs +++ b/src/Haddock/Artifact.hs @@ -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) -> diff --git a/src/Haddock/Sqlite.hs b/src/Haddock/Sqlite.hs --- a/src/Haddock/Sqlite.hs +++ b/src/Haddock/Sqlite.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 \"" - <> 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" diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -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 "" - <> value (CabalSandbox Nothing) - <> help "a ghc package db provider: cabal|ghc|dir\n") - <*> - strOption ( - long "output" - <> short 'o' - <> metavar "" - <> 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 "" - <> 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 "" + <> 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 "" + <> 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 "" + <> 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 ',') + diff --git a/src/Options/Cabal.hs b/src/Options/Cabal.hs --- a/src/Options/Cabal.hs +++ b/src/Options/Cabal.hs @@ -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 diff --git a/src/Options/CabalConstraints.hs b/src/Options/CabalConstraints.hs deleted file mode 100644 --- a/src/Options/CabalConstraints.hs +++ /dev/null @@ -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 diff --git a/src/Options/Db.hs b/src/Options/Db.hs new file mode 100644 --- /dev/null +++ b/src/Options/Db.hs @@ -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)" + diff --git a/src/Options/DbProvider.hs b/src/Options/DbProvider.hs deleted file mode 100644 --- a/src/Options/DbProvider.hs +++ /dev/null @@ -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)) - ] diff --git a/src/Options/Documentation.hs b/src/Options/Documentation.hs --- a/src/Options/Documentation.hs +++ b/src/Options/Documentation.hs @@ -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 ,", - "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 \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 " - , "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 " - , "----------------------------------------- --------------------------------" - , " 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 diff --git a/src/Package.hs b/src/Package.hs deleted file mode 100644 --- a/src/Package.hs +++ /dev/null @@ -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 diff --git a/src/Package/Conf.hs b/src/Package/Conf.hs deleted file mode 100644 --- a/src/Package/Conf.hs +++ /dev/null @@ -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 - } diff --git a/src/PackageConf.hs b/src/PackageConf.hs new file mode 100644 --- /dev/null +++ b/src/PackageConf.hs @@ -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" + ] diff --git a/src/PackageId.hs b/src/PackageId.hs --- a/src/PackageId.hs +++ b/src/PackageId.hs @@ -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 diff --git a/src/Pipe/Conf.hs b/src/Pipe/Conf.hs new file mode 100644 --- /dev/null +++ b/src/Pipe/Conf.hs @@ -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) diff --git a/src/Pipe/FileSystem.hs b/src/Pipe/FileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Pipe/FileSystem.hs @@ -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 $ + [ "" + , "" + , "" + , "" + , "CFBundleIdentifier" + , "" ++ str ++ "" + , "CFBundleName" + , "docset for Haskell package " ++ str ++ "" + , "DocSetPlatformFamily" + , "haskell" + , "isDashDocset" + , "" + , "dashIndexFilePath" + , "index.html" + , "" + , "" + ] + +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" diff --git a/src/Pipes/Conf.hs b/src/Pipes/Conf.hs deleted file mode 100644 --- a/src/Pipes/Conf.hs +++ /dev/null @@ -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" diff --git a/src/Pipes/Db.hs b/src/Pipes/Db.hs deleted file mode 100644 --- a/src/Pipes/Db.hs +++ /dev/null @@ -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) diff --git a/src/Pipes/FileSystem.hs b/src/Pipes/FileSystem.hs deleted file mode 100644 --- a/src/Pipes/FileSystem.hs +++ /dev/null @@ -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 $ - [ "" - , "" - , "" - , "" - , "CFBundleIdentifier" - , "" ++ Ghc.packageKeyString p ++ "" - , "CFBundleName" - , "docset for Haskell package " ++ Ghc.packageKeyString p ++ "" - , "DocSetPlatformFamily" - , "haskell" - , "isDashDocset" - , "" - , "dashIndexFilePath" - , "index.html" - , "" - , "" - ] - -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"