Add stack support

3 files changed, 304 insertions, 1 deletions

diff --git a/src/CabalHelper/Compiletime/Program/Stack.hs b/src/CabalHelper/Compiletime/Program/Stack.hs
new file mode 100644
index 0000000..4751f0a
--- /dev/null
+++ b/src/CabalHelper/Compiletime/Program/Stack.hs
@@ -0,0 +1,86 @@
+-- cabal-helper: Simple interface to Cabal's configuration state
+-- Copyright (C) 2018  Daniel Gröber <cabal-helper@dxld.at>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-|
+Module      : CabalHelper.Compiletime.Program.Stack
+Description : Stack program interface
+License     : GPL-3
+-}
+
+{-# LANGUAGE GADTs, DataKinds #-}
+
+module CabalHelper.Compiletime.Program.Stack where
+
+import Control.Monad
+import Data.Char
+import Data.List hiding (filter)
+import Data.String
+import Data.Maybe
+import Data.Function
+import System.FilePath hiding ((<.>))
+import Prelude
+
+import CabalHelper.Compiletime.Types
+import CabalHelper.Compiletime.Types.RelativePath
+
+getUnit :: QueryEnvI c 'Stack -> CabalFile -> IO Unit
+getUnit qe (CabalFile cabal_file) = do
+  let pkgdir = takeDirectory cabal_file
+  let pkg_name = dropExtension $ takeFileName cabal_file
+  look <- paths qe pkgdir
+  let distdirv1 = look "dist-dir:"
+  return $ Unit
+    { uUnitId     = UnitId pkg_name
+    , uPackageDir = pkgdir
+    , uDistDir    = DistDirLib distdirv1
+    }
+
+-- 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 {qeProjectDir=ProjDirStack projdir} = do
+  look <- paths qe projdir
+  return StackProjPaths
+    { sppGlobalPkgDb = PackageDbDir $ look "global-pkg-db:"
+    , sppSnapPkgDb   = PackageDbDir $ look "snapshot-pkg-db:"
+    , sppLocalPkgDb  = PackageDbDir $ look "local-pkg-db:"
+    }
+
+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
+  where
+    split l = let (key, ' ' : val) = span (not . isSpace) l in (key, val)
+
+listPackageCabalFiles :: QueryEnvI c 'Stack -> IO [CabalFile]
+listPackageCabalFiles qe@QueryEnv{qeProjectDir=ProjDirStack projdir} = do
+  out <- qeReadProcess qe (Just projdir) (stackProgram $ qePrograms qe)
+    [ "ide", "packages", "--cabal-files" ] ""
+  return $ map CabalFile $ lines out
+
+workdirArg :: QueryEnvI c 'Stack -> [String]
+workdirArg QueryEnv{qeDistDir=DistDirStack mworkdir} =
+  maybeToList $ ("--work-dir="++) . unRelativePath <$> mworkdir
diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs
index 843a886..58e90b1 100644
--- a/src/CabalHelper/Compiletime/Types.hs
+++ b/src/CabalHelper/Compiletime/Types.hs
@@ -34,8 +34,182 @@ import Data.Typeable
 import Data.Map.Strict (Map)
 import GHC.Generics
 import System.Posix.Types
+import CabalHelper.Compiletime.Types.RelativePath
 import CabalHelper.Shared.InterfaceTypes
 
+
+-- | 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.
+
+-- | 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
+
+    -- | A @stack@ project\'s marker file is called @stack.yaml@. This
+    -- configuration file points to the packages that make up this project.
+    ProjDirStack :: FilePath -> ProjDir 'Stack
+
+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
+
+    -- | 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
+
+-- | 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
+
+  ProjInfoStack ::
+    { piStackProjConfModTimes :: !(ProjConfModTimes 'Stack)
+    , piStackUnits            :: ![Unit]
+    , piStackProjPaths        :: !StackProjPaths
+    } -> ProjInfo 'Stack
+
+data ProjConfModTimes pt where
+    ProjConfModTimesV1
+        :: !(FilePath, EpochTime)     -> ProjConfModTimes 'V1
+    ProjConfModTimesV2
+        :: !([(FilePath, EpochTime)]) -> ProjConfModTimes 'V2
+    ProjConfModTimesStack
+        :: !(FilePath, EpochTime)     -> ProjConfModTimes 'Stack
+
+deriving instance Eq (ProjConfModTimes pt)
+
+data UnitModTimes = UnitModTimes
+    { umtCabalFile   :: !(FilePath, EpochTime)
+    , umtSetupConfig :: !(FilePath, EpochTime)
+    } deriving (Eq, Ord, Read, Show)
+
+newtype CabalFile = CabalFile FilePath
+
+data StackProjPaths = StackProjPaths
+    { sppGlobalPkgDb :: !PackageDbDir
+    , sppSnapPkgDb   :: !PackageDbDir
+    , sppLocalPkgDb  :: !PackageDbDir
+    }
+
 type Verbose = (?verbose :: Bool)
 type Progs = (?progs :: Programs)
 -- TODO: rname to `CompEnv` or something
@@ -49,6 +223,9 @@ data Programs = Programs {
       -- | The path to the @cabal@ program.
       cabalProgram  :: FilePath,
 
+      -- | The path to the @stack@ program.
+      stackProgram  :: FilePath,
+
       -- | The path to the @ghc@ program.
       ghcProgram    :: FilePath,
 
@@ -60,7 +237,8 @@ data Programs = Programs {
 -- | By default all programs use their unqualified names, i.e. they will be
 -- searched for on @PATH@.
 defaultPrograms :: Programs
-defaultPrograms = Programs "cabal" "ghc" "ghc-pkg"
+defaultPrograms = Programs "cabal" "stack" "ghc" "ghc-pkg"
+
 
 data CompileOptions = CompileOptions
     { oVerbose       :: Bool
diff --git a/src/CabalHelper/Compiletime/Types/RelativePath.hs b/src/CabalHelper/Compiletime/Types/RelativePath.hs
new file mode 100644
index 0000000..bfc29bf
--- /dev/null
+++ b/src/CabalHelper/Compiletime/Types/RelativePath.hs
@@ -0,0 +1,39 @@
+-- cabal-helper: Simple interface to Cabal's configuration state
+-- Copyright (C) 2018  Daniel Gröber <cabal-helper@dxld.at>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-|
+Module      : CabalHelper.Compiletime.Types.RelativePath
+License     : GPL-3
+-}
+
+module CabalHelper.Compiletime.Types.RelativePath
+    ( RelativePath
+    , mkRelativePath
+    , unRelativePath
+    ) where
+
+import System.FilePath
+
+-- | A path guaranteed to be relative. The constructor is not exposed, use the
+-- 'mkRelativePath' smart constructor.
+newtype RelativePath = RelativePath { unRelativePath :: FilePath }
+
+-- | Smart constructor for 'RelativePath'. Checks if the given path is absolute
+-- and throws 'UserError' if not.
+mkRelativePath :: FilePath -> RelativePath
+mkRelativePath dir
+    | isAbsolute dir = RelativePath dir
+    | otherwise = error "mkRelativePath: the path given was absolute!"