Add support and test coverage for mulit-pkg projects

1 files changed, 40 insertions, 23 deletions

diff --git a/src/CabalHelper/Compiletime/Program/Stack.hs b/src/CabalHelper/Compiletime/Program/Stack.hs
index f4ada8f..33ba031 100644
--- a/src/CabalHelper/Compiletime/Program/Stack.hs
+++ b/src/CabalHelper/Compiletime/Program/Stack.hs
@@ -24,43 +24,48 @@ License     : GPL-3
 
 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.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 Text.Show.Pretty
 import Prelude
 
 import CabalHelper.Compiletime.Types
 import CabalHelper.Compiletime.Types.RelativePath
+import CabalHelper.Shared.Common
 
 getUnit :: QueryEnvI c 'Stack -> CabalFile -> IO (Unit 'Stack)
-getUnit qe cabal_file@(CabalFile cabal_file_path) = do
+getUnit
+  qe@QueryEnv{qeProjLoc=ProjLocStackYaml stack_yaml}
+  cabal_file@(CabalFile cabal_file_path)
+  = do
+  let projdir = takeDirectory stack_yaml
   let pkgdir = takeDirectory cabal_file_path
   let pkg_name = dropExtension $ takeFileName cabal_file_path
   look <- paths qe pkgdir
-  let distdirv1 = look "dist-dir:"
+  let distdirv1_rel = look "dist-dir:"
   return $ Unit
     { uUnitId     = UnitId pkg_name
     , uPackageDir = pkgdir
     , uCabalFile  = cabal_file
-    , uDistDir    = DistDirLib distdirv1
+    , uDistDir    = DistDirLib $ pkgdir </> distdirv1_rel
     , uImpl       = UnitImplStack
     }
 
--- TODO: patch ghc/ghc-pkg program paths like in ghc-mod when using stack so
--- compilation logic works even if no system compiler is installed
-
-packageDistDir :: QueryEnvI c 'Stack -> FilePath -> IO FilePath
-packageDistDir qe pkgdir = do
-  look <- paths qe pkgdir
-  return $ look "dist-dir:"
-
 projPaths :: QueryEnvI c 'Stack -> IO StackProjPaths
-projPaths qe@QueryEnv {qeProjLoc=ProjLocStackDir projdir} = do
-  look <- paths qe projdir
+projPaths qe@QueryEnv {qeProjLoc=ProjLocStackYaml stack_yaml} = do
+  look <- paths qe $ takeDirectory stack_yaml
   return StackProjPaths
     { sppGlobalPkgDb = PackageDbDir $ look "global-pkg-db:"
     , sppSnapPkgDb   = PackageDbDir $ look "snapshot-pkg-db:"
@@ -68,20 +73,20 @@ projPaths qe@QueryEnv {qeProjLoc=ProjLocStackDir projdir} = do
     , sppCompExe     = look "compiler-exe:"
     }
 
-paths :: QueryEnvI c 'Stack
-      -> FilePath
-      -> IO (String -> FilePath)
-paths qe dir = do
-    out <- qeReadProcess qe (Just dir) (stackProgram $ qePrograms qe)
-      (workdirArg qe ++ [ "path" ]) ""
-    return $ \k -> let Just x = lookup k $ map split $ lines out in x
+paths :: QueryEnvI c 'Stack -> FilePath -> IO (String -> FilePath)
+paths qe@QueryEnv{qeProjLoc=ProjLocStackYaml stack_yaml} cwd
+  = do
+  out <- readStackCmd qe (Just cwd) $
+    workdirArg qe ++ [ "path", "--stack-yaml="++stack_yaml ]
+  return $ \k -> let Just x = lookup k $ map split $ lines out in x
   where
     split l = let (key, ' ' : val) = span (not . isSpace) l in (key, val)
 
 listPackageCabalFiles :: QueryEnvI c 'Stack -> IO [CabalFile]
-listPackageCabalFiles qe@QueryEnv{qeProjLoc=ProjLocStackDir projdir} = do
-  out <- qeReadProcess qe (Just projdir) (stackProgram $ qePrograms qe)
-    [ "ide", "packages", "--cabal-files" ] ""
+listPackageCabalFiles qe@QueryEnv{qeProjLoc=ProjLocStackYaml stack_yaml} = do
+  let projdir = takeDirectory stack_yaml
+  out <- readStackCmd qe (Just projdir)
+    [ "ide", "packages", "--cabal-files", "--stdout" ]
   return $ map CabalFile $ lines out
 
 workdirArg :: QueryEnvI c 'Stack -> [String]
@@ -91,3 +96,15 @@ workdirArg QueryEnv{qeDistDir=DistDirStack mworkdir} =
 patchCompPrograms :: StackProjPaths -> CompPrograms -> CompPrograms
 patchCompPrograms StackProjPaths{sppCompExe} cprogs =
   cprogs { ghcProgram = sppCompExe }
+
+doStackCmd :: (QueryEnvI c 'Stack -> CallProcessWithCwd a)
+           -> QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO a
+doStackCmd procfn qe mcwd args =
+  let Programs{..} = qePrograms qe in
+  procfn qe mcwd stackProgram $ stackArgsBefore ++ args ++ stackArgsAfter
+
+readStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO String
+callStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO ()
+
+readStackCmd = doStackCmd (\qe -> qeReadProcess qe "")
+callStackCmd = doStackCmd qeCallProcess