Add stack support

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