-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2015-2017  Daniel Gröber <cabal-helper@dxld.at>
--
-- SPDX-License-Identifier: Apache-2.0
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0

{-|
Module      : CabalHelper.Shared.Sandbox
Description : Extracting information from @cabal.sandbox.config@ files
License     : Apache-2.0
-}

module CabalHelper.Compiletime.Sandbox where

import Control.Applicative
import Data.Char
import Data.Maybe
import Data.List
import System.FilePath
import Prelude

import qualified Data.Traversable as T

import CabalHelper.Shared.Common
import CabalHelper.Compiletime.Program.GHC
    ( GhcVersion (..), showGhcVersion )

-- | Get the path to the sandbox package-db in a project
getSandboxPkgDb :: String
             -- ^ Cabal build platform, i.e. @buildPlatform@
             -> GhcVersion
             -- ^ GHC version (@cProjectVersion@ is your friend)
             -> FilePath
             -- ^ Path to the cabal package root directory (containing the
             -- @cabal.sandbox.config@ file)
             -> IO (Maybe FilePath)
getSandboxPkgDb :: String -> GhcVersion -> String -> IO (Maybe String)
getSandboxPkgDb String
platform GhcVersion
ghcVer String
projdir = do
  Maybe String
mConf <-
      (String -> IO String) -> Maybe String -> IO (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse String -> IO String
readFile (Maybe String -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Maybe String)
mightExist (String
projdir String -> String -> String
</> String
"cabal.sandbox.config")
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> String
fixPkgDbVer (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Maybe String
extractSandboxDbDir (String -> Maybe String) -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
mConf)

 where
   fixPkgDbVer :: String -> String
fixPkgDbVer String
dir =
       case String -> String
takeFileName String
dir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> GhcVersion -> String
ghcSandboxPkgDbDir String
platform GhcVersion
ghcVer of
         Bool
True -> String
dir
         Bool
False -> String -> String
takeDirectory String
dir String -> String -> String
</> String -> GhcVersion -> String
ghcSandboxPkgDbDir String
platform GhcVersion
ghcVer

ghcSandboxPkgDbDir :: String -> GhcVersion -> String
ghcSandboxPkgDbDir :: String -> GhcVersion -> String
ghcSandboxPkgDbDir String
platform GhcVersion
ghcVer =
   String
platform String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-ghc-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ GhcVersion -> String
showGhcVersion GhcVersion
ghcVer String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-packages.conf.d"

-- | Extract the sandbox package db directory from the cabal.sandbox.config
-- file. Exception is thrown if the sandbox config file is broken.
extractSandboxDbDir :: String -> Maybe FilePath
extractSandboxDbDir :: String -> Maybe String
extractSandboxDbDir String
conf = String -> String
extractValue (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe String
parse String
conf
  where
    key :: String
key = String
"package-db:"
    keyLen :: Int
keyLen = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
key

    parse :: String -> Maybe String
parse = [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String)
-> (String -> [String]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
key String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    extractValue :: String -> String
extractValue = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
CabalHelper.Compiletime.Sandbox.dropWhileEnd Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
keyLen

-- dropWhileEnd is not provided prior to base 4.5.0.0.
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd a -> Bool
p = (a -> [a] -> [a]) -> [a] -> [a] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
xs -> if a -> Bool
p a
x Bool -> Bool -> Bool
&& [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs then [] else a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs) []