aboutsummaryrefslogtreecommitdiff
path: root/src/CabalHelper/Compiletime
diff options
context:
space:
mode:
Diffstat (limited to 'src/CabalHelper/Compiletime')
-rw-r--r--src/CabalHelper/Compiletime/Program/Stack.hs63
-rw-r--r--src/CabalHelper/Compiletime/Types.hs90
-rw-r--r--src/CabalHelper/Compiletime/Types/RelativePath.hs1
3 files changed, 105 insertions, 49 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
diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs
index 56f2468..185725d 100644
--- a/src/CabalHelper/Compiletime/Types.hs
+++ b/src/CabalHelper/Compiletime/Types.hs
@@ -30,7 +30,6 @@ import Cabal.Plan
import Data.IORef
import Data.Version
import Data.Typeable
-import Data.Map.Strict (Map)
import GHC.Generics
import System.FilePath
import System.Posix.Types
@@ -39,32 +38,41 @@ import CabalHelper.Shared.InterfaceTypes
import Data.List.NonEmpty (NonEmpty)
--import qualified Data.List.NonEmpty as NonEmpty
-
+import Data.Map.Strict (Map)
+--import qualified Data.Map.Strict as Strict
-- | The kind of project being managed by a 'QueryEnv' (pun intended).
data ProjType
= V1 -- ^ @cabal v1-build@ project, see 'DistDirV1'
| V2 -- ^ @cabal v2-build@ project, see 'DistDirV2'
| Stack -- ^ @stack@ project.
+ deriving (Eq, Ord, Show, Read)
+
+data SProjType pt where
+ SV1 :: SProjType 'V1
+ SV2 :: SProjType 'V2
+ SStack :: SProjType 'Stack
--- | The location of a project. The kind of location marker given determines the
--- 'ProjType'. The project type of a given directory can be determined by trying
--- to access a set of marker files. See below.
+-- | Location of project sources. The project type of a given directory can be
+-- determined by trying to access a set of marker files. See below.
data ProjLoc (pt :: ProjType) where
-- | A @cabal v1-build@ project directory can be identified by one file
-- ending in @.cabal@ existing in the directory. More than one such files
-- existing is a user error. Note: For this project type the concepts of
-- project and package coincide.
- ProjLocCabalFile :: { plCabalFile :: FilePath } -> ProjLoc 'V1
+ ProjLocCabalFile :: { plCabalFile :: !FilePath } -> ProjLoc 'V1
-- | A @cabal v2-build@ project\'s marker file is called
-- @cabal.project@. This configuration file points to the packages that make
-- up this project.
- ProjLocV2Dir :: { plV2Dir :: FilePath } -> ProjLoc 'V2
+ ProjLocV2File :: { plCabalProjectFile :: !FilePath } -> ProjLoc 'V2
+ ProjLocV2Dir :: { plV2Dir :: !FilePath } -> ProjLoc 'V2
-- | A @stack@ project\'s marker file is called @stack.yaml@. This
-- configuration file points to the packages that make up this project.
- ProjLocStackDir :: { plStackDir :: FilePath } -> ProjLoc 'Stack
+ ProjLocStackYaml :: { plStackYaml :: !FilePath } -> ProjLoc 'Stack
+
+deriving instance Show (ProjLoc pt)
plV1Dir :: ProjLoc 'V1 -> FilePath
plV1Dir (ProjLocCabalFile cabal_file) = takeDirectory cabal_file
@@ -76,7 +84,7 @@ data DistDir (pt :: ProjType) where
--
-- You can tell a builddir is a /v1/ builddir by looking for a file
-- called @setup-config@ directly underneath it.
- DistDirV1 :: FilePath -> DistDir 'V1
+ DistDirV1 :: !FilePath -> DistDir 'V1
-- | Build directory for cabal /new-build/ aka. /v2-build/, as of the time
-- of this writing it is usually called @dist-newstyle/@ but this will
@@ -84,11 +92,13 @@ data DistDir (pt :: ProjType) where
--
-- You can tell a builddir is a /v2/ builddir by trying to access the path
-- @cache/plan.json@ directly underneath it.
- DistDirV2 :: FilePath -> DistDir 'V2
+ DistDirV2 :: !FilePath -> DistDir 'V2
-- | Build directory for stack, aka. /work-dir/. Optionally override Stack's
-- /work-dir/. If you just want to use Stack's default set to @Nothing@
- DistDirStack :: Maybe RelativePath -> DistDir 'Stack
+ DistDirStack :: !(Maybe RelativePath) -> DistDir 'Stack
+
+deriving instance Show (DistDir pt)
-- | Environment for running a 'Query' value. The constructor is not exposed in
-- the API to allow extending the environment without breaking user code.
@@ -100,12 +110,13 @@ type QueryEnv (pt :: ProjType)
= QueryEnvI QueryCache pt
data QueryEnvI c (pt :: ProjType) = QueryEnv
- { qeReadProcess
- :: !(Maybe FilePath -> FilePath -> [String] -> String -> IO String)
+ { qeReadProcess :: !ReadProcessWithCwd
-- ^ Field accessor for 'QueryEnv'. Function used to to start
-- processes. Useful if you need to, for example, redirect standard error
-- output of programs started by cabal-helper.
+ , qeCallProcess :: !(CallProcessWithCwd ())
+
, qePrograms :: !Programs
-- ^ Field accessor for 'QueryEnv'.
@@ -126,6 +137,9 @@ data QueryEnvI c (pt :: ProjType) = QueryEnv
-- 'QueryEnv' is used.
}
+type ReadProcessWithCwd = String -> CallProcessWithCwd String
+type CallProcessWithCwd a = Maybe FilePath -> FilePath -> [String] -> IO a
+
data QueryCache pt = QueryCache
{ qcProjInfo :: !(Maybe (ProjInfo pt))
, qcUnitInfos :: !(Map DistDirLib UnitInfo)
@@ -144,7 +158,7 @@ data Unit pt = Unit
, uCabalFile :: !CabalFile
, uDistDir :: !DistDirLib
, uImpl :: !(UnitImpl pt)
- }
+ } deriving (Show)
data UnitImpl pt where
UnitImplV1 :: UnitImpl 'V1
@@ -156,6 +170,8 @@ data UnitImpl pt where
UnitImplStack :: UnitImpl 'Stack
+deriving instance Show (UnitImpl pt)
+
-- | This returns the component a 'Unit' corresponds to. This information is
-- only available if the correspondence happens to be unique and known before
-- querying setup-config for the respective project type. Currently this only
@@ -228,7 +244,7 @@ data ProjConf pt where
-- these are supposed to be opaque, as they are meant to be used only for cache
-- invalidation
newtype ProjConfModTimes = ProjConfModTimes [(FilePath, EpochTime)]
- deriving (Eq)
+ deriving (Eq, Show)
-- | Project-scope information cache.
data ProjInfo pt = ProjInfo
@@ -238,7 +254,7 @@ data ProjInfo pt = ProjInfo
, piProjConfModTimes :: !ProjConfModTimes
-- ^ Key for cache invalidation. When this is not equal to the return
-- value of 'getProjConfModTime' this 'ProjInfo' is considered invalid.
- }
+ } deriving (Show)
data ProjInfoImpl pt where
ProjInfoV1 :: ProjInfoImpl 'V1
@@ -253,6 +269,21 @@ data ProjInfoImpl pt where
{ piStackProjPaths :: !StackProjPaths
} -> ProjInfoImpl 'Stack
+instance Show (ProjInfoImpl pt) where
+ show ProjInfoV1 = "ProjInfoV1"
+ show ProjInfoV2 {..} = concat
+ [ "ProjInfoV2 {"
+ , "piV2Plan = ", show piV2Plan, ", " --
+ , "piV2PlanModTime = ", show piV2PlanModTime, ", "
+ , "piV2CompilerId = ", show piV2CompilerId
+ , "}"
+ ]
+ show ProjInfoStack {..} = concat
+ [ "ProjInfoStack {"
+ , "piStackProjPaths = ", show piStackProjPaths
+ , "}"
+ ]
+
data UnitModTimes = UnitModTimes
{ umtPkgYaml :: !(Maybe (FilePath, EpochTime))
, umtCabalFile :: !(FilePath, EpochTime)
@@ -260,13 +291,14 @@ data UnitModTimes = UnitModTimes
} deriving (Eq, Ord, Read, Show)
newtype CabalFile = CabalFile FilePath
+ deriving (Show)
data StackProjPaths = StackProjPaths
{ sppGlobalPkgDb :: !PackageDbDir
, sppSnapPkgDb :: !PackageDbDir
, sppLocalPkgDb :: !PackageDbDir
, sppCompExe :: !FilePath
- }
+ } deriving (Show)
-- Beware: GHC 8.0.2 doesn't like these being recursively defined for some
@@ -277,19 +309,23 @@ type Progs = (?cprogs :: CompPrograms, ?progs :: Programs)
type CProgs = (?cprogs :: CompPrograms)
-- | Configurable paths to various programs we use.
-data Programs = Programs {
- -- | The path to the @cabal@ program.
- cabalProgram :: FilePath,
-
- -- | The path to the @stack@ program.
- stackProgram :: FilePath
+data Programs = Programs
+ { cabalProgram :: !FilePath
+ -- ^ The path to the @cabal@ program.
+ , cabalArgsBefore :: ![String]
+ , cabalArgsAfter :: ![String]
+
+ , stackProgram :: !FilePath
+ -- ^ The path to the @stack@ program.
+ , stackArgsBefore :: ![String]
+ , stackArgsAfter :: ![String]
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
data CompPrograms = CompPrograms
- { ghcProgram :: FilePath
+ { ghcProgram :: !FilePath
-- ^ The path to the @ghc@ program.
- , ghcPkgProgram :: FilePath
+ , ghcPkgProgram :: !FilePath
-- ^ The path to the @ghc-pkg@ program. If not changed it will be derived
-- from the path to 'ghcProgram'.
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
@@ -297,7 +333,7 @@ data CompPrograms = CompPrograms
-- | By default all programs use their unqualified names, i.e. they will be
-- searched for on @PATH@.
defaultPrograms :: Programs
-defaultPrograms = Programs "cabal" "stack"
+defaultPrograms = Programs "cabal" [] [] "stack" [] []
defaultCompPrograms :: CompPrograms
defaultCompPrograms = CompPrograms "ghc" "ghc-pkg"
@@ -317,4 +353,6 @@ defaultCompileOptions =
CompileOptions False Nothing Nothing defaultPrograms
newtype PackageDbDir = PackageDbDir { unPackageDbDir :: FilePath }
+ deriving (Show)
newtype PackageEnvFile = PackageEnvFile { unPackageEnvFile :: FilePath }
+ deriving (Show)
diff --git a/src/CabalHelper/Compiletime/Types/RelativePath.hs b/src/CabalHelper/Compiletime/Types/RelativePath.hs
index bfc29bf..107a8ce 100644
--- a/src/CabalHelper/Compiletime/Types/RelativePath.hs
+++ b/src/CabalHelper/Compiletime/Types/RelativePath.hs
@@ -30,6 +30,7 @@ import System.FilePath
-- | A path guaranteed to be relative. The constructor is not exposed, use the
-- 'mkRelativePath' smart constructor.
newtype RelativePath = RelativePath { unRelativePath :: FilePath }
+ deriving (Show)
-- | Smart constructor for 'RelativePath'. Checks if the given path is absolute
-- and throws 'UserError' if not.
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 09:33:27 +0000