aboutsummaryrefslogtreecommitdiff
path: root/src/CabalHelper/Compiletime/Program
diff options
context:
space:
mode:
authorDaniel Gröber <dxld@darkboxed.org>2019-08-06 02:21:32 +0200
committerDaniel Gröber (dxld) <dxld@darkboxed.org>2019-09-17 17:48:26 +0200
commit6d8b9e26885149ff6d3710ae3c7381a1c5b1fb64 (patch)
tree958392e341c0a7d7149a424bb5d575a87c1d3166 /src/CabalHelper/Compiletime/Program
parent8f2e5eee7db0cfae21f0c347d5551f23e69de34c (diff)
Introduce Package abstracton
After lamenting the fact that we don't have this in the docs I figured it really ought to be an exposed abstraction.
Diffstat (limited to 'src/CabalHelper/Compiletime/Program')
-rw-r--r--src/CabalHelper/Compiletime/Program/CabalInstall.hs98
-rw-r--r--src/CabalHelper/Compiletime/Program/Stack.hs25
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