Factor out cabal-helper into a package
This commit is contained in:
Daniel Gröber
parent
a97e07065e
commit
90d9577f8d
|
|
@ -1,98 +0,0 @@
|
|||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
|
||||
module CabalHelper.Common where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception as E
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Version
|
||||
import Data.Typeable
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import System.Environment
|
||||
import System.IO
|
||||
import System.Exit
|
||||
import Text.ParserCombinators.ReadP
|
||||
|
||||
data Panic = Panic String deriving (Typeable, Show)
|
||||
instance Exception Panic
|
||||
|
||||
panic :: String -> a
|
||||
panic msg = throw $ Panic msg
|
||||
|
||||
handlePanic :: IO a -> IO a
|
||||
handlePanic action =
|
||||
action `E.catch` \(Panic msg) -> errMsg msg >> exitFailure
|
||||
|
||||
errMsg :: String -> IO ()
|
||||
errMsg str = do
|
||||
prog <- getProgName
|
||||
hPutStrLn stderr $ prog ++ ": " ++ str
|
||||
|
||||
align :: String -> String -> String -> String
|
||||
align n an str = let
|
||||
h:rest = lines str
|
||||
[hm] = match n h
|
||||
rest' = [ move (hm - rm) r | r <- rest, rm <- match an r]
|
||||
in
|
||||
unlines (h:rest')
|
||||
where
|
||||
match p str' = maybeToList $
|
||||
fst <$> find ((p `isPrefixOf`) . snd) ([0..] `zip` tails str')
|
||||
move i str' | i > 0 = replicate i ' ' ++ str'
|
||||
move i str' = drop i str'
|
||||
|
||||
|
||||
-- | @getCabalConfigHeader "dist/setup-config"@ returns the cabal version and
|
||||
-- compiler version
|
||||
getCabalConfigHeader :: FilePath -> IO (Maybe (Version, Version))
|
||||
getCabalConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do
|
||||
parseHeader <$> BS.hGetLine h
|
||||
|
||||
parseHeader :: ByteString -> Maybe (Version, Version)
|
||||
parseHeader header = case BS8.words header of
|
||||
["Saved", "package", "config", "for", _pkgId ,
|
||||
"written", "by", cabalId,
|
||||
"using", compId]
|
||||
-> liftM2 (,) (ver cabalId) (ver compId)
|
||||
_ -> Nothing
|
||||
where
|
||||
ver i = snd <$> parsePkgId i
|
||||
|
||||
parsePkgId :: ByteString -> Maybe (ByteString, Version)
|
||||
parsePkgId bs =
|
||||
case BS8.split '-' bs of
|
||||
[pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers)
|
||||
_ -> Nothing
|
||||
|
||||
parseVer :: String -> Version
|
||||
parseVer vers = runReadP parseVersion vers
|
||||
|
||||
-- majorVer :: Version -> Version
|
||||
-- majorVer (Version b _) = Version (take 2 b) []
|
||||
|
||||
-- sameMajorVersion :: Version -> Version -> Bool
|
||||
-- sameMajorVersion a b = majorVer a == majorVer b
|
||||
|
||||
runReadP :: ReadP t -> String -> t
|
||||
runReadP p i = case filter ((=="") . snd) $ readP_to_S p i of
|
||||
(a,""):[] -> a
|
||||
_ -> error $ "Error parsing: " ++ show i
|
||||
|
|
@ -1,83 +0,0 @@
|
|||
module CabalHelper.GuessGhc (guessToolFromGhcPath) where
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Char
|
||||
import Distribution.Simple.BuildPaths
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
-- Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren,
|
||||
-- Bjorn Bringert, Krasimir Angelov,
|
||||
-- Malcolm Wallace, Ross Patterson, Ian Lynagh,
|
||||
-- Duncan Coutts, Thomas Schilling,
|
||||
-- Johan Tibell, Mikhail Glushenkov
|
||||
-- All rights reserved.
|
||||
|
||||
-- Redistribution and use in source and binary forms, with or without
|
||||
-- modification, are permitted provided that the following conditions are
|
||||
-- met:
|
||||
|
||||
-- * Redistributions of source code must retain the above copyright
|
||||
-- notice, this list of conditions and the following disclaimer.
|
||||
|
||||
-- * Redistributions in binary form must reproduce the above
|
||||
-- copyright notice, this list of conditions and the following
|
||||
-- disclaimer in the documentation and/or other materials provided
|
||||
-- with the distribution.
|
||||
|
||||
-- * Neither the name of Isaac Jones nor the names of other
|
||||
-- contributors may be used to endorse or promote products derived
|
||||
-- from this software without specific prior written permission.
|
||||
|
||||
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
guessToolFromGhcPath :: FilePath -- ^ Tool name
|
||||
-> FilePath -- ^ GHC exe path
|
||||
-> IO (Maybe FilePath)
|
||||
guessToolFromGhcPath toolname ghcPath
|
||||
= do let
|
||||
path = ghcPath
|
||||
dir = takeDirectory path
|
||||
versionSuffix = takeVersionSuffix (dropExeExtension path)
|
||||
guessNormal = dir </> toolname <.> exeExtension
|
||||
guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)
|
||||
<.> exeExtension
|
||||
guessVersioned = dir </> (toolname ++ versionSuffix)
|
||||
<.> exeExtension
|
||||
guesses | null versionSuffix = [guessNormal]
|
||||
| otherwise = [guessGhcVersioned,
|
||||
guessVersioned,
|
||||
guessNormal]
|
||||
exists <- mapM doesFileExist guesses
|
||||
return $ listToMaybe [ file | (file, True) <- zip guesses exists ]
|
||||
|
||||
where takeVersionSuffix :: FilePath -> String
|
||||
takeVersionSuffix = takeWhileEndLE isSuffixChar
|
||||
|
||||
isSuffixChar :: Char -> Bool
|
||||
isSuffixChar c = isDigit c || c == '.' || c == '-'
|
||||
|
||||
dropExeExtension :: FilePath -> FilePath
|
||||
dropExeExtension filepath =
|
||||
case splitExtension filepath of
|
||||
(filepath', extension) | extension == exeExtension -> filepath'
|
||||
| otherwise -> filepath
|
||||
|
||||
-- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but
|
||||
-- is usually faster (as well as being easier to read).
|
||||
takeWhileEndLE :: (a -> Bool) -> [a] -> [a]
|
||||
takeWhileEndLE p = fst . foldr go ([], False)
|
||||
where
|
||||
go x (rest, done)
|
||||
| not done && p x = (x:rest, False)
|
||||
| otherwise = (rest, True)
|
||||
|
|
@ -1,344 +0,0 @@
|
|||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE CPP, BangPatterns, RecordWildCards #-}
|
||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||
import Distribution.Simple.Utils (cabalVersion)
|
||||
import Distribution.Simple.Configure
|
||||
|
||||
import Distribution.Package (PackageIdentifier, InstalledPackageId, PackageId)
|
||||
import Distribution.PackageDescription (PackageDescription,
|
||||
FlagAssignment,
|
||||
Executable(..),
|
||||
Library(..),
|
||||
TestSuite(..),
|
||||
Benchmark(..),
|
||||
BuildInfo(..),
|
||||
TestSuiteInterface(..),
|
||||
BenchmarkInterface(..),
|
||||
withLib)
|
||||
import Distribution.PackageDescription.Parse (readPackageDescription)
|
||||
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
|
||||
|
||||
import Distribution.Simple.Program (requireProgram, ghcProgram)
|
||||
import Distribution.Simple.Program.Types (ConfiguredProgram(..))
|
||||
import Distribution.Simple.Configure (getPersistBuildConfig)
|
||||
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),
|
||||
Component(..),
|
||||
ComponentName(..),
|
||||
ComponentLocalBuildInfo(..),
|
||||
componentBuildInfo,
|
||||
externalPackageDeps,
|
||||
withComponentsLBI,
|
||||
inplacePackageId)
|
||||
|
||||
import Distribution.Simple.GHC (componentGhcOptions)
|
||||
import Distribution.Simple.Program.GHC (GhcOptions(..), renderGhcOptions)
|
||||
|
||||
import Distribution.Simple.Setup (ConfigFlags(..),Flag(..))
|
||||
import Distribution.Simple.Build (initialBuildSteps)
|
||||
import Distribution.Simple.BuildPaths (autogenModuleName, cppHeaderName, exeExtension)
|
||||
import Distribution.Simple.Compiler (PackageDB(..))
|
||||
|
||||
import Distribution.ModuleName (components)
|
||||
import qualified Distribution.ModuleName as C (ModuleName)
|
||||
import Distribution.Text (display)
|
||||
import Distribution.Verbosity (Verbosity, silent, deafening)
|
||||
|
||||
#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22
|
||||
import Distribution.Utils.NubList
|
||||
#endif
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad
|
||||
import Control.Exception (catch, PatternMatchFail(..))
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import Data.IORef
|
||||
import System.Environment
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)
|
||||
import Text.Printf
|
||||
|
||||
import CabalHelper.Common
|
||||
import CabalHelper.Types
|
||||
|
||||
usage = do
|
||||
prog <- getProgName
|
||||
hPutStr stderr $ align "(" "|" ("Usage: " ++ prog ++ " " ++ usageMsg)
|
||||
where
|
||||
usageMsg = ""
|
||||
++"DIST_DIR ( version\n"
|
||||
++" | print-lbi\n"
|
||||
++" | write-autogen-files\n"
|
||||
++" | ghc-options [--with-inplace]\n"
|
||||
++" | ghc-src-options [--with-inplace]\n"
|
||||
++" | ghc-pkg-options [--with-inplace]\n"
|
||||
++" | entrypoints\n"
|
||||
++" | source-dirs\n"
|
||||
++" ) ...\n"
|
||||
|
||||
commands :: [String]
|
||||
commands = [ "print-bli"
|
||||
, "write-autogen-files"
|
||||
, "component-from-file"
|
||||
, "ghc-options"
|
||||
, "ghc-src-options"
|
||||
, "ghc-pkg-options"
|
||||
, "entrypoints"
|
||||
, "source-dirs"]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
|
||||
distdir:args' <- case args of
|
||||
[] -> usage >> exitFailure
|
||||
_ -> return args
|
||||
|
||||
ddexists <- doesDirectoryExist distdir
|
||||
when (not ddexists) $ do
|
||||
errMsg $ "distdir '"++distdir++"' does not exist"
|
||||
exitFailure
|
||||
|
||||
v <- maybe silent (const deafening) . lookup "GHC_MOD_DEBUG" <$> getEnvironment
|
||||
lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir
|
||||
let pd = localPkgDescr lbi
|
||||
|
||||
let
|
||||
-- a =<< b $$ c == (a =<< b) $$ c
|
||||
-- a <$$> b $$ c == a <$$> (b $$ c)
|
||||
infixr 2 $$
|
||||
($$) = ($)
|
||||
infixr 1 <$$>
|
||||
(<$$>) = (<$>)
|
||||
|
||||
collectCmdOptions :: [String] -> [[String]]
|
||||
collectCmdOptions =
|
||||
reverse . map reverse . foldl f [] . dropWhile isOpt
|
||||
where
|
||||
isOpt = ("--" `isPrefixOf`)
|
||||
f [] x = [[x]]
|
||||
f (a:as) x
|
||||
| isOpt x = (x:a):as
|
||||
| otherwise = [x]:(a:as)
|
||||
|
||||
let cmds = collectCmdOptions args'
|
||||
|
||||
if any (["version"] `isPrefixOf`) cmds
|
||||
then do
|
||||
putStrLn $
|
||||
printf "using version %s of the Cabal library" (display cabalVersion)
|
||||
exitSuccess
|
||||
else return ()
|
||||
|
||||
print =<< flip mapM cmds $$ \cmd -> do
|
||||
case cmd of
|
||||
"write-autogen-files":[] -> do
|
||||
let pd = localPkgDescr lbi
|
||||
-- calls writeAutogenFiles
|
||||
initialBuildSteps distdir pd lbi v
|
||||
return Nothing
|
||||
|
||||
"ghc-options":flags ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
\c clbi bi -> let
|
||||
outdir = componentOutDir lbi c
|
||||
(clbi', adopts) = case flags of
|
||||
["--with-inplace"] -> (clbi, mempty)
|
||||
[] -> removeInplaceDeps pd clbi
|
||||
opts = componentGhcOptions v lbi bi clbi' outdir
|
||||
in
|
||||
renderGhcOptions' lbi v $ opts `mappend` adopts
|
||||
|
||||
"ghc-src-options":flags ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
\c clbi bi -> let
|
||||
outdir = componentOutDir lbi c
|
||||
(clbi', adopts) = case flags of
|
||||
["--with-inplace"] -> (clbi, mempty)
|
||||
[] -> removeInplaceDeps 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,
|
||||
ghcOptFfiIncludes = ghcOptFfiIncludes opts,
|
||||
ghcOptSourcePathClear = ghcOptSourcePathClear opts,
|
||||
ghcOptSourcePath = ghcOptSourcePath opts
|
||||
}
|
||||
in
|
||||
renderGhcOptions' lbi v $ opts `mappend` adopts
|
||||
|
||||
"ghc-pkg-options":flags ->
|
||||
Just . GmCabalHelperStrings <$$> 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
|
||||
opts = componentGhcOptions v lbi bi clbi' outdir
|
||||
|
||||
opts' = mempty {
|
||||
ghcOptPackageDBs = ghcOptPackageDBs opts,
|
||||
ghcOptPackages = ghcOptPackages opts,
|
||||
ghcOptHideAllPackages = ghcOptHideAllPackages opts
|
||||
}
|
||||
in
|
||||
renderGhcOptions' lbi v $ opts' `mappend` adopts
|
||||
|
||||
"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'
|
||||
|
||||
"source-dirs":[] ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
\c clbi bi -> return $ hsSourceDirs bi
|
||||
|
||||
"print-lbi":[] ->
|
||||
return $ Just $ GmCabalHelperLbi $ show lbi
|
||||
|
||||
cmd:_ | not (cmd `elem` commands) ->
|
||||
errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure
|
||||
_ ->
|
||||
errMsg "Invalid usage!" >> usage >> exitFailure
|
||||
|
||||
|
||||
getLibrary :: PackageDescription -> Library
|
||||
getLibrary pd = unsafePerformIO $ do
|
||||
lr <- newIORef (error "libraryMap: empty IORef")
|
||||
withLib pd (writeIORef lr)
|
||||
readIORef lr
|
||||
|
||||
componentsMap :: LocalBuildInfo
|
||||
-> Verbosity
|
||||
-> FilePath
|
||||
-> ( Component
|
||||
-> ComponentLocalBuildInfo
|
||||
-> BuildInfo
|
||||
-> IO a)
|
||||
-> IO [(GmComponentName, a)]
|
||||
componentsMap lbi v distdir f = do
|
||||
let pd = localPkgDescr lbi
|
||||
|
||||
lr <- newIORef []
|
||||
|
||||
withComponentsLBI pd lbi $ \c clbi -> do
|
||||
let bi = componentBuildInfo c
|
||||
name = componentNameFromComponent c
|
||||
|
||||
l' <- readIORef lr
|
||||
r <- f c clbi bi
|
||||
writeIORef lr $ (componentNameToGm name, r):l'
|
||||
reverse <$> readIORef lr
|
||||
|
||||
componentNameToGm CLibName = GmLibName
|
||||
componentNameToGm (CExeName n) = GmExeName n
|
||||
componentNameToGm (CTestName n) = GmTestName n
|
||||
componentNameToGm (CBenchName n) = GmBenchName n
|
||||
|
||||
componentNameFromComponent (CLib Library {}) = CLibName
|
||||
componentNameFromComponent (CExe Executable {..}) = CExeName exeName
|
||||
componentNameFromComponent (CTest TestSuite {..}) = CTestName testName
|
||||
componentNameFromComponent (CBench Benchmark {..}) = CBenchName benchmarkName
|
||||
|
||||
componentOutDir lbi (CLib Library {..})= buildDir lbi
|
||||
componentOutDir lbi (CExe Executable {..})= exeOutDir lbi exeName
|
||||
componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteExeV10 _ _, ..}) =
|
||||
exeOutDir lbi testName
|
||||
componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..}) =
|
||||
exeOutDir lbi (testName ++ "Stub")
|
||||
componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})=
|
||||
exeOutDir lbi benchmarkName
|
||||
|
||||
gmModuleName :: C.ModuleName -> GmModuleName
|
||||
gmModuleName = GmModuleName . intercalate "." . components
|
||||
|
||||
componentEntrypoints :: Component -> Either FilePath [GmModuleName]
|
||||
componentEntrypoints (CLib Library {..})
|
||||
= Right $ map gmModuleName $ exposedModules ++ (otherModules libBuildInfo)
|
||||
componentEntrypoints (CExe Executable {..})
|
||||
= Left modulePath
|
||||
componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp })
|
||||
= Left fp
|
||||
componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn })
|
||||
= Right [gmModuleName mn]
|
||||
componentEntrypoints (CTest TestSuite {})
|
||||
= Right []
|
||||
componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ fp})
|
||||
= Left fp
|
||||
componentEntrypoints (CBench Benchmark {})
|
||||
= Left []
|
||||
|
||||
exeOutDir :: LocalBuildInfo -> String -> FilePath
|
||||
exeOutDir lbi exeName =
|
||||
----- Copied from Distribution/Simple/GHC.hs:buildOrReplExe
|
||||
-- exeNameReal, the name that GHC really uses (with .exe on Windows)
|
||||
let exeNameReal = exeName <.>
|
||||
(if takeExtension exeName /= ('.':exeExtension)
|
||||
then exeExtension
|
||||
else "")
|
||||
|
||||
targetDir = (buildDir lbi) </> exeName
|
||||
in targetDir
|
||||
|
||||
|
||||
removeInplaceDeps :: PackageDescription
|
||||
-> ComponentLocalBuildInfo
|
||||
-> (ComponentLocalBuildInfo, GhcOptions)
|
||||
removeInplaceDeps pd clbi = let
|
||||
(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)
|
||||
|
||||
where
|
||||
isInplaceDep :: (InstalledPackageId, PackageId) -> Bool
|
||||
isInplaceDep (ipid, pid) = inplacePackageId pid == ipid
|
||||
|
||||
renderGhcOptions' lbi v opts = do
|
||||
#if CABAL_MAJOR == 1 && CABAL_MINOR < 20
|
||||
(ghcProg, _) <- requireProgram v ghcProgram (withPrograms lbi)
|
||||
let Just ghcVer = programVersion ghcProg
|
||||
return $ renderGhcOptions ghcVer opts
|
||||
#else
|
||||
return $ renderGhcOptions (compiler lbi) opts
|
||||
#endif
|
||||
|
|
@ -1,18 +0,0 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
module CabalHelper.Types where
|
||||
|
||||
newtype GmModuleName = GmModuleName String
|
||||
deriving (Read, Show)
|
||||
|
||||
data GmComponentName = GmSetupHsName
|
||||
| GmLibName
|
||||
| GmExeName String
|
||||
| GmTestName String
|
||||
| GmBenchName String
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
data GmCabalHelperResponse
|
||||
= GmCabalHelperStrings [(GmComponentName, [String])]
|
||||
| GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [GmModuleName])]
|
||||
| GmCabalHelperLbi String
|
||||
deriving (Read, Show)
|
||||
|
|
@ -1,418 +0,0 @@
|
|||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE TemplateHaskell, RecordWildCards, FlexibleContexts #-}
|
||||
module Main where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import Control.Exception as E
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String
|
||||
import Data.Version
|
||||
import Text.Printf
|
||||
import System.Console.GetOpt
|
||||
import System.Environment
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.Process
|
||||
import System.Exit
|
||||
import System.IO
|
||||
|
||||
import Distribution.System (buildPlatform)
|
||||
import Distribution.Text (display)
|
||||
|
||||
import NotCPP.Declarations
|
||||
|
||||
import Paths_ghc_mod
|
||||
import CabalHelper.Common
|
||||
import CabalHelper.GuessGhc
|
||||
import Utils
|
||||
|
||||
ifD [d| getExecutablePath = getProgName |]
|
||||
|
||||
usage :: IO ()
|
||||
usage = do
|
||||
prog <- getProgName
|
||||
hPutStr stderr $ align "(" "|" ("Usage: " ++ prog ++ " " ++ usageMsg)
|
||||
where
|
||||
usageMsg = "\
|
||||
\( print-appdatadir\n\
|
||||
\| print-build-platform\n\
|
||||
\| DIST_DIR ( print-exe | [CABAL_HELPER_ARGS...] ) )\n"
|
||||
|
||||
data Options = Options {
|
||||
ghcProgram :: FilePath
|
||||
, ghcPkgProgram :: FilePath
|
||||
, cabalProgram :: FilePath
|
||||
}
|
||||
|
||||
defaultOptions :: Options
|
||||
defaultOptions = Options "ghc" "ghc-pkg" "cabal"
|
||||
|
||||
globalArgSpec :: [OptDescr (Options -> Options)]
|
||||
globalArgSpec =
|
||||
[ option "" ["with-ghc"] "GHC executable to use" $
|
||||
reqArg "PROG" $ \p o -> o { ghcProgram = p }
|
||||
|
||||
, option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $
|
||||
reqArg "PROG" $ \p o -> o { ghcPkgProgram = p }
|
||||
|
||||
, option "" ["with-cabal"] "cabal-install executable to use" $
|
||||
reqArg "PROG" $ \p o -> o { cabalProgram = p }
|
||||
]
|
||||
where
|
||||
option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
|
||||
option s l udsc dsc = Option s l dsc udsc
|
||||
|
||||
reqArg :: String -> (String -> a) -> ArgDescr a
|
||||
reqArg udsc dsc = ReqArg dsc udsc
|
||||
|
||||
parseCommandArgs :: Options -> [String] -> (Options, [String])
|
||||
parseCommandArgs opts argv
|
||||
= case getOpt Permute globalArgSpec argv of
|
||||
(o,r,[]) -> (foldr id opts o, r)
|
||||
(_,_,errs) ->
|
||||
panic $ "Parsing command options failed: " ++ concat errs
|
||||
|
||||
guessProgramPaths :: Options -> IO Options
|
||||
guessProgramPaths opts = do
|
||||
if not (same ghcProgram opts dopts) && same ghcPkgProgram opts dopts
|
||||
then do
|
||||
mghcPkg <- guessToolFromGhcPath "ghc-pkg" (ghcProgram opts)
|
||||
return opts {
|
||||
ghcPkgProgram = fromMaybe (ghcPkgProgram opts) mghcPkg
|
||||
}
|
||||
else return opts
|
||||
where
|
||||
same f o o' = f o == f o'
|
||||
dopts = defaultOptions
|
||||
|
||||
main :: IO ()
|
||||
main = handlePanic $ do
|
||||
(opts', args) <- parseCommandArgs defaultOptions <$> getArgs
|
||||
opts <- guessProgramPaths opts'
|
||||
case args of
|
||||
[] -> usage
|
||||
"--help":[] -> usage
|
||||
"print-appdatadir":[] -> putStrLn =<< appDataDir
|
||||
"print-build-platform":[] -> putStrLn $ display buildPlatform
|
||||
distdir:args' -> do
|
||||
cfgf <- canonicalizePath (distdir </> "setup-config")
|
||||
mhdr <- getCabalConfigHeader cfgf
|
||||
case mhdr of
|
||||
Nothing -> panic $ printf "\
|
||||
\Could not read Cabal's persistent setup configuration header\n\
|
||||
\- Check first line of: %s\n\
|
||||
\- Maybe try: $ cabal configure" cfgf
|
||||
|
||||
Just (hdrCabalVersion, _hdrCompilerVersion) -> do
|
||||
eexe <- compileHelper opts hdrCabalVersion
|
||||
case eexe of
|
||||
Left e -> exitWith e
|
||||
Right exe ->
|
||||
case args' of
|
||||
"print-exe":_ -> putStrLn exe
|
||||
_ -> do
|
||||
(_,_,_,h) <- createProcess $ proc exe args
|
||||
exitWith =<< waitForProcess h
|
||||
|
||||
appDataDir :: IO FilePath
|
||||
appDataDir = (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
|
||||
|
||||
tryFindSrcDirInGhcModTree :: IO (Maybe FilePath)
|
||||
tryFindSrcDirInGhcModTree = do
|
||||
dir <- (!!4) . iterate takeDirectory <$> getExecutablePath
|
||||
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
|
||||
src_exists <- doesFileExist $ dir </> "CabalHelper/Main.hs"
|
||||
if exists && src_exists
|
||||
then return $ Just dir
|
||||
else return Nothing
|
||||
|
||||
tryFindRealSrcDir :: IO (Maybe FilePath)
|
||||
tryFindRealSrcDir = do
|
||||
datadir <- getDataDir
|
||||
exists <- doesFileExist $ datadir </> "CabalHelper/Main.hs"
|
||||
return $ if exists
|
||||
then Just datadir
|
||||
else Nothing
|
||||
|
||||
findCabalHelperSourceDir :: IO FilePath
|
||||
findCabalHelperSourceDir = do
|
||||
msrcdir <- runMaybeT $ MaybeT tryFindSrcDirInGhcModTree
|
||||
<|> MaybeT tryFindRealSrcDir
|
||||
case msrcdir of
|
||||
Nothing -> getDataDir >>= errorNoMain
|
||||
Just datadir -> return datadir
|
||||
|
||||
compileHelper :: Options -> Version -> IO (Either ExitCode FilePath)
|
||||
compileHelper opts cabalVer = do
|
||||
chdir <- findCabalHelperSourceDir
|
||||
run [ Right <$> MaybeT (cachedExe cabalVer chdir)
|
||||
, compileGlobal chdir
|
||||
, cachedCabalPkg chdir
|
||||
, compileCabalSource chdir
|
||||
, MaybeT (Just <$> compileSandbox chdir)
|
||||
]
|
||||
|
||||
where
|
||||
run actions = fromJust <$> runMaybeT (msum actions)
|
||||
|
||||
-- | Check if this version is globally available
|
||||
compileGlobal :: FilePath -> MaybeT IO (Either ExitCode FilePath)
|
||||
compileGlobal chdir = do
|
||||
_ <- MaybeT $ find (== cabalVer) <$> listCabalVersions opts
|
||||
liftIO $ compileWithPkg chdir Nothing
|
||||
|
||||
-- | Check if we already compiled this version of cabal into a private
|
||||
-- package-db
|
||||
cachedCabalPkg :: FilePath -> MaybeT IO (Either ExitCode FilePath)
|
||||
cachedCabalPkg chdir = do
|
||||
db_exists <- liftIO $ cabalPkgDbExists opts cabalVer
|
||||
case db_exists of
|
||||
False -> mzero
|
||||
True -> liftIO $ do
|
||||
db <- cabalPkgDb opts cabalVer
|
||||
compileWithPkg chdir (Just db)
|
||||
|
||||
-- | See if we're in a cabal source tree
|
||||
compileCabalSource :: FilePath -> MaybeT IO (Either ExitCode FilePath)
|
||||
compileCabalSource chdir = do
|
||||
couldBeSrcDir <- liftIO $ takeDirectory <$> getDataDir
|
||||
let cabalFile = couldBeSrcDir </> "Cabal.cabal"
|
||||
cabal <- liftIO $ doesFileExist cabalFile
|
||||
case cabal of
|
||||
False -> mzero
|
||||
True -> liftIO $ do
|
||||
ver <- cabalFileVersion <$> readFile cabalFile
|
||||
compileWithCabalTree chdir ver couldBeSrcDir
|
||||
|
||||
-- | Compile the requested cabal version into an isolated package-db
|
||||
compileSandbox :: FilePath -> IO (Either ExitCode FilePath)
|
||||
compileSandbox chdir = do
|
||||
db <- installCabal opts cabalVer `E.catch`
|
||||
\(SomeException _) -> errorInstallCabal cabalVer
|
||||
compileWithPkg chdir (Just db)
|
||||
|
||||
compileWithCabalTree chdir ver srcDir =
|
||||
compile opts $ Compile chdir (Just srcDir) Nothing ver []
|
||||
|
||||
compileWithPkg chdir mdb =
|
||||
compile opts $ Compile chdir Nothing mdb cabalVer [cabalPkgId cabalVer]
|
||||
|
||||
cabalPkgId v = "Cabal-" ++ showVersion v
|
||||
|
||||
-- errorNoCabal :: Version -> a
|
||||
-- errorNoCabal cabalVer = panic $ printf "\
|
||||
-- \No appropriate Cabal package found, wanted version %s.\n"
|
||||
-- where
|
||||
-- sver = showVersion cabalVer
|
||||
|
||||
errorInstallCabal :: Version -> a
|
||||
errorInstallCabal cabalVer = panic $ printf "\
|
||||
\Installing Cabal version %s failed.\n\
|
||||
\n\
|
||||
\You have two choices now:\n\
|
||||
\- Either you install this version of Cabal in your globa/luser package-db\n\
|
||||
\ somehow\n\
|
||||
\n\
|
||||
\- Or you can see if you can update your cabal-install to use a different\n\
|
||||
\ version of the Cabal library that we can build with:\n\
|
||||
\ $ cabal install cabal-install --constraint 'Cabal > %s'\n\
|
||||
\n\
|
||||
\To check the version cabal-install is currently using try:\n\
|
||||
\ $ cabal --version\n" sver sver
|
||||
where
|
||||
sver = showVersion cabalVer
|
||||
|
||||
errorNoMain :: FilePath -> a
|
||||
errorNoMain datadir = panic $ printf "\
|
||||
\Could not find $datadir/CabalHelper/Main.hs!\n\
|
||||
\\n\
|
||||
\If you are a developer you can use the environment variable `ghc_mod_datadir'\n\
|
||||
\to override $datadir[1], `$ export ghc_mod_datadir=$PWD' will work in the\n\
|
||||
\ghc-mod tree.\n\
|
||||
\[1]: %s\n\
|
||||
\\n\
|
||||
\If you don't know what I'm talking about something went wrong with your\n\
|
||||
\installation. Please report this problem here:\n\
|
||||
\ https://github.com/kazu-yamamoto/ghc-mod/issues" datadir
|
||||
|
||||
data Compile = Compile {
|
||||
cabalHelperSourceDir :: FilePath,
|
||||
cabalSourceDir :: Maybe FilePath,
|
||||
packageDb :: Maybe FilePath,
|
||||
cabalVersion :: Version,
|
||||
packageDeps :: [String]
|
||||
}
|
||||
|
||||
compile :: Options -> Compile -> IO (Either ExitCode FilePath)
|
||||
compile Options {..} Compile {..} = do
|
||||
outdir <- appDataDir
|
||||
createDirectoryIfMissing True outdir
|
||||
exe <- exePath cabalVersion
|
||||
|
||||
let Version (mj:mi:_) _ = cabalVersion
|
||||
let ghc_opts =
|
||||
concat [
|
||||
[ "-outputdir", outdir
|
||||
, "-o", exe
|
||||
, "-optP-DCABAL_HELPER=1"
|
||||
, "-optP-DCABAL_MAJOR=" ++ show mj
|
||||
, "-optP-DCABAL_MINOR=" ++ show mi
|
||||
],
|
||||
maybeToList $ ("-package-db="++) <$> packageDb,
|
||||
map ("-i"++) $ cabalHelperSourceDir:maybeToList cabalSourceDir,
|
||||
concatMap (\p -> ["-package", p]) packageDeps,
|
||||
[ "--make", cabalHelperSourceDir </> "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
|
||||
return $ case rv of
|
||||
ExitSuccess -> Right exe
|
||||
e@(ExitFailure _) -> Left e
|
||||
|
||||
exePath :: Version -> IO FilePath
|
||||
exePath cabalVersion = do
|
||||
outdir <- appDataDir
|
||||
return $ outdir </> "cabal-helper-" ++ showVersion cabalVersion
|
||||
|
||||
cachedExe :: Version -> FilePath -> IO (Maybe FilePath)
|
||||
cachedExe cabalVersion chdir = do
|
||||
exe <- exePath cabalVersion
|
||||
exists <- doesFileExist exe
|
||||
case exists of
|
||||
False -> return Nothing
|
||||
True -> do
|
||||
texe <- timeFile exe
|
||||
tsrcs <- mapM timeFile srcFiles
|
||||
return $ if any (texe <) tsrcs then Nothing else Just exe
|
||||
where
|
||||
srcFiles =
|
||||
map ((chdir </> "CabalHelper") </>) ["Main.hs", "Common.hs", "Types.hs"]
|
||||
|
||||
callProcessStderr' :: Maybe FilePath -> FilePath -> [String] -> IO ExitCode
|
||||
callProcessStderr' mwd exe args = do
|
||||
(_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr
|
||||
, cwd = mwd }
|
||||
waitForProcess h
|
||||
|
||||
callProcessStderr :: Maybe FilePath -> FilePath -> [String] -> IO ()
|
||||
callProcessStderr mwd exe args = do
|
||||
rv <- callProcessStderr' mwd exe args
|
||||
case rv of
|
||||
ExitSuccess -> return ()
|
||||
ExitFailure v -> processFailedException "callProcessStderr" exe args v
|
||||
|
||||
processFailedException :: String -> String -> [String] -> Int -> IO a
|
||||
processFailedException fn exe args rv =
|
||||
panic $ concat [fn, ": ", exe, " "
|
||||
, intercalate " " (map show args)
|
||||
, " (exit " ++ show rv ++ ")"]
|
||||
|
||||
installCabal :: Options -> Version -> IO FilePath
|
||||
installCabal opts ver = do
|
||||
appdir <- appDataDir
|
||||
hPutStr stderr $ printf "\
|
||||
\cabal-helper-wrapper: Installing a private copy of Cabal, this might take a\n\
|
||||
\while but will only happen once per Cabal version.\n\
|
||||
\\n\
|
||||
\If anything goes horribly wrong just delete this directory and try again:\n\
|
||||
\ %s\n\
|
||||
\\n\
|
||||
\If you want to avoid this automatic installation altogether install version\n\
|
||||
\%s of Cabal manually (into your use or global package-db):\n\
|
||||
\ $ cabal install Cabal-%s\n\
|
||||
\..." appdir (showVersion ver) (showVersion ver)
|
||||
|
||||
db <- createPkgDb opts ver
|
||||
callProcessStderr (Just "/") (cabalProgram opts) $ concat
|
||||
[
|
||||
[ "--package-db=clear"
|
||||
, "--package-db=global"
|
||||
, "--package-db=" ++ db
|
||||
, "--prefix=" ++ db </> "prefix"
|
||||
, "-v0"
|
||||
, "--with-ghc=" ++ ghcProgram opts
|
||||
]
|
||||
, if ghcPkgProgram opts /= ghcPkgProgram defaultOptions
|
||||
then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ]
|
||||
else []
|
||||
, [ "install", "Cabal-"++showVersion ver ]
|
||||
]
|
||||
hPutStrLn stderr "Done"
|
||||
return db
|
||||
|
||||
ghcVersion :: Options -> IO Version
|
||||
ghcVersion Options {..} = do
|
||||
parseVer . trim <$> readProcess ghcProgram ["--numeric-version"] ""
|
||||
|
||||
ghcPkgVersion :: Options -> IO Version
|
||||
ghcPkgVersion Options {..} = do
|
||||
parseVer . trim <$> readProcess ghcPkgProgram ["--numeric-version"] ""
|
||||
|
||||
trim :: String -> String
|
||||
trim = dropWhileEnd isSpace
|
||||
|
||||
createPkgDb :: Options -> Version -> IO FilePath
|
||||
createPkgDb opts@Options {..} ver = do
|
||||
db <- cabalPkgDb opts ver
|
||||
exists <- doesDirectoryExist db
|
||||
when (not exists) $ callProcessStderr Nothing ghcPkgProgram ["init", db]
|
||||
return db
|
||||
|
||||
cabalPkgDb :: Options -> Version -> IO FilePath
|
||||
cabalPkgDb opts ver = do
|
||||
appdir <- appDataDir
|
||||
ghcVer <- ghcVersion opts
|
||||
return $ appdir </> "Cabal-" ++ showVersion ver ++ "-db-" ++ showVersion ghcVer
|
||||
|
||||
cabalPkgDbExists :: Options -> Version -> IO Bool
|
||||
cabalPkgDbExists opts ver = do
|
||||
db <- cabalPkgDb opts ver
|
||||
dexists <- doesDirectoryExist db
|
||||
case dexists of
|
||||
False -> return False
|
||||
True -> do
|
||||
vers <- listCabalVersions' opts (Just db)
|
||||
return $ ver `elem` vers
|
||||
|
||||
listCabalVersions :: Options -> IO [Version]
|
||||
listCabalVersions opts = listCabalVersions' opts Nothing
|
||||
|
||||
-- TODO: Include sandbox? Probably only relevant for build-type:custom projects.
|
||||
listCabalVersions' :: Options -> Maybe FilePath -> IO [Version]
|
||||
listCabalVersions' Options {..} mdb = do
|
||||
let mdbopt = ("--package-db="++) <$> mdb
|
||||
opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
|
||||
|
||||
catMaybes . map (fmap snd . parsePkgId . fromString) . words
|
||||
<$> readProcess ghcPkgProgram opts ""
|
||||
|
||||
-- | Find @version: XXX@ delcaration in a cabal file
|
||||
cabalFileVersion :: String -> Version
|
||||
cabalFileVersion cabalFile = do
|
||||
fromJust $ parseVer . extract <$> find ("version" `isPrefixOf`) ls
|
||||
where
|
||||
ls = map (map toLower) $ lines cabalFile
|
||||
extract = dropWhile (/=':') >>> dropWhile isSpace >>> takeWhile (not . isSpace)
|
||||
|
|
@ -58,6 +58,7 @@ module Language.Haskell.GhcMod (
|
|||
import Language.Haskell.GhcMod.Boot
|
||||
import Language.Haskell.GhcMod.Browse
|
||||
import Language.Haskell.GhcMod.CaseSplit
|
||||
import Language.Haskell.GhcMod.CabalHelper
|
||||
import Language.Haskell.GhcMod.Check
|
||||
import Language.Haskell.GhcMod.Cradle
|
||||
import Language.Haskell.GhcMod.Debug
|
||||
|
|
@ -72,3 +73,4 @@ import Language.Haskell.GhcMod.Modules
|
|||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.PkgDoc
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Target
|
||||
|
|
|
|||
|
|
@ -15,21 +15,18 @@
|
|||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
module Language.Haskell.GhcMod.CabalHelper (
|
||||
CabalHelper(..)
|
||||
, getComponents
|
||||
, getGhcOptions
|
||||
getComponents
|
||||
, getGhcPkgOptions
|
||||
, cabalHelper
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import Control.Monad
|
||||
import Data.Monoid
|
||||
import Data.List
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Distribution.Helper
|
||||
import qualified Language.Haskell.GhcMod.Types as T
|
||||
import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram,
|
||||
cabalProgram)
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Language.Haskell.GhcMod.Error as E
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Language.Haskell.GhcMod.World
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
|
|
@ -37,26 +34,42 @@ import System.FilePath
|
|||
|
||||
-- | Only package related GHC options, sufficient for things that don't need to
|
||||
-- access home modules
|
||||
getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])]
|
||||
getGhcPkgOptions = chGhcPkgOptions `liftM` cabalHelper
|
||||
getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(ChComponentName, [GHCOption])]
|
||||
getGhcPkgOptions = do
|
||||
Cradle {..} <- cradle
|
||||
let distdir = cradleRootDir </> "dist"
|
||||
runQuery distdir ghcPkgOptions
|
||||
|
||||
getGhcOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])]
|
||||
getGhcOptions = chGhcOptions `liftM` cabalHelper
|
||||
helperProgs :: Options -> Programs
|
||||
helperProgs opts = Programs {
|
||||
cabalProgram = T.cabalProgram opts,
|
||||
ghcProgram = T.ghcProgram opts,
|
||||
ghcPkgProgram = T.ghcPkgProgram opts
|
||||
}
|
||||
|
||||
-- | Primary interface to cabal-helper and intended single entrypoint to
|
||||
-- constructing 'GmComponent's
|
||||
--
|
||||
-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
|
||||
-- 'resolveGmComponents'.
|
||||
getComponents :: (MonadIO m, GmEnv m)
|
||||
=> m [GmComponent (Either FilePath [ModuleName])]
|
||||
getComponents = cabalHelper >>= \CabalHelper {..} -> return $ let
|
||||
([(scn, sep)], eps) = partition ((GmSetupHsName ==) . fst) chEntrypoints
|
||||
sc = GmComponent scn [] [] sep sep ["."] mempty
|
||||
cs = flip map (zip4 eps chGhcOptions chGhcSrcOptions chSourceDirs) $
|
||||
\((cn, ep), (_, opts), (_, srcOpts), (_, srcDirs)) ->
|
||||
getComponents :: (MonadIO m, GmEnv m) => m [GmComponent ChEntrypoint]
|
||||
getComponents = withCabal $ do
|
||||
Cradle {..} <- cradle
|
||||
let distdir = cradleRootDir </> "dist"
|
||||
opt <- options
|
||||
|
||||
runQuery' (helperProgs opt) distdir $ do
|
||||
q <- liftM4 join4 ghcOptions ghcSrcOptions entrypoints sourceDirs
|
||||
return $ flip map q $ \(cn, (opts, (srcOpts, (ep, srcDirs)))) ->
|
||||
GmComponent cn opts srcOpts ep ep srcDirs mempty
|
||||
in sc:cs
|
||||
where
|
||||
join4 a b c = join' a . join' b . join' c
|
||||
join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]
|
||||
join' lb lc = [ (a, (b, c))
|
||||
| (a, b) <- lb
|
||||
, (a', c) <- lc
|
||||
, a == a'
|
||||
]
|
||||
|
||||
withCabal :: (MonadIO m, GmEnv m) => m a -> m a
|
||||
withCabal action = do
|
||||
|
|
@ -65,58 +78,11 @@ withCabal action = do
|
|||
liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $
|
||||
withDirectory_ (cradleRootDir crdl) $ do
|
||||
let progOpts =
|
||||
[ "--with-ghc=" ++ ghcProgram opts ]
|
||||
[ "--with-ghc=" ++ T.ghcProgram opts ]
|
||||
-- Only pass ghc-pkg if it was actually set otherwise we
|
||||
-- might break cabal's guessing logic
|
||||
++ if ghcPkgProgram opts /= ghcPkgProgram defaultOptions
|
||||
then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ]
|
||||
++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
|
||||
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
|
||||
else []
|
||||
void $ readProcess (cabalProgram opts) ("configure":progOpts) ""
|
||||
void $ readProcess (T.cabalProgram opts) ("configure":progOpts) ""
|
||||
action
|
||||
|
||||
data CabalHelper = CabalHelper {
|
||||
chEntrypoints :: [(GmComponentName, Either FilePath [ModuleName])],
|
||||
chSourceDirs :: [(GmComponentName, [String])],
|
||||
chGhcOptions :: [(GmComponentName, [String])],
|
||||
chGhcSrcOptions :: [(GmComponentName, [String])],
|
||||
chGhcPkgOptions :: [(GmComponentName, [String])]
|
||||
} deriving (Show)
|
||||
|
||||
cabalHelper :: (MonadIO m, GmEnv m) => m CabalHelper
|
||||
cabalHelper = withCabal $ do
|
||||
Cradle {..} <- cradle
|
||||
Options {..} <- options
|
||||
let progArgs = [ "--with-ghc=" ++ ghcProgram
|
||||
, "--with-ghc-pkg=" ++ ghcPkgProgram
|
||||
, "--with-cabal=" ++ cabalProgram
|
||||
]
|
||||
|
||||
let args = [ "entrypoints"
|
||||
, "source-dirs"
|
||||
, "ghc-options"
|
||||
, "ghc-src-options"
|
||||
, "ghc-pkg-options"
|
||||
] ++ progArgs
|
||||
|
||||
distdir = cradleRootDir </> "dist"
|
||||
|
||||
res <- liftIO $ do
|
||||
exe <- findLibexecExe "cabal-helper-wrapper"
|
||||
hexe <- readProcess exe ([distdir, "print-exe"] ++ progArgs) ""
|
||||
|
||||
cached cradleRootDir (cabalHelperCache hexe args) $ do
|
||||
out <- readProcess exe (distdir:args) ""
|
||||
evaluate (read out) `E.catch`
|
||||
\(SomeException _) -> error "cabalHelper: read failed"
|
||||
|
||||
let [ Just (GmCabalHelperEntrypoints eps),
|
||||
Just (GmCabalHelperStrings srcDirs),
|
||||
Just (GmCabalHelperStrings ghcOpts),
|
||||
Just (GmCabalHelperStrings ghcSrcOpts),
|
||||
Just (GmCabalHelperStrings ghcPkgOpts) ] = res
|
||||
eps' = map (second $ fmap $ map md) eps
|
||||
|
||||
return $ CabalHelper eps' srcDirs ghcOpts ghcSrcOpts ghcPkgOpts
|
||||
|
||||
where
|
||||
md (GmModuleName mn) = mkModuleName mn
|
||||
|
|
|
|||
|
|
@ -103,6 +103,7 @@ import Data.Map (Map, empty)
|
|||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import Data.IORef
|
||||
import Distribution.Helper
|
||||
|
||||
import MonadUtils (MonadIO(..))
|
||||
|
||||
|
|
@ -128,7 +129,7 @@ data GmGhcSession = GmGhcSession {
|
|||
|
||||
data GhcModState = GhcModState {
|
||||
gmGhcSession :: !(Maybe GmGhcSession)
|
||||
, gmComponents :: !(Map GmComponentName (GmComponent (Set ModulePath)))
|
||||
, gmComponents :: !(Map ChComponentName (GmComponent (Set ModulePath)))
|
||||
, gmCompilerMode :: !CompilerMode
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -23,7 +23,9 @@ import Control.Monad.Trans.Maybe
|
|||
import Data.List
|
||||
import Data.Char
|
||||
import Data.Maybe
|
||||
import Data.Version
|
||||
import Data.Traversable (traverse)
|
||||
import Distribution.Helper
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.IO.Unsafe
|
||||
|
|
@ -233,11 +235,11 @@ cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $
|
|||
packageCache :: String
|
||||
packageCache = "package.cache"
|
||||
|
||||
cabalHelperCache ::
|
||||
FilePath -> [String] -> Cached [String] [Maybe GmCabalHelperResponse]
|
||||
cabalHelperCache cabalHelperExe cmds = Cached {
|
||||
inputFiles = [cabalHelperExe, setupConfigPath],
|
||||
inputData = cmds,
|
||||
cabalHelperCache :: Version -> [String]
|
||||
-> Cached (Version, [String]) [GmComponent ChEntrypoint]
|
||||
cabalHelperCache cabalHelperVer cmds = Cached {
|
||||
inputFiles = [setupConfigPath],
|
||||
inputData = (cabalHelperVer, cmds),
|
||||
cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper"
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@ module Language.Haskell.GhcMod.Pretty where
|
|||
import Control.Arrow hiding ((<+>))
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Distribution.Helper
|
||||
import Text.PrettyPrint
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
|
|
@ -29,12 +30,12 @@ docStyle = style { ribbonsPerLine = 1.2 }
|
|||
gmRenderDoc :: Doc -> String
|
||||
gmRenderDoc = renderStyle docStyle
|
||||
|
||||
gmComponentNameDoc :: GmComponentName -> Doc
|
||||
gmComponentNameDoc GmSetupHsName = text $ "Setup.hs"
|
||||
gmComponentNameDoc GmLibName = text $ "library"
|
||||
gmComponentNameDoc (GmExeName n) = text $ "exe:" ++ n
|
||||
gmComponentNameDoc (GmTestName n) = text $ "test:" ++ n
|
||||
gmComponentNameDoc (GmBenchName n) = text $ "bench:" ++ n
|
||||
gmComponentNameDoc :: ChComponentName -> Doc
|
||||
gmComponentNameDoc ChSetupHsName = text $ "Setup.hs"
|
||||
gmComponentNameDoc ChLibName = text $ "library"
|
||||
gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n
|
||||
gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n
|
||||
gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n
|
||||
|
||||
gmLogLevelDoc :: GmLogLevel -> Doc
|
||||
gmLogLevelDoc GmPanic = text "PANIC"
|
||||
|
|
|
|||
|
|
@ -46,6 +46,7 @@ import Data.Map (Map)
|
|||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Distribution.Helper
|
||||
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
|
@ -185,9 +186,9 @@ targetGhcOptions crdl sefnmn = do
|
|||
let cn = pickComponent candidates
|
||||
return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
|
||||
|
||||
moduleComponents :: Map GmComponentName (GmComponent (Set ModulePath))
|
||||
moduleComponents :: Map ChComponentName (GmComponent (Set ModulePath))
|
||||
-> Either FilePath ModuleName
|
||||
-> Set GmComponentName
|
||||
-> Set ChComponentName
|
||||
moduleComponents m efnmn =
|
||||
foldr' Set.empty m $ \c s ->
|
||||
let
|
||||
|
|
@ -203,10 +204,9 @@ moduleComponents m efnmn =
|
|||
|
||||
foldr' b as f = Map.foldr f b as
|
||||
|
||||
pickComponent :: Set GmComponentName -> GmComponentName
|
||||
pickComponent :: Set ChComponentName -> ChComponentName
|
||||
pickComponent scn = Set.findMin scn
|
||||
|
||||
|
||||
packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption]
|
||||
packageGhcOptions = do
|
||||
crdl <- cradle
|
||||
|
|
@ -223,14 +223,16 @@ sandboxOpts crdl = return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts
|
|||
|
||||
resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
|
||||
=> Maybe [Either FilePath ModuleName] -- ^ Updated modules
|
||||
-> GmComponent (Either FilePath [ModuleName])
|
||||
-> GmComponent ChEntrypoint
|
||||
-> m (GmComponent (Set ModulePath))
|
||||
resolveGmComponent mums c@GmComponent {..} =
|
||||
withLightHscEnv gmcGhcSrcOpts $ \env -> do
|
||||
let srcDirs = gmcSourceDirs
|
||||
mg = gmcHomeModuleGraph
|
||||
|
||||
let eps = either (return . Left) (map Right) gmcEntrypoints
|
||||
Cradle { cradleRootDir } <- cradle
|
||||
|
||||
eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
|
||||
simp <- liftIO $ resolveEntrypoints env srcDirs eps
|
||||
sump <- liftIO $ case mums of
|
||||
Nothing -> return simp
|
||||
|
|
@ -263,11 +265,30 @@ resolveEntrypoints env srcDirs ms =
|
|||
findFile' dirs file =
|
||||
mconcat <$> mapM (mightExist . (</>file)) dirs
|
||||
|
||||
resolveChEntrypoints ::
|
||||
FilePath -> ChEntrypoint -> IO [Either FilePath ModuleName]
|
||||
resolveChEntrypoints _ (ChLibEntrypoint em om) =
|
||||
return $ map (Right . chModToMod) (em ++ om)
|
||||
|
||||
resolveChEntrypoints _ (ChExeEntrypoint main om) =
|
||||
return $ [Left main] ++ map (Right . chModToMod) om
|
||||
|
||||
resolveChEntrypoints srcDir ChSetupEntrypoint = do
|
||||
shs <- doesFileExist (srcDir </> "Setup.hs")
|
||||
slhs <- doesFileExist (srcDir </> "Setup.lhs")
|
||||
return $ case (shs, slhs) of
|
||||
(True, _) -> [Left "Setup.hs"]
|
||||
(_, True) -> [Left "Setup.lhs"]
|
||||
(False, False) -> []
|
||||
|
||||
chModToMod :: ChModuleName -> ModuleName
|
||||
chModToMod (ChModuleName mn) = mkModuleName mn
|
||||
|
||||
resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
|
||||
=> Maybe [Either FilePath ModuleName]
|
||||
-- ^ Updated modules
|
||||
-> [GmComponent (Either FilePath [ModuleName])]
|
||||
-> m (Map GmComponentName (GmComponent (Set ModulePath)))
|
||||
-> [GmComponent ChEntrypoint]
|
||||
-> m (Map ChComponentName (GmComponent (Set ModulePath)))
|
||||
resolveGmComponents mumns cs = do
|
||||
s <- gmsGet
|
||||
m' <- foldrM' (gmComponents s) cs $ \c m -> do
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
|
||||
module Language.Haskell.GhcMod.Types (
|
||||
module Language.Haskell.GhcMod.Types
|
||||
, module CabalHelper.Types
|
||||
, ModuleName
|
||||
, mkModuleName
|
||||
, moduleNameString
|
||||
|
|
@ -18,13 +17,12 @@ import Data.Set (Set)
|
|||
import qualified Data.Set as Set
|
||||
import Data.Monoid
|
||||
import Data.Typeable (Typeable)
|
||||
import Distribution.Helper
|
||||
import Exception (ExceptionMonad)
|
||||
import MonadUtils (MonadIO)
|
||||
import GHC (ModuleName, moduleNameString, mkModuleName)
|
||||
import PackageConfig (PackageConfig)
|
||||
|
||||
import CabalHelper.Types
|
||||
|
||||
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
|
||||
-- 'GhcModT' somewhat cleaner.
|
||||
--
|
||||
|
|
@ -168,10 +166,10 @@ instance Monoid GmModuleGraph where
|
|||
GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c')
|
||||
|
||||
data GmComponent eps = GmComponent {
|
||||
gmcName :: GmComponentName,
|
||||
gmcName :: ChComponentName,
|
||||
gmcGhcOpts :: [GHCOption],
|
||||
gmcGhcSrcOpts :: [GHCOption],
|
||||
gmcRawEntrypoints :: Either FilePath [ModuleName],
|
||||
gmcRawEntrypoints :: ChEntrypoint,
|
||||
gmcEntrypoints :: eps,
|
||||
gmcSourceDirs :: [FilePath],
|
||||
gmcHomeModuleGraph :: GmModuleGraph
|
||||
|
|
@ -204,10 +202,10 @@ data GhcModError
|
|||
| GMECabalFlags GhcModError
|
||||
-- ^ Retrieval of the cabal configuration flags failed.
|
||||
|
||||
| GMECabalComponent GmComponentName
|
||||
| GMECabalComponent ChComponentName
|
||||
-- ^ Cabal component could not be found
|
||||
|
||||
| GMECabalCompAssignment [(Either FilePath ModuleName, Set GmComponentName)]
|
||||
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
|
||||
-- ^ Could not find a consistent component assignment for modules
|
||||
|
||||
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
||||
|
|
|
|||
|
|
@ -24,7 +24,6 @@ Cabal-Version: >= 1.16
|
|||
Build-Type: Custom
|
||||
Data-Files: elisp/Makefile
|
||||
elisp/*.el
|
||||
CabalHelper/*.hs
|
||||
|
||||
Extra-Source-Files: ChangeLog
|
||||
SetupCompat.hs
|
||||
|
|
@ -78,7 +77,6 @@ Library
|
|||
Language.Haskell.GhcMod.Internal
|
||||
Other-Modules: Paths_ghc_mod
|
||||
Utils
|
||||
CabalHelper.Types
|
||||
Language.Haskell.GhcMod.Boot
|
||||
Language.Haskell.GhcMod.Browse
|
||||
Language.Haskell.GhcMod.CaseSplit
|
||||
|
|
@ -116,6 +114,7 @@ Library
|
|||
Build-Depends: base >= 4.0 && < 5
|
||||
, bytestring
|
||||
, containers
|
||||
, cabal-helper >= 0.3
|
||||
, deepseq
|
||||
, directory
|
||||
, filepath
|
||||
|
|
@ -186,27 +185,6 @@ Executable ghc-modi
|
|||
, ghc
|
||||
, ghc-mod
|
||||
|
||||
Executable cabal-helper-wrapper
|
||||
Default-Language: Haskell2010
|
||||
Other-Extensions: TemplateHaskell
|
||||
Main-Is: CabalHelper/Wrapper.hs
|
||||
Other-Modules: Paths_ghc_mod
|
||||
GHC-Options: -Wall
|
||||
HS-Source-Dirs: .
|
||||
X-Install-Target: $libexecdir
|
||||
Build-Depends: base >= 4.0 && < 5
|
||||
, bytestring
|
||||
, binary
|
||||
, containers
|
||||
, Cabal >= 1.14
|
||||
, directory
|
||||
, filepath
|
||||
, old-time
|
||||
, process
|
||||
, transformers
|
||||
, template-haskell
|
||||
, time
|
||||
|
||||
Test-Suite doctest
|
||||
Type: exitcode-stdio-1.0
|
||||
Default-Language: Haskell2010
|
||||
|
|
|
|||
Loading…
Reference in New Issue