diff --git a/Documentation/Haddocset.hs b/Documentation/Haddocset.hs --- a/Documentation/Haddocset.hs +++ b/Documentation/Haddocset.hs @@ -151,11 +151,19 @@ packageLike p = let t = both $ P.toText p in T.any (== '-') t && (T.all (`elem` "0123456789.") . T.takeWhile (/= '-') $ T.reverse t) +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 [] + 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 + where pfx = commonPrefix base path + up = P.concat . flip replicate ".." . length . P.splitDirectories . fromMaybe err $ P.stripPrefix pfx base + p = fromMaybe err $ P.stripPrefix pfx path + err = error $ "relativize: " ++ show base ++ " -> " ++ show path data DocFile = DocFile { docPackage :: PackageId @@ -279,11 +287,14 @@ 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 +-- 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 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;" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -43,13 +43,13 @@ 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 + forM_ iFiles $ \iFile -> addSinglePackage (optQuiet o) False (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 +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 @@ -57,9 +57,9 @@ where go conn p = readDocInfoFile p >>= \mbIFile -> case mbIFile of Nothing -> return () - Just iFile -> addSinglePackage (optQuiet o) (optDocumentsDir o) (optHaddockDir o) conn iFile + Just iFile -> addSinglePackage (optQuiet o) force (optDocumentsDir o) (optHaddockDir o) conn iFile handler ioe - | isDoesNotExistError ioe = print ioe + | isDoesNotExistError ioe = print ioe | otherwise = ioError ioe listCommand :: Options -> IO () @@ -81,33 +81,33 @@ data Command = Create { createPlist :: Plist, toAddFiles :: [P.FilePath] } | List - | Add { toAddFiles :: [P.FilePath] } + | Add { toAddFiles :: [P.FilePath], forceAdd :: Bool } 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 + Options{optCommand = Create{}} -> createCommand opts + Options{optCommand = List} -> listCommand opts + Options{optCommand = Add{forceAdd}} -> addCommand opts forceAdd 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.")) + <$> (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 (P.decodeString <$> str) (metavar "CONFS" <> help "path to installed package configuration.")) - - addOpts = Add <$> some (argument (P.decodeString <$> str) (metavar "CONFS" <> help "path to installed package configuration.")) + <$> ( 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.")) + addOpts = Add + <$> some (argument (P.decodeString <$> str) (metavar "CONFS" <> help "path to installed package configuration.")) + <*> switch (long "force" <> short 'f' <> help "overwrite exist package.") diff --git a/haddocset.cabal b/haddocset.cabal --- a/haddocset.cabal +++ b/haddocset.cabal @@ -1,5 +1,5 @@ name: haddocset -version: 0.2.0 +version: 0.3.0 synopsis: Generate docset of Dash by Haddock haskell documentation tool description: please read README.md license: BSD3