diff --git a/dash-haskell.cabal b/dash-haskell.cabal --- a/dash-haskell.cabal +++ b/dash-haskell.cabal @@ -1,5 +1,5 @@ name: dash-haskell -version: 1.0.0.0 +version: 1.0.0.1 synopsis: Command line tool to generate Dash docsets (IDE docs) from package haddock homepage: http://www.github.com/jfeltz/dash-haskell Bug-reports: https://github.com/jfeltz/dash-haskell/issues @@ -103,6 +103,24 @@ 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 + build-depends: Cabal >= 1.18 , base >= 4.7 && <4.8 , bytestring >= 0.10.0.1 diff --git a/src/Control/Monad/M.hs b/src/Control/Monad/M.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/M.hs @@ -0,0 +1,53 @@ +module Control.Monad.M where +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 Pipes + +import Data.String.Indent + +type M r = ReaderT Env (EitherT String IO) r + +data Env = Env { indention :: Int, verbosity :: Bool } + +newEnv :: Bool -> Env +newEnv = Env 0 + +env :: M Env +env = ask + +warning :: String -> M () +warning str = do + i <- indention <$> env + liftIO . putStr $ fromIndent ("warning: " ++ str) i + +indent :: Int -> Env -> Env +indent amount (Env i v) = Env (i + amount) v + +indentM :: Int -> M r -> M r +indentM amount = local (indent amount) + +msg :: (MonadIO m) => String -> ReaderT Env m () +msg str = do + e <- ask + when (verbosity e) . liftIO . putStr . fromIndent str $ indention e + +err :: String -> M r +err = lift . left + +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 + exitFailure + Right () -> + exitSuccess + +type ConsumerM i r = Consumer i (ReaderT Env (EitherT String IO)) r +type ProducerM i r = Producer i (ReaderT Env (EitherT String IO)) r +type PipeM a b r = Pipe a b (ReaderT Env (EitherT String IO)) r diff --git a/src/Data/String/Indent.hs b/src/Data/String/Indent.hs new file mode 100644 --- /dev/null +++ b/src/Data/String/Indent.hs @@ -0,0 +1,6 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Data/String/Util.hs @@ -0,0 +1,10 @@ +module Data.String.Util (preposition) where +import Data.String.Indent +import qualified Data.List as L + +preposition :: String -> String -> String -> String -> [String] -> String +preposition problem prep subjectLabel subject problems = + L.intercalate "\n" $ + (problem ++ ' ':prep ++ ' ':subjectLabel ++ ":") + : (' ':subject) + : "with problem(s):" : L.lines (fromIndent (L.unlines problems) 1) diff --git a/src/Haddock.hs b/src/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Haddock.hs @@ -0,0 +1,33 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Haddock/Artifact.hs @@ -0,0 +1,43 @@ +module Haddock.Artifact where +import Control.Monad.IO.Class +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 + +-- This ADT approach is heavily influenced by philopen's haddocset package: +-- https://github.com/philopon/haddocset + +data Artifact + = Haddock P.FilePath -- Note, this is not yet honored. TODO + | Package + | Module Ghc.Module + | Function Ghc.Module Ghc.Name + +parseError :: String -> P.FilePath -> M r +parseError e p = + err $ preposition "parser error" "in" "haddock interface" (P.encodeString p) [e] + +fromInterfaces :: Ghc.PackageId -> [InstalledInterface] -> [Artifact] +fromInterfaces _ [] = [] +fromInterfaces pkg (i:rest) = + let moduleName = instMod i in + if OptHide `notElem` instOptions i then + Module moduleName : + foldl + (\a e -> Function moduleName e : a) + -- append to artifacts from rest of installed interfaces + (fromInterfaces pkg rest) + (instVisibleExports i) + else + fromInterfaces pkg rest + +toArtifacts :: Ghc.PackageId -> P.FilePath -> M [Artifact] +toArtifacts pkg haddock' = do + interface_file <- liftIO $ readInterfaceFile freshNameCache (P.encodeString haddock') + case interface_file of + Left e -> parseError e haddock' + Right (InterfaceFile _ installed_ifaces) -> + return $ Haddock haddock' : Package : fromInterfaces pkg installed_ifaces diff --git a/src/Haddock/Sqlite.hs b/src/Haddock/Sqlite.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Sqlite.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +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 +import qualified Module as Ghc +import qualified Name as Ghc + +data IndexRow = IndexRow { + nameAttr :: T.Text + , typeAttr :: T.Text + , pathAttr :: T.Text + , modAttr :: T.Text +} deriving (Show) + +instance Monoid IndexRow where + mempty = IndexRow mempty mempty mempty mempty + mappend l r = + IndexRow + (mappend (nameAttr l) (nameAttr r)) + (mappend (typeAttr l) (typeAttr r)) + (mappend (pathAttr l) (pathAttr r)) + (mappend (modAttr l) (modAttr r)) + +-- TODO lensify +instance ToRow IndexRow where + toRow index = + [SQLText . nameAttr $ index + , SQLText . typeAttr $ index + , SQLText . pathAttr $ index + , SQLText . modAttr $ index + ] + +-- I probably chould derive this from a type, but that's overkill right now. +table :: String +table = "searchIndex(name, type, path, module)" + +createTable :: Connection -> IO () +createTable conn = + mapM_ (execute_ conn) + ["CREATE TABLE searchIndex(id INTEGER PRIMARY KEY, name TEXT, type TEXT, path TEXT, module TEXT);", + Query . T.pack $ "CREATE UNIQUE INDEX anchor ON " ++ table ++ ";"] + +insertRow :: Connection -> IndexRow -> IO () +insertRow conn = + execute conn + (Query . T.pack $ "INSERT OR IGNORE INTO " ++ table ++ " VALUES (?,?,?,?);") + +modUrl :: Ghc.Module -> String +modUrl = + map (\c-> if c == '.' then '-' else c) + . Ghc.moduleNameString + . Ghc.moduleName + +escapeSpecial :: String -> String +escapeSpecial = + concatMap (\c -> if c `elem` specialChars then '-': show (fromEnum c) ++ "-" else [c]) + where + specialChars = "!&|+$%(,)*<>-/=#^\\?" + +-- | Update the sqlite database with the given haddock artifact. +fromArtifact :: Ghc.PackageId -> Connection -> Artifact -> M () +fromArtifact p conn art = do + attributes <- toAttributes + case attributes of + Just (name, type', path, m) -> + liftIO . insertRow conn $ + mempty { + nameAttr = T.pack name + , typeAttr = type' + , pathAttr = T.pack path + , modAttr = T.pack m + } + Nothing -> + return () + where + modStr m = Ghc.moduleNameString $ Ghc.moduleName m + -- | Convert haddock artifacts to attributes for table update. + toAttributes = + case art of + Haddock _ -> + -- TODO unsupported right now + return Nothing + Package -> + return . Just $ + (Ghc.packageIdString p, "Package", "index.html", []) + Module ghcmod -> + return . Just $ + (modStr ghcmod, "Module" , modUrl ghcmod ++ ".html" , modStr ghcmod) + Function ghcmod ghcname -> + let (declType, pfx) = toPair ghcname in + return . Just $ + ( modStr ghcmod ++ '.':Ghc.getOccString ghcname, + declType, + url pfx, + modStr ghcmod) + where + url pfx = + modUrl ghcmod ++ ".html#" ++ pfx : ':' : + escapeSpecial (Ghc.getOccString ghcname) + toPair n + | Ghc.isTyConName n = ("Type" , 't') + | Ghc.isDataConName n = ("Constructor" , 'v') + | otherwise = ("Function" , 'v') diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -34,6 +34,6 @@ where parserInfo :: ParserInfo Options parserInfo = info (helper <*> parser) $ - header "dash-haskell v1.0.0.0, a dash docset construction tool for Haskell packages" + header "dash-haskell v1.0.0.1, 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" diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE TupleSections #-} + +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.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 + +data Options = Options { + dbprovider :: DbProvider, + outputDir :: FilePath, + quiet :: Bool, + cabal :: Maybe FilePath, + cabalConstraints :: CabalConstraints, + packages :: [C.PackageId] +} deriving Show + +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 (return . Just) + (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 simpleParse (metavar "packages" <> + help "a list of packages to specifically build, e.g. either-1.0.1 text" + )) + +-- | 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 :: String -> C.PackageId +versionless n = C.PackageIdentifier (C.PackageName n) $ CV.Version [] [] + +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) diff --git a/src/Options/Cabal.hs b/src/Options/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Options/Cabal.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +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.PackageDescription as C +import Data.Either +import Data.String.Util +import Control.Monad.IO.Class +import qualified Options.CabalConstraints as OC + +type Package = String +newtype Targets = Targets { mapping :: M.Map String (S.Set Package) } + +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 + } + +-- | 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) ()) + +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) + 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) + +-- | 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 + case parse_result of + (C.ParseFailed fail_msg) -> + err . show $ fail_msg + (C.ParseOk warnings desc) -> do + unless (L.null warnings) . warning $ + preposition + "warnings during parse" + "of" + "cabal file" + "warnings" + (map show warnings) + + toPackages cabal (toDescription desc) constraints + 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) diff --git a/src/Options/CabalConstraints.hs b/src/Options/CabalConstraints.hs new file mode 100644 --- /dev/null +++ b/src/Options/CabalConstraints.hs @@ -0,0 +1,92 @@ +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 simpliifed 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 :: String -> O.ReadM CabalConstraints +toConstraints expr = + O.ReadM $ + case parse (constraints Nothing) [] expr of + Left err -> Left . O.ErrorMsg . show $ err + Right c -> Right c diff --git a/src/Options/DbProvider.hs b/src/Options/DbProvider.hs new file mode 100644 --- /dev/null +++ b/src/Options/DbProvider.hs @@ -0,0 +1,71 @@ +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 + ReadM . Left . ErrorMsg $ "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 :: String -> ReadM DbProvider +toProvider expr = do + (prov, arg) <- fromSplit ',' expr + join $ constructor prov <*> pure arg + where + constructor :: String -> ReadM (Maybe String -> ReadM DbProvider) + constructor prov = + ReadM $ maybe (Left . ErrorMsg $ "invalid db provider") Right 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 + (ReadM . Left . ErrorMsg $ "requires directory path") + (return . Db)) + ] diff --git a/src/Options/Documentation.hs b/src/Options/Documentation.hs new file mode 100644 --- /dev/null +++ b/src/Options/Documentation.hs @@ -0,0 +1,114 @@ +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 + +data Topic = Topic { title :: String, content :: String } +instance Eq Topic where + l == r = title l == title r +instance Ord Topic where + compare l r = compare (title l) (title r) + +type Tag = String + +type Documentation = M.Map Tag Topic + +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" + ] + +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" $ + 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\"" + ] + +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." + ] + +toEntry :: S.Set String -> Topic -> Documentation -> Documentation +toEntry s t doc = L.foldl (\m' k -> M.insert k t m') doc $ S.toList s + +docs :: Documentation +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"]) + ] + +-- | Given an arbitrary stream of options, +-- convert to possible topic indexes for documenation lookup. +toIndexes :: [String] -> [String] +toIndexes = S.toList . S.fromList . map toTopic + where + toTopic :: String -> String + toTopic [] = [] + toTopic ('-':rest) = toTopic rest + toTopic remainder = remainder + +toHelp :: Documentation -> [String] -> IO () +toHelp d [] = + putStrLn $ "available help topics:\n" ++ L.intercalate ", " (tags d) +toHelp d args = + -- fold over each index, producing a list of docs to display + let topic_set = L.foldl folded S.empty $ toIndexes args in + if S.null topic_set then do + 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" + where + headed :: Topic -> String + headed topic = ' ':title topic ++ ':':'\n':'\n': + fromIndent (content topic) 2 + + 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 new file mode 100644 --- /dev/null +++ b/src/Package.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Package/Conf.hs @@ -0,0 +1,10 @@ +module Package.Conf where +import qualified Module as Ghc +import qualified Filesystem.Path.CurrentOS as P + +data Conf = Conf + { pkg :: Ghc.PackageId + , interfaceFile :: P.FilePath -- interface, i.e. .haddock file + , htmlDir :: P.FilePath -- root html source directory + , exposed :: Bool -- module exposure flag + } diff --git a/src/PackageId.hs b/src/PackageId.hs new file mode 100644 --- /dev/null +++ b/src/PackageId.hs @@ -0,0 +1,9 @@ +module PackageId where +import qualified Distribution.Package as C +import qualified Distribution.Version as CV + +emptyVersion :: CV.Version +emptyVersion = CV.Version [] [] + +unversioned :: C.PackageId -> C.PackageId +unversioned p = p { C.pkgVersion = emptyVersion } diff --git a/src/Pipes/Conf.hs b/src/Pipes/Conf.hs new file mode 100644 --- /dev/null +++ b/src/Pipes/Conf.hs @@ -0,0 +1,76 @@ +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 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.mkPackageId . 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.packageIdString (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 new file mode 100644 --- /dev/null +++ b/src/Pipes/Db.hs @@ -0,0 +1,175 @@ +{-# 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.PackageId)) +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.PackageId)) + fromFound p = do + modify (S.delete p) + return . Just $ (p, Ghc.stringToPackageId 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.PackageId)])] + -> M [(FilePath, [(String, Ghc.PackageId)])] +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 " + +toMapping :: String -> [String] -> S.Set String -> M [(FilePath, [(String, Ghc.PackageId)])] +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.PackageId)])] +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.PackageId -> P.FilePath -> Bool +isConf p f = P.hasExtension f "conf" && pkgRelated p f + +findConf :: Ghc.PackageId -> State (S.Set P.FilePath) (Either Ghc.PackageId 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.PackageId] -> 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.packageIdString remainder) + mapM (return . P.encodeString) confs' + +pkgRelated :: Ghc.PackageId -> P.FilePath -> Bool +pkgRelated p = + T.isPrefixOf (T.pack . Ghc.packageIdString $ 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 ++ ["Please be sure to provide exact package versions."]) + + else -- yield over each returned file, + -- types are added to make this _much_ easier to understand + let + mapped :: (FilePath, [(String, Ghc.PackageId)]) -> 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 new file mode 100644 --- /dev/null +++ b/src/Pipes/FileSystem.hs @@ -0,0 +1,239 @@ +{-# 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 + +-- | See: +-- https://developer.apple.com/library/ios/documentation/general/Reference/InfoPlistKeyReference/Articles/CoreFoundationKeys.html +data Plist = Plist + { cfBundleIdentifier :: String + , cfBundleName :: String + , docSetPlatformFamily :: String + } deriving Show + +-- TODO/FIXME the utility of some of these fields are still unclear to me, +-- at the moment they are filled simply to satisfy the docset spec. +plist :: Ghc.PackageId -> BS.ByteString +plist p = Data.ByteString.Char8.pack . unlines $ + [ "" + , "" + , "" + , "" + , "CFBundleIdentifier" + , "" ++ Ghc.packageIdString p ++ "" + , "CFBundleName" + , "docset for Haskell package " ++ Ghc.packageIdString p ++ "" + , "DocSetPlatformFamily" + , "haskell" + , "isDashDocset" + , "" + , "dashIndexFilePath" + , "index.html" + , "" + , "" + ] + +docsetDir :: Ghc.PackageId -> P.FilePath +docsetDir p = P.decodeString $ Ghc.packageIdString 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.PackageId -> P.FilePath -> Either String T.Text +relativize package p = + let filename = P.filename p + packageSubpath = P.decodeString $ Ghc.packageIdString 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.PackageId -> 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.PackageId -> 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.PackageId -> 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.packageIdString . 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) + + -- FIXME/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"