haddocset 0.3.2 → 0.4.0
raw patch · 5 files changed
+480/−222 lines, 5 filesdep +directorydep +filepathdep +http-typesdep −system-fileiodep −system-filepathdep ~Cabaldep ~basedep ~exceptions
Dependencies added: directory, filepath, http-types
Dependencies removed: system-fileio, system-filepath
Dependency ranges changed: Cabal, base, exceptions, ghc, mtl
Files
- Documentation/Haddocset.hs +266/−173
- Documentation/Haddocset/Index.hs +108/−0
- Documentation/Haddocset/Plist.hs +39/−0
- Main.hs +54/−40
- haddocset.cabal +13/−9
Documentation/Haddocset.hs view
@@ -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- [ "<?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>" ++ cfBundleIdentifier ++ "</string>"- , "<key>CFBundleName</key>"- , "<string>" ++ cfBundleName ++ "</string>"- , "<key>DocSetPlatformFamily</key>"- , "<string>" ++ docSetPlatformFamily ++ "</string>"- , "<key>isDashDocset</key>"- , "<true/>"- , "<key>dashIndexFilePath</key>"- , "<string>index.html</string>"- , "</dict>"- , "</plist>"- ]--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."
+ Documentation/Haddocset/Index.hs view
@@ -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)
+ Documentation/Haddocset/Plist.hs view
@@ -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+ [ "<?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>" <> cfBundleIdentifier <> "</string>"+ , "<key>CFBundleName</key>"+ , "<string>" <> cfBundleName <> "</string>"+ , "<key>DocSetPlatformFamily</key>"+ , "<string>" <> docSetPlatformFamily <> "</string>"+ , "<key>isDashDocset</key>"+ , "<true/>"+ , "<key>dashIndexFilePath</key>"+ , "<string>index.html</string>"+ , "<key>DashDocSetFamily</key>"+ , "<string>dashtoc</string>"+ , "</dict>"+ , "</plist>"+ ]
Main.hs view
@@ -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
haddocset.cabal view
@@ -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 <https://github.com/philopon/haddocset/blob/master/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