packages feed

dash-haskell 1.0.0.0 → 1.0.0.1

raw patch · 19 files changed

+1309/−2 lines, 19 files

Files

dash-haskell.cabal view
@@ -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
+ src/Control/Monad/M.hs view
@@ -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
+ src/Data/String/Indent.hs view
@@ -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
+ src/Data/String/Util.hs view
@@ -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)
+ src/Haddock.hs view
@@ -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]
+ src/Haddock/Artifact.hs view
@@ -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
+ src/Haddock/Sqlite.hs view
@@ -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')
src/Main.hs view
@@ -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 <topic|option>\""      <> footer "http://www.github.com/jfeltz/dash-haskell (C) John P. Feltz 2014"
+ src/Options.hs view
@@ -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 "<provider,args>"+      <> value (CabalSandbox Nothing) +      <> help "a ghc package db provider: cabal|ghc|dir\n")+    <*>+    strOption (+     long "output" +     <> short 'o'+     <> metavar "<dir>" +     <> value "./docsets" +     <> help "the directory to write created docsets to")+    <*>+    switch (long "quiet" <> short 'q' <> help "set to quiet output")+    <*>+    option (return . Just) +     (long "cabal"+     <> short 'c'  +     <> metavar "<file.cabal>" +     <> value Nothing+     <> help "the cabal file to retrieve package dependencies from")+    <*>+    option toConstraints+      (long "cabal-constraints" +      <> short 'r'+      <> value none +      <> metavar "executable=name, .."+      <> help "limit package results from a cabal file source, see documentation")+    <*>+    many (+     argument 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)
+ src/Options/Cabal.hs view
@@ -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)
+ src/Options/CabalConstraints.hs view
@@ -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
+ src/Options/DbProvider.hs view
@@ -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))+          ]
+ src/Options/Documentation.hs view
@@ -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 <var=value>,<var2=value1,value2>",+      "e.g. \"-r executables=foo,excluded=base,ghc\"",+      "\npossible variables:\n",+      " executables : the executable targets to limit to",+      " suites      : the suite targets to limit to",+      " benchmarks  : the benchmark targets to limit to",+      " library     : limit to library, this takes no arguments\n",+      " excluded    : unversioned packages to avoid using"+   ]++providerTopic = Topic "package database provider" $+  L.intercalate "\n" [+    "The external program to call to produce package databases\n"+    , "options are the form <var,args>" +    , "e.g:" +    , "    -p ghc,'--user'"+    , " or -p dir,/home/jpf/.ghc/x86_64-linux-7.8.3/package.conf.d\n"+    , "Note, only one provider at once is supported at this time.\n"+    , "pairings for <var,args>:"+    , " var                                      args "+    , "----------------------------------------- --------------------------------"+    , " cabal : use cabal sandbox package db(s)  flag string to pass to cabal"+    , " ghc   : use ghc's package db(s),         flag string to pass to ghc"+    , " dir   : use package db dir directory     the package db directory"+    +    ]++outputTopic= Topic "output" $ + 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
+ src/Package.hs view
@@ -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
+ src/Package/Conf.hs view
@@ -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+  }
+ src/PackageId.hs view
@@ -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 }
+ src/Pipes/Conf.hs view
@@ -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"
+ src/Pipes/Db.hs view
@@ -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)
+ src/Pipes/FileSystem.hs view
@@ -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 $+  [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+  , "<!DOCTYPE plist PUBLIC \"-//Apple//DTD PLIST 1.0//EN\" \"http://www.apple.com/DTDs/PropertyList-1.0.dtd\">"+  , "<plist version=\"1.0\">"+  , "<dict>"+  , "<key>CFBundleIdentifier</key>"+  , "<string>" ++ Ghc.packageIdString p ++ "</string>"+  , "<key>CFBundleName</key>"+  , "<string>docset for Haskell package " ++ Ghc.packageIdString p ++ "</string>"+  , "<key>DocSetPlatformFamily</key>"+  , "<string>haskell</string>" +  , "<key>isDashDocset</key>"+  , "<true/>"+  , "<key>dashIndexFilePath</key>"+  , "<string>index.html</string>"+  , "</dict>"+  , "</plist>"+  ]++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"