aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/CabalHelper/Compiletime/Program/CabalInstall.hs98
-rw-r--r--src/CabalHelper/Compiletime/Program/Stack.hs25
-rw-r--r--src/CabalHelper/Compiletime/Types.hs28
3 files changed, 90 insertions, 61 deletions
diff --git a/src/CabalHelper/Compiletime/Program/CabalInstall.hs b/src/CabalHelper/Compiletime/Program/CabalInstall.hs
index 8ce0135..686743b 100644
--- a/src/CabalHelper/Compiletime/Program/CabalInstall.hs
+++ b/src/CabalHelper/Compiletime/Program/CabalInstall.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, MultiWayIf #-}
+{-# LANGUAGE DataKinds, MultiWayIf, TupleSections #-}
-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2018 Daniel Gröber <cabal-helper@dxld.at>
@@ -24,10 +24,12 @@ License : GPL-3
module CabalHelper.Compiletime.Program.CabalInstall where
+import Control.Arrow ((&&&))
import qualified Cabal.Plan as CP
import Control.Monad
import Data.Coerce
-import Data.Either
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Semigroup ((<>))
import Data.Maybe
import Data.Version
import System.IO
@@ -37,7 +39,6 @@ import System.Environment
import System.FilePath
import Text.Printf
import Text.Read
-import Text.Show.Pretty
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
@@ -86,16 +87,23 @@ installingMessage = message
-- a way to let API clients override this!
hPutStr stderr $ printf "\
\cabal-helper: Installing a private copy of Cabal because we couldn't\n\
-\find the right version in your global/user package-db. This might take a\n\
-\while but will only happen once per Cabal version you're using.\n\
+\find the right version anywhere on your system. You can set the environment\n\
+\variable CABAL_HELPER_DEBUG=1 to see where we searched.\n\
\\n\
-\If anything goes horribly wrong just delete this directory and try again:\n\
-\ %s\n\
+\Note that this installation might take a little while but it will only\n\
+\happen once per Cabal library version used in your build-plans.\n\
\\n\
\If you want to avoid this automatic installation altogether install\n\
-\version %s of Cabal manually (into your user or global package-db):\n\
+\version %s of the Cabal library manually, either using cabal or your\n\
+\system package manager. With cabal you can use the following command:\n\
\ $ cabal install Cabal --constraint \"Cabal == %s\"\n\
\\n\
+\FYI the build products and cabal-helper executable cache are all in the\n\
+\following directory, you can simply delete it if you think something\n\
+\is broken :\n\
+\ %s\n\
+\Please do report any problems you encounter.\n\
+\\n\
\Installing Cabal %s ...\n" appdir sver sver sver
callCabalInstall
@@ -244,39 +252,55 @@ cabalV2WithGHCProgOpts = concat
else []
]
-planUnits :: CP.PlanJson -> IO [Unit ('Cabal 'CV2)]
-planUnits plan = do
- units <- fmap catMaybes $ mapM takeunit $ Map.elems $ CP.pjUnits plan
- case lefts units of
- [] -> return $ rights units
- us@(_:_) -> panicIO $
- msg ++ (concat $ map (unlines . map (" "++) . lines . ppShow) us)
+planPackages :: CP.PlanJson -> IO [Package ('Cabal 'CV2)]
+planPackages plan = do
+ fmap Map.elems $
+ mapM mkPackage $
+ groupByMap $ Map.elems $
+ Map.filter ((==CP.UnitTypeLocal) . CP.uType) $
+ CP.pjUnits plan
where
- msg = "\
-\plan.json doesn't contain 'dist-dir' key for the following local units:\n"
- takeunit u@CP.Unit
- { uType=CP.UnitTypeLocal
- , uDistDir=Just distdirv1
- , uPkgSrc=Just (CP.LocalUnpackedPackage pkgdir)
+ groupByMap = Map.fromListWith (<>) . map (CP.uPId &&& (:|[]))
+
+ mkPackage units@(unit :| _) =
+ case unit of
+ CP.Unit
+ { uPkgSrc=Just (CP.LocalUnpackedPackage pkgdir)
+ } -> do
+ cabal_file <- Cabal.complainIfNoCabalFile pkgdir =<< Cabal.findCabalFile pkgdir
+ let pkg = Package
+ { pPackageName =
+ let CP.PkgId (CP.PkgName pkg_name) _ = CP.uPId unit
+ in Text.unpack pkg_name
+ , pSourceDir = pkgdir
+ , pCabalFile = CabalFile cabal_file
+ , pFlags = []
+ , pUnits = fmap (mkUnit pkg) units
+ }
+ return pkg
+ _ -> panicIO "planPackages.mkPackage: Got non-unpacked package src!"
+
+ mkUnit pkg CP.Unit
+ { uDistDir=Just distdirv1
, uComps=comps
- , uPId=CP.PkgId pkg_name _
- } = do
- cabal_file <- Cabal.complainIfNoCabalFile pkgdir =<< Cabal.findCabalFile pkgdir
- let comp_names = Map.keys comps
- let uiV2Components =
- map (Text.unpack . CP.dispCompNameTarget pkg_name) $ Map.keys comps
- let uiV2ComponentNames = map cpCompNameToChComponentName comp_names
- return $ Just $ Right $ Unit
- { uUnitId = UnitId $ Text.unpack (coerce (CP.uId u))
- , uPackageDir = pkgdir
- , uCabalFile = CabalFile cabal_file
+ , uPId = CP.PkgId pkg_name _
+ , uId
+ } =
+ let comp_names = Map.keys comps in
+ Unit
+ { uUnitId = UnitId $ Text.unpack (coerce uId)
+ , uPackage = pkg
, uDistDir = DistDirLib distdirv1
- , uImpl = UnitImplV2 {..}
+ , uImpl =
+ let
+ uiV2ComponentNames = map cpCompNameToChComponentName comp_names
+ uiV2Components =
+ map (Text.unpack . CP.dispCompNameTarget pkg_name) $
+ Map.keys comps
+ in UnitImplV2 {..}
}
- takeunit u@CP.Unit {uType=CP.UnitTypeLocal} =
- return $ Just $ Left u
- takeunit _ =
- return $ Nothing
+ mkUnit _ _ =
+ error "planPackages.mkUnit: Got package without distdir!"
cpCompNameToChComponentName :: CP.CompName -> ChComponentName
cpCompNameToChComponentName cn =
diff --git a/src/CabalHelper/Compiletime/Program/Stack.hs b/src/CabalHelper/Compiletime/Program/Stack.hs
index 896c73e..264050a 100644
--- a/src/CabalHelper/Compiletime/Program/Stack.hs
+++ b/src/CabalHelper/Compiletime/Program/Stack.hs
@@ -30,6 +30,7 @@ import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Data.Char
import Data.List hiding (filter)
+import Data.List.NonEmpty (NonEmpty(..))
import Data.String
import Data.Maybe
import Data.Function
@@ -45,19 +46,25 @@ 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
+getPackage :: QueryEnvI c 'Stack -> CabalFile -> IO (Package 'Stack)
+getPackage qe cabal_file@(CabalFile cabal_file_path) = do
let pkgdir = takeDirectory cabal_file_path
let pkg_name = dropExtension $ takeFileName cabal_file_path
look <- paths qe pkgdir
let distdirv1_rel = look "dist-dir:"
- return $ Unit
- { uUnitId = UnitId pkg_name
- , uPackageDir = pkgdir
- , uCabalFile = cabal_file
- , uDistDir = DistDirLib $ pkgdir </> distdirv1_rel
- , uImpl = UnitImplStack
- }
+ let pkg = Package
+ { pPackageName = pkg_name
+ , pSourceDir = pkgdir
+ , pCabalFile = cabal_file
+ , pFlags = []
+ , pUnits = (:|[]) $ Unit
+ { uUnitId = UnitId pkg_name
+ , uDistDir = DistDirLib $ pkgdir </> distdirv1_rel
+ , uPackage = pkg
+ , uImpl = UnitImplStack
+ }
+ }
+ return pkg
projPaths :: QueryEnvI c 'Stack -> IO StackProjPaths
projPaths qe@QueryEnv {qeProjLoc=ProjLocStackYaml stack_yaml} = do
diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs
index 3871576..b9572cb 100644
--- a/src/CabalHelper/Compiletime/Types.hs
+++ b/src/CabalHelper/Compiletime/Types.hs
@@ -106,18 +106,7 @@ demoteSProjType SStack = Stack
--
-- Hence it isn't actually possible to find the whole project's toplevel
-- source directory given just a 'ProjLoc'. However the packages within a
--- project have a well defined source directory.
---
--- Unfortunately we do not expose the concept of a "package" in the API to
--- abstract the differences between the project types. Instead each 'Unit'
--- (which is conceptually part of a "package") carries the corresponding
--- package source directory in 'uPackageDir'. Together with a 'Unit' query
--- such as 'projectUnits' you can thus get the source directory for each
--- unit.
---
--- If you need to present this in a per-package view rather than a per-unit
--- view you should be able to use the source directory as a key to
--- determine which units to group into a package.
+-- project have a well defined source directory, see 'Package.pSourceDir'
data ProjLoc (pt :: ProjType) where
-- | A fully specified @cabal v1-build@ project context. Here you can
-- specify both the path to the @.cabal@ file and the source directory
@@ -287,6 +276,16 @@ data QueryCache pt = QueryCache
newtype DistDirLib = DistDirLib FilePath
deriving (Eq, Ord, Read, Show)
+-- | A 'Package' is a named collection of many 'Unit's.
+data Package pt = Package
+ { pPackageName :: !String
+ , pSourceDir :: !FilePath
+ , pCabalFile :: !CabalFile
+ , pFlags :: ![(String, Bool)]
+ -- | Cabal flags to set when configuring and building this package.
+ , pUnits :: !(NonEmpty (Unit pt))
+ } deriving (Show)
+
-- | A 'Unit' is essentially a "build target". It is used to refer to a set
-- of components (exes, libs, tests etc.) which are managed by a certain
-- instance of the Cabal build-system[1]. We may get information on the
@@ -301,8 +300,7 @@ newtype DistDirLib = DistDirLib FilePath
-- was created in. However this is not enforced by the API.
data Unit pt = Unit
{ uUnitId :: !UnitId
- , uPackageDir :: !FilePath
- , uCabalFile :: !CabalFile
+ , uPackage :: !(Package pt)
, uDistDir :: !DistDirLib
, uImpl :: !(UnitImpl pt)
} deriving (Show)
@@ -414,7 +412,7 @@ newtype ProjConfModTimes = ProjConfModTimes [(FilePath, EpochTime)]
-- | Project-scope information cache.
data ProjInfo pt = ProjInfo
{ piCabalVersion :: !Version
- , piUnits :: !(NonEmpty (Unit pt))
+ , piPackages :: !(NonEmpty (Package pt))
, piImpl :: !(ProjInfoImpl pt)
, piProjConfModTimes :: !ProjConfModTimes
-- ^ Key for cache invalidation. When this is not equal to the return