{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Yu.Tool.Repo ( RepoCfg(..) , Summary(..) , Item(..) , Nav(..) , findRepo , makeAbsoluteRepoT , makePathRelateRepo , yuRepoName , yuRepoNameT ) where import Data.Char (toLower) import Data.Function import Data.List import System.Directory import System.FilePath.Posix (makeRelative) import Yu.Import import Yu.Import.Aeson import qualified Yu.Import.Text as T data RepoCfg = RepoCfg { siteUrl :: String } deriving Show deriveJSON defaultOptions{ fieldLabelModifier = map toLower , constructorTagModifier = map toLower} ''RepoCfg newtype Summary a = Summary (Either FilePath a) deriving Show deriveJSON defaultOptions ''Summary instance Functor Summary where fmap f (Summary summary) = Summary $ f <$> summary data Item a = Item { iSummary :: Summary a , iMIME :: Maybe a , iPath :: a , iWhose :: Maybe a , iCreTime :: UTCTime , iId :: a , iContent :: a , iTitle :: Maybe a , iType :: a , iTags :: [a] } deriving Show deriveJSON defaultOptions{ fieldLabelModifier = map toLower . drop 1 , constructorTagModifier = map toLower} ''Item instance Functor Item where fmap f Item{..} = Item (f <$> iSummary) (f <$> iMIME) (f iPath) (f <$> iWhose) ( iCreTime) (f iId) (f iContent) (f <$> iTitle) (f iType) (f <$> iTags) data Nav a = Nav { nOrder :: Int , nUrl :: a -- url , nLabel :: a -- name, or say label } deriving Show instance Functor Nav where fmap f Nav{..} = Nav nOrder (f nUrl) (f nLabel) instance Eq a => Eq (Nav a) where (==) = (==) `on` nLabel deriveJSON defaultOptions{ fieldLabelModifier = map toLower . drop 1 , constructorTagModifier = map toLower} ''Nav -- | find out repo's dir -- If the path of the .git direcory is @/path/to/repo/.git@ -- @the findRepo ".git"@ will return @/path/to/repo@ findRepo :: FilePath -> IO (Maybe FilePath) findRepo fp = getCurrentDirectory >>= findRepoStep where findRepoStep "" = return Nothing findRepoStep dir = do list <- filter (== fp) <$> listDirectory dir if null list then findRepoStep (uplevel dir) else return (Just dir) uplevel "/" = "" uplevel p = reverse . dropWhile (\x -> x /= '/' && x /= '\\') . dropWhile (\x -> x == '/' || x == '\\') . reverse $ p makeAbsoluteRepoT :: FilePath -- ^ repo -> Item T.Text -> Item T.Text makeAbsoluteRepoT repo item = let newCon = T.pack repo `T.append` iContent item newSum = case iSummary item of Summary (Left p) -> Summary $ Left $ repo ++ p _ -> iSummary item in item { iSummary = newSum, iContent = newCon} yuRepoName :: String yuRepoName = ".yu" yuRepoNameT :: T.Text yuRepoNameT = ".yu" makePathRelateRepo :: FilePath -- ^ repo path -> Item String -> IO (Item String) makePathRelateRepo repo item = do newSum <- case iSummary item of Summary (Left path) -> makeAbsolute path >>= (return . Summary . Left . makeRelative repo) _ -> return (iSummary item) newCon <- makeRelative repo <$> makeAbsolute (iContent item) return item{iSummary = newSum, iContent = newCon}