aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorDaniel Gröber <dxld@darkboxed.org>2018-10-14 03:32:49 +0200
committerDaniel Gröber <dxld@darkboxed.org>2018-10-27 19:53:16 +0200
commit679c3145fb8fdc346880c205c9dde369e782feee (patch)
treee3d42ee09e5816448a33a212fadc63c540ca580e /lib
parent807354f7dc6644fec15dfa1e534c69c14d219628 (diff)
Add stack support
Diffstat (limited to 'lib')
-rw-r--r--lib/Distribution/Helper.hs200
1 files changed, 46 insertions, 154 deletions
diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs
index edf71f7..ad77eb3 100644
--- a/lib/Distribution/Helper.hs
+++ b/lib/Distribution/Helper.hs
@@ -119,7 +119,9 @@ import Text.Show.Pretty
import Prelude
import CabalHelper.Compiletime.Compile
+import qualified CabalHelper.Compiletime.Program.Stack as Stack
import CabalHelper.Compiletime.Types
+import CabalHelper.Compiletime.Types.RelativePath
import CabalHelper.Shared.InterfaceTypes
import CabalHelper.Shared.Sandbox
import CabalHelper.Shared.Common
@@ -127,6 +129,7 @@ import CabalHelper.Shared.Common
import CabalHelper.Compiletime.Compat.Version
import qualified CabalHelper.Compiletime.Compat.ProgramDb as ProgDb
( defaultProgramDb, programPath, lookupProgram, ghcProgram, ghcPkgProgram)
+import CabalHelper.Shared.Common
import Distribution.System (buildPlatform)
import Distribution.Text (display)
@@ -139,160 +142,6 @@ import qualified CabalHelper.Compiletime.Compat.ProgramDb as ProgDb
import CabalHelper.Compiletime.Compat.Version
import CabalHelper.Shared.Common
-
--- | 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'
-
--- | A project directory. The project type of a given directory can be
--- determined by trying to access a set of marker files. See below.
-data ProjDir (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.
- ProjDirV1 :: FilePath -> ProjDir '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.
- ProjDirV2 :: FilePath -> ProjDir 'V2
-
-data DistDir (pt :: ProjType) where
- -- | Build directory for cabal /old-build/ aka. /v1-build/ aka. just
- -- /build/. Planned to be superceeded by /v2-build/, see 'DistDirV2' for
- -- that.
- --
- -- You can tell a builddir is a /v1/ builddir by looking for a file
- -- called @setup-config@ directly underneath it.
- 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
- -- presumably change once it becomes the default /build/ command.
- --
- -- 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
-
--- | Environment for running a 'Query' value. The real constructor is
--- not exposed, use the 'mkQueryEnv' smart constructor instead. The field
--- accessors are exported and may be used to override the defaults, see below.
-type QueryEnv (proj_type :: ProjType)
- = QueryEnvI (QueryCache proj_type) proj_type
-
-data QueryEnvI cache (proj_type :: ProjType) = QueryEnv
- { qeReadProcess
- :: Maybe FilePath -> FilePath -> [String] -> String -> IO String
- -- ^ Field accessor for 'QueryEnv'. Function used to to start
- -- processes. Useful if you need to, for example, redirect standard error
- -- output away from the user\'s terminal.
-
- , qePrograms :: Programs
- -- ^ Field accessor for 'QueryEnv'.
-
- , qeProjectDir :: ProjDir proj_type
- -- ^ Field accessor for 'QueryEnv'. Defines path to the project directory,
- -- i.e. a directory containing a @cabal.project@ file
-
- , qeDistDir :: DistDir proj_type
- -- ^ Field accessor for 'QueryEnv'. Defines path to the @dist/@ or
- -- @dist-newstyle/@ directory, aka. /builddir/ in Cabal terminology.
-
- , qeCacheRef :: IORef cache
- -- ^ Cache for query results, only accessible when type parameter @cache@ is
- -- instantiated and not forall quantified.
- }
-
-data QueryCache pt = QueryCache
- { qcProjInfo :: !(Maybe (ProjInfo pt))
- , qcUnitInfos :: !(Map DistDirLib UnitInfo)
- }
-
-newtype DistDirLib = DistDirLib FilePath
- deriving (Eq, Ord, Read, Show)
-
--- | Abstractly speaking a Unit consists of a set of components (exes, libs,
--- tests etc.) which are managed by an instance of the Cabal build system. The
--- distinction between a Unit and a set of components is somewhat hard to
--- explain if you're not already familliar with the concept from
--- cabal-install. Luckily for most purposes the details may be ignored.
---
--- We merely use the concept of a Unit for caching purposes. It is necessary to
--- extract the information on all components in a Unit at the same time as we
--- must load all of it into memory before extracting any of it.
---
--- As opposed to components, different 'Unit's can be queried independently
--- since their on-disk information is stored separately.
-data Unit = Unit
- { uUnitId :: !UnitId
- , uPackageDir :: !FilePath
- , uDistDir :: !DistDirLib
- }
-
-newtype UnitId = UnitId String
- deriving (Eq, Ord, Read, Show)
-
--- | The information extracted from a 'Unit's on-disk configuration.
-data UnitInfo = UnitInfo
- { uiUnitId :: !UnitId
- -- ^ A unique identifier of this init within the project.
-
- , uiComponents :: !(Map ChComponentName ChComponentInfo)
- -- ^ The components of the unit: libraries, executables, test-suites,
- -- benchmarks and so on.
-
- , uiCompilerVersion :: !(String, Version)
- -- ^ The version of GHC the unit is configured to use
-
- , uiPackageDbStack :: !([ChPkgDb])
- -- ^ List of package databases to use.
-
- , uiPackageFlags :: !([(String, Bool)])
- -- ^ Flag definitions from cabal file
-
- , uiConfigFlags :: ![(String, Bool)]
- -- ^ Flag assignments from active configuration
-
- , uiNonDefaultConfigFlags :: ![(String, Bool)]
- -- ^ Flag assignments from setup-config which differ from the default
- -- setting. This can also include flags which cabal decided to modify,
- -- i.e. don't rely on these being the flags set by the user directly.
-
- , uiModTimes :: !UnitModTimes
- } deriving (Eq, Ord, Read, Show)
-
-data ProjInfo pt where
- ProjInfoV1 ::
- { piV1ProjConfModTimes :: !(ProjConfModTimes 'V1)
- } -> ProjInfo 'V1
-
- ProjInfoV2 ::
- { piV2ProjConfModTimes :: !(ProjConfModTimes 'V2)
- , piV2Plan :: !PlanJson
- , piV2PlanModTime :: !EpochTime
- } -> ProjInfo 'V2
-
-data ProjConfModTimes pt where
- ProjConfModTimesV1
- :: !(FilePath, EpochTime) -> ProjConfModTimes 'V1
- ProjConfModTimesV2
- :: !([(FilePath, EpochTime)]) -> ProjConfModTimes 'V2
-
-deriving instance Eq (ProjConfModTimes pt)
-
-piProjConfModTimes :: ProjInfo pt -> ProjConfModTimes pt
-piProjConfModTimes ProjInfoV1 {piV1ProjConfModTimes} =
- piV1ProjConfModTimes
-piProjConfModTimes ProjInfoV2 {piV2ProjConfModTimes} =
- piV2ProjConfModTimes
-
-data UnitModTimes = UnitModTimes
- { umtCabalFile :: !(FilePath, EpochTime)
- , umtSetupConfig :: !(FilePath, EpochTime)
- } deriving (Eq, Ord, Read, Show)
-
-- | A lazy, cached, query against a package's Cabal configuration. Use
-- 'runQuery' to execute it.
newtype Query pt a = Query
@@ -332,6 +181,14 @@ mkQueryEnv projdir distdir = do
, qeCacheRef = cr
}
+piProjConfModTimes :: ProjInfo pt -> ProjConfModTimes pt
+piProjConfModTimes ProjInfoV1 {piV1ProjConfModTimes} =
+ piV1ProjConfModTimes
+piProjConfModTimes ProjInfoV2 {piV2ProjConfModTimes} =
+ piV2ProjConfModTimes
+piProjConfModTimes ProjInfoStack {piStackProjConfModTimes} =
+ piStackProjConfModTimes
+
piUnits :: DistDir pt -> ProjInfo pt -> [Unit]
piUnits (DistDirV1 distdir) (ProjInfoV1 (ProjConfModTimesV1 (cabal_file, _))) =
(:[]) $ Unit
@@ -361,6 +218,7 @@ piUnits _ ProjInfoV2{..} =
Just $ Left u
takeunit _ =
Nothing
+piUnits DistDirStack{} ProjInfoStack{..} = piStackUnits
-- | Find files relevant to the project-scope configuration. Depending on the
@@ -380,6 +238,8 @@ projConfModTimes (ProjDirV2 projdir) = do
[ "cabal.project.local"
, "cabal.project.freeze"
]
+projConfModTimes (ProjDirStack projdir) = do
+ ProjConfModTimesStack <$> getFileModTime (projdir </> "stack.yml")
getUnitModTimes :: Unit -> IO UnitModTimes
getUnitModTimes Unit { uDistDir=DistDirLib distdirv1, uPackageDir=pkgdir } = do
@@ -518,12 +378,21 @@ shallowReconfigureProject QueryEnv
_ <- liftIO $ qeReadProcess (Just projdir) (cabalProgram qePrograms)
["v2-build", "--dry-run", "all"] ""
return ()
+shallowReconfigureProject QueryEnv
+ { qeProjectDir = ProjDirStack _projdir, .. } =
+ -- TODO: do we need to do anything here? Maybe package.yaml support needs to
+ -- do stuff here?
+ return ()
reconfigureUnit :: QueryEnvI c pt -> Unit -> IO ()
reconfigureUnit QueryEnv{qeDistDir=DistDirV1{}, ..} Unit{uPackageDir=_} = do
return ()
reconfigureUnit QueryEnv{qeDistDir=DistDirV2{}, ..} Unit{uPackageDir=_} = do
return ()
+reconfigureUnit QueryEnv{qeDistDir=DistDirStack{}, ..} Unit{uPackageDir} = do
+ _ <- liftIO $ qeReadProcess (Just uPackageDir) (stackProgram qePrograms)
+ ["stack", "build", "--only-configure", "."] ""
+ return ()
findCabalFile :: ProjDir 'V1 -> IO FilePath
findCabalFile (ProjDirV1 pkgdir) = do
@@ -549,6 +418,15 @@ readProjInfo qe conf_files = do
, piV2Plan = plan
, piV2PlanModTime = plan_mtime
}
+ (ProjDirStack{} , DistDirStack{}) -> do
+ cabal_files <- Stack.listPackageCabalFiles qe
+ units <- mapM (Stack.getUnit qe) cabal_files
+ proj_paths <- Stack.projPaths qe
+ return $ ProjInfoStack
+ { piStackProjConfModTimes = conf_files
+ , piStackUnits = units
+ , piStackProjPaths = proj_paths
+ }
readUnitInfo :: QueryEnvI c pt -> FilePath -> Unit -> IO UnitInfo
readUnitInfo
@@ -720,6 +598,20 @@ wrapper'
projdir
(Just (plan, distdir))
(distdir </> "cache")
+wrapper'
+ (ProjDirStack projdir)
+ (DistDirStack mworkdir)
+ ProjInfoStack{piStackProjPaths=StackProjPaths{sppGlobalPkgDb}}
+ = do
+ -- Stack also just picks whatever version ghc-pkg spits out, see
+ -- Stack.GhcPkg.getCabalPkgVer.
+ Just (cabalVer:_) <- runMaybeT $ listCabalVersions' (Just sppGlobalPkgDb)
+ let workdir = fromMaybe ".stack-work" $ unRelativePath <$> mworkdir
+ compileHelper' cabalVer
+ (Just sppGlobalPkgDb)
+ projdir
+ Nothing
+ (projdir </> workdir)
compileHelper'
:: Env