{-# Language CPP, PatternGuards #-}

module CabalLenses.Utils
   ( findCabalFile
   , findPackageDB
   , findDistDir
   , findNewDistDir
   , symPathsToFilePaths
   , symbolicPathListToFilePathList
   ) where

import Control.Monad.Trans.Except (ExceptT, throwE)
import Control.Monad.IO.Class
import Control.Monad (filterM)
import Control.Lens (Iso', iso)
import qualified System.IO.Strict as Strict
import qualified Filesystem.Path.CurrentOS as FP
import Filesystem.Path.CurrentOS ((</>))
import qualified Filesystem as FS
import qualified Data.List as L
import qualified Data.Text as T
import Distribution.Utils.Path (SymbolicPath, getSymbolicPath, makeSymbolicPath)

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif

type Error = String

io :: MonadIO m => IO a -> m a
io :: forall (m :: * -> *) a. MonadIO m => IO a -> m a
io = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Find a cabal file starting at the given directory, going upwards the directory
--   tree until a cabal file could be found. The returned file path is absolute.
findCabalFile :: FilePath -> ExceptT Error IO FilePath
findCabalFile :: Error -> ExceptT Error IO Error
findCabalFile Error
file = do
   FilePath
cabalFile <- IO FilePath -> ExceptT Error IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO FilePath -> ExceptT Error IO FilePath)
-> IO FilePath -> ExceptT Error IO FilePath
forall a b. (a -> b) -> a -> b
$ do
      FilePath
dir <- Error -> IO FilePath
absoluteDirectory Error
file
      FilePath -> IO FilePath
findCabalFile' FilePath
dir

   if FilePath
cabalFile FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
FP.empty
      then Error -> ExceptT Error IO Error
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Error
"Couldn't find Cabal file!"
      else Error -> ExceptT Error IO Error
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Error -> ExceptT Error IO Error)
-> Error -> ExceptT Error IO Error
forall a b. (a -> b) -> a -> b
$ FilePath -> Error
FP.encodeString FilePath
cabalFile

   where
      findCabalFile' :: FilePath -> IO FilePath
findCabalFile' FilePath
dir = do
         [FilePath]
files <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
FS.isFile ([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FilePath -> IO [FilePath]
FS.listDirectory FilePath
dir)
         case (FilePath -> Bool) -> [FilePath] -> Maybe FilePath
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find FilePath -> Bool
isCabalFile [FilePath]
files of
              Just FilePath
file -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
              Maybe FilePath
_         -> do
                 let parent :: FilePath
parent = FilePath -> FilePath
FP.parent FilePath
dir
                 if FilePath
parent FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
dir
                    then FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
FP.empty
                    else FilePath -> IO FilePath
findCabalFile' FilePath
parent

      isCabalFile :: FilePath -> Bool
isCabalFile FilePath
file
         | Just Text
ext <- FilePath -> Maybe Text
FP.extension FilePath
file
         = Text
ext Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
cabalExt

         | Bool
otherwise
         = Bool
False

      cabalExt :: Text
cabalExt = Error -> Text
T.pack Error
"cabal"


-- | Find the package database of the cabal sandbox from the given cabal file.
--   The returned file path is absolute.
findPackageDB :: FilePath -> ExceptT Error IO (Maybe FilePath)
findPackageDB :: Error -> ExceptT Error IO (Maybe Error)
findPackageDB Error
cabalFile = do
   FilePath
cabalDir <- IO FilePath -> ExceptT Error IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO FilePath -> ExceptT Error IO FilePath)
-> IO FilePath -> ExceptT Error IO FilePath
forall a b. (a -> b) -> a -> b
$ Error -> IO FilePath
absoluteDirectory Error
cabalFile
   let sandboxConfig :: FilePath
sandboxConfig = FilePath
cabalDir FilePath -> FilePath -> FilePath
</> FilePath
sandbox_config
   Bool
isFile   <- IO Bool -> ExceptT Error IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Bool -> ExceptT Error IO Bool)
-> IO Bool -> ExceptT Error IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
FS.isFile FilePath
sandboxConfig
   if Bool
isFile
      then do
         Maybe Error
packageDB <- IO (Maybe Error) -> ExceptT Error IO (Maybe Error)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe Error) -> ExceptT Error IO (Maybe Error))
-> IO (Maybe Error) -> ExceptT Error IO (Maybe Error)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe Error)
readPackageDB FilePath
sandboxConfig
         case Maybe Error
