-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2018  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.Compiletime.Program.Stack
Description : Stack program interface
License     : Apache-2.0
-}

{-# 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
  -- this is kind of a hack but works even for unicode package names and
  -- besides stack even enforces this naming convention unlike cabal. This
  -- is the error you get if the names don't match:
  --
  -- cabal file path foo-bla.cabal does not match the package name it defines.
  -- Please rename the file to: foo.cabal
  -- For more information, see:
  --  https://github.com/commercialhaskell/stack/issues/317
  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 }