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.Boot
|
||||||
import Language.Haskell.GhcMod.Browse
|
import Language.Haskell.GhcMod.Browse
|
||||||
import Language.Haskell.GhcMod.CaseSplit
|
import Language.Haskell.GhcMod.CaseSplit
|
||||||
|
import Language.Haskell.GhcMod.CabalHelper
|
||||||
import Language.Haskell.GhcMod.Check
|
import Language.Haskell.GhcMod.Check
|
||||||
import Language.Haskell.GhcMod.Cradle
|
import Language.Haskell.GhcMod.Cradle
|
||||||
import Language.Haskell.GhcMod.Debug
|
import Language.Haskell.GhcMod.Debug
|
||||||
@ -72,3 +73,4 @@ import Language.Haskell.GhcMod.Modules
|
|||||||
import Language.Haskell.GhcMod.Monad
|
import Language.Haskell.GhcMod.Monad
|
||||||
import Language.Haskell.GhcMod.PkgDoc
|
import Language.Haskell.GhcMod.PkgDoc
|
||||||
import Language.Haskell.GhcMod.Types
|
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/>.
|
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
module Language.Haskell.GhcMod.CabalHelper (
|
module Language.Haskell.GhcMod.CabalHelper (
|
||||||
CabalHelper(..)
|
getComponents
|
||||||
, getComponents
|
|
||||||
, getGhcOptions
|
|
||||||
, getGhcPkgOptions
|
, getGhcPkgOptions
|
||||||
, cabalHelper
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Arrow
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.List
|
import Distribution.Helper
|
||||||
import Language.Haskell.GhcMod.Types
|
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.Monad.Types
|
||||||
import Language.Haskell.GhcMod.Error as E
|
|
||||||
import Language.Haskell.GhcMod.Utils
|
import Language.Haskell.GhcMod.Utils
|
||||||
import Language.Haskell.GhcMod.World
|
import Language.Haskell.GhcMod.World
|
||||||
import Language.Haskell.GhcMod.PathsAndFiles
|
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
|
-- | Only package related GHC options, sufficient for things that don't need to
|
||||||
-- access home modules
|
-- access home modules
|
||||||
getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])]
|
getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(ChComponentName, [GHCOption])]
|
||||||
getGhcPkgOptions = chGhcPkgOptions `liftM` cabalHelper
|
getGhcPkgOptions = do
|
||||||
|
Cradle {..} <- cradle
|
||||||
|
let distdir = cradleRootDir </> "dist"
|
||||||
|
runQuery distdir ghcPkgOptions
|
||||||
|
|
||||||
getGhcOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])]
|
helperProgs :: Options -> Programs
|
||||||
getGhcOptions = chGhcOptions `liftM` cabalHelper
|
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
|
-- | Primary interface to cabal-helper and intended single entrypoint to
|
||||||
-- constructing 'GmComponent's
|
-- constructing 'GmComponent's
|
||||||
--
|
--
|
||||||
-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
|
-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
|
||||||
-- 'resolveGmComponents'.
|
-- 'resolveGmComponents'.
|
||||||
getComponents :: (MonadIO m, GmEnv m)
|
getComponents :: (MonadIO m, GmEnv m) => m [GmComponent ChEntrypoint]
|
||||||
=> m [GmComponent (Either FilePath [ModuleName])]
|
getComponents = withCabal $ do
|
||||||
getComponents = cabalHelper >>= \CabalHelper {..} -> return $ let
|
Cradle {..} <- cradle
|
||||||
([(scn, sep)], eps) = partition ((GmSetupHsName ==) . fst) chEntrypoints
|
let distdir = cradleRootDir </> "dist"
|
||||||
sc = GmComponent scn [] [] sep sep ["."] mempty
|
opt <- options
|
||||||
cs = flip map (zip4 eps chGhcOptions chGhcSrcOptions chSourceDirs) $
|
|
||||||
\((cn, ep), (_, opts), (_, srcOpts), (_, srcDirs)) ->
|
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
|
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 :: (MonadIO m, GmEnv m) => m a -> m a
|
||||||
withCabal action = do
|
withCabal action = do
|
||||||
@ -65,58 +78,11 @@ withCabal action = do
|
|||||||
liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $
|
liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $
|
||||||
withDirectory_ (cradleRootDir crdl) $ do
|
withDirectory_ (cradleRootDir crdl) $ do
|
||||||
let progOpts =
|
let progOpts =
|
||||||
[ "--with-ghc=" ++ ghcProgram opts ]
|
[ "--with-ghc=" ++ T.ghcProgram opts ]
|
||||||
-- Only pass ghc-pkg if it was actually set otherwise we
|
-- Only pass ghc-pkg if it was actually set otherwise we
|
||||||
-- might break cabal's guessing logic
|
-- might break cabal's guessing logic
|
||||||
++ if ghcPkgProgram opts /= ghcPkgProgram defaultOptions
|
++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
|
||||||
then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ]
|
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
|
||||||
else []
|
else []
|
||||||
void $ readProcess (cabalProgram opts) ("configure":progOpts) ""
|
void $ readProcess (T.cabalProgram opts) ("configure":progOpts) ""
|
||||||
action
|
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.Maybe
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
|
import Distribution.Helper
|
||||||
|
|
||||||
import MonadUtils (MonadIO(..))
|
import MonadUtils (MonadIO(..))
|
||||||
|
|
||||||
@ -128,7 +129,7 @@ data GmGhcSession = GmGhcSession {
|
|||||||
|
|
||||||
data GhcModState = GhcModState {
|
data GhcModState = GhcModState {
|
||||||
gmGhcSession :: !(Maybe GmGhcSession)
|
gmGhcSession :: !(Maybe GmGhcSession)
|
||||||
, gmComponents :: !(Map GmComponentName (GmComponent (Set ModulePath)))
|
, gmComponents :: !(Map ChComponentName (GmComponent (Set ModulePath)))
|
||||||
, gmCompilerMode :: !CompilerMode
|
, gmCompilerMode :: !CompilerMode
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@ -23,7 +23,9 @@ import Control.Monad.Trans.Maybe
|
|||||||
import Data.List
|
import Data.List
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import Data.Version
|
||||||
import Data.Traversable (traverse)
|
import Data.Traversable (traverse)
|
||||||
|
import Distribution.Helper
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO.Unsafe
|
import System.IO.Unsafe
|
||||||
@ -233,11 +235,11 @@ cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $
|
|||||||
packageCache :: String
|
packageCache :: String
|
||||||
packageCache = "package.cache"
|
packageCache = "package.cache"
|
||||||
|
|
||||||
cabalHelperCache ::
|
cabalHelperCache :: Version -> [String]
|
||||||
FilePath -> [String] -> Cached [String] [Maybe GmCabalHelperResponse]
|
-> Cached (Version, [String]) [GmComponent ChEntrypoint]
|
||||||
cabalHelperCache cabalHelperExe cmds = Cached {
|
cabalHelperCache cabalHelperVer cmds = Cached {
|
||||||
inputFiles = [cabalHelperExe, setupConfigPath],
|
inputFiles = [setupConfigPath],
|
||||||
inputData = cmds,
|
inputData = (cabalHelperVer, cmds),
|
||||||
cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper"
|
cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper"
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@ -19,6 +19,7 @@ module Language.Haskell.GhcMod.Pretty where
|
|||||||
import Control.Arrow hiding ((<+>))
|
import Control.Arrow hiding ((<+>))
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.List
|
import Data.List
|
||||||
|
import Distribution.Helper
|
||||||
import Text.PrettyPrint
|
import Text.PrettyPrint
|
||||||
|
|
||||||
import Language.Haskell.GhcMod.Types
|
import Language.Haskell.GhcMod.Types
|
||||||
@ -29,12 +30,12 @@ docStyle = style { ribbonsPerLine = 1.2 }
|
|||||||
gmRenderDoc :: Doc -> String
|
gmRenderDoc :: Doc -> String
|
||||||
gmRenderDoc = renderStyle docStyle
|
gmRenderDoc = renderStyle docStyle
|
||||||
|
|
||||||
gmComponentNameDoc :: GmComponentName -> Doc
|
gmComponentNameDoc :: ChComponentName -> Doc
|
||||||
gmComponentNameDoc GmSetupHsName = text $ "Setup.hs"
|
gmComponentNameDoc ChSetupHsName = text $ "Setup.hs"
|
||||||
gmComponentNameDoc GmLibName = text $ "library"
|
gmComponentNameDoc ChLibName = text $ "library"
|
||||||
gmComponentNameDoc (GmExeName n) = text $ "exe:" ++ n
|
gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n
|
||||||
gmComponentNameDoc (GmTestName n) = text $ "test:" ++ n
|
gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n
|
||||||
gmComponentNameDoc (GmBenchName n) = text $ "bench:" ++ n
|
gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n
|
||||||
|
|
||||||
gmLogLevelDoc :: GmLogLevel -> Doc
|
gmLogLevelDoc :: GmLogLevel -> Doc
|
||||||
gmLogLevelDoc GmPanic = text "PANIC"
|
gmLogLevelDoc GmPanic = text "PANIC"
|
||||||
|
|||||||
@ -46,6 +46,7 @@ import Data.Map (Map)
|
|||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
import Distribution.Helper
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
@ -185,9 +186,9 @@ targetGhcOptions crdl sefnmn = do
|
|||||||
let cn = pickComponent candidates
|
let cn = pickComponent candidates
|
||||||
return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
|
return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
|
||||||
|
|
||||||
moduleComponents :: Map GmComponentName (GmComponent (Set ModulePath))
|
moduleComponents :: Map ChComponentName (GmComponent (Set ModulePath))
|
||||||
-> Either FilePath ModuleName
|
-> Either FilePath ModuleName
|
||||||
-> Set GmComponentName
|
-> Set ChComponentName
|
||||||
moduleComponents m efnmn =
|
moduleComponents m efnmn =
|
||||||
foldr' Set.empty m $ \c s ->
|
foldr' Set.empty m $ \c s ->
|
||||||
let
|
let
|
||||||
@ -203,10 +204,9 @@ moduleComponents m efnmn =
|
|||||||
|
|
||||||
foldr' b as f = Map.foldr f b as
|
foldr' b as f = Map.foldr f b as
|
||||||
|
|
||||||
pickComponent :: Set GmComponentName -> GmComponentName
|
pickComponent :: Set ChComponentName -> ChComponentName
|
||||||
pickComponent scn = Set.findMin scn
|
pickComponent scn = Set.findMin scn
|
||||||
|
|
||||||
|
|
||||||
packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption]
|
packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption]
|
||||||
packageGhcOptions = do
|
packageGhcOptions = do
|
||||||
crdl <- cradle
|
crdl <- cradle
|
||||||
@ -223,14 +223,16 @@ sandboxOpts crdl = return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts
|
|||||||
|
|
||||||
resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
|
resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
|
||||||
=> Maybe [Either FilePath ModuleName] -- ^ Updated modules
|
=> Maybe [Either FilePath ModuleName] -- ^ Updated modules
|
||||||
-> GmComponent (Either FilePath [ModuleName])
|
-> GmComponent ChEntrypoint
|
||||||
-> m (GmComponent (Set ModulePath))
|
-> m (GmComponent (Set ModulePath))
|
||||||
resolveGmComponent mums c@GmComponent {..} =
|
resolveGmComponent mums c@GmComponent {..} =
|
||||||
withLightHscEnv gmcGhcSrcOpts $ \env -> do
|
withLightHscEnv gmcGhcSrcOpts $ \env -> do
|
||||||
let srcDirs = gmcSourceDirs
|
let srcDirs = gmcSourceDirs
|
||||||
mg = gmcHomeModuleGraph
|
mg = gmcHomeModuleGraph
|
||||||
|
|
||||||
let eps = either (return . Left) (map Right) gmcEntrypoints
|
Cradle { cradleRootDir } <- cradle
|
||||||
|
|
||||||
|
eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
|
||||||
simp <- liftIO $ resolveEntrypoints env srcDirs eps
|
simp <- liftIO $ resolveEntrypoints env srcDirs eps
|
||||||
sump <- liftIO $ case mums of
|
sump <- liftIO $ case mums of
|
||||||
Nothing -> return simp
|
Nothing -> return simp
|
||||||
@ -263,11 +265,30 @@ resolveEntrypoints env srcDirs ms =
|
|||||||
findFile' dirs file =
|
findFile' dirs file =
|
||||||
mconcat <$> mapM (mightExist . (</>file)) dirs
|
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)
|
resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
|
||||||
=> Maybe [Either FilePath ModuleName]
|
=> Maybe [Either FilePath ModuleName]
|
||||||
-- ^ Updated modules
|
-- ^ Updated modules
|
||||||
-> [GmComponent (Either FilePath [ModuleName])]
|
-> [GmComponent ChEntrypoint]
|
||||||
-> m (Map GmComponentName (GmComponent (Set ModulePath)))
|
-> m (Map ChComponentName (GmComponent (Set ModulePath)))
|
||||||
resolveGmComponents mumns cs = do
|
resolveGmComponents mumns cs = do
|
||||||
s <- gmsGet
|
s <- gmsGet
|
||||||
m' <- foldrM' (gmComponents s) cs $ \c m -> do
|
m' <- foldrM' (gmComponents s) cs $ \c m -> do
|
||||||
|
|||||||
@ -2,7 +2,6 @@
|
|||||||
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
|
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
|
||||||
module Language.Haskell.GhcMod.Types (
|
module Language.Haskell.GhcMod.Types (
|
||||||
module Language.Haskell.GhcMod.Types
|
module Language.Haskell.GhcMod.Types
|
||||||
, module CabalHelper.Types
|
|
||||||
, ModuleName
|
, ModuleName
|
||||||
, mkModuleName
|
, mkModuleName
|
||||||
, moduleNameString
|
, moduleNameString
|
||||||
@ -18,13 +17,12 @@ import Data.Set (Set)
|
|||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.Typeable (Typeable)
|
import Data.Typeable (Typeable)
|
||||||
|
import Distribution.Helper
|
||||||
import Exception (ExceptionMonad)
|
import Exception (ExceptionMonad)
|
||||||
import MonadUtils (MonadIO)
|
import MonadUtils (MonadIO)
|
||||||
import GHC (ModuleName, moduleNameString, mkModuleName)
|
import GHC (ModuleName, moduleNameString, mkModuleName)
|
||||||
import PackageConfig (PackageConfig)
|
import PackageConfig (PackageConfig)
|
||||||
|
|
||||||
import CabalHelper.Types
|
|
||||||
|
|
||||||
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
|
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
|
||||||
-- 'GhcModT' somewhat cleaner.
|
-- 'GhcModT' somewhat cleaner.
|
||||||
--
|
--
|
||||||
@ -168,10 +166,10 @@ instance Monoid GmModuleGraph where
|
|||||||
GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c')
|
GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c')
|
||||||
|
|
||||||
data GmComponent eps = GmComponent {
|
data GmComponent eps = GmComponent {
|
||||||
gmcName :: GmComponentName,
|
gmcName :: ChComponentName,
|
||||||
gmcGhcOpts :: [GHCOption],
|
gmcGhcOpts :: [GHCOption],
|
||||||
gmcGhcSrcOpts :: [GHCOption],
|
gmcGhcSrcOpts :: [GHCOption],
|
||||||
gmcRawEntrypoints :: Either FilePath [ModuleName],
|
gmcRawEntrypoints :: ChEntrypoint,
|
||||||
gmcEntrypoints :: eps,
|
gmcEntrypoints :: eps,
|
||||||
gmcSourceDirs :: [FilePath],
|
gmcSourceDirs :: [FilePath],
|
||||||
gmcHomeModuleGraph :: GmModuleGraph
|
gmcHomeModuleGraph :: GmModuleGraph
|
||||||
@ -204,10 +202,10 @@ data GhcModError
|
|||||||
| GMECabalFlags GhcModError
|
| GMECabalFlags GhcModError
|
||||||
-- ^ Retrieval of the cabal configuration flags failed.
|
-- ^ Retrieval of the cabal configuration flags failed.
|
||||||
|
|
||||||
| GMECabalComponent GmComponentName
|
| GMECabalComponent ChComponentName
|
||||||
-- ^ Cabal component could not be found
|
-- ^ 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
|
-- ^ Could not find a consistent component assignment for modules
|
||||||
|
|
||||||
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
||||||
|
|||||||
@ -24,7 +24,6 @@ Cabal-Version: >= 1.16
|
|||||||
Build-Type: Custom
|
Build-Type: Custom
|
||||||
Data-Files: elisp/Makefile
|
Data-Files: elisp/Makefile
|
||||||
elisp/*.el
|
elisp/*.el
|
||||||
CabalHelper/*.hs
|
|
||||||
|
|
||||||
Extra-Source-Files: ChangeLog
|
Extra-Source-Files: ChangeLog
|
||||||
SetupCompat.hs
|
SetupCompat.hs
|
||||||
@ -78,7 +77,6 @@ Library
|
|||||||
Language.Haskell.GhcMod.Internal
|
Language.Haskell.GhcMod.Internal
|
||||||
Other-Modules: Paths_ghc_mod
|
Other-Modules: Paths_ghc_mod
|
||||||
Utils
|
Utils
|
||||||
CabalHelper.Types
|
|
||||||
Language.Haskell.GhcMod.Boot
|
Language.Haskell.GhcMod.Boot
|
||||||
Language.Haskell.GhcMod.Browse
|
Language.Haskell.GhcMod.Browse
|
||||||
Language.Haskell.GhcMod.CaseSplit
|
Language.Haskell.GhcMod.CaseSplit
|
||||||
@ -116,6 +114,7 @@ Library
|
|||||||
Build-Depends: base >= 4.0 && < 5
|
Build-Depends: base >= 4.0 && < 5
|
||||||
, bytestring
|
, bytestring
|
||||||
, containers
|
, containers
|
||||||
|
, cabal-helper >= 0.3
|
||||||
, deepseq
|
, deepseq
|
||||||
, directory
|
, directory
|
||||||
, filepath
|
, filepath
|
||||||
@ -186,27 +185,6 @@ Executable ghc-modi
|
|||||||
, ghc
|
, ghc
|
||||||
, ghc-mod
|
, 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
|
Test-Suite doctest
|
||||||
Type: exitcode-stdio-1.0
|
Type: exitcode-stdio-1.0
|
||||||
Default-Language: Haskell2010
|
Default-Language: Haskell2010
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user