diff options
Diffstat (limited to 'src/CabalHelper/Compiletime/Program')
| -rw-r--r-- | src/CabalHelper/Compiletime/Program/CabalInstall.hs | 98 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Program/Stack.hs | 25 |
2 files changed, 77 insertions, 46 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 |