diff options
| author | Daniel Gröber <dxld@darkboxed.org> | 2018-10-14 03:33:38 +0200 | 
|---|---|---|
| committer | Daniel Gröber <dxld@darkboxed.org> | 2018-10-27 19:53:16 +0200 | 
| commit | 807354f7dc6644fec15dfa1e534c69c14d219628 (patch) | |
| tree | 49ca70cb413edece5c6448a74a552a5ca1a1bfbd /src | |
| parent | 69e4efe5286e8955743c64034a2c7eb69e7e4a6a (diff) | |
Start refactoring to support cabal v2-build
Diffstat (limited to 'src')
| -rw-r--r-- | src/CabalHelper/Compiletime/Compile.hs | 70 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 29 | ||||
| -rw-r--r-- | src/CabalHelper/Runtime/Compat.hs | 4 | ||||
| -rw-r--r-- | src/CabalHelper/Runtime/Main.hs | 252 | ||||
| -rw-r--r-- | src/CabalHelper/Shared/InterfaceTypes.hs | 54 | 
5 files changed, 239 insertions, 170 deletions
diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs index 305c11c..3126128 100644 --- a/src/CabalHelper/Compiletime/Compile.hs +++ b/src/CabalHelper/Compiletime/Compile.hs @@ -13,8 +13,8 @@  --  -- You should have received a copy of the GNU General Public License  -- along with this program.  If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE RecordWildCards, FlexibleContexts, NamedFieldPuns, DeriveFunctor, -  GADTs, ImplicitParams, ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts, DeriveFunctor, GADTs, ConstraintKinds, +  ImplicitParams, NamedFieldPuns, RecordWildCards #-}  {-|  Module      : CabalHelper.Compiletime.Compile @@ -24,7 +24,9 @@ License     : GPL-3  module CabalHelper.Compiletime.Compile where +import qualified Cabal.Plan as CP  import Cabal.Plan +  ( PlanJson(..), PkgId(..), PkgName(..), Ver(..), uPId)  import Control.Applicative  import Control.Arrow  import Control.Exception as E @@ -49,16 +51,24 @@ import System.IO.Error  import System.IO.Temp  import Prelude -  import qualified Data.Text as Text  import qualified Data.Map.Strict as Map -import Distribution.System (buildPlatform) -import Distribution.Text (display) +import Distribution.System +  ( buildPlatform ) +import Distribution.Text +  ( display ) + +import Paths_cabal_helper +  ( version ) -import Paths_cabal_helper (version) +--import CabalHelper.Compiletime.Cabal  import CabalHelper.Compiletime.Data +--import CabalHelper.Compiletime.Log +--import CabalHelper.Compiletime.Program.GHC +--import CabalHelper.Compiletime.Program.CabalInstall  import CabalHelper.Compiletime.Types +  import CabalHelper.Shared.Common  import CabalHelper.Shared.Sandbox (getSandboxPkgDb) @@ -87,18 +97,17 @@ data CompPaths = CompPaths  data CompilationProductScope = CPSGlobal | CPSProject  compileHelper -    :: CompileOptions -    -> Version +    :: Env +    => Version +    -> Maybe PackageDbDir      -> FilePath      -> Maybe (PlanJson, FilePath)      -> FilePath      -> IO (Either ExitCode FilePath) -compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do -    let ?opts = opts - +compileHelper hdrCabalVersion cabalPkgDb projdir mnewstyle cachedir = do      ghcVer <- ghcVersion      Just (prepare, comp) <- runMaybeT $ msum $ -      case oCabalPkgDb opts of +      case cabalPkgDb of          Nothing ->            [ compileCabalSource            , compileNewBuild ghcVer @@ -107,7 +116,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do            , MaybeT $ Just <$> compileWithCabalInPrivatePkgDb            ]          Just db -> -            [ return $ (return (), compileWithPkg (Just db) hdrCabalVersion CPSProject) +          [ pure $ (pure (), compileWithPkg (Just db) hdrCabalVersion CPSProject)            ]      appdir <- appCacheDir @@ -122,7 +131,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do          vLog $ "helper exe does not exist, compiling "++compExePath          prepare >> compile comp cp - where +  where     logMsg = "using helper compiled with Cabal from "  -- for relaxed deps: find (sameMajorVersionAs hdrCabalVersion) . reverse . sort @@ -130,7 +139,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do     -- | Check if this version is globally available     compileGlobal :: Env => MaybeT IO (IO (), Compile)     compileGlobal = do -       cabal_versions <- listCabalVersions +       cabal_versions <- listCabalVersions' Nothing         ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions         vLog $ logMsg ++ "user/global package-db"         return $ (return (), compileWithPkg Nothing ver CPSGlobal) @@ -150,10 +159,10 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do         (PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure mnewstyle         let cabal_pkgid =                 PkgId (PkgName (Text.pack "Cabal")) -                     (Ver $ versionBranch hdrCabalVersion) +                        (Ver $ versionBranch hdrCabalVersion)             mcabal_unit = listToMaybe $ -             Map.elems $ Map.filter (\Unit {..} -> uPId == cabal_pkgid) pjUnits -       Unit {} <- maybe mzero pure mcabal_unit +             Map.elems $ Map.filter (\CP.Unit{..} -> uPId == cabal_pkgid) pjUnits +       CP.Unit {} <- maybe mzero pure mcabal_unit         let inplace_db_path = distdir_newstyle               </> "packagedb" </> ("ghc-" ++ showVersion ghcVer)             inplace_db = PackageDbDir inplace_db_path @@ -175,7 +184,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do           db_exists <- liftIO $ cabalVersionExistsInPkgDb hdrCabalVersion db           when (not db_exists) $             void $ installCabal (Right hdrCabalVersion) `E.catch` -             \(SomeException _) -> errorInstallCabal hdrCabalVersion cachedir +             \(SomeException _) -> errorInstallCabal hdrCabalVersion     -- | See if we're in a cabal source tree     compileCabalSource :: Env => MaybeT IO (IO (), Compile) @@ -318,7 +327,7 @@ cabalMinVersionMacro _ =  invokeGhc :: Env => GhcInvocation -> IO (Either ExitCode FilePath)  invokeGhc GhcInvocation {..} = do -    rv <- callProcessStderr' Nothing oGhcProgram $ concat +    rv <- callProcessStderr' Nothing (ghcProgram ?progs) $ concat        [ [ "-outputdir", giOutDir          , "-o", giOutput          ] @@ -335,8 +344,6 @@ invokeGhc GhcInvocation {..} = do        case rv of          ExitSuccess -> Right giOutput          e@(ExitFailure _) -> Left e -  where -    CompileOptions {..} = ?opts  -- | Cabal library version we're compiling the helper exe against. @@ -460,7 +467,7 @@ runCabalInstall (PackageDbDir db) (CabalSourceDir srcdir) ever = do               then ["--no-require-sandbox"]               else []          , [ "install", srcdir ] -        , if oVerbose ?opts +        , if ?verbose              then ["-v"]              else []          , [ "--only-dependencies" ] @@ -635,8 +642,8 @@ unpackCabalHEAD tmpdir = do           (liftIO . setCurrentDirectory)           (\_ -> liftIO (setCurrentDirectory dir) >> action) -errorInstallCabal :: Version -> FilePath -> IO a -errorInstallCabal cabalVer _distdir = panicIO $ printf "\ +errorInstallCabal :: Version -> IO a +errorInstallCabal cabalVer = panicIO $ printf "\  \Installing Cabal version %s failed.\n\  \\n\  \You have the following choices to fix this:\n\ @@ -670,9 +677,6 @@ errorInstallCabal cabalVer _distdir = panicIO $ printf "\   where     sver = showVersion cabalVer -listCabalVersions :: Env => MaybeT IO [Version] -listCabalVersions = listCabalVersions' Nothing -  listCabalVersions' :: Env => Maybe PackageDbDir -> MaybeT IO [Version]  listCabalVersions' mdb = do    case mdb of @@ -746,12 +750,12 @@ cabalFileTopField field cabalFile = value    ls = map (map toLower) $ lines cabalFile    extract = dropWhile (/=':') >>> drop 1 >>> dropWhile isSpace >>> takeWhile (not . isSpace) -vLog :: (Env, MonadIO m) => String -> m () -vLog msg | CompileOptions { oVerbose = True } <- ?opts = -    liftIO $ hPutStrLn stderr msg -vLog _ = return () +vLog :: (MonadIO m, Verbose) => String -> m () +vLog msg +    | ?verbose  = liftIO $ hPutStrLn stderr msg +    | otherwise = return () -logIOError :: Env => String -> IO (Maybe a) -> IO (Maybe a) +logIOError :: Verbose => String -> IO (Maybe a) -> IO (Maybe a)  logIOError label a = do    a `catchIOError` \ex -> do        vLog $ label ++ ": " ++ show ex diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 10fe916..843a886 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -15,7 +15,8 @@  -- along with this program.  If not, see <http://www.gnu.org/licenses/>.  {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures, -  KindSignatures, ImplicitParams, ConstraintKinds #-} +  StandaloneDeriving, GADTs, DataKinds, KindSignatures, ImplicitParams, +  ConstraintKinds, RankNTypes #-}  {-|  Module      : CabalHelper.Compiletime.Types @@ -25,13 +26,25 @@ License     : GPL-3  module CabalHelper.Compiletime.Types where +import Cabal.Plan +  ( PlanJson ) +import Data.IORef  import Data.Version  import Data.Typeable +import Data.Map.Strict (Map)  import GHC.Generics +import System.Posix.Types +import CabalHelper.Shared.InterfaceTypes -type Env = (?opts :: CompileOptions) +type Verbose = (?verbose :: Bool) +type Progs = (?progs :: Programs) +-- TODO: rname to `CompEnv` or something +type Env = +    ( ?verbose :: Bool +    , ?progs   :: Programs +    ) --- | Paths or names of various programs we need. +-- | Configurable paths to various programs we use.  data Programs = Programs {        -- | The path to the @cabal@ program.        cabalProgram  :: FilePath, @@ -44,8 +57,8 @@ data Programs = Programs {        ghcPkgProgram :: FilePath      } deriving (Eq, Ord, Show, Read, Generic, Typeable) --- | Default all programs to their unqualified names, i.e. they will be searched --- for on @PATH@. +-- | 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" @@ -57,13 +70,13 @@ data CompileOptions = CompileOptions      }  oCabalProgram :: Env => FilePath -oCabalProgram = cabalProgram $ oPrograms ?opts +oCabalProgram = cabalProgram ?progs  oGhcProgram :: Env => FilePath -oGhcProgram = ghcProgram $ oPrograms ?opts +oGhcProgram = ghcProgram ?progs  oGhcPkgProgram :: Env => FilePath -oGhcPkgProgram = ghcPkgProgram $ oPrograms ?opts +oGhcPkgProgram = ghcPkgProgram ?progs  defaultCompileOptions :: CompileOptions  defaultCompileOptions = diff --git a/src/CabalHelper/Runtime/Compat.hs b/src/CabalHelper/Runtime/Compat.hs index cafbfc3..8c32adf 100644 --- a/src/CabalHelper/Runtime/Compat.hs +++ b/src/CabalHelper/Runtime/Compat.hs @@ -151,9 +151,9 @@ type UnitId = InstalledPackageId  componentNameToCh :: ComponentName -> ChComponentName -componentNameToCh CLibName = ChLibName +componentNameToCh CLibName = ChLibName ChMainLibName  #if CH_MIN_VERSION_Cabal(2,0,0) -componentNameToCh (CSubLibName n) = ChSubLibName (unUnqualComponentName' n) +componentNameToCh (CSubLibName n) = ChLibName $ ChSubLibName (unUnqualComponentName' n)  componentNameToCh (CFLibName n) = ChFLibName (unUnqualComponentName' n)  #endif  componentNameToCh (CExeName n) = ChExeName (unUnqualComponentName' n) diff --git a/src/CabalHelper/Runtime/Main.hs b/src/CabalHelper/Runtime/Main.hs index ecdbc2a..3a363a3 100644 --- a/src/CabalHelper/Runtime/Main.hs +++ b/src/CabalHelper/Runtime/Main.hs @@ -14,7 +14,11 @@  -- You should have received a copy of the GNU General Public License  -- along with this program.  If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE CPP, BangPatterns, RecordWildCards, RankNTypes, ViewPatterns #-} +{-# LANGUAGE CPP, BangPatterns, RecordWildCards, RankNTypes, ViewPatterns, +  TupleSections #-} + +{- # OPTIONS_GHC -Wno-missing-signatures #-} +{- # OPTIONS_GHC -fno-warn-incomplete-patterns #-}  #ifdef MIN_VERSION_Cabal  #undef CH_MIN_VERSION_Cabal @@ -34,7 +38,7 @@ import Distribution.PackageDescription    ( PackageDescription    , GenericPackageDescription(..)    , Flag(..) -  , FlagName(..) +  , FlagName    , FlagAssignment    , Executable(..)    , Library(..) @@ -65,7 +69,7 @@ import Distribution.Simple.LocalBuildInfo    , ComponentLocalBuildInfo(..)    , componentBuildInfo    , externalPackageDeps -  , withComponentsLBI +  , withAllComponentsInBuildOrder    , withLibLBI    , withExeLBI    ) @@ -141,7 +145,13 @@ import Distribution.Types.ForeignLib    ( ForeignLib(..)    )  import Distribution.Types.UnqualComponentName -  ( unUnqualComponentName +  ( UnqualComponentName +  , unUnqualComponentName +  ) +#else +-- <1.25 +import Distribution.PackageDescription +  ( FlagName(FlagName)    )  #endif @@ -198,12 +208,12 @@ import Distribution.Types.GenericPackageDescription    )  #endif -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>), ZipList(..))  import Control.Arrow (first, second, (&&&))  import Control.Monad  import Control.Exception (catch, PatternMatchFail(..))  import Data.List -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map  import Data.Maybe  import Data.Monoid  import Data.IORef @@ -227,42 +237,26 @@ usage = do    hPutStr stderr $ "Usage: " ++ prog ++ " " ++ usageMsg   where     usageMsg = "" -     ++"PROJ_DIR DIST_DIR [--with-* ...] (\n" -     ++"    version\n" -     ++"  | print-lbi [--human]\n" -     ++"  | package-id\n" +     ++"PROJ_DIR DIST_DIR [--with-* ...]\n" +     ++"  ( version\n"       ++"  | flags\n"       ++"  | config-flags\n"       ++"  | non-default-config-flags\n"       ++"  | write-autogen-files\n"       ++"  | compiler-version\n" -     ++"  | ghc-options     [--with-inplace]\n" -     ++"  | ghc-src-options [--with-inplace]\n" -     ++"  | ghc-pkg-options [--with-inplace]\n" -     ++"  | ghc-merged-pkg-options [--with-inplace]\n" -     ++"  | ghc-lang-options [--with-inplace]\n" -     ++"  | package-db-stack\n" -     ++"  | entrypoints\n" -     ++"  | needs-build-output\n" -     ++"  | source-dirs\n" +     ++"  | component-info\n" +     ++"  | print-lbi [--human]\n"       ++"  ) ...\n"  commands :: [String] -commands = [ "print-lbi" -           , "package-id" -           , "flags" +commands = [ "flags"             , "config-flags"             , "non-default-config-flags"             , "write-autogen-files"             , "compiler-version" -           , "ghc-options" -           , "ghc-src-options" -           , "ghc-pkg-options" -           , "ghc-lang-options"             , "package-db-stack" -           , "entrypoints" -           , "needs-build-output" -           , "source-dirs" +           , "component-info" +           , "print-lbi"             ]  main :: IO () @@ -352,12 +346,41 @@ main = do        let CompilerId comp ver = compilerId $ compiler lbi        return $ Just $ ChResponseVersion (show comp) (toDataVersion ver) -    "ghc-options":flags -> do -      res <- componentOptions lvd True flags id -      return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) +    "package-db-stack":[] -> do +      let +          pkgDb GlobalPackageDB = ChPkgGlobal +          pkgDb UserPackageDB   = ChPkgUser +          pkgDb (SpecificPackageDB s) = ChPkgSpecific s + +      -- TODO: Setup.hs has access to the sandbox as well: ghc-mod#478 +      return $ Just $ ChResponsePkgDbs $ map pkgDb $ withPackageDB lbi + +    "component-info":flags -> do +      res <- componentsInfo flags lvd lbi v distdir +      return $ Just $ ChResponseComponentsInfo res + +    "print-lbi":flags -> +      case flags of +        ["--human"] -> print lbi >> return Nothing +        []          -> return $ Just $ ChResponseLbi $ show lbi -    "ghc-src-options":flags -> do -      res <- componentOptions lvd False flags $ \opts -> mempty { +    cmd:_ | not (cmd `elem` commands) -> +            errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure +    _ -> +            errMsg "Invalid usage!" >> usage >> exitFailure + + +componentsInfo +    :: [String] +    -> (LocalBuildInfo, Verbosity, FilePath) +    -> LocalBuildInfo +    -> Verbosity +    -> FilePath +    -> IO (Map.Map ChComponentName ChComponentInfo) +componentsInfo flags lvd lbi v distdir = do +      ciGhcOptions <- componentOptions lvd True flags id + +      ciGhcSrcOptions <- componentOptions lvd False flags $ \opts -> mempty {                 -- Not really needed but "unexpected package db stack: []"                 ghcOptPackageDBs      = [GlobalPackageDB, UserPackageDB], @@ -368,90 +391,61 @@ main = do                 ghcOptSourcePathClear = ghcOptSourcePathClear opts,                 ghcOptSourcePath      = ghcOptSourcePath opts                } -      return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) -    "ghc-pkg-options":flags -> do -      res <- componentOptions lvd True flags $ \opts -> mempty { +      ciGhcPkgOptions <- componentOptions lvd True flags $ \opts -> mempty {                         ghcOptPackageDBs = ghcOptPackageDBs opts,                         ghcOptPackages   = ghcOptPackages opts,                         ghcOptHideAllPackages = ghcOptHideAllPackages opts                     } -      return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) - -    "ghc-merged-pkg-options":flags -> do -      res <- mconcat . map snd <$> (componentOptions' lvd True flags (\_ _ o -> return o) $ \opts -> mempty { -                       ghcOptPackageDBs = [], -                       ghcOptHideAllPackages = NoFlag, -                       ghcOptPackages   = ghcOptPackages opts -                   }) - -      let res' = nubPackageFlags $ res { ghcOptPackageDBs = withPackageDB lbi -                                       , ghcOptHideAllPackages = Flag True -                                       } - -      Just . ChResponseList <$> renderGhcOptions' lbi v res' -    "ghc-lang-options":flags -> do -      res <- componentOptions lvd False flags $ \opts -> mempty { +      ciGhcLangOptions <- componentOptions lvd False flags $ \opts -> mempty {                         ghcOptPackageDBs      = [GlobalPackageDB, UserPackageDB],                         ghcOptLanguage = ghcOptLanguage opts,                         ghcOptExtensions = ghcOptExtensions opts,                         ghcOptExtensionMap = ghcOptExtensionMap opts                     } -      return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) -    "package-db-stack":[] -> do -      let -          pkgDb GlobalPackageDB = ChPkgGlobal -          pkgDb UserPackageDB   = ChPkgUser -          pkgDb (SpecificPackageDB s) = ChPkgSpecific s +      ciSourceDirs <- componentsMap lbi v distdir $ \_ _ bi -> return $ hsSourceDirs bi -      -- TODO: Setup.hs has access to the sandbox as well: ghc-mod#478 -      return $ Just $ ChResponsePkgDbs $ map pkgDb $ withPackageDB lbi - -    "entrypoints":[] -> do  #if CH_MIN_VERSION_Cabal(2,0,0)        includeDirMap <- recursiveDepInfo lbi v distdir -      eps <- componentsMap lbi v distdir $ \c clbi _bi -> do +      ciEntrypoints <- componentsMap lbi v distdir $ \c clbi _bi -> do                 case needsBuildOutput includeDirMap (componentUnitId clbi) of                   ProduceBuildOutput -> return $ componentEntrypoints c                   NoBuildOutput -> return seps                     where (_,_,seps) = recursiveIncludeDirs includeDirMap (componentUnitId clbi)  #else -      eps <- componentsMap lbi v distdir $ \c _clbi _bi -> +      ciEntrypoints <- componentsMap lbi v distdir $ \c _clbi _bi ->                 return $ componentEntrypoints c  #endif -      -- MUST append Setup component at the end otherwise CabalHelper gets -      -- confused -      let eps' = eps ++ [(ChSetupHsName, ChSetupEntrypoint)] -      return $ Just $ ChResponseEntrypoints eps' -    "needs-build-output":[] -> do  #if CH_MIN_VERSION_Cabal(2,0,0) -      includeDirMap <- recursiveDepInfo lbi v distdir -      nbs <- componentsMap lbi v distdir $ \c clbi _bi -> +      ciNeedsBuildOutput <- componentsMap lbi v distdir $ \_c clbi _bi ->                 return $ needsBuildOutput includeDirMap (componentUnitId clbi)  #else -      nbs <- componentsMap lbi v distdir $ \c _clbi _bi -> +      ciNeedsBuildOutput <- componentsMap lbi v distdir $ \_c _clbi _bi ->                 return $ NoBuildOutput  #endif -      return $ Just $ ChResponseNeedsBuild nbs -    "source-dirs":[] -> do -      res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi -      return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) +      let comp_name = map fst ciGhcOptions +          uiComponents = Map.fromList +                      $ map (ciComponentName &&& id) +                      $ getZipList +                      $ ChComponentInfo +                     <$> ZipList comp_name +                     <*> ZipList (map snd ciGhcOptions) +                     <*> ZipList (map snd ciGhcSrcOptions) +                     <*> ZipList (map snd ciGhcPkgOptions) +                     <*> ZipList (map snd ciGhcLangOptions) +                     <*> ZipList (map snd ciSourceDirs) +                     <*> ZipList (map snd ciEntrypoints) +                     <*> ZipList (map snd ciNeedsBuildOutput) -    "print-lbi":flags -> -      case flags of -        ["--human"] -> print lbi >> return Nothing -        []          -> return $ Just $ ChResponseLbi $ show lbi +      return uiComponents -    cmd:_ | not (cmd `elem` commands) -> -            errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure -    _ -> -            errMsg "Invalid usage!" >> usage >> exitFailure +flagName' :: Distribution.PackageDescription.Flag -> String  flagName' = unFlagName . flagName  -- getLibrary :: PackageDescription -> Library @@ -460,6 +454,10 @@ flagName' = unFlagName . flagName  --   withLib pd (writeIORef lr)  --   readIORef lr +getLibraryClbi +    :: PackageDescription +    -> LocalBuildInfo +    -> Maybe (Library, ComponentLocalBuildInfo)  getLibraryClbi pd lbi = unsafePerformIO $ do    lr <- newIORef Nothing @@ -469,15 +467,6 @@ getLibraryClbi pd lbi = unsafePerformIO $ do    readIORef lr -getExeClbi pd lbi = unsafePerformIO $ do -  lr <- newIORef Nothing - -  withExeLBI pd lbi $ \ exe clbi -> -      writeIORef lr $ Just (exe,clbi) - -  readIORef lr - -  componentsMap :: LocalBuildInfo                -> Verbosity                -> FilePath @@ -493,20 +482,23 @@ componentsMap lbi _v _distdir f = do      -- withComponentsLBI is deprecated but also exists in very old versions      -- it's equivalent to withAllComponentsInBuildOrder in newer versions -    withComponentsLBI pd lbi $ \c clbi -> do +    withAllComponentsInBuildOrder pd lbi $ \c clbi -> do          let bi = componentBuildInfo c -            name = componentNameFromComponent c +            name = componentNameToCh $ componentNameFromComponent c          l' <- readIORef lr          r <- f c clbi bi -#if CH_MIN_VERSION_Cabal(2,0,0) -        writeIORef lr $ (componentNameToCh name, r):l' -#else -        writeIORef lr $ (componentNameToCh name, r):l' -#endif +        writeIORef lr $ (name, r) : l'      reverse <$> readIORef lr +componentOptions' +    :: (LocalBuildInfo, Verbosity, FilePath) +    -> Bool +    -> [String] +    -> (LocalBuildInfo -> Verbosity -> GhcOptions -> IO a) +    -> (GhcOptions -> GhcOptions) +    -> IO [(ChComponentName, a)]  componentOptions' (lbi, v, distdir) inplaceFlag flags rf f = do    let pd = localPkgDescr lbi  #if CH_MIN_VERSION_Cabal(2,0,0) @@ -529,12 +521,18 @@ componentOptions' (lbi, v, distdir) inplaceFlag flags rf f = do           in rf lbi v $ nubPackageFlags $ opts' `mappend` adopts +componentOptions :: (LocalBuildInfo, Verbosity, FilePath) +                 -> Bool +                 -> [String] +                 -> (GhcOptions -> GhcOptions) +                 -> IO [(ChComponentName, [String])]  componentOptions (lbi, v, distdir) inplaceFlag flags f =      componentOptions' (lbi, v, distdir) inplaceFlag flags renderGhcOptions' f  gmModuleName :: C.ModuleName -> ChModuleName  gmModuleName = ChModuleName . intercalate "." . components +  #if CH_MIN_VERSION_Cabal(2,0,0)  removeInplaceDeps :: Verbosity                    -> LocalBuildInfo @@ -571,7 +569,7 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let               , ghcOptPackages   = ghcOptPackages   opts <> toNubListR extraDeps }      libopts = -      case (getLibraryClbi pd lbi,getExeClbi pd lbi) of +      case (getLibraryClbi pd lbi, getExeClbi pd lbi) of          (Just (lib, libclbi),_) | hasIdeps ->            let              libbi = libBuildInfo lib @@ -594,7 +592,21 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let                   NoBuildOutput -> libopts                   ProduceBuildOutput -> mempty { ghcOptPackageDBs = [SpecificPackageDB packageDbDir] }    in (clbi', libopts') + +getExeClbi +    :: PackageDescription +    -> LocalBuildInfo +    -> Maybe (Executable, ComponentLocalBuildInfo) +getExeClbi pd lbi = unsafePerformIO $ do +  lr <- newIORef Nothing + +  withExeLBI pd lbi $ \ exe clbi -> +      writeIORef lr $ Just (exe,clbi) + +  readIORef lr +  #else +  removeInplaceDeps :: Verbosity                    -> LocalBuildInfo                    -> PackageDescription @@ -616,10 +628,16 @@ removeInplaceDeps _v lbi pd clbi = let          _ -> mempty      clbi' = clbi { componentPackageDeps = deps }    in (clbi', libopts) +  #endif  #if CH_MIN_VERSION_Cabal(2,0,0) +recursiveDepInfo +    :: LocalBuildInfo +    -> Verbosity +    -> FilePath +    -> IO (Map.Map UnitId SubDeps)  recursiveDepInfo lbi v distdir = do    includeDirs <- componentsMap lbi v distdir $ \c clbi bi -> do      return (componentUnitId clbi @@ -656,7 +674,7 @@ needsBuildOutput includeDirs unit = go [unit]      go [] = NoBuildOutput      go (u:us) = case Map.lookup u includeDirs of        Nothing -> go us -      Just (SubDeps us' sfp sci sep) -> +      Just (SubDeps us' _sfp sci _sep) ->          if any (isIndef . fst) sci            then ProduceBuildOutput            else go (us++us') @@ -666,31 +684,32 @@ needsBuildOutput includeDirs unit = go [unit]  -- current accumulated value, and the second one is the current sub-dependency  -- being considered. So the bias should be to preserve the type of entrypoint  -- from the first parameter. +combineEp :: Maybe ChEntrypoint -> ChEntrypoint -> ChEntrypoint  combineEp Nothing e = e  combineEp (Just ChSetupEntrypoint) e = e  combineEp (Just (ChLibEntrypoint es1 os1 ss1))   (ChLibEntrypoint es2 os2 ss2) = (ChLibEntrypoint (nub $ es2++es1) (nub $ os2++os1) (nub $ ss2++ss1)) -combineEp _                                    e@(ChExeEntrypoint  mi os2)     = error $ "combineEP: cannot have a sub exe:" ++ show e +combineEp _                                    e@(ChExeEntrypoint  _mi _os2)     = error $ "combineEP: cannot have a sub exe:" ++ show e  combineEp (Just (ChExeEntrypoint  mi os1))       (ChLibEntrypoint es2 os2 ss2) = (ChExeEntrypoint mi  (nub $ os1++es2++os2++ss2))  -- no, you unconditionally always wrap the result in Just, so instead of `f x = Just y; f x = Just z` do `f x = y; f x = z` and use f as `Just . f` - - -instantiatedGhcPackage :: (ModuleName,OpenModule) -> [(OpenUnitId, ModuleRenaming)] -instantiatedGhcPackage (_,OpenModule oui@(DefiniteUnitId _) _) = [(oui,DefaultRenaming)] -instantiatedGhcPackage (_, _) = []  #endif + +initialBuildStepsForAllComponents +    :: FilePath +    -> PackageDescription +    -> LocalBuildInfo +    -> Verbosity +    -> IO ()  initialBuildStepsForAllComponents distdir pd lbi v =    initialBuildSteps distdir pd lbi v - - -  #if !CH_MIN_VERSION_Cabal(1,25,0)  -- CPP < 1.25 +unFlagName :: FlagName -> String  unFlagName (FlagName n) = n  -- mkFlagName n = FlagName n  #endif @@ -742,14 +761,14 @@ componentEntrypoints (CBench Benchmark {})  #if CH_MIN_VERSION_Cabal(2,0,0)  isInplaceCompInc :: ComponentLocalBuildInfo -> (OpenUnitId, ModuleRenaming) -> Bool  isInplaceCompInc clbi (DefiniteUnitId uid, _mr)     = unDefUnitId uid `elem` componentInternalDeps clbi -isInplaceCompInc clbi (IndefFullUnitId uid _, _mmr) = False +isInplaceCompInc _clbi (IndefFullUnitId _uid _, _mmr) = False  #endif  #if CH_MIN_VERSION_Cabal(2,0,0) -isInplaceDep :: LocalBuildInfo -> ComponentLocalBuildInfo -> (UnitId, MungedPackageId) -> Bool -isInplaceDep lbi clbi (uid, _mpid) = uid `elem` componentInternalDeps clbi +-- isInplaceDep :: LocalBuildInfo -> ComponentLocalBuildInfo -> (UnitId, MungedPackageId) -> Bool +-- isInplaceDep lbi clbi (uid, _mpid) = uid `elem` componentInternalDeps clbi  #else -isInplaceDep :: LocalBuildInfo -> (InstalledPackageId, PackageId) -> Bool +isInplaceDep :: LocalBuildInfo -> (UnitId, PackageId) -> Bool  #  if CH_MIN_VERSION_Cabal(1,23,0)  -- CPP >= 1.23  isInplaceDep lbi (ipid, _pid) = localUnitId lbi == ipid @@ -759,6 +778,7 @@ isInplaceDep _lbi (ipid, pid) = inplacePackageId pid == ipid  #  endif  #endif +nubPackageFlags :: GhcOptions -> GhcOptions  #if CH_MIN_VERSION_Cabal(1,22,0)  -- CPP >= 1.22  -- >= 1.22 uses NubListR diff --git a/src/CabalHelper/Shared/InterfaceTypes.hs b/src/CabalHelper/Shared/InterfaceTypes.hs index a108c72..0539b96 100644 --- a/src/CabalHelper/Shared/InterfaceTypes.hs +++ b/src/CabalHelper/Shared/InterfaceTypes.hs @@ -34,31 +34,63 @@ module CabalHelper.Shared.InterfaceTypes where  import GHC.Generics  import Data.Version +import Data.Map.Strict (Map)  data ChResponse -    = ChResponseCompList    [(ChComponentName, [String])] -    | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)] -    | ChResponseNeedsBuild  [(ChComponentName, NeedsBuildOutput)] -    | ChResponseList        [String] -    | ChResponsePkgDbs      [ChPkgDb] -    | ChResponseLbi         String -    | ChResponseVersion     String Version -    | ChResponseLicenses    [(String, [(String, Version)])] -    | ChResponseFlags       [(String, Bool)] +    = ChResponseComponentsInfo (Map ChComponentName ChComponentInfo) +    | ChResponseList           [String] +    | ChResponsePkgDbs         [ChPkgDb] +    | ChResponseLbi            String +    | ChResponseVersion        String Version +    | ChResponseLicenses       [(String, [(String, Version)])] +    | ChResponseFlags          [(String, Bool)]    deriving (Eq, Ord, Read, Show, Generic)  data ChComponentName = ChSetupHsName -                     | ChLibName -                     | ChSubLibName String +                     | ChLibName ChLibraryName                       | ChFLibName String                       | ChExeName String                       | ChTestName String                       | ChBenchName String    deriving (Eq, Ord, Read, Show, Generic) +data ChLibraryName = ChMainLibName +                   | ChSubLibName String +  deriving (Eq, Ord, Read, Show, Generic) +  newtype ChModuleName = ChModuleName String      deriving (Eq, Ord, Read, Show, Generic) +data ChComponentInfo = ChComponentInfo +    { ciComponentName         :: ChComponentName +    -- ^ The component\'s type and name + +    , ciGhcOptions            :: [String] +    -- ^ Full set of GHC options, ready for loading this component into GHCi. + +    , ciGhcSrcOptions         :: [String] +    -- ^ Only search path related GHC options. + +    , ciGhcPkgOptions         :: [String] +    -- ^ Only package related GHC options, sufficient for things don't need to +    -- access any home modules. + +    , ciGhcLangOptions        :: [String] +    -- ^ Only Haskell language extension related options, i.e. @-XSomeExtension@ + +    , ciSourceDirs            :: [String] +    -- ^ A component's @source-dirs@ field, beware since if this is empty +    -- implicit behaviour in GHC kicks in which you might have to emulate. + +    , ciEntrypoints           :: ChEntrypoint +    -- ^ Modules or files Cabal would have the compiler build directly. Can be +    -- used to compute the home module closure for a component. + +    , ciNeedsBuildOutput      :: NeedsBuildOutput +    -- ^ If a component has a non-default module renaming (backpack) it cannot +    -- be built in memory and instead needs proper build output. +    } deriving (Eq, Ord, Read, Show) +  data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but                                        -- @main-is@ could either be @"Setup.hs"@                                        -- or @"Setup.lhs"@. Since we don't know  | 