packageDB of
              Just Error
db -> Maybe Error -> ExceptT Error IO (Maybe Error)
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Error -> ExceptT Error IO (Maybe Error))
-> Maybe Error -> ExceptT Error IO (Maybe Error)
forall a b. (a -> b) -> a -> b
$ Error -> Maybe Error
forall a. a -> Maybe a
Just Error
db
              Maybe Error
_       -> Error -> ExceptT Error IO (Maybe Error)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Error -> ExceptT Error IO (Maybe Error))
-> Error -> ExceptT Error IO (Maybe Error)
forall a b. (a -> b) -> a -> b
$ Error
"Couldn't find field 'package-db: ' in " Error -> Error -> Error
forall a. [a] -> [a] -> [a]
++ (FilePath -> Error
forall a. Show a => a -> Error
show FilePath
sandboxConfig)
      else
         Maybe Error -> ExceptT Error IO (Maybe Error)
forall a. a -> ExceptT Error IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Error
forall a. Maybe a
Nothing

   where
      -- | reads the 'package-db: ' field from the sandbox config file and returns the value of the field
      readPackageDB :: FP.FilePath -> IO (Maybe FilePath)
      readPackageDB :: FilePath -> IO (Maybe Error)
readPackageDB FilePath
sandboxConfig = do
         [Error]
lines <- Error -> [Error]
lines (Error -> [Error]) -> IO Error -> IO [Error]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Error -> IO Error
Strict.readFile (FilePath -> Error
FP.encodeString FilePath
sandboxConfig)
         Maybe Error -> IO (Maybe Error)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Error -> IO (Maybe Error))
-> Maybe Error -> IO (Maybe Error)
forall a b. (a -> b) -> a -> b
$ do
            Error
line <- (Error -> Bool) -> [Error] -> Maybe Error
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Error
package_db Error -> Error -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf`) [Error]
lines
            Error -> Error -> Maybe Error
forall a. Eq a => [a] -> [a] -> Maybe [a]
L.stripPrefix Error
package_db Error
line

      sandbox_config :: FilePath
sandbox_config = Error -> FilePath
FP.decodeString Error
"cabal.sandbox.config"
      package_db :: Error
package_db     = Error
"package-db: "


-- | Find the dist directory of the cabal build from the given cabal file. For a non sandboxed
--   build it's just the directory 'dist' in the cabal build directory. For a sandboxed build
--   it's the directory 'dist/dist-sandbox-*'. The returned file path is absolute.
findDistDir :: FilePath -> IO (Maybe FilePath)
findDistDir :: Error -> IO (Maybe Error)
findDistDir Error
cabalFile = do
   FilePath
cabalDir   <- Error -> IO FilePath
absoluteDirectory Error
cabalFile
   let distDir :: FilePath
distDir = FilePath
cabalDir FilePath -> FilePath -> FilePath
</> Error -> FilePath
FP.decodeString Error
"dist"
   Bool
hasDistDir <- FilePath -> IO Bool
FS.isDirectory FilePath
distDir
   if Bool
hasDistDir
      then do
         [FilePath]
files <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
FS.isDirectory ([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FilePath -> IO [FilePath]
FS.listDirectory FilePath
distDir)
         Maybe Error -> IO (Maybe Error)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Error -> IO (Maybe Error))
-> Maybe Error -> IO (Maybe Error)
forall a b. (a -> b) -> a -> b
$ FilePath -> Error
FP.encodeString (FilePath -> Error) -> Maybe FilePath -> Maybe Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
-> (FilePath -> Maybe FilePath) -> Maybe FilePath -> Maybe FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
distDir) FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just ((FilePath -> Bool) -> [FilePath] -> Maybe FilePath
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find FilePath -> Bool
isSandboxDistDir [FilePath]
files)
      else Maybe Error -> IO (Maybe Error)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Error
forall a. Maybe a
Nothing

   where
      isSandboxDistDir :: FilePath -> Bool
isSandboxDistDir FilePath
file =
         Error
"dist-sandbox-" Error -> Error -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` (FilePath -> Error
FP.encodeString (FilePath -> Error) -> (FilePath -> FilePath) -> FilePath -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FP.filename (FilePath -> Error) -> FilePath -> Error
forall a b. (a -> b) -> a -> b
$ FilePath
file)


-- | Find the new style dist directory of the cabal build from the given cabal file.
--   The returned file path is absolute.
findNewDistDir :: FilePath -> IO (Maybe FilePath)
findNewDistDir :: Error -> IO (Maybe Error)
findNewDistDir Error
cabalFile = do
   FilePath
cabalDir   <- Error -> IO FilePath
absoluteDirectory Error
cabalFile
   let distDir :: FilePath
distDir = FilePath
cabalDir FilePath -> FilePath -> FilePath
</> Error -> FilePath
FP.decodeString Error
"dist-newstyle"
   Bool
hasDistDir <- FilePath -> IO Bool
FS.isDirectory FilePath
distDir
   Maybe Error -> IO (Maybe Error)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Error -> IO (Maybe Error))
-> Maybe Error -> IO (Maybe Error)
forall a b. (a -> b) -> a -> b
$ if Bool
hasDistDir then Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error)
-> (FilePath -> Error) -> FilePath -> Maybe Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Error
FP.encodeString (FilePath -> Maybe Error) -> FilePath -> Maybe Error
forall a b. (a -> b) -> a -> b
$ FilePath
distDir else Maybe Error
forall a. Maybe a
Nothing


absoluteDirectory :: FilePath -> IO FP.FilePath
absoluteDirectory :: Error -> IO FilePath
absoluteDirectory Error
file = do
   FilePath
absFile <- Error -> IO FilePath
absoluteFile Error
file
   Bool
isDir   <- FilePath -> IO Bool
FS.isDirectory FilePath
absFile
   if Bool
isDir
      then FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
absFile
      else FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath)
-> (FilePath -> FilePath) -> FilePath -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
FP.directory (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
absFile


absoluteFile :: FilePath -> IO FP.FilePath
absoluteFile :: Error -> IO FilePath
absoluteFile = FilePath -> IO FilePath
FS.canonicalizePath (FilePath -> IO FilePath)
-> (Error -> FilePath) -> Error -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> FilePath
FP.decodeString

symPathsToFilePaths :: Iso' [SymbolicPath from to] [FilePath]
symPathsToFilePaths :: forall from (to :: FileOrDir) (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p [Error] (f [Error])
-> p [SymbolicPath from to] (f [SymbolicPath from to])
symPathsToFilePaths = ([SymbolicPath from to] -> [Error])
-> ([Error] -> [SymbolicPath from to])
-> Iso
     [SymbolicPath from to] [SymbolicPath from to] [Error] [Error]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso [SymbolicPath from to] -> [Error]
forall from (to :: FileOrDir). [SymbolicPath from to] -> [Error]
toFilePathList [Error] -> [SymbolicPath from to]
forall from (to :: FileOrDir). [Error] -> [SymbolicPath from to]
fromFilePathList
   where
      toFilePathList :: [SymbolicPath from to] -> [FilePath]
      toFilePathList :: forall from (to :: FileOrDir). [SymbolicPath from to] -> [Error]
toFilePathList [SymbolicPath from to]
symPathList = (SymbolicPath from to -> Error)
-> [SymbolicPath from to] -> [Error]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath from to -> Error
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> Error
getSymbolicPath [SymbolicPath from to]
symPathList

      fromFilePathList :: [FilePath] -> [SymbolicPath from to]
      fromFilePathList :: forall from (to :: FileOrDir). [Error] -> [SymbolicPath from to]
fromFilePathList [Error]
strList   = (Error -> SymbolicPath from to)
-> [Error] -> [SymbolicPath from to]
forall a b. (a -> b) -> [a] -> [b]
map Error -> SymbolicPath from to
forall from (to :: FileOrDir). Error -> SymbolicPath from to
makeSymbolicPath [Error]
strList

{-# DEPRECATED symbolicPathListToFilePathList "Use symPathsToFilePaths." #-}
symbolicPathListToFilePathList :: Iso' [SymbolicPath from to] [FilePath]
symbolicPathListToFilePathList :: forall from (to :: FileOrDir) (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p [Error] (f [Error])
-> p [SymbolicPath from to] (f [SymbolicPath from to])
symbolicPathListToFilePathList = p [Error] (f [Error])
-> p [SymbolicPath from to] (f [SymbolicPath from to])
forall from (to :: FileOrDir) (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p [Error] (f [Error])
-> p [SymbolicPath from to] (f [SymbolicPath from to])
symPathsToFilePaths