hackport-0.8.5.2: src/Overlays.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Overlays
    ( getOverlayPath
    ) where

import Control.Monad
import Control.Monad.State.Strict (MonadState)
import Data.List (nub, inits)
import Data.Maybe (maybeToList, listToMaybe, isJust, fromJust)
import qualified System.Directory as SD
import System.FilePath ((</>), splitPath, joinPath)

import Error
import Portage.Host
import Util (info)
import Hackport.Env hiding (local)

-- getOverlayPath :: forall m. (HasGlobalEnv m, MonadIO m) => m String
getOverlayPath :: Env env String
getOverlayPath = askGlobalEnv >>= \(GlobalEnv _ override_overlay _) -> do
  overlays <- if isJust override_overlay
                  then do info $ "Forced " ++ fromJust override_overlay
                          return [fromJust override_overlay]
                  else getOverlays
  case overlays of
    [] -> throw NoOverlay
    [x] -> return x
    mul -> search mul
  where
  search :: [String] -> Env env String
  search mul = do
    let loop [] = throw (MultipleOverlays mul)
        loop (x:xs) = do
          info $ "Checking '" ++ x ++ "'..."
          found <- liftIO $ SD.doesDirectoryExist (x </> ".hackport")
          if found
            then do
              info "OK!"
              return x
            else do
              info "Not ok."
              loop xs
    info "There are several overlays in your configuration."
    mapM_ (info . (" * " ++)) mul
    info "Looking for one with a HackPort cache..."
    overlay <- loop mul
    info $ "I choose " ++ overlay
    info "Override my decision with hackport --overlay /my/overlay"
    return overlay

getOverlays :: (HasGlobalEnv m, MonadIO m, MonadState WarningBuffer m)
    => m [String]
getOverlays = do
  local    <- getLocalOverlay
  overlays <- overlay_list <$> getInfo
  return $ nub $ map clean $
                 maybeToList local
              ++ overlays
  where
  clean path = case reverse path of
                '/':p -> reverse p
                _ -> path

getLocalOverlay :: MonadIO m => m (Maybe FilePath)
getLocalOverlay = do
  curDir <- liftIO $ SD.getCurrentDirectory
  let lookIn = map joinPath . reverse . inits . splitPath $ curDir
  fmap listToMaybe (filterM probe lookIn)

  where
    probe dir = liftIO $ SD.doesDirectoryExist (dir </> "dev-haskell")