{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TupleSections     #-}
-- | Dealing with Cabal packages in Fay's own special way.
module Fay.Compiler.Packages where

import           Fay.Compiler.Prelude

import           Fay.Config
import           Paths_fay

import           Data.Version
import           GHC.Paths
import           System.Directory
import           System.FilePath
import           System.Environment

-- | Given a configuration, resolve any packages specified to their
-- data file directories for importing the *.hs sources.
resolvePackages :: Config -> IO Config
resolvePackages :: Config -> IO Config
resolvePackages Config
config =
  (Config -> String -> IO Config) -> Config -> [String] -> IO Config
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Config -> String -> IO Config
resolvePackage Config
config (Config -> [String]
configPackages Config
config)

-- | Resolve package.
resolvePackage :: Config -> String -> IO Config
resolvePackage :: Config -> String -> IO Config
resolvePackage Config
config String
name = do
  String
desc <- Maybe String -> String -> IO String
describePackage (Config -> Maybe String
configPackageConf Config
config) String
name
  case String -> Maybe String
packageVersion String
desc of
    Maybe String
Nothing -> String -> IO Config
forall a. HasCallStack => String -> a
error (String -> IO Config) -> String -> IO Config
forall a b. (a -> b) -> a -> b
$ String
"unable to find package version: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
    Just String
ver -> do
      let nameVer :: String
nameVer = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ver
      String
shareDir <- if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Config -> Maybe String
configBasePath Config
config) Bool -> Bool -> Bool
&& String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"fay-base"
                    then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String)
-> (Maybe String -> String) -> Maybe String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> IO String) -> Maybe String -> IO String
forall a b. (a -> b) -> a -> b
$ Config -> Maybe String
configBasePath Config
config
                    else ((String -> String) -> String)
-> IO (String -> String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
nameVer) IO (String -> String)
getShareGen
      let includes :: [String]
includes = [String
shareDir,String
shareDir String -> String -> String
</> String
"src"]
      [Bool]
exists <- (String -> IO Bool) -> [String] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Bool
doesSourceDirExist [String]
includes
      if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
exists
         then Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Maybe String, String)] -> Config -> Config
addConfigDirectoryIncludes ((String -> (Maybe String, String))
-> [String] -> [(Maybe String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe String
forall a. a -> Maybe a
Just String
nameVer,) [String]
includes) Config
config)
         else String -> IO Config
forall a. HasCallStack => String -> a
error (String -> IO Config) -> String -> IO Config
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ String
"unable to find (existing) package's share dir: ", String
name, String
"\n"
                , String
"tried: ", [String] -> String
unlines [String]
includes, String
"\n"
                , String
"but none of them seem to have Haskell files in them.\n"
                , String
"If you are using a sandbox you need to specify the HASKELL_PACKAGE_SANDBOX environment variable or use --package-conf."
                ]

-- | Does a directory exist and does it contain any Haskell sources?
doesSourceDirExist :: FilePath -> IO Bool
doesSourceDirExist :: String -> IO Bool
doesSourceDirExist String
path = do
  Bool
exists <- String -> IO Bool
doesDirectoryExist String
path
  if Bool -> Bool
not Bool
exists
     then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
     else do [String]
files <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
v -> String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"." Bool -> Bool -> Bool
&& String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"..") ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
path
             Bool
sub   <- (String -> IO Bool) -> [String] -> IO Bool
forall (m :: * -> *) a.
(Functor m, Applicative m, Monad m) =>
(a -> m Bool) -> [a] -> m Bool
anyM String -> IO Bool
doesSourceDirExist ([String] -> IO Bool) -> [String] -> IO Bool
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
path String -> String -> String
</>) [String]
files
             Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
".hs") (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension) [String]
files Bool -> Bool -> Bool
|| Bool
sub

-- | Describe the given package.
describePackage :: Maybe FilePath -> String -> IO String
describePackage :: Maybe String -> String -> IO String
describePackage Maybe String
db String
name = do
  Bool
exists <- String -> IO Bool
doesFileExist String
ghc_pkg
  Bool
stackInNixShell <- (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (String -> IO (Maybe String)
lookupEnv String
"STACK_IN_NIX_SHELL")
  let command :: String
command = if Bool
exists
        then if (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
".stack" String
ghc_pkg Bool -> Bool -> Bool
|| Bool
stackInNixShell)
             then String
"stack"
             else String
ghc_pkg
        else String
"ghc-pkg"
      extraArgs :: [String]
extraArgs = case String
command of
        String
"stack" -> [String
"exec",String
"--",String
"ghc-pkg"]
        String
_       -> []
      args :: [String]
args = [String]
extraArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"describe",String
name] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--expand-env-vars", String
"-v2"]
             [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--package-db=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
db' | Just String
db' <- [Maybe String
db]]
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
stackInNixShell (String -> IO ()
unsetEnv String
"STACK_IN_NIX_SHELL")
  Either (String, String) (String, String)
result <- String
-> [String]
-> String
-> IO (Either (String, String) (String, String))
readAllFromProcess String
command [String]
args String
""
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
stackInNixShell (String -> String -> IO ()
setEnv String
"STACK_IN_NIX_SHELL" String
"1")
  case Either (String, String) (String, String)
result of
    Left  (String
err,String
out) -> String -> IO String
forall a. HasCallStack => String -> a
error (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"ghc-pkg describe error:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
out
    Right (String
_err,String
out) -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
out

-- | Get the package version from the package description.
packageVersion :: String -> Maybe String
packageVersion :: String -> Maybe String
packageVersion = (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ')) (Maybe String -> Maybe String)
-> (String -> Maybe String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"version:" ([(String, String)] -> Maybe String)
-> (String -> [(String, String)]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
' ')) ([String] -> [(String, String)])
-> (String -> [String]) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

-- | Make a share directory generator.
getShareGen :: IO (String -> FilePath)
getShareGen :: IO (String -> String)
getShareGen = do
  String
dataDir <- IO String
getDataDir
  (String -> String) -> IO (String -> String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> String) -> IO (String -> String))
-> (String -> String) -> IO (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
pkg ->
    [String] -> String
joinPath ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
replace String
pkg (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropTrailingPathSeparator) (String -> [String]
splitPath String
dataDir))

  where replace :: String -> String -> String
replace String
pkg String
component
          | String
component String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
nameVer = String
pkg
          | Bool
otherwise = String
component
        nameVer :: String
nameVer = String
"fay-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show (Version -> [Int]
versionBranch Version
version))