diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ + +The MIT License (MIT) + +Copyright (c) 2015 Ranjit Jhala + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghc-options.cabal b/ghc-options.cabal new file mode 100644 --- /dev/null +++ b/ghc-options.cabal @@ -0,0 +1,65 @@ +-- Initial ghc-options.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: ghc-options +version: 0.1.0.0 +synopsis: Utilities for extracting GHC options needed to compile a given Haskell target. +description: 'ghcopts' is a library that makes it easy to determine what + GHC options are needed to compile a file. It was built + by extracting the relevant code from 'hdevtools' which + queries 'cabal' and 'stack' to determine the locations + of various package databases, in order to pass them to + GHC to process a target file. We have refactored this + code into a separate package so that it can be used by + other tools built on the GHC API. + +homepage: https://github.com/ranjitjhala/ghc-options.git +license: MIT +license-file: LICENSE +author: Ranjit Jhala +maintainer: jhala@cs.ucsd.edu +-- copyright: +category: Language +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +executable ghcopts + hs-source-dirs: src + ghc-options: -Wall + cpp-options: -DCABAL + main-is: Main.hs + build-depends: base >=4.8 && <4.9, + process, + filepath, + directory, + transformers, + Cabal >= 1.22, + bin-package-db, + unix + + other-modules: Language.Haskell.GhcOpts, + Language.Haskell.GhcOpts.Types, + Language.Haskell.GhcOpts.Stack, + Language.Haskell.GhcOpts.Cabal, + Language.Haskell.GhcOpts.Utils + + hs-source-dirs: src + default-language: Haskell2010 + cpp-options: -DENABLE_CABAL + +library + exposed-modules: Language.Haskell.GhcOpts + + build-depends: base >=4.8 && <4.9, + process, + filepath, + directory, + transformers, + Cabal >= 1.22, + bin-package-db, + unix + + hs-source-dirs: src + default-language: Haskell2010 + cpp-options: -DENABLE_CABAL diff --git a/src/Language/Haskell/GhcOpts.hs b/src/Language/Haskell/GhcOpts.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhcOpts.hs @@ -0,0 +1,51 @@ +module Language.Haskell.GhcOpts + ( ghcOpts + , module Language.Haskell.GhcOpts.Types + ) where + +import System.Directory (setCurrentDirectory) +import System.FilePath (takeDirectory) + +import Language.Haskell.GhcOpts.Utils +import Language.Haskell.GhcOpts.Types +import Language.Haskell.GhcOpts.Cabal +import Language.Haskell.GhcOpts.Stack + +ghcOpts :: FilePath -> IO (Either String Config) +ghcOpts f = fileCommand f >>= newConfig >>= packageConfig +{- + do + -- putStrLn $ "File: " ++ f + cmd <- fileCommand f + -- putStrLn $ "Command: " ++ show cmd + cf0 <- newConfig cmd + -- putStrLn $ "NewCfg: " ++ show cf0 + packageConfig cf0 +-} + +fileCommand :: FilePath -> IO CommandExtra +fileCommand f = do + mCabalFile <- findCabalFile (Just f) >>= traverse absoluteFilePath + return $ emptyCommand { cePath = Just f, ceCabalConfig = mCabalFile} + +newConfig :: CommandExtra -> IO Config +newConfig cmd = do + cabal <- traverse (\path -> mkCabalConfig path (ceCabalOptions cmd)) $ ceCabalConfig cmd + stack <- getStackConfig (cePath cmd) + return Config { configGhcOpts = "-O0" : ceGhcOptions cmd + , configCabal = cabal + , configStack = stack } + +packageConfig :: Config -> IO (Either String Config) +packageConfig cfg = + case configCabal cfg of + Nothing -> return $ Right cfg + Just c -> (withOpts cfg <$>) <$> packageOptions (configStack cfg) c + +withOpts :: Config -> [String] -> Config +withOpts cfg opts = cfg { configGhcOpts = opts ++ configGhcOpts cfg } + +packageOptions :: Maybe StackConfig -> CabalConfig -> IO (Either String [String]) +packageOptions stack cabal = do + setCurrentDirectory . takeDirectory $ cabalConfigPath cabal + getPackageGhcOpts (cabalConfigPath cabal) stack (cabalConfigOpts cabal) diff --git a/src/Language/Haskell/GhcOpts/Cabal.hs b/src/Language/Haskell/GhcOpts/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhcOpts/Cabal.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE CPP #-} +module Language.Haskell.GhcOpts.Cabal + ( getPackageGhcOpts + , mkCabalConfig + , findCabalFile + ) where + +import Language.Haskell.GhcOpts.Types + +import System.Posix.Files (getFileStatus, modificationTime) +import Control.Exception (IOException, catch) +import Control.Monad (when) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State (execStateT, modify) +import Data.Char (isSpace) +import Data.List (foldl', nub, sort, find, isPrefixOf, isSuffixOf) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>)) +import Data.Monoid (Monoid(..)) +#endif +import Distribution.Package (PackageIdentifier(..), PackageName) +import Distribution.PackageDescription (PackageDescription(..), Executable(..), TestSuite(..), Benchmark(..), emptyHookedBuildInfo, buildable, libBuildInfo) +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Simple.Configure (configure) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), ComponentLocalBuildInfo(..), + Component(..), ComponentName(..), +#if __GLASGOW_HASKELL__ < 707 + allComponentsBy, +#endif + componentBuildInfo, foldComponent) +import Distribution.Simple.Compiler (PackageDB(..)) +import Distribution.Simple.Command (CommandParse(..), commandParseArgs) +import Distribution.Simple.GHC (componentGhcOptions) +import Distribution.Simple.Program (defaultProgramConfiguration) +import Distribution.Simple.Program.Db (lookupProgram) +import Distribution.Simple.Program.Types (ConfiguredProgram(programVersion), simpleProgram) +import Distribution.Simple.Program.GHC (GhcOptions(..), renderGhcOptions) +import Distribution.Simple.Setup (ConfigFlags(..), defaultConfigFlags, configureCommand, toFlag) +#if __GLASGOW_HASKELL__ >= 709 +import Distribution.Utils.NubList +import qualified Distribution.Simple.GHC as GHC(configure) +#endif +import Distribution.Verbosity (silent) +import Distribution.Version (Version(..)) + +import System.IO.Error (ioeGetErrorString) +import System.Directory (getCurrentDirectory, doesFileExist, getDirectoryContents) +import System.FilePath (takeDirectory, splitFileName, ()) +import Language.Haskell.GhcOpts.Utils + +componentName :: Component -> ComponentName +componentName = + foldComponent (const CLibName) + (CExeName . exeName) + (CTestName . testName) + (CBenchName . benchmarkName) + +getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo +#if __GLASGOW_HASKELL__ >= 707 +getComponentLocalBuildInfo lbi cname = getLocalBuildInfo cname $ componentsConfigs lbi + where getLocalBuildInfo cname' ((cname'', clbi, _):cfgs) = + if cname' == cname'' then clbi else getLocalBuildInfo cname' cfgs + getLocalBuildInfo _ [] = error $ "internal error: missing config" +#else +getComponentLocalBuildInfo lbi CLibName = + case libraryConfig lbi of + Nothing -> error $ "internal error: missing library config" + Just clbi -> clbi +getComponentLocalBuildInfo lbi (CExeName name) = + case lookup name (executableConfigs lbi) of + Nothing -> error $ "internal error: missing config for executable " ++ name + Just clbi -> clbi +getComponentLocalBuildInfo lbi (CTestName name) = + case lookup name (testSuiteConfigs lbi) of + Nothing -> error $ "internal error: missing config for test suite " ++ name + Just clbi -> clbi +getComponentLocalBuildInfo lbi (CBenchName name) = + case lookup name (testSuiteConfigs lbi) of + Nothing -> error $ "internal error: missing config for benchmark " ++ name + Just clbi -> clbi +#endif + +#if __GLASGOW_HASKELL__ >= 707 +-- TODO: Fix callsites so we don't need `allComponentsBy`. It was taken from +-- http://hackage.haskell.org/package/Cabal-1.16.0.3/docs/src/Distribution-Simple-LocalBuildInfo.html#allComponentsBy +-- since it doesn't exist in Cabal 1.18.* +-- +-- | Obtains all components (libs, exes, or test suites), transformed by the +-- given function. Useful for gathering dependencies with component context. +allComponentsBy :: PackageDescription + -> (Component -> a) + -> [a] +allComponentsBy pkg_descr f = + [ f (CLib lib) | Just lib <- [library pkg_descr] + , buildable (libBuildInfo lib) ] + ++ [ f (CExe exe) | exe <- executables pkg_descr + , buildable (buildInfo exe) ] + ++ [ f (CTest tst) | tst <- testSuites pkg_descr + , buildable (testBuildInfo tst) + , testEnabled tst ] + ++ [ f (CBench bm) | bm <- benchmarks pkg_descr + , buildable (benchmarkBuildInfo bm) + , benchmarkEnabled bm ] +#endif + +stackifyFlags :: ConfigFlags -> Maybe StackConfig -> ConfigFlags +stackifyFlags cfg Nothing = cfg +stackifyFlags cfg (Just si) = cfg { configDistPref = toFlag dist + , configPackageDBs = pdbs + } + where + pdbs = [Nothing, Just GlobalPackageDB] ++ pdbs' + pdbs' = Just . SpecificPackageDB <$> stackDbs si + dist = stackDist si + +-- via: https://groups.google.com/d/msg/haskell-stack/8HJ6DHAinU0/J68U6AXTsasJ +-- cabal configure --package-db=clear --package-db=global --package-db=$(stack path --snapshot-pkg-db) --package-db=$(stack path --local-pkg-db) + +-- returns the right 'dist' directory in the case of a sandbox +getDistDir :: FilePath -> IO FilePath +getDistDir path = do + let dir = takeDirectory path "dist" + contents <- getDirectoryContentsIfExists dir + return $ case find ("dist-sandbox-" `isPrefixOf`) contents of + Just sbdir -> dir sbdir + Nothing -> dir + +getPackageGhcOpts :: FilePath -> Maybe StackConfig -> [String] -> IO (Either String [String]) +getPackageGhcOpts path mbStack opts = do + -- putStrLn $ "getPackageGhcOpts: path = " ++ path + getPackageGhcOpts' `catch` (\e -> return $ Left $ "Cabal error: " ++ ioeGetErrorString (e :: IOException)) + where + getPackageGhcOpts' :: IO (Either String [String]) + getPackageGhcOpts' = do + genPkgDescr <- readPackageDescription silent path + distDir <- getDistDir path + + let programCfg = defaultProgramConfiguration + let initCfgFlags = (defaultConfigFlags programCfg) + { configDistPref = toFlag distDir + -- TODO: figure out how to find out this flag + , configUserInstall = toFlag True + + -- configure with --enable-tests to include test dependencies/modules + , configTests = toFlag True + + -- configure with --enable-benchmarks to include benchmark dependencies/modules + , configBenchmarks = toFlag True + } + let initCfgFlags' = stackifyFlags initCfgFlags mbStack + + cfgFlags <- flip execStateT initCfgFlags' $ do + let sandboxConfig = takeDirectory path "cabal.sandbox.config" + + exists <- lift $ doesFileExist sandboxConfig + when exists $ do + sandboxPackageDb <- lift $ getSandboxPackageDB sandboxConfig + modify $ \x -> x { configPackageDBs = [Just sandboxPackageDb] } + + let cmdUI = configureCommand programCfg + case commandParseArgs cmdUI True opts of + CommandReadyToGo (modFlags, _) -> modify modFlags + CommandErrors (e:_) -> error e + _ -> return () + + localBuildInfo <- configure (genPkgDescr, emptyHookedBuildInfo) cfgFlags + let pkgDescr = localPkgDescr localBuildInfo + let baseDir = fst . splitFileName $ path + case getGhcVersion localBuildInfo of + Nothing -> return $ Left "GHC is not configured" + + Just _ -> do + let mbLibName = pkgLibName pkgDescr + let ghcOpts' = foldl' mappend mempty $ map (getComponentGhcOptions localBuildInfo) $ flip allComponentsBy (\c -> c) . localPkgDescr $ localBuildInfo + -- FIX bug in GhcOptions' `mappend` + ghcOpts = ghcOpts' { ghcOptExtra = overNubListR (filter (/= "-Werror")) $ ghcOptExtra ghcOpts' + , ghcOptPackageDBs = sort $ nub (ghcOptPackageDBs ghcOpts') + , ghcOptPackages = overNubListR (filter (\(_, pkgId, _) -> Just (pkgName pkgId) /= mbLibName)) $ (ghcOptPackages ghcOpts') + , ghcOptSourcePath = overNubListR (map (baseDir )) (ghcOptSourcePath ghcOpts') + } + -- putStrLn "configuring" + (ghcInfo,_,_) <- GHC.configure silent Nothing Nothing defaultProgramConfiguration + + return $ Right $ renderGhcOptions ghcInfo ghcOpts + +pkgLibName :: PackageDescription -> Maybe PackageName +pkgLibName pkgDescr = if hasLibrary pkgDescr + then Just $ pkgName . package $ pkgDescr + else Nothing + +hasLibrary :: PackageDescription -> Bool +hasLibrary = maybe False (\_ -> True) . library + +getComponentGhcOptions :: LocalBuildInfo -> Component -> GhcOptions +getComponentGhcOptions lbi comp = + componentGhcOptions silent lbi bi clbi (buildDir lbi) + + where bi = componentBuildInfo comp + clbi = getComponentLocalBuildInfo lbi (componentName comp) + +getGhcVersion :: LocalBuildInfo -> Maybe Version +getGhcVersion lbi = let db = withPrograms lbi + in do ghc <- lookupProgram (simpleProgram "ghc") db + programVersion ghc + +getSandboxPackageDB :: FilePath -> IO PackageDB +getSandboxPackageDB sandboxPath = do + contents <- readFile sandboxPath + return $ SpecificPackageDB $ extractValue . parse $ contents + where + pkgDbKey = "package-db:" + parse = head . filter (pkgDbKey `isPrefixOf`) . lines + extractValue = fst . break isSpace . dropWhile isSpace . drop (length pkgDbKey) + + +findCabalFile :: Maybe FilePath -> IO (Maybe FilePath) +findCabalFile f = go =<< maybe getCurrentDirectory (return . takeDirectory) f + where + go dir = do + allFiles <- getDirectoryContents dir + let mbCabalFile = find isCabalFile allFiles + case mbCabalFile of + Just cabalFile -> return $ Just $ dir cabalFile + Nothing -> + let parentDir = takeDirectory dir in + if parentDir == dir then return Nothing else go parentDir + +isCabalFile :: FilePath -> Bool +isCabalFile path = cabalExtension `isSuffixOf` path && + length path > length cabalExtension + where + cabalExtension = ".cabal" + +-------------------------------------------------------------------------------- +mkCabalConfig :: FilePath -> [String] -> IO CabalConfig +-------------------------------------------------------------------------------- +mkCabalConfig path opts = do + fileStatus <- getFileStatus path + return CabalConfig { cabalConfigPath = path + , cabalConfigOpts = opts + , cabalConfigLastUpdatedAt = modificationTime fileStatus + } diff --git a/src/Language/Haskell/GhcOpts/Stack.hs b/src/Language/Haskell/GhcOpts/Stack.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhcOpts/Stack.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE CPP #-} + +-- | This module adds support for `stack`, as follows: +-- 1. Figure out if the target-file is in a stack project, +-- 2. If `stack.yaml` in PATH, run `stack exec` to extract `StackConfig` +-- 3. Use `StackConfig` to alter the cabal ConfigFlags in Cabal.hs + +module Language.Haskell.GhcOpts.Stack ( getStackConfig ) where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative((<$>), (<*>)) +import System.IO +#endif + +import Data.Maybe (listToMaybe) + +import System.FilePath +import System.Directory +import Control.Monad (filterM) + +import Language.Haskell.GhcOpts.Utils +import Language.Haskell.GhcOpts.Types + +-------------------------------------------------------------------------------- +getStackConfig :: Maybe FilePath -> IO (Maybe StackConfig) +-------------------------------------------------------------------------------- +getStackConfig Nothing = + return Nothing +getStackConfig (Just p) = do + mbYaml <- getStackYaml p + case mbYaml of + Nothing -> return Nothing + Just _ -> do mdbs <- getStackDbs p + mdst <- getStackDist p + return $ StackConfig <$> mdst <*> mdbs + +-------------------------------------------------------------------------------- +getStackYaml :: FilePath -> IO (Maybe FilePath) +-------------------------------------------------------------------------------- +getStackYaml p = listToMaybe <$> filterM doesFileExist paths + where + paths = [ d "stack.yaml" | d <- pathsToRoot dir] + dir = takeDirectory p + +-------------------------------------------------------------------------------- +getStackDist :: FilePath -> IO (Maybe FilePath) +-------------------------------------------------------------------------------- +getStackDist p = (trim <$>) <$> execInPath cmd p + where + cmd = "stack path --dist-dir" + +-------------------------------------------------------------------------------- +getStackDbs :: FilePath -> IO (Maybe [FilePath]) +-------------------------------------------------------------------------------- +getStackDbs p = do mpp <- execInPath cmd p + case mpp of + Just pp -> Just <$> extractDbs pp + Nothing -> return Nothing + where + cmd = "stack --verbosity quiet exec printenv GHC_PACKAGE_PATH" + +extractDbs :: String -> IO [FilePath] +extractDbs = filterM doesDirectoryExist . stringPaths + +stringPaths :: String -> [String] +stringPaths = splitBy ':' . trim diff --git a/src/Language/Haskell/GhcOpts/Types.hs b/src/Language/Haskell/GhcOpts/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhcOpts/Types.hs @@ -0,0 +1,41 @@ +module Language.Haskell.GhcOpts.Types ( + CommandExtra (..) + , emptyCommand + , Config (..) + , CabalConfig (..) + , StackConfig (..) + ) where + +import System.Posix.Types (EpochTime) + +data Config = Config + { configGhcOpts :: [String] + , configCabal :: Maybe CabalConfig + , configStack :: Maybe StackConfig + } + deriving (Eq, Show) + +data CabalConfig = CabalConfig + { cabalConfigPath :: FilePath + , cabalConfigOpts :: [String] + , cabalConfigLastUpdatedAt :: EpochTime + } + deriving (Eq, Show) + +data StackConfig = StackConfig + { stackDist :: FilePath + , stackDbs :: [FilePath] + } + deriving (Eq, Show) + +-- | Bonus config parameters used to override those in .cabal and stack.yaml + +data CommandExtra = CommandExtra + { ceGhcOptions :: [String] + , ceCabalConfig :: Maybe FilePath + , cePath :: Maybe FilePath + , ceCabalOptions :: [String] + } deriving (Read, Show) + +emptyCommand :: CommandExtra +emptyCommand = CommandExtra [] Nothing Nothing [] diff --git a/src/Language/Haskell/GhcOpts/Utils.hs b/src/Language/Haskell/GhcOpts/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhcOpts/Utils.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} + +-- | Various utilities pertaining to searching for files & directories. + +module Language.Haskell.GhcOpts.Utils where + +import Control.Exception +import System.Process +import Data.Char (isSpace) +import System.FilePath +import System.Directory + + +getDirectoryContentsIfExists :: FilePath -> IO [FilePath] +getDirectoryContentsIfExists dir = do + b <- doesFileExist dir + if b then getDirectoryContents dir + else return [] + +absoluteFilePath :: FilePath -> IO FilePath +absoluteFilePath p = if isAbsolute p then return p else do + dir <- getCurrentDirectory + return $ dir p + + +pathsToRoot :: FilePath -> [FilePath] +pathsToRoot p + | p == parent = [p] + | otherwise = p : pathsToRoot parent + where + parent = takeDirectory p + +splitBy :: Char -> String -> [String] +splitBy c str + | null str' = [x] + | otherwise = x : splitBy c (tail str') + where + (x, str') = span (c /=) str + +trim :: String -> String +trim = f . f + where + f = reverse . dropWhile isSpace + +#if __GLASGOW_HASKELL__ < 709 +execInPath :: String -> FilePath -> IO (Maybe String) +execInPath cmd p = do + eIOEstr <- try $ createProcess prc :: IO (Either IOError ProcH) + case eIOEstr of + Right (_, Just h, _, _) -> Just <$> getClose h + Right (_, Nothing, _, _) -> return Nothing + -- This error is most likely "/bin/sh: stack: command not found" + -- which is caused by the package containing a stack.yaml file but + -- no stack command is in the PATH. + Left _ -> return Nothing + where + prc = (shell cmd) { cwd = Just $ takeDirectory p } + +getClose :: Handle -> IO String +getClose h = do + str <- hGetContents h + hClose h + return str + +type ProcH = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) + +-- Not deleting this because this is likely more robust than the above! (but +-- only works on process-1.2.3.0 onwards + +#else +execInPath :: String -> FilePath -> IO (Maybe String) +execInPath cmd p = do + eIOEstr <- try $ readCreateProcess prc "" :: IO (Either IOError String) + return $ case eIOEstr of + Right s -> Just s + -- This error is most likely "/bin/sh: stack: command not found" + -- which is caused by the package containing a stack.yaml file but + -- no stack command is in the PATH. + Left _ -> Nothing + where + prc = (shell cmd) { cwd = Just $ takeDirectory p } +#endif diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,9 @@ +import System.Environment + +import Language.Haskell.GhcOpts + +main :: IO () +main = do + f:_ <- getArgs + z <- ghcOpts f + putStrLn $ "GHC Options: " ++ show z