Repository.hs

module GI.GIR.Repository (readGiRepository) where

import Prelude hiding (readFile)

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif

import Control.Monad (when)
import Data.Maybe
import qualified Data.List as List
import qualified Data.Text as T
import Data.Text (Text)
import Safe (maximumMay)
import Text.XML

import System.Directory
import System.Environment.XDG.BaseDir (getSystemDataDirs)
import System.FilePath

girDataDirs :: IO [FilePath]
girDataDirs = getSystemDataDirs "gir-1.0"

girFilePath :: String -> String -> FilePath -> FilePath
girFilePath name version path = path </> name ++ "-" ++ version <.> "gir"

girFile' :: Text -> Maybe Text -> FilePath -> IO (Maybe FilePath)
girFile' name (Just version) path =
    let filePath = girFilePath (T.unpack name) (T.unpack version) path
    in  doesFileExist filePath >>= \case
        True  -> return $ Just filePath
        False -> return Nothing
girFile' name Nothing path =
    doesDirectoryExist path >>= \case
        True -> do
            repositories <- map takeBaseName <$> getDirectoryContents path
            let version = maximumMay . catMaybes $
                    List.stripPrefix (T.unpack name ++ "-") <$> repositories

            return $ case version of
                Just v  -> Just $ girFilePath (T.unpack name) v path
                Nothing -> Nothing

        False -> return Nothing

girFile :: Text -> Maybe Text -> [FilePath] -> IO (Maybe FilePath)
girFile name version extraPaths = do
  dataDirs <- girDataDirs
  firstJust <$> (mapM (girFile' name version) (extraPaths ++ dataDirs))
    where firstJust = listToMaybe . catMaybes

readGiRepository :: Bool -> Text -> Maybe Text -> [FilePath] -> IO Document
readGiRepository verbose name version extraPaths =
    girFile name version extraPaths >>= \case
        Just path -> do
            when verbose $ putStrLn $ "Loading GI repository: " ++ path
            readFile def path
        Nothing -> do
            dataDirs <- girDataDirs
            error $ "Did not find a GI repository for " ++ (T.unpack name)
                ++ maybe "" ("-" ++) (T.unpack <$> version)
                ++ " in " ++ show dataDirs