{-# LANGUAGE GADTs, DataKinds #-}
module CabalHelper.Compiletime.Program.Stack where
import Control.Exception (handle, throwIO)
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Data.Char
import Data.List hiding (filter)
import Data.List.NonEmpty (NonEmpty(..))
import Data.String
import Data.Maybe
import Data.Function
import Data.Version
import System.Directory (findExecutable)
import System.FilePath hiding ((<.>))
import System.IO (hPutStrLn, stderr)
import Text.Printf (printf)
import Prelude
import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Types.RelativePath
import CabalHelper.Shared.Common
getPackage :: QueryEnvI c 'Stack -> CabalFile -> IO (Package 'Stack)
getPackage :: QueryEnvI c 'Stack -> CabalFile -> IO (Package 'Stack)
getPackage qe :: QueryEnvI c 'Stack
qe cabal_file :: CabalFile
cabal_file@(CabalFile cabal_file_path :: FilePath
cabal_file_path) = do
let pkgdir :: FilePath
pkgdir = FilePath -> FilePath
takeDirectory FilePath
cabal_file_path
let pkg_name :: FilePath
pkg_name = FilePath -> FilePath
dropExtension (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
cabal_file_path
FilePath -> FilePath
look <- QueryEnvI c 'Stack -> FilePath -> IO (FilePath -> FilePath)
forall (c :: ProjType -> *).
QueryEnvI c 'Stack -> FilePath -> IO (FilePath -> FilePath)
paths QueryEnvI c 'Stack
qe FilePath
pkgdir
let distdirv1_rel :: FilePath
distdirv1_rel = FilePath -> FilePath
look "dist-dir:"
let pkg :: Package 'Stack
pkg = $WPackage :: forall units.
FilePath
-> FilePath
-> CabalFile
-> [(FilePath, Bool)]
-> units
-> Package' units
Package
{ pPackageName :: FilePath
pPackageName = FilePath
pkg_name
, pSourceDir :: FilePath
pSourceDir = FilePath
pkgdir
, pCabalFile :: CabalFile
pCabalFile = CabalFile
cabal_file
, pFlags :: [(FilePath, Bool)]
pFlags = []
, pUnits :: NonEmpty (Unit 'Stack)
pUnits = (Unit 'Stack -> [Unit 'Stack] -> NonEmpty (Unit 'Stack)
forall a. a -> [a] -> NonEmpty a
:|[]) (Unit 'Stack -> NonEmpty (Unit 'Stack))
-> Unit 'Stack -> NonEmpty (Unit 'Stack)
forall a b. (a -> b) -> a -> b
$ $WUnit :: forall (pt :: ProjType).
UnitId -> Package' () -> DistDirLib -> UnitImpl pt -> Unit pt
Unit
{ uUnitId :: UnitId
uUnitId = FilePath -> UnitId
UnitId FilePath
pkg_name
, uDistDir :: DistDirLib
uDistDir = FilePath -> DistDirLib
DistDirLib (FilePath -> DistDirLib) -> FilePath -> DistDirLib
forall a b. (a -> b) -> a -> b
$ FilePath
pkgdir FilePath -> FilePath -> FilePath
</> FilePath
distdirv1_rel
, uPackage :: Package' ()
uPackage = Package 'Stack
pkg { pUnits :: ()
pUnits = () }
, uImpl :: UnitImpl 'Stack
uImpl = UnitImpl 'Stack
UnitImplStack
}
}
Package 'Stack -> IO (Package 'Stack)
forall (m :: * -> *) a. Monad m => a -> m a
return Package 'Stack
pkg
projPaths :: QueryEnvI c 'Stack -> IO StackProjPaths
projPaths :: QueryEnvI c 'Stack -> IO StackProjPaths
projPaths qe :: QueryEnvI c 'Stack
qe@QueryEnv {ProjLoc 'Stack
qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qeProjLoc :: ProjLoc 'Stack
qeProjLoc} = do
FilePath -> FilePath
look <- QueryEnvI c 'Stack -> FilePath -> IO (FilePath -> FilePath)
forall (c :: ProjType -> *).
QueryEnvI c 'Stack -> FilePath -> IO (FilePath -> FilePath)
paths QueryEnvI c 'Stack
qe (FilePath -> IO (FilePath -> FilePath))
-> FilePath -> IO (FilePath -> FilePath)
forall a b. (a -> b) -> a -> b
$ ProjLoc 'Stack -> FilePath
plStackProjectDir ProjLoc 'Stack
qeProjLoc
StackProjPaths -> IO StackProjPaths
forall (m :: * -> *) a. Monad m => a -> m a
return $WStackProjPaths :: PackageDbDir
-> PackageDbDir -> PackageDbDir -> FilePath -> StackProjPaths
StackProjPaths
{ sppGlobalPkgDb :: PackageDbDir
sppGlobalPkgDb = FilePath -> PackageDbDir
PackageDbDir (FilePath -> PackageDbDir) -> FilePath -> PackageDbDir
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
look "global-pkg-db:"
, sppSnapPkgDb :: PackageDbDir
sppSnapPkgDb = FilePath -> PackageDbDir
PackageDbDir (FilePath -> PackageDbDir) -> FilePath -> PackageDbDir
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
look "snapshot-pkg-db:"
, sppLocalPkgDb :: PackageDbDir
sppLocalPkgDb = FilePath -> PackageDbDir
PackageDbDir (FilePath -> PackageDbDir) -> FilePath -> PackageDbDir
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
look "local-pkg-db:"
, sppCompExe :: FilePath
sppCompExe = FilePath -> FilePath
look "compiler-exe:"
}
paths :: QueryEnvI c 'Stack -> FilePath -> IO (String -> FilePath)
paths :: QueryEnvI c 'Stack -> FilePath -> IO (FilePath -> FilePath)
paths qe :: QueryEnvI c 'Stack
qe@QueryEnv{qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qeProjLoc=ProjLocStackYaml stack_yaml :: FilePath
stack_yaml} cwd :: FilePath
cwd
= do
FilePath
out <- QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO FilePath
forall (c :: ProjType -> *).
QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO FilePath
readStackCmd QueryEnvI c 'Stack
qe (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
cwd) ([FilePath] -> IO FilePath) -> [FilePath] -> IO FilePath
forall a b. (a -> b) -> a -> b
$
QueryEnvI c 'Stack -> [FilePath]
forall (c :: ProjType -> *). QueryEnvI c 'Stack -> [FilePath]
workdirArg QueryEnvI c 'Stack
qe [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [ "path", "--stack-yaml="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
stack_yaml ]
(FilePath -> FilePath) -> IO (FilePath -> FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath -> FilePath) -> IO (FilePath -> FilePath))
-> (FilePath -> FilePath) -> IO (FilePath -> FilePath)
forall a b. (a -> b) -> a -> b
$ \k :: FilePath
k -> let Just x :: FilePath
x = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
k ([(FilePath, FilePath)] -> Maybe FilePath)
-> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> (FilePath, FilePath)
split ([FilePath] -> [(FilePath, FilePath)])
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
out in FilePath
x
where
split :: FilePath -> (FilePath, FilePath)
split l :: FilePath
l = let (key :: FilePath
key, val :: FilePath
val) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace FilePath
l in (FilePath
key, (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace FilePath
val)
listPackageCabalFiles :: QueryEnvI c 'Stack -> IO [CabalFile]
listPackageCabalFiles :: QueryEnvI c 'Stack -> IO [CabalFile]
listPackageCabalFiles qe :: QueryEnvI c 'Stack
qe@QueryEnv{ProjLoc 'Stack
qeProjLoc :: ProjLoc 'Stack
qeProjLoc :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ProjLoc pt
qeProjLoc}
= (IOError -> IO [CabalFile]) -> IO [CabalFile] -> IO [CabalFile]
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO [CabalFile]
forall a. IOError -> IO a
ioerror (IO [CabalFile] -> IO [CabalFile])
-> IO [CabalFile] -> IO [CabalFile]
forall a b. (a -> b) -> a -> b
$ do
let projdir :: FilePath
projdir = ProjLoc 'Stack -> FilePath
plStackProjectDir ProjLoc 'Stack
qeProjLoc
FilePath
out <- QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO FilePath
forall (c :: ProjType -> *).
QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO FilePath
readStackCmd QueryEnvI c 'Stack
qe (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
projdir)
[ "ide", "packages", "--cabal-files", "--stdout" ]
[CabalFile] -> IO [CabalFile]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CabalFile] -> IO [CabalFile]) -> [CabalFile] -> IO [CabalFile]
forall a b. (a -> b) -> a -> b
$ (FilePath -> CabalFile) -> [FilePath] -> [CabalFile]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> CabalFile
CabalFile ([FilePath] -> [CabalFile]) -> [FilePath] -> [CabalFile]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
out
where
ioerror :: IOError -> IO a
ioerror :: IOError -> IO a
ioerror ioe :: IOError
ioe = (IO a -> Maybe (IO a) -> IO a
forall a. a -> Maybe a -> a
fromMaybe (IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO IOError
ioe) (Maybe (IO a) -> IO a) -> IO (Maybe (IO a)) -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO (Maybe (IO a)) -> IO a) -> IO (Maybe (IO a)) -> IO a
forall a b. (a -> b) -> a -> b
$ MaybeT IO (IO a) -> IO (Maybe (IO a))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (IO a) -> IO (Maybe (IO a)))
-> MaybeT IO (IO a) -> IO (Maybe (IO a))
forall a b. (a -> b) -> a -> b
$ do
FilePath
stack_exe <- IO (Maybe FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe FilePath) -> MaybeT IO FilePath)
-> IO (Maybe FilePath) -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
findExecutable (FilePath -> IO (Maybe FilePath))
-> FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ Programs -> FilePath
stackProgram (Programs -> FilePath) -> Programs -> FilePath
forall a b. (a -> b) -> a -> b
$ QueryEnvI c 'Stack -> Programs
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qePrograms QueryEnvI c 'Stack
qe
FilePath
stack_ver_str
<- IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> MaybeT IO FilePath)
-> IO FilePath -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
trim (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO FilePath
forall (c :: ProjType -> *).
QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO FilePath
readStackCmd QueryEnvI c 'Stack
qe Maybe FilePath
forall a. Maybe a
Nothing ["--numeric-version"]
Version
stack_ver <- IO (Maybe Version) -> MaybeT IO Version
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Version) -> MaybeT IO Version)
-> IO (Maybe Version) -> MaybeT IO Version
forall a b. (a -> b) -> a -> b
$ Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Version -> IO (Maybe Version))
-> Maybe Version -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe Version
parseVerMay FilePath
stack_ver_str
Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT IO ()) -> Bool -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Version
stack_ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
makeVersion [1,9,4]
let prog_cfg :: FilePath
prog_cfg = Programs -> FilePath
forall a. Show a => a -> FilePath
show (Programs -> FilePath) -> Programs -> FilePath
forall a b. (a -> b) -> a -> b
$ QueryEnvI c 'Stack -> Programs
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qePrograms QueryEnvI c 'Stack
qe
IO () -> MaybeT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf
"\nerror: stack version too old!\
\\n\n\
\You have '%s' installed but cabal-helper needs at least\n\
\stack version 1.9.4+.\n\
\\n\
\FYI cabal-helper is using the following `stack` executable:\n\
\ %s\n\
\\n\
\Additional debugging info: QueryEnv qePrograms =\n\
\ %s\n" FilePath
stack_ver_str FilePath
stack_exe FilePath
prog_cfg
MaybeT IO (IO a)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
workdirArg :: QueryEnvI c 'Stack -> [String]
workdirArg :: QueryEnvI c 'Stack -> [FilePath]
workdirArg QueryEnv{qeDistDir :: forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> DistDir pt
qeDistDir=DistDirStack mworkdir :: Maybe RelativePath
mworkdir} =
Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList (Maybe FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ("--work-dir="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> (RelativePath -> FilePath) -> RelativePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativePath -> FilePath
unRelativePath (RelativePath -> FilePath) -> Maybe RelativePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RelativePath
mworkdir
doStackCmd :: (QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv a)
-> QueryEnvI c 'Stack
-> Maybe FilePath -> [String] -> IO a
doStackCmd :: (QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv a)
-> QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO a
doStackCmd procfn :: QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv a
procfn qe :: QueryEnvI c 'Stack
qe mcwd :: Maybe FilePath
mcwd args :: [FilePath]
args =
let Programs{..} = QueryEnvI c 'Stack -> Programs
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qePrograms QueryEnvI c 'Stack
qe in
QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv a
procfn QueryEnvI c 'Stack
qe Maybe FilePath
mcwd [(FilePath, EnvOverride)]
stackEnv FilePath
stackProgram ([FilePath] -> IO a) -> [FilePath] -> IO a
forall a b. (a -> b) -> a -> b
$
[FilePath]
stackProjArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
args [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
stackUnitArgs
readStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO String
callStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO ()
readStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO FilePath
readStackCmd = (QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv FilePath)
-> QueryEnvI c 'Stack
-> Maybe FilePath
-> [FilePath]
-> IO FilePath
forall (c :: ProjType -> *) a.
(QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv a)
-> QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO a
doStackCmd (\qe :: QueryEnvI c 'Stack
qe -> QueryEnvI c 'Stack -> ReadProcessWithCwdAndEnv
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ReadProcessWithCwdAndEnv
qeReadProcess QueryEnvI c 'Stack
qe "")
callStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO ()
callStackCmd = (QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv ())
-> QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO ()
forall (c :: ProjType -> *) a.
(QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv a)
-> QueryEnvI c 'Stack -> Maybe FilePath -> [FilePath] -> IO a
doStackCmd QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv ()
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> CallProcessWithCwdAndEnv ()
qeCallProcess
patchCompPrograms :: StackProjPaths -> Programs -> Programs
patchCompPrograms :: StackProjPaths -> Programs -> Programs
patchCompPrograms StackProjPaths{FilePath
sppCompExe :: FilePath
sppCompExe :: StackProjPaths -> FilePath
sppCompExe} progs :: Programs
progs =
Programs
progs { ghcProgram :: FilePath
ghcProgram = FilePath
sppCompExe }