diff --git a/Documentation/Haddocset.hs b/Documentation/Haddocset.hs new file mode 100644 --- /dev/null +++ b/Documentation/Haddocset.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Documentation.Haddocset where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class + +import qualified Filesystem as P +import qualified Filesystem.Path.CurrentOS as P + +import System.IO +import System.IO.Error +import System.Process + +import qualified Database.SQLite.Simple as Sql + +import Data.Maybe +import qualified Data.Text as T +import Text.HTML.TagSoup as Ts +import Text.HTML.TagSoup.Match as Ts + +import Distribution.Compat.ReadP +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Text (display, parse) +import Documentation.Haddock +import qualified Module as Ghc +import qualified Name as Ghc + +import Data.Conduit +import qualified Data.Conduit.Filesystem as P +import qualified Data.Conduit.List as CL + +docsetDir :: P.FilePath -> P.FilePath +docsetDir d = + if P.extension d == Just "docset" + then d + else d P.<.> "docset" + +globalPackageDirectory :: FilePath -> IO P.FilePath +globalPackageDirectory hcPkg = + P.decodeString . init . head . lines <$> readProcess hcPkg ["list"] "" + +packageConfs :: P.FilePath -> IO [P.FilePath] +packageConfs dir = + filter ((== Just "conf") . P.extension) <$> P.listDirectory dir + +data DocInfo = DocInfo + { diPackageId :: PackageId + , diInterfaces :: [P.FilePath] + , diHTMLs :: [P.FilePath] + , diExposed :: Bool + } deriving Show + +readDocInfoFile :: P.FilePath -> IO (Maybe DocInfo) +readDocInfoFile pifile = P.isDirectory pifile >>= \isDir -> + if isDir + then filter ((== Just "haddock") . P.extension) <$> P.listDirectory pifile >>= \hdc -> case hdc of + [] -> return Nothing + hs@(h:_) -> readInterfaceFile freshNameCache (P.encodeString h) >>= \ei -> case ei of + Left _ -> return Nothing + Right (InterfaceFile _ (intf:_)) -> do + let rPkg = readP_to_S parse . Ghc.packageIdString . Ghc.modulePackageId $ instMod intf :: [(PackageId, String)] + case rPkg of + [] -> return Nothing + pkg -> do + return . Just $ DocInfo (fst $ last pkg) hs [P.collapse $ pifile P. P.decodeString "./" ] True + Right _ -> return Nothing + else do + result <- parseInstalledPackageInfo <$> readFile (P.encodeString pifile) + return $ case result of + ParseFailed _ -> Nothing + ParseOk [] a + | null (haddockHTMLs a) -> Nothing + | null (haddockInterfaces a) -> Nothing + | otherwise -> Just $ + DocInfo (sourcePackageId a) (map P.decodeString $ haddockInterfaces a) + (map (P.decodeString . (++"/")) $ haddockHTMLs a) (exposed a) + + ParseOk _ _ -> Nothing + +data Plist = Plist + { cfBundleIdentifier :: String + , cfBundleName :: String + , docSetPlatformFamily :: String + } deriving Show + +showPlist :: Plist -> String +showPlist Plist{..} = unlines + [ "" + , "" + , "" + , "" + , "CFBundleIdentifier" + , "" ++ cfBundleIdentifier ++ "" + , "CFBundleName" + , "" ++ cfBundleName ++ "" + , "DocSetPlatformFamily" + , "" ++ docSetPlatformFamily ++ "" + , "isDashDocset" + , "" + , "dashIndexFilePath" + , "index.html" + , "" + , "" + ] + +copyHtml :: DocFile -> P.FilePath -> IO () +copyHtml doc dst = do + tags <- Ts.parseTags <$> P.readTextFile (docAbsolute doc) + P.writeTextFile dst . Ts.renderTags $ map mapFunc tags + where + mapFunc tag + | Ts.tagOpenLit "a" (Ts.anyAttrNameLit "href") tag = + let url = Ts.fromAttrib "href" tag + absp p = P.collapse $ docBaseDir doc P. P.fromText p + attr = filter (\(n,_) -> n /= "href") (getAttr tag) + in case url of + _ | "http://" `T.isPrefixOf` url -> tag + | "https://" `T.isPrefixOf` url -> tag + | "file:///" `T.isPrefixOf` url -> Ts.TagOpen "a" (toAttr "href" (rebase . P.fromText $ T.drop 7 url) attr) + | otherwise -> Ts.TagOpen "a" (toAttr "href" (rebase . absp $ url) attr) + | otherwise = tag + + getAttr (TagOpen _ a) = a + getAttr _ = error "copyHtml: call attr to !TagOpen." + + toAttr attr url = case P.toText url of + Right r -> ((attr, r):) + Left _ -> id + + both a = case a of + Left l -> l + Right r -> r + + rebase p = let fil = P.filename p + pkgs = filter packageLike . reverse $ P.splitDirectories (P.parent p) + in case pkgs of + [] -> fil + pkg:_ -> relativize (P.decodeString . display . packageName $ docPackage doc) $ pkg P. fil + + packageLike p = let t = both $ P.toText p + in T.any (== '-') t && (T.all (`elem` "0123456789.") . T.takeWhile (/= '-') $ T.reverse t) + +relativize :: P.FilePath -> P.FilePath -> P.FilePath +relativize base path = up P. p + where pfx = P.commonPrefix [base, path] + up = P.concat . flip replicate ".." . length . P.splitDirectories . fromMaybe (error "relativize") $ P.stripPrefix pfx base + p = fromMaybe (error "relativize") $ P.stripPrefix pfx path + +data DocFile = DocFile + { docPackage :: PackageId + , docBaseDir :: P.FilePath + , docRationalDir :: P.FilePath + } deriving Show + + +docAbsolute :: DocFile -> P.FilePath +docAbsolute doc = docBaseDir doc P. docRationalDir doc + +copyDocument :: (MonadThrow m, MonadIO m) => P.FilePath + -> Consumer DocFile m () +copyDocument docdir = awaitForever $ \doc -> do + let full = docAbsolute doc + dst = docdir + P. (P.decodeString . display) (docPackage doc) + P. docRationalDir doc + liftIO $ P.createTree (P.directory dst) + ex <- liftIO $ (||) <$> P.isFile dst <*> P.isDirectory dst + when ex $ monadThrow $ mkIOError alreadyExistsErrorType "copyDocument" Nothing (Just $ P.encodeString dst) + case P.extension $ docRationalDir doc of + Just "html" -> liftIO $ copyHtml doc dst + Just "haddock" -> return () + _ -> liftIO $ P.copyFile full dst + +docFiles :: MonadIO m => PackageId -> [P.FilePath] -> Producer m DocFile +docFiles sourcePackageId haddockHTMLs = + forM_ haddockHTMLs $ \dir -> + P.traverse False dir + =$= awaitForever (\f -> yield $ DocFile sourcePackageId dir $ fromMaybe (error $ "Prefix missmatch: " ++ show (dir ,f)) $ P.stripPrefix dir f) + +data Provider + = Haddock PackageId P.FilePath + | Package PackageId + | Module PackageId Ghc.Module + | Function PackageId Ghc.Module Ghc.Name + +moduleProvider :: MonadIO m => DocInfo -> Producer m Provider +moduleProvider iFile = + mapM_ sub $ diInterfaces iFile + where + sub file = do + rd <- liftIO $ readInterfaceFile freshNameCache (P.encodeString file) + case rd of + Left _ -> return () + Right (ifInstalledIfaces -> iIntrf) -> do + let pkg = diPackageId iFile + yield $ Haddock pkg file + yield $ Package pkg + forM_ iIntrf $ \i -> do + let modn = instMod i + fs = instVisibleExports i + when (OptHide `notElem` instOptions i) $ do + yield $ Module pkg modn + mapM_ (yield . Function pkg modn) fs + +populatePackage :: Sql.Connection -> PackageId -> IO () +populatePackage conn pkg = + Sql.execute conn "INSERT OR IGNORE INTO searchIndex(name, type, path,package) VALUES (?,?,?,?);" + (display pkg, "Package" :: String, url,display pkg) + where + url = display pkg ++ "/index.html" + +moduleNmaeUrl :: String -> String +moduleNmaeUrl = map dot2Dash + where dot2Dash '.' = '-' + dot2Dash c = c + +populateModule :: Sql.Connection -> PackageId -> Ghc.Module -> IO () +populateModule conn pkg modn = + Sql.execute conn "INSERT OR IGNORE INTO searchIndex(name, type, path, package) VALUES (?,?,?,?);" + (Ghc.moduleNameString $ Ghc.moduleName modn, "Module" :: String, url,display pkg) + where + url = display pkg ++ '/': + (moduleNmaeUrl . Ghc.moduleNameString . Ghc.moduleName) modn ++ ".html" + +populateFunction :: Sql.Connection -> PackageId -> Ghc.Module -> Ghc.Name -> IO () +populateFunction conn pkg modn name = + Sql.execute conn "INSERT OR IGNORE INTO searchIndex(name, type, path, package) VALUES (?,?,?,?);" + (Ghc.getOccString name, dataType :: String, url, display pkg) + where + url = display pkg ++ '/': + (moduleNmaeUrl . Ghc.moduleNameString . Ghc.moduleName) modn ++ ".html#" ++ + prefix : ':' : + escapeSpecial (Ghc.getOccString name) + specialChars = "!&|+$%(,)*<>-/=#^\\?" + escapeSpecial = concatMap (\c -> if c `elem` specialChars then '-': show (fromEnum c) ++ "-" else [c]) + prefix = case name of + _ | Ghc.isTyConName name -> 't' + | otherwise -> 'v' + dataType = case name of + _ | Ghc.isTyConName name -> "Type" + | Ghc.isDataConName name -> "Constructor" + | otherwise -> "Function" + +progress :: MonadIO m => Bool -> Int -> Char -> ConduitM o o m () +progress cr u c = sub 1 + where + sub n = await >>= \mbi -> case mbi of + Nothing -> when cr $ liftIO (hPutChar stderr '\n' >> hFlush stderr) + Just i -> do + when (n `mod` u == 0) $ liftIO (hPutChar stderr c >> hFlush stderr) + yield i + sub (succ n) + +dispatchProvider :: Sql.Connection -> P.FilePath -> Provider -> IO () +dispatchProvider _ hdir (Haddock p h) = + let dst = hdir P. P.decodeString (display p) P.<.> "haddock" + in P.copyFile h dst +dispatchProvider conn _ (Package p) = populatePackage conn p +dispatchProvider conn _ (Module p m) = populateModule conn p m +dispatchProvider conn _ (Function p m n) = populateFunction conn p m n + + +haddockIndex :: P.FilePath -> P.FilePath -> IO () +haddockIndex haddockdir documentdir = do + argIs <- map (\h -> "--read-interface=" + ++ P.encodeString (P.dropExtension $ P.filename h) ++ + ',': P.encodeString h) <$> P.listDirectory haddockdir + + haddock $ "--gen-index": "--gen-contents": ("--odir=" ++ P.encodeString documentdir): argIs + +addSinglePackage :: Bool -> P.FilePath -> P.FilePath -> Sql.Connection -> DocInfo -> IO () +addSinglePackage quiet docDir haddockDir conn iFile = go `catchIOError` handler + where + go = do + putStr " " >> putStr (display $ diPackageId iFile) >> putChar ' ' >> hFlush stdout + docFiles (diPackageId iFile) (diHTMLs iFile) + $$ (if quiet then id else (progress False 10 '.' =$)) (copyDocument docDir) + Sql.execute_ conn "BEGIN;" + ( moduleProvider iFile + $$ (if quiet then id else (progress True 100 '*' =$)) (CL.mapM_ (liftIO . dispatchProvider conn haddockDir))) + `onException` (Sql.execute_ conn "ROLLBACK;") + Sql.execute_ conn "COMMIT;" + handler ioe + | isDoesNotExistError ioe = putStr "Error: " >> print ioe + | otherwise = ioError ioe + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, philopon + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of philopon nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TupleSections #-} + +import Control.Applicative +import Control.Monad + +import qualified Filesystem as P +import qualified Filesystem.Path.CurrentOS as P + +import System.IO.Error + +import qualified Database.SQLite.Simple as Sql + +import Data.Maybe + + +import Options.Applicative + +import Documentation.Haddocset + +createCommand :: Options -> IO () +createCommand o = do + unless (optQuiet o) $ putStrLn "[1/5] Create Directory." + P.createDirectory False (optTarget o) -- for fail when directory already exists. + P.createTree (optDocumentsDir o) + P.createDirectory True (optHaddockDir o) + + unless (optQuiet o) $ putStrLn "[2/5] Writing plist." + writeFile (P.encodeString $ optTarget o P. "Contents/Info.plist") $ showPlist (createPlist $ optCommand o) + + unless (optQuiet o) $ putStrLn "[3/5] Migrate Database." + conn <- Sql.open . P.encodeString $ optTarget o P. "Contents/Resources/docSet.dsidx" + Sql.execute_ conn "CREATE TABLE searchIndex(id INTEGER PRIMARY KEY, name TEXT, type TEXT, path TEXT, package TEXT);" + Sql.execute_ conn "CREATE UNIQUE INDEX anchor ON searchIndex (name, type, path, package);" + + globalDir <- globalPackageDirectory (optHcPkg o) + unless (optQuiet o) $ putStr " Global package directory: " >> putStrLn (P.encodeString globalDir) + globals <- map (globalDir P.) <$> packageConfs globalDir + let locals = toAddFiles $ optCommand o + iFiles <- filter diExposed . catMaybes <$> mapM readDocInfoFile (globals ++ locals) + unless (optQuiet o) $ putStr " Global package count: " >> print (length globals) + + unless (optQuiet o) $ putStrLn "[4/5] Copy and populate Documents." + forM_ iFiles $ \iFile -> addSinglePackage (optQuiet o) (optDocumentsDir o) (optHaddockDir o) conn iFile + + unless (optQuiet o) $ putStrLn "[5/5] Create index." + haddockIndex (optHaddockDir o) (optDocumentsDir o) + +addCommand :: Options -> IO () +addCommand o = do + conn <- Sql.open . P.encodeString $ optTarget o P. "Contents/Resources/docSet.dsidx" + forM_ (toAddFiles $ optCommand o) $ \i -> go conn i + `catchIOError` handler + haddockIndex (optHaddockDir o) (optDocumentsDir o) + where + go conn p = readDocInfoFile p >>= \mbIFile -> case mbIFile of + Nothing -> return () + Just iFile -> addSinglePackage (optQuiet o) (optDocumentsDir o) (optHaddockDir o) conn iFile + handler ioe + | isDoesNotExistError ioe = print ioe + | otherwise = ioError ioe + +listCommand :: Options -> IO () +listCommand o = + mapM_ (putStrLn . P.encodeString . P.dropExtension . P.filename) =<< P.listDirectory (optHaddockDir o) + +data Options + = Options { optHcPkg :: String + , optTarget :: P.FilePath + , optQuiet :: Bool + , optCommand :: Command + } + deriving Show + +optHaddockDir, optDocumentsDir :: Options -> P.FilePath +optHaddockDir opt = optTarget opt P. "Contents/Resources/Haddock/" +optDocumentsDir opt = optTarget opt P. "Contents/Resources/Documents/" + +data Command + = Create { createPlist :: Plist, toAddFiles :: [P.FilePath] } + | List + | Add { toAddFiles :: [P.FilePath] } + deriving Show + +main :: IO () +main = do + opts <- execParser optRule + case opts of + Options{optCommand = Create{}} -> createCommand opts + Options{optCommand = List} -> listCommand opts + Options{optCommand = Add{}} -> addCommand opts + where + optRule = info (helper <*> options) fullDesc + options = Options + <$> (strOption (long "hc-pkg" <> metavar "CMD" <> help "hc-pkg command (default: ghc-pkg)") <|> pure "ghc-pkg") + <*> fmap (docsetDir . P.decodeString) + (strOption (long "target" <> short 't' <> metavar "DOCSET" <> help "output directory (default: haskell.docset)") <|> pure "haskell") + <*> switch (long "quiet" <> short 'q' <> help "suppress output.") + <*> subparser (command "create" (info createOpts $ progDesc "crate new docset.") + <> command "list" (info (pure List) $ progDesc "list package of docset.") + <> command "add" (info addOpts $ progDesc "add package to docset.")) + + createOpts = Create + <$> ( Plist + <$> (strOption (long "CFBundleIdentifier") <|> pure "haskell") + <*> (strOption (long "CFBundleName") <|> pure "Haskell") + <*> (strOption (long "DocSetPlatformFamily") <|> pure "haskell")) + <*> many (argument (Just . P.decodeString) (metavar "CONFS" <> help "path to installed package configuration.")) + + addOpts = Add <$> some (argument (Just . P.decodeString) (metavar "CONFS" <> help "path to installed package configuration.")) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haddocset.cabal b/haddocset.cabal new file mode 100644 --- /dev/null +++ b/haddocset.cabal @@ -0,0 +1,38 @@ +name: haddocset +version: 0.1.0 +synopsis: Generate docset of Dash by Haddock haskell documentation tool +description: please read README.md +license: BSD3 +license-file: LICENSE +author: HirotomoMoriwaki +maintainer: HirotomoMoriwaki +Homepage: https://github.com/philopon/haddocset +Bug-reports: https://github.com/philopon/haddocset/issues +copyright: (c) 2014 Hirotomo Moriwaki +category: Distribution +build-type: Simple +cabal-version: >=1.10 + +executable haddocset + main-is: Main.hs + other-modules: Documentation.Haddocset + ghc-options: -Wall -O2 + build-depends: base >=4.6 && <4.8 + , ghc >=7.4 + , optparse-applicative >=0.7 + , conduit >=1.0 + , filesystem-conduit >=1.0 + , tagsoup >=0.13 + , Cabal >=1.16 + , text >=1.0 + , sqlite-simple >=0.4.5 + , process >=1.1 + , system-filepath >=0.4 + , system-fileio >=0.3 + , transformers >=0.3 + if impl(ghc >= 7.8) + build-depends: haddock >=2.14 + else + build-depends: haddock >=2.13 && <2.14 + + default-language: Haskell2010