From 871334f10f2d4d8033d2aca73e8df8dc6f83c02f Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sat, 28 Mar 2015 01:23:52 +0100 Subject: Handle inplace library deps and do a rename pass --- .travis.yml | 1 + CabalHelper/Main.hs | 130 ++++++++++++++++++++++++++----------------------- CabalHelper/Types.hs | 28 +++++++---- CabalHelper/Wrapper.hs | 6 +-- Distribution/Helper.hs | 47 ++++++++---------- cabal-helper.cabal | 20 ++++---- 6 files changed, 122 insertions(+), 110 deletions(-) diff --git a/.travis.yml b/.travis.yml index 63fa1e6..35d74d1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -22,4 +22,5 @@ script: - if [ -n "$(ghc --version | awk '{ print $8 }' | sed -n '/^7.8/p')" ]; then export WERROR="--ghc-option=-Werror"; fi - cabal configure --enable-tests $WERROR - cabal build + - ./dist/build/cabal-helper-wrapper/cabal-helper-wrapper dist # - cabal test diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs index 777ac7a..ef3447b 100644 --- a/CabalHelper/Main.hs +++ b/CabalHelper/Main.hs @@ -43,6 +43,7 @@ import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), componentBuildInfo, externalPackageDeps, withComponentsLBI, + withLibLBI, inplacePackageId) import Distribution.Simple.GHC (componentGhcOptions) @@ -88,7 +89,7 @@ usage = do ++"DIST_DIR ( version\n" ++" | print-lbi\n" ++" | write-autogen-files\n" - ++" | ghc-options [--with-inplace]\n" + ++" | ghc-options [--with-inplace]\n" ++" | ghc-src-options [--with-inplace]\n" ++" | ghc-pkg-options [--with-inplace]\n" ++" | entrypoints\n" @@ -124,11 +125,8 @@ main = do let -- a =<< b $$ c == (a =<< b) $$ c - -- a <$$> b $$ c == a <$$> (b $$ c) infixr 2 $$ ($$) = ($) - infixr 1 <$$> - (<$$>) = (<$>) collectCmdOptions :: [String] -> [[String]] collectCmdOptions = @@ -157,30 +155,31 @@ main = do initialBuildSteps distdir pd lbi v return Nothing - "ghc-options":flags -> - Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ - \c clbi bi -> let + "ghc-options":flags -> do + res <- componentsMap lbi v distdir $ \c clbi bi -> let outdir = componentOutDir lbi c (clbi', adopts) = case flags of ["--with-inplace"] -> (clbi, mempty) - [] -> removeInplaceDeps pd clbi + [] -> removeInplaceDeps v lbi pd clbi + + opts = componentGhcOptions v lbi bi clbi' outdir - in - renderGhcOptions' lbi v $ opts `mappend` adopts + in renderGhcOptions' lbi v (opts `mappend` adopts) + return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])]) - "ghc-src-options":flags -> - Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ - \c clbi bi -> let + "ghc-src-options":flags -> do + res <- componentsMap lbi v distdir $ \c clbi bi -> let outdir = componentOutDir lbi c (clbi', adopts) = case flags of ["--with-inplace"] -> (clbi, mempty) - [] -> removeInplaceDeps pd clbi + [] -> removeInplaceDeps v lbi pd clbi opts = componentGhcOptions v lbi bi clbi' outdir comp = compiler lbi opts' = mempty { -- Not really needed but "unexpected package db stack: []" ghcOptPackageDBs = [GlobalPackageDB], + ghcOptCppOptions = ghcOptCppOptions opts, ghcOptCppIncludePath = ghcOptCppIncludePath opts, ghcOptCppIncludes = ghcOptCppIncludes opts, @@ -188,17 +187,16 @@ main = do ghcOptSourcePathClear = ghcOptSourcePathClear opts, ghcOptSourcePath = ghcOptSourcePath opts } - in - renderGhcOptions' lbi v $ opts `mappend` adopts + in renderGhcOptions' lbi v $ opts `mappend` adopts + return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])]) - "ghc-pkg-options":flags -> - Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ - \c clbi bi -> let + "ghc-pkg-options":flags -> do + res <- componentsMap lbi v distdir $ \c clbi bi -> let comp = compiler lbi outdir = componentOutDir lbi c (clbi', adopts) = case flags of ["--with-inplace"] -> (clbi, mempty) - [] -> removeInplaceDeps pd clbi + [] -> removeInplaceDeps v lbi pd clbi opts = componentGhcOptions v lbi bi clbi' outdir opts' = mempty { @@ -206,23 +204,23 @@ main = do ghcOptPackages = ghcOptPackages opts, ghcOptHideAllPackages = ghcOptHideAllPackages opts } - in - renderGhcOptions' lbi v $ opts' `mappend` adopts + in renderGhcOptions' lbi v $ opts' `mappend` adopts + return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])]) "entrypoints":[] -> do eps <- componentsMap lbi v distdir $ \c clbi bi -> return $ componentEntrypoints c -- MUST append Setup component at the end otherwise CabalHelper gets -- confused - let eps' = eps ++ [(GmSetupHsName, Right [GmModuleName "Setup"])] - return $ Just $ GmCabalHelperEntrypoints eps' + let eps' = eps ++ [(ChSetupHsName, ChSetupEntrypoint)] + return $ Just $ ChResponseEntrypoints eps' - "source-dirs":[] -> - Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$ - \c clbi bi -> return $ hsSourceDirs bi + "source-dirs":[] -> do + res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi + return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])]) "print-lbi":[] -> - return $ Just $ GmCabalHelperLbi $ show lbi + return $ Just $ ChResponseLbi $ show lbi cmd:_ | not (cmd `elem` commands) -> errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure @@ -236,6 +234,15 @@ getLibrary pd = unsafePerformIO $ do withLib pd (writeIORef lr) readIORef lr +getLibraryClbi pd lbi = unsafePerformIO $ do + lr <- newIORef (error "getLibraryClbi: empty IORef") + + withLibLBI pd lbi $ \ lib clbi -> + writeIORef lr (lib,clbi) + + readIORef lr + + componentsMap :: LocalBuildInfo -> Verbosity -> FilePath @@ -243,7 +250,7 @@ componentsMap :: LocalBuildInfo -> ComponentLocalBuildInfo -> BuildInfo -> IO a) - -> IO [(GmComponentName, a)] + -> IO [(ChComponentName, a)] componentsMap lbi v distdir f = do let pd = localPkgDescr lbi @@ -255,13 +262,14 @@ componentsMap lbi v distdir f = do l' <- readIORef lr r <- f c clbi bi - writeIORef lr $ (componentNameToGm name, r):l' + writeIORef lr $ (componentNameToCh name, r):l' + reverse <$> readIORef lr -componentNameToGm CLibName = GmLibName -componentNameToGm (CExeName n) = GmExeName n -componentNameToGm (CTestName n) = GmTestName n -componentNameToGm (CBenchName n) = GmBenchName n +componentNameToCh CLibName = ChLibName +componentNameToCh (CExeName n) = ChExeName n +componentNameToCh (CTestName n) = ChTestName n +componentNameToCh (CBenchName n) = ChBenchName n componentNameFromComponent (CLib Library {}) = CLibName componentNameFromComponent (CExe Executable {..}) = CExeName exeName @@ -277,24 +285,26 @@ componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..}) componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})= exeOutDir lbi benchmarkName -gmModuleName :: C.ModuleName -> GmModuleName -gmModuleName = GmModuleName . intercalate "." . components +gmModuleName :: C.ModuleName -> ChModuleName +gmModuleName = ChModuleName . intercalate "." . components -componentEntrypoints :: Component -> Either FilePath [GmModuleName] +componentEntrypoints :: Component -> ChEntrypoint componentEntrypoints (CLib Library {..}) - = Right $ map gmModuleName $ exposedModules ++ (otherModules libBuildInfo) + = ChLibEntrypoint + (map gmModuleName exposedModules) + (map gmModuleName $ otherModules libBuildInfo) componentEntrypoints (CExe Executable {..}) - = Left modulePath -componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp }) - = Left fp -componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn }) - = Right [gmModuleName mn] + = ChExeEntrypoint modulePath (map gmModuleName $ otherModules buildInfo) +componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp, ..}) + = ChExeEntrypoint fp (map gmModuleName $ otherModules testBuildInfo) +componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn, ..}) + = ChLibEntrypoint [gmModuleName mn] (map gmModuleName $ otherModules testBuildInfo) componentEntrypoints (CTest TestSuite {}) - = Right [] -componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ fp}) - = Left fp + = ChLibEntrypoint [] [] +componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ fp, ..}) + = ChExeEntrypoint fp (map gmModuleName $ otherModules benchmarkBuildInfo) componentEntrypoints (CBench Benchmark {}) - = Left [] + = ChLibEntrypoint [] [] exeOutDir :: LocalBuildInfo -> String -> FilePath exeOutDir lbi exeName = @@ -309,26 +319,24 @@ exeOutDir lbi exeName = in targetDir -removeInplaceDeps :: PackageDescription +removeInplaceDeps :: Verbosity + -> LocalBuildInfo + -> PackageDescription -> ComponentLocalBuildInfo -> (ComponentLocalBuildInfo, GhcOptions) -removeInplaceDeps pd clbi = let +removeInplaceDeps v lbi pd clbi = let + (lib, libclbi) = getLibraryClbi pd lbi + libbi = libBuildInfo lib + liboutdir = componentOutDir lbi (CLib lib) + libopts = (componentGhcOptions v lbi libbi libclbi liboutdir) { + ghcOptPackageDBs = [] + } + (ideps, deps) = partition isInplaceDep (componentPackageDeps clbi) hasIdeps = not $ null ideps clbi' = clbi { componentPackageDeps = deps } - lib = getLibrary pd - src_dirs = hsSourceDirs (libBuildInfo lib) - adopts = mempty { - ghcOptSourcePath = -#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22 - toNubListR src_dirs -#else - src_dirs -#endif - - } - in (clbi', if hasIdeps then adopts else mempty) + in (clbi', if hasIdeps then libopts else mempty) where isInplaceDep :: (InstalledPackageId, PackageId) -> Bool diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs index 85cf2d2..add6dc1 100644 --- a/CabalHelper/Types.hs +++ b/CabalHelper/Types.hs @@ -14,27 +14,35 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# LANGUAGE DeriveGeneric, DefaultSignatures #-} module CabalHelper.Types where +import GHC.Generics + newtype ChModuleName = ChModuleName String - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Read, Show, Generic) data ChComponentName = ChSetupHsName | ChLibName | ChExeName String | ChTestName String | ChBenchName String - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Read, Show, Generic) -data Response - = ResponseStrings [(ChComponentName, [String])] - | ResponseEntrypoints [(ChComponentName, ChEntrypoint)] - | ResponseLbi String - deriving (Eq, Ord, Read, Show) +data ChResponse + = ChResponseStrings [(ChComponentName, [String])] + | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)] + | ChResponseLbi String + deriving (Eq, Ord, Read, Show, Generic) -data ChEntrypoint = ChExeEntrypoint { chMainIs :: FilePath +data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but + -- @main-is@ could either be @"Setup.hs"@ + -- or @"Setup.lhs"@. Since we don't know + -- where the source directory is you have + -- to find these files. + | ChLibEntrypoint { chExposedModules :: [ChModuleName] , chOtherModules :: [ChModuleName] } - | ChLibentrypoint { chExposedModules :: [ChModuleName] + | ChExeEntrypoint { chMainIs :: FilePath , chOtherModules :: [ChModuleName] - } deriving (Eq, Ord, Read, Show) + } deriving (Eq, Ord, Read, Show, Generic) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs index 933cb2f..1334a9d 100644 --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -237,14 +237,14 @@ compile Options {..} Compile {..} = do , "-optP-DCABAL_MINOR=" ++ show mi ], maybeToList $ ("-package-conf="++) <$> packageDb, - map ("-i"++) $ cabalHelperSourceDir:maybeToList cabalSourceDir, + map ("-i"++) $ ".":maybeToList cabalSourceDir, concatMap (\p -> ["-package", p]) packageDeps, - [ "--make", cabalHelperSourceDir "CabalHelper/Main.hs" ] + [ "--make", "CabalHelper/Main.hs" ] ] -- TODO: touch exe after, ghc doesn't do that if the input files didn't -- actually change - rv <- callProcessStderr' Nothing ghcProgram ghc_opts + rv <- callProcessStderr' (Just cabalHelperSourceDir) ghcProgram ghc_opts return $ case rv of ExitSuccess -> Right exe e@(ExitFailure _) -> Left e diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs index e97d656..cd1d30e 100644 --- a/Distribution/Helper.hs +++ b/Distribution/Helper.hs @@ -14,15 +14,16 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP, FlexibleContexts, ConstraintKinds, DeriveDataTypeable #-} +{-# LANGUAGE CPP, FlexibleContexts, ConstraintKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric #-} + module Distribution.Helper ( Programs(..) -- * Running Queries , Query , runQuery - , runKQuery - , runKQuery_ + , runQuery' -- * Queries against Cabal\'s on disk state @@ -62,6 +63,7 @@ import System.FilePath import System.Directory import System.Process import Text.Printf +import GHC.Generics import Paths_cabal_helper (getLibexecDir) import CabalHelper.Types @@ -71,7 +73,7 @@ data Programs = Programs { cabalProgram :: FilePath, ghcProgram :: FilePath, ghcPkgProgram :: FilePath - } + } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Default Programs where def = Programs "cabal" "ghc" "ghc-pkg" @@ -89,6 +91,7 @@ data SomeLocalBuildInfo = SomeLocalBuildInfo { -- running all possible queries against it at once is cheap. newtype Query m a = Query { unQuery :: StateT (Maybe SomeLocalBuildInfo) (ReaderT (Programs, FilePath) m) a } + deriving (Functor, Applicative, Monad) type MonadQuery m = ( MonadIO m , MonadState (Maybe SomeLocalBuildInfo) m @@ -99,25 +102,17 @@ run r s action = flip runReaderT r (flip evalStateT s (unQuery action)) -- | @runQuery query distdir@. Run a 'Query'. @distdir@ is where Cabal's -- @setup-config@ file is located. runQuery :: Monad m - => Query m a + => FilePath -- ^ Path to @dist/@ + -> Query m a + -> m a +runQuery fp action = run (def, fp) Nothing action + +runQuery' :: Monad m + => Programs -> FilePath -- ^ Path to @dist/@ + -> Query m a -> m a -runQuery action fp = run (def, fp) Nothing action - --- | Run a 'Query' as an Arrow by wrapping it in a 'Kleisli' constructor. -runKQuery :: Monad m - => Kleisli (Query m) a b - -> FilePath -- ^ Path to @dist/@ - -> a - -> m b -runKQuery (Kleisli action) fp a = run (def, fp) Nothing (action a) - --- | Same as 'runKQuery' but pass unit as input to the arrow. -runKQuery_ :: Monad m - => Kleisli (Query m) () b - -> FilePath -- ^ Path to @dist/@ - -> m b -runKQuery_ (Kleisli action) fp = run (def, fp) Nothing (action ()) +runQuery' progs fp action = run (progs, fp) Nothing action getSlbi :: MonadQuery m => m SomeLocalBuildInfo getSlbi = do @@ -192,11 +187,11 @@ getSomeConfigState = ask >>= \(progs, distdir) -> do , intercalate " " (map show $ distdir:args) , " (read failed)"] - let [ Just (ResponseEntrypoints eps), - Just (ResponseStrings srcDirs), - Just (ResponseStrings ghcOpts), - Just (ResponseStrings ghcSrcOpts), - Just (ResponseStrings ghcPkgOpts) ] = res + let [ Just (ChResponseEntrypoints eps), + Just (ChResponseStrings srcDirs), + Just (ChResponseStrings ghcOpts), + Just (ChResponseStrings ghcSrcOpts), + Just (ChResponseStrings ghcPkgOpts) ] = res return $ SomeLocalBuildInfo eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts diff --git a/cabal-helper.cabal b/cabal-helper.cabal index fdb985e..15e79b8 100644 --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -1,35 +1,33 @@ name: cabal-helper -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Simple interface to Cabal's configuration state used by ghc-mod description: @cabal-helper@ provides a library which wraps the internal use of executables to lift the restrictions imposed by linking against versions of GHC before @7.10@. - + . @cabal-helper@ uses a wrapper executable to compile the actual cabal-helper executable at runtime while linking against an arbitrary version of Cabal. This runtime-compiled helper executable is then used to extract various bits and peices from Cabal\'s on disk state (dist/setup-config) written by it's configure command. - + . In addition to this the wrapper executable also supports installing any version of Cabal from hackage in case it cannot be found in any available package database. The wrapper installs these instances of the Cabal library into a private package database so as to not interfere with the user's packages. - + . Furthermore the wrapper supports one special case namely reading a state file for Cabal itself. This is needed as Cabal compiles it's Setup.hs using itself and not using any version of Cabal installed in any package database. - Currently @cabal-helper@ supports @Cabal >= 1.16@. - license: AGPL-3 license-file: LICENSE author: Daniel Gröber maintainer: dxld@darkboxed.org category: Distribution -build-type: Simple +build-type: Custom cabal-version: >=1.10 extra-source-files: CabalHelper/Main.hs @@ -39,15 +37,17 @@ source-repository head library exposed-modules: Distribution.Helper - build-depends: base >= 4.5 && < 5 + Other-Modules: Paths_cabal_helper + , CabalHelper.Types default-language: Haskell2010 - Build-Depends: base + Build-Depends: base >= 4.5 && < 5 , data-default , directory , filepath , transformers , mtl , process + , ghc-prim Executable cabal-helper-wrapper Default-Language: Haskell2010 @@ -62,7 +62,7 @@ Executable cabal-helper-wrapper X-Install-Target: $libexecdir Build-Depends: base >= 4.5 && < 5 , bytestring - , Cabal + , Cabal >= 1.16 && <= 1.22 , directory , filepath , process -- cgit v1.2.3