diff --git a/Documentation/Haddocset.hs b/Documentation/Haddocset.hs --- a/Documentation/Haddocset.hs +++ b/Documentation/Haddocset.hs @@ -1,30 +1,50 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} -module Documentation.Haddocset where +module Documentation.Haddocset + ( globalPackageDirectories + , packageConfs + , DocInfo(..) + , readDocInfoFile + + , ResolutionStrategy(..) + , addSinglePackage + + , docsetDir + , haddockIndex + ) where + +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative +#endif + import Control.Monad.Catch import Control.Monad import Control.Monad.Trans.Resource import Control.Monad.IO.Class +import Data.Typeable (Typeable) -import qualified Filesystem as P -import qualified Filesystem.Path.CurrentOS as P +import System.FilePath +import System.Directory import System.IO import System.IO.Error(mkIOError, alreadyExistsErrorType, isDoesNotExistError) import System.Process -import qualified Database.SQLite.Simple as Sql +import Network.HTTP.Types.URI (urlEncode) +import Data.Char +import Data.List import Data.Maybe import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T import Text.HTML.TagSoup as Ts import Text.HTML.TagSoup.Match as Ts @@ -37,180 +57,199 @@ import qualified Name as Ghc import Data.Conduit -import qualified Data.Conduit.Filesystem as P -import qualified Data.Conduit.List as CL +import Data.Conduit.Filesystem (sourceDirectoryDeep) -docsetDir :: P.FilePath -> P.FilePath -docsetDir d = - if P.extension d == Just "docset" - then d - else d P.<.> "docset" +import Documentation.Haddocset.Index -globalPackageDirectories :: FilePath -> IO [P.FilePath] +collapse :: FilePath -> FilePath +collapse = joinPath . reverse . go [] . splitDirectories + where + go cs [] = cs + go cs (".": ps) = go cs ps + go cs ("..":ps) = go (tail cs) ps + go cs (p: ps) = go (p:cs) ps + +parent :: FilePath -> FilePath +parent = takeDirectory . dropTrailingPathSeparator + +stripPrefixPath :: FilePath -> FilePath -> Maybe FilePath +stripPrefixPath a0 b0 = joinPath <$> go (splitPath a0) (splitPath b0) + where + go _ [] = Nothing + go [] bs = Just bs + go (a:as) (b:bs) + | a == b = go as bs + | otherwise = Nothing + +docsetDir :: FilePath -> FilePath +docsetDir = flip replaceExtension "docset" + +listDirectory :: FilePath -> IO [FilePath] +listDirectory p = map (p ) . filter (`notElem` [".", ".."]) <$> getDirectoryContents p + +globalPackageDirectories :: FilePath -> IO [FilePath] globalPackageDirectories hcPkg = do - ds <- map (P.decodeString . init) . filter isPkgDBLine . lines <$> + ds <- map init . filter isPkgDBLine . lines <$> readProcess hcPkg ["list", "--global"] "" - forM ds $ \d -> P.isDirectory d >>= \isDir -> + forM ds $ \d -> doesDirectoryExist d >>= \isDir -> return $ if isDir - then return d - else return (P.directory d) + then d + else (takeDirectory d) where isPkgDBLine "" = False isPkgDBLine (' ':_) = False isPkgDBLine _ = True -packageConfs :: P.FilePath -> IO [P.FilePath] +packageConfs :: FilePath -> IO [FilePath] packageConfs dir = - filter (("package.cache" /=) . P.filename) <$> P.listDirectory dir + filter (("package.cache" /=) . takeFileName) <$> listDirectory dir data DocInfo = DocInfo { diPackageId :: PackageId - , diInterfaces :: [P.FilePath] - , diHTMLs :: [P.FilePath] + , diInterfaces :: [FilePath] + , diHTMLs :: [FilePath] , diExposed :: Bool } deriving Show -readDocInfoFile :: P.FilePath -> IO (Maybe DocInfo) -readDocInfoFile pifile = P.isDirectory pifile >>= \isDir -> +readDocInfoFile :: FilePath -> IO (Maybe DocInfo) +readDocInfoFile pifile = doesDirectoryExist pifile >>= \isDir -> if isDir - then filter ((== Just "haddock") . P.extension) <$> P.listDirectory pifile >>= \hdc -> case hdc of + then filter ((== ".haddock") . takeExtension) <$> listDirectory pifile >>= \hdc -> case hdc of [] -> return Nothing - hs@(h:_) -> readInterfaceFile freshNameCache (P.encodeString h) >>= \ei -> case ei of + hs@(h:_) -> readInterfaceFile freshNameCache h >>= \ei -> case ei of Left _ -> return Nothing Right (InterfaceFile _ (intf:_)) -> do +#if __GLASGOW_HASKELL__ >= 710 + let rPkg = readP_to_S parse . Ghc.packageKeyString . Ghc.modulePackageKey $ instMod intf :: [(PackageId, String)] +#else let rPkg = readP_to_S parse . Ghc.packageIdString . Ghc.modulePackageId $ instMod intf :: [(PackageId, String)] +#endif case rPkg of [] -> return Nothing pkg -> do - return . Just $ DocInfo (fst $ last pkg) hs [P.collapse $ pifile P. P.decodeString "./" ] True + return . Just $ DocInfo (fst $ last pkg) hs [collapse pifile] True Right _ -> return Nothing else do - result <- parseInstalledPackageInfo <$> readFile (P.encodeString pifile) + result <- parseInstalledPackageInfo <$> readFile 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) + DocInfo + (sourcePackageId a) + (haddockInterfaces a) + (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 :: DocFile -> FilePath -> IO () copyHtml doc dst = do - tags <- Ts.parseTags <$> P.readTextFile (docAbsolute doc) - P.writeTextFile dst . Ts.renderTags $ map mapFunc tags + tags <- Ts.parseTags <$> T.readFile (docAbsolute doc) + T.writeFile dst . Ts.renderTags $ concatMap (addAnchor . modifyUrl) tags where - mapFunc tag + modifyUrl tag | Ts.tagOpenLit "a" (Ts.anyAttrNameLit "href") tag = - let absp p = P.collapse $ docBaseDir doc P. P.fromText p + let absp p = collapse $ docBaseDir doc p attr = filter (\(n,_) -> n /= "href") (getAttr tag) - in case Ts.fromAttrib "href" tag of - url | "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) - | "#" `T.isPrefixOf` url -> Ts.TagOpen "a" (toAttr "href" (rebase $ addHash url dst) attr) - | otherwise -> Ts.TagOpen "a" (toAttr "href" (rebase . absp $ url) attr) + in case T.unpack $ Ts.fromAttrib "href" tag of + url | "http://" `isPrefixOf` url -> tag + | "https://" `isPrefixOf` url -> tag + | "file:///" `isPrefixOf` url -> Ts.TagOpen "a" $ ("href", T.pack . rebase $ drop 7 url) : attr + | "#" `isPrefixOf` url -> Ts.TagOpen "a" $ ("href", T.pack . rebase $ dst ++ url) : attr + | otherwise -> Ts.TagOpen "a" $ ("href", T.pack . rebase $ absp url) : attr | Ts.tagOpenLit "a" (Ts.anyAttrNameLit "name") tag = let Ts.TagOpen _ attr = tag - hash = '#' `T.cons` Ts.fromAttrib "name" tag - in Ts.TagOpen "a" (toAttr "href" (rebase $ addHash hash dst) attr) + hash = '#' : T.unpack (Ts.fromAttrib "name" tag) + in Ts.TagOpen "a" $ ("href", T.pack . rebase $ dst ++ hash) : attr | otherwise = tag - addHash h file = P.dirname file P. case P.toText $ P.filename file of - Right r -> P.fromText $ r `T.append` h - Left _ -> "" + addAnchor tag@(Ts.TagOpen "a" as) + | Ts.anyAttrNameLit "name" as && hasClass "def" as = + maybe id (\(t, n) -> (++) + [ Ts.TagOpen "a" + [ ("class", "dashAnchor") + , ("name", T.concat ["//apple_ref/cpp/", t, "/", T.decodeUtf8 . urlEncode True $ T.encodeUtf8 n]) + ] + , Ts.TagClose "a" + ]) (anchorName =<< lookup "name" as) $ + [tag] + | otherwise = [tag] + addAnchor tag = [tag] - getAttr (TagOpen _ a) = a - getAttr _ = error "copyHtml: call attr to !TagOpen." + unescape [] = Just [] + unescape ('-':n) = case reads n of + [(c, '-':o)] -> (toEnum c :) <$> unescape o + _ -> Nothing + unescape (c:n) = (c:) <$> unescape n - toAttr attr url = case P.toText url of - Right r -> ((attr, r):) - Left _ -> id + anchorName s = fmap T.pack <$> case T.unpack s of + ('t':_:t) -> ("Type",) <$> unescape t + ('v':_:':':c) -> ("Constructor",) <$> unescape (':':c) + ('v':_:a:as) + | isUpper a -> ("Constructor",) <$> unescape (a:as) + | otherwise -> ("Function",) <$> unescape (a:as) + _ -> Nothing - both a = case a of - Left l -> l - Right r -> r + hasClass c = maybe False (any (c ==) . T.words) . lookup "class" + getAttr (TagOpen _ a) = a + getAttr _ = error "copyHtml: call attr to !TagOpen." + + rebase :: FilePath -> FilePath rebase p = - let file = P.filename p - isSrc = "src" `elem` P.splitDirectories (P.parent p) - srcNize = if isSrc then ("src" P.) else id - pkgs = filter packageLike . reverse $ P.splitDirectories (P.parent p) + let file = takeFileName p + isSrc = "src" `elem` splitDirectories (parent p) + srcNize = if isSrc then ("src" ) else id + pkgs = filter packageLike . reverse $ splitDirectories (parent p) in case pkgs of [] -> file - pkg:_ -> ".." P. pkg P. srcNize file - - packageLike p = let t = both $ P.toText p - in T.any (== '-') t && (T.all (`elem` "0123456789.") . T.takeWhile (/= '-') $ T.reverse t) + pkg:_ -> ".." pkg srcNize file -commonPrefix :: P.FilePath -> P.FilePath -> P.FilePath -commonPrefix a0 b0 = P.concat $ loop id (P.splitDirectories a0) (P.splitDirectories b0) where - loop f [] _ = f [] - loop f _ [] = f [] - loop f (a:as) (b:bs) | a == b = loop (f . (a:)) as bs - | otherwise = f [] + packageLike :: FilePath -> Bool + packageLike p = + let t = T.pack $ dropTrailingPathSeparator p + (pkg, version) = T.breakOnEnd "-" t + in not (T.null pkg) && T.all (`elem` ("0123456789." :: String)) version data DocFile = DocFile { docPackage :: PackageId - , docBaseDir :: P.FilePath - , docRationalDir :: P.FilePath + , docBaseDir :: FilePath + , docRationalDir :: FilePath } deriving Show - -docAbsolute :: DocFile -> P.FilePath -docAbsolute doc = docBaseDir doc P. docRationalDir doc +docAbsolute :: DocFile -> FilePath +docAbsolute doc = docBaseDir doc docRationalDir doc -copyDocument :: (MonadThrow m, MonadIO m) => P.FilePath +copyDocument :: (MonadThrow m, MonadIO m) => 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 $ throwM $ 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 + display (docPackage doc) + docRationalDir doc + liftIO $ createDirectoryIfMissing True (takeDirectory dst) + ex <- liftIO $ (||) <$> doesFileExist dst <*> doesDirectoryExist dst + when ex $ throwM $ mkIOError alreadyExistsErrorType "copyDocument" Nothing (Just dst) + case takeExtension $ docRationalDir doc of + ".html" -> liftIO $ copyHtml doc dst + ".haddock" -> return () + _ -> liftIO $ copyFile full dst -docFiles :: (MonadIO m, MonadResource m) => PackageId -> [P.FilePath] -> Producer m DocFile +docFiles :: (MonadIO m, MonadResource m) => PackageId -> [FilePath] -> Producer m DocFile docFiles sourcePackageId haddockHTMLs = forM_ haddockHTMLs $ \dir -> - P.sourceDirectoryDeep False (P.encodeString dir) - =$= awaitForever (\f -> yield $ DocFile sourcePackageId dir $ fromMaybe (error $ "Prefix missmatch: " ++ show (dir ,f)) $ P.stripPrefix dir (P.decodeString f)) + sourceDirectoryDeep False dir + =$= awaitForever + (\f -> yield + $ DocFile sourcePackageId dir + $ fromMaybe (error $ "Prefix missmatch: " ++ show (dir, f)) + $ stripPrefixPath (addTrailingPathSeparator dir) f) data Provider - = Haddock PackageId P.FilePath + = Haddock PackageId FilePath | Package PackageId | Module PackageId Ghc.Module | Function PackageId Ghc.Module Ghc.Name @@ -220,7 +259,7 @@ mapM_ sub $ diInterfaces iFile where sub file = do - rd <- liftIO $ readInterfaceFile freshNameCache (P.encodeString file) + rd <- liftIO $ readInterfaceFile freshNameCache file case rd of Left _ -> return () Right (ifInstalledIfaces -> iIntrf) -> do @@ -234,45 +273,11 @@ 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 @@ -283,39 +288,127 @@ 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 +providerToEntry :: FilePath -> Conduit Provider IO IndexEntry +providerToEntry hdir = awaitForever $ \provider -> case provider of + Haddock p h -> liftIO $ + copyFile h (hdir display p <.> "haddock") + Package pkg -> + yield $! IndexEntry + { entryName = T.pack (display pkg) + , entryType = PackageEntry + , entryPath = display pkg ++ "/index.html" + , entryPackage = pkg + } + Module pkg modn -> + yield $! IndexEntry + { entryName = T.pack $ Ghc.moduleNameString $ Ghc.moduleName modn + , entryType = ModuleEntry + , entryPath = display pkg ++ '/' : moduleNameURL modn ++ ".html" + , entryPackage = pkg + } + Function pkg modn name -> + let typ = case () of + _ | Ghc.isTyConName name -> TypeEntry + | Ghc.isDataConName name -> ConstructorEntry + | otherwise -> FunctionEntry + prefix = case typ of + TypeEntry -> 't' + _ -> 'v' + in yield $! IndexEntry + { entryName = T.pack $ Ghc.getOccString name + , entryType = typ + , entryPath + = display pkg ++ '/' + : moduleNameURL modn ++ ".html#" + ++ prefix : ':' : escapeSpecial (Ghc.getOccString name) + , entryPackage = pkg + } + where + moduleNameURL = moduleNmaeUrl . Ghc.moduleNameString . Ghc.moduleName -haddockIndex :: P.FilePath -> P.FilePath -> IO () + specialChars = "!&|+$%(,)*<>-/=#^\\?" :: String + escapeSpecial = concatMap (\c -> if c `elem` specialChars then '-': show (fromEnum c) ++ "-" else [c]) + + +haddockIndex :: FilePath -> FilePath -> IO () haddockIndex haddockdir documentdir = do argIs <- map (\h -> "--read-interface=" - ++ P.encodeString (P.dropExtension $ P.filename h) ++ - ',': P.encodeString h) <$> P.listDirectory haddockdir + ++ (dropExtension $ takeFileName h) ++ + ',': h) <$> listDirectory haddockdir + haddock $ "--gen-index": "--gen-contents": ("--odir=" ++ documentdir): argIs - haddock $ "--gen-index": "--gen-contents": ("--odir=" ++ P.encodeString documentdir): argIs +-- | What to do if documentation for a package already exists? +data ResolutionStrategy + = Skip + | Overwrite + | Fail + deriving (Show, Ord, Eq) --- dst = docdir --- P. (P.decodeString . display) (docPackage doc) -addSinglePackage :: Bool -> Bool -> P.FilePath -> P.FilePath -> Sql.Connection -> DocInfo -> IO () -addSinglePackage quiet force docDir haddockDir conn iFile = go `catchIOError` handler +addSinglePackage + :: Bool + -> ResolutionStrategy + -> FilePath + -> FilePath + -> SearchIndex ReadOnly + -> DocInfo + -> IO () +addSinglePackage quiet resolution docDir haddockDir idx iFile = + go `catchIOError` handler where - go = do - putStr " " >> putStr (display $ diPackageId iFile) >> putChar ' ' >> hFlush stdout - when force $ P.removeTree $ docDir P. (P.decodeString . display) (diPackageId iFile) - runResourceT $ 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;" + -- Directory to which documentation for this package will be written. + pkgDocDir = docDir display (diPackageId iFile) + + resolveConflict :: PackageId -> IO () -> IO () + resolveConflict pkgId io = do + hasConflict <- doesDirectoryExist pkgDocDir + if not hasConflict + then io + else case resolution of + Fail -> throwM $ AlreadyExists pkgId + Overwrite -> do + unless quiet $ + putStrLn $ " " ++ display pkgId ++ + ": Found existing documentation. Deleting." + removeDirectoryRecursive pkgDocDir >> io + _ -> + unless quiet $ + putStrLn $ " " ++ display pkgId ++ + ": Found existing documentation. Skipping." + + go = resolveConflict (diPackageId iFile) $ do + -- These operations are run only after resolving a conflict--if + -- one existed. + + putStr " " + putStr (display $ diPackageId iFile) + putChar ' ' + hFlush stdout + + runResourceT $ + docFiles (diPackageId iFile) (diHTMLs iFile) + $$ (if quiet then id else (progress False 10 '.' =$)) + (copyDocument docDir) + + withReadWrite idx $ \idx' -> + moduleProvider iFile + $= providerToEntry haddockDir + $$ (if quiet then id else (progress True 100 '*' =$)) + (sinkEntries idx') + handler ioe | isDoesNotExistError ioe = putStr "Error: " >> print ioe | otherwise = ioError ioe + +data AddException + = AlreadyExists PackageId + deriving (Typeable) + +instance Exception AddException + +instance Show AddException where + show (AlreadyExists pkg) = + "Failed to write documentation for " ++ display pkg ++ ". " ++ + "Documentation for it already exists. " ++ + "Use -f/--force to overwrite it or -s/--skip to skip it." diff --git a/Documentation/Haddocset/Index.hs b/Documentation/Haddocset/Index.hs new file mode 100644 --- /dev/null +++ b/Documentation/Haddocset/Index.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Documentation.Haddocset.Index + ( SearchIndex + , ReadWrite + , ReadOnly + + , EntryType(..) + , IndexEntry(..) + + , withSearchIndex + , withReadWrite + , insert + , sinkEntries + ) where + + +import Data.Text (Text) +import Distribution.Package (PackageId) +import Distribution.Text (display) + +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import qualified Database.SQLite.Simple as Sql +import qualified Database.SQLite.Simple.ToField as Sql + +data ReadWrite + +data ReadOnly + +-- | A handle to a docset search index. +-- +-- This will be tagged with 'ReadWrite' or 'ReadOnly'. +newtype SearchIndex a = SearchIndex Sql.Connection + +data EntryType + = PackageEntry + | ModuleEntry + | TypeEntry + | ConstructorEntry + | FunctionEntry + deriving (Show, Ord, Eq) + +instance Sql.ToField EntryType where + toField PackageEntry = Sql.SQLText "Package" + toField ModuleEntry = Sql.SQLText "Module" + toField TypeEntry = Sql.SQLText "Type" + toField ConstructorEntry = Sql.SQLText "Constructor" + toField FunctionEntry = Sql.SQLText "Function" + + +-- | An entry in the search index. +data IndexEntry = IndexEntry + { entryName :: !Text + , entryType :: !EntryType + , entryPath :: !String + , entryPackage :: !PackageId + } deriving (Show, Ord, Eq) + +instance Sql.ToRow IndexEntry where + toRow IndexEntry{..} = + Sql.toRow (entryName, entryType, entryPath, display entryPackage) + +-- | Executes the given operation on the search index at the specified +-- location. +withSearchIndex :: FilePath -> (SearchIndex ReadOnly -> IO a) -> IO a +withSearchIndex path f = + Sql.withConnection path $ \conn -> do + Sql.execute_ conn + "CREATE TABLE IF NOT EXISTS searchIndex \ + \ ( id INTEGER PRIMARY KEY \ + \ , name TEXT \ + \ , type TEXT \ + \ , path TEXT \ + \ , package TEXT \ + \ )" + + Sql.execute_ conn + "CREATE UNIQUE INDEX IF NOT EXISTS \ + \ anchor ON searchIndex (name, type, path, package)" + + f (SearchIndex conn) + + +-- | Executes an operation on a 'ReadWrite' SearchIndex. +-- +-- Opens a database transaction. If the operation fails for any reason, the +-- changes are rolled back. +withReadWrite :: SearchIndex ReadOnly -> (SearchIndex ReadWrite -> IO a) -> IO a +withReadWrite (SearchIndex conn) f = + Sql.withTransaction conn $ + f (SearchIndex conn) + +-- | Inserts an item into a SearchIndex. +insert :: SearchIndex ReadWrite -> IndexEntry -> IO () +insert (SearchIndex conn) = Sql.execute conn insertStmt + + +insertStmt :: Sql.Query +insertStmt = + "INSERT OR IGNORE INTO searchIndex \ + \ (name, type, path,package) VALUES (?, ?, ?, ?)" + + +-- | A sink to write index entries. +sinkEntries :: SearchIndex ReadWrite -> C.Consumer IndexEntry IO () +sinkEntries searchIndex = CL.mapM_ (insert searchIndex) diff --git a/Documentation/Haddocset/Plist.hs b/Documentation/Haddocset/Plist.hs new file mode 100644 --- /dev/null +++ b/Documentation/Haddocset/Plist.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Documentation.Haddocset.Plist + ( Plist(..) + , showPlist + ) where + +import Data.Monoid +import Data.Text (Text) + +import qualified Data.Text as T + +data Plist = Plist + { cfBundleIdentifier :: Text + , cfBundleName :: Text + , docSetPlatformFamily :: Text + } deriving Show + +showPlist :: Plist -> Text +showPlist Plist{..} = T.unlines + [ "" + , "" + , "" + , "" + , "CFBundleIdentifier" + , "" <> cfBundleIdentifier <> "" + , "CFBundleName" + , "" <> cfBundleName <> "" + , "DocSetPlatformFamily" + , "" <> docSetPlatformFamily <> "" + , "isDashDocset" + , "" + , "dashIndexFilePath" + , "index.html" + , "DashDocSetFamily" + , "dashtoc" + , "" + , "" + ] diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -3,15 +3,19 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TupleSections #-} +module Main ( main ) where + import Control.Applicative import Control.Monad +import Data.Foldable (asum) -import qualified Filesystem as P -import qualified Filesystem.Path.CurrentOS as P +import System.FilePath +import System.Directory import System.IO.Error -import qualified Database.SQLite.Simple as Sql +import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Maybe @@ -19,88 +23,92 @@ import Options.Applicative import Documentation.Haddocset +import Documentation.Haddocset.Index +import Documentation.Haddocset.Plist 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 "[1/5] Create Directory." + createDirectory (optTarget o) -- for fail when directory already exists. + createDirectoryIfMissing True (optDocumentsDir o) + createDirectoryIfMissing False (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 "[2/5] Writing plist." + T.writeFile (optTarget o "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);" + unless (optQuiet o) $ putStrLn "[3/5] Migrate Database." + withSearchIndex (optTarget o "Contents/Resources/docSet.dsidx") $ \idx -> do globalDirs <- globalPackageDirectories (optHcPkg o) unless (optQuiet o) $ do putStr " Global package directory: " - putStr (P.encodeString $ head globalDirs) + putStr (head globalDirs) if length globalDirs > 1 then putStr " and " >> putStr (show . pred $ length globalDirs) >> putStrLn "directories." else putStrLn "" - globals <- concat <$> mapM (\d -> map (d P.) <$> packageConfs d) globalDirs + globals <- concat <$> mapM (\d -> map (d ) <$> packageConfs d) globalDirs 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) False (optDocumentsDir o) (optHaddockDir o) conn iFile + forM_ iFiles $ \iFile -> + addSinglePackage (optQuiet o) Fail (optDocumentsDir o) (optHaddockDir o) idx iFile unless (optQuiet o) $ putStrLn "[5/5] Create index." haddockIndex (optHaddockDir o) (optDocumentsDir o) -addCommand :: Options -> Bool -> IO () -addCommand o force = do - conn <- Sql.open . P.encodeString $ optTarget o P. "Contents/Resources/docSet.dsidx" - forM_ (toAddFiles $ optCommand o) $ \i -> go conn i - `catchIOError` handler +addCommand :: Options -> ResolutionStrategy -> IO () +addCommand o resolution = + withSearchIndex (optTarget o "Contents/Resources/docSet.dsidx") $ \idx -> do + forM_ (toAddFiles $ optCommand o) $ \i -> + go idx i `catchIOError` handler haddockIndex (optHaddockDir o) (optDocumentsDir o) where - go conn p = readDocInfoFile p >>= \mbIFile -> case mbIFile of + go idx p = readDocInfoFile p >>= \mbIFile -> case mbIFile of Nothing -> return () - Just iFile -> addSinglePackage (optQuiet o) force (optDocumentsDir o) (optHaddockDir o) conn iFile + Just iFile -> addSinglePackage (optQuiet o) resolution (optDocumentsDir o) (optHaddockDir o) idx 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) + mapM_ (putStrLn . dropExtension . takeFileName) =<< getDirectoryContents (optHaddockDir o) data Options = Options { optHcPkg :: String - , optTarget :: P.FilePath + , optTarget :: 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/" +optHaddockDir, optDocumentsDir :: Options -> FilePath +optHaddockDir opt = optTarget opt "Contents/Resources/Haddock/" +optDocumentsDir opt = optTarget opt "Contents/Resources/Documents/" data Command - = Create { createPlist :: Plist, toAddFiles :: [P.FilePath] } + = Create { createPlist :: Plist, toAddFiles :: [FilePath] } | List - | Add { toAddFiles :: [P.FilePath], forceAdd :: Bool } + | Add { toAddFiles :: [FilePath] + , resolution :: ResolutionStrategy + } 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{forceAdd}} -> addCommand opts forceAdd + Options{optCommand = Create{}} -> createCommand opts + Options{optCommand = List} -> listCommand opts + Options{optCommand = Add{resolution}} -> addCommand opts resolution 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) + <*> fmap docsetDir (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.") @@ -108,11 +116,17 @@ <> 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 (P.decodeString <$> str) (metavar "CONFS" <> help "path to installed package configuration.")) + <$> ( Plist <$> (textOption (long "CFBundleIdentifier") <|> pure "haskell") + <*> (textOption (long "CFBundleName") <|> pure "Haskell") + <*> (textOption (long "DocSetPlatformFamily") <|> pure "haskell")) + <*> many (argument str (metavar "CONFS" <> help "path to installed package configuration.")) addOpts = Add - <$> some (argument (P.decodeString <$> str) (metavar "CONFS" <> help "path to installed package configuration.")) - <*> switch (long "force" <> short 'f' <> help "overwrite exist package.") + <$> some (argument str (metavar "CONFS" <> help "path to installed package configuration.")) + <*> asum + [ flag' Overwrite (long "force" <> short 'f' <> help "overwrite exist package.") + , flag' Skip (long "skip" <> short 's' <> help "skip existing packages") + , pure Fail + ] + + textOption = fmap T.pack . strOption diff --git a/haddocset.cabal b/haddocset.cabal --- a/haddocset.cabal +++ b/haddocset.cabal @@ -1,5 +1,5 @@ name: haddocset -version: 0.3.2 +version: 0.4.0 synopsis: Generate docset of Dash by Haddock haskell documentation tool description: please read README.md license: BSD3 @@ -15,24 +15,28 @@ executable haddocset main-is: Main.hs - other-modules: Documentation.Haddocset + other-modules: + Documentation.Haddocset + Documentation.Haddocset.Index + Documentation.Haddocset.Plist ghc-options: -Wall -O2 - build-depends: base >=4.6 && <4.8 - , ghc >=7.4 && <7.9 + build-depends: base >=4.6 && <4.9 + , ghc >=7.4 && <7.11 , optparse-applicative >=0.11 && <0.12 , conduit >=1.0 && <1.3 , conduit-extra >=1.1 && <1.2 , tagsoup >=0.13 && <1.4 - , Cabal >=1.16 && <1.21 + , Cabal >=1.16 && <1.23 , text >=1.0 && <1.3 , sqlite-simple >=0.4.5 && <0.5 , process >=1.1 && <1.3 - , system-filepath >=0.4 && <0.5 - , system-fileio >=0.3 && <0.4 + , directory >=1.1 && <1.3 + , filepath >=1.3 && <1.5 , transformers >=0.3 && <0.5 - , exceptions >=0.6 && <0.7 + , exceptions >=0.6 && <0.9 , resourcet >=1.1 && <1.2 - , mtl >=2.0 && <2.2 + , mtl >=2.0 && <2.3 + , http-types >=0.8 && <0.9 if impl(ghc >= 7.8) build-depends: haddock-api >=2.15 else