diff options
Diffstat (limited to 'src/CabalHelper')
| -rw-r--r-- | src/CabalHelper/Compiletime/Program/CabalInstall.hs | 98 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Program/Stack.hs | 25 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 28 |
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 |