ghc-mod/CabalApi.hs

153 lines
5.4 KiB
Haskell
Raw Normal View History

2013-03-03 06:47:03 +00:00
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
module CabalApi (
2013-03-03 06:50:09 +00:00
fromCabalFile
2013-03-03 06:47:03 +00:00
, cabalParseFile
, cabalBuildInfo
2013-03-01 06:25:43 +00:00
, cabalAllDependPackages
, cabalAllExtentions
2013-03-04 04:55:03 +00:00
, getGHCVersion
) where
import Control.Applicative
2013-03-04 04:55:03 +00:00
import Control.Exception (throwIO)
import Data.List (intercalate)
import Data.Maybe (fromJust, maybeToList, mapMaybe)
import Data.Set (fromList, toList)
import Distribution.Package (Dependency(Dependency), PackageName(PackageName))
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse (readPackageDescription)
2013-03-04 04:55:03 +00:00
import Distribution.Simple.Program (ghcProgram)
import Distribution.Simple.Program.Types (programName, programFindVersion)
2013-03-01 06:25:43 +00:00
import Distribution.Text (display)
import Distribution.Verbosity (silent)
2013-03-04 04:55:03 +00:00
import Distribution.Version (versionBranch)
2013-03-01 06:25:43 +00:00
import Language.Haskell.Extension (Extension(..))
2013-03-03 06:47:03 +00:00
import System.FilePath
import Types
----------------------------------------------------------------
2013-03-03 06:50:09 +00:00
fromCabalFile :: [GHCOption]
-> Cradle
-> IO ([GHCOption]
,[IncludeDir]
,[Package]
,[LangExt])
fromCabalFile ghcOptions cradle = do
2013-03-03 06:47:03 +00:00
cabal <- cabalParseFile cfile
let binfo@BuildInfo{..} = cabalBuildInfo cabal
let exts = map (("-X" ++) . display) $ usedExtensions binfo
lang = maybe "-XHaskell98" (("-X" ++) . display) defaultLanguage
libs = map ("-l" ++) extraLibs
libDirs = map ("-L" ++) extraLibDirs
gopts = ghcOptions ++ exts ++ [lang] ++ libs ++ libDirs
idirs = case hsSourceDirs of
[] -> [cdir,owdir]
dirs -> map (cdir </>) dirs ++ [owdir]
let depPkgs = removeMe cfile $ cabalAllDependPackages cabal
hdrExts = cabalAllExtentions cabal
return (gopts,idirs,depPkgs,hdrExts)
where
2013-03-04 01:39:39 +00:00
owdir = cradleCurrentDir cradle
Just cdir = cradleCabalDir cradle
Just cfile = cradleCabalFile cradle
2013-03-03 06:47:03 +00:00
removeMe :: FilePath -> [String] -> [String]
removeMe cabalfile = filter (/= me)
where
me = dropExtension $ takeFileName cabalfile
----------------------------------------------------------------
cabalParseFile :: FilePath -> IO GenericPackageDescription
cabalParseFile = readPackageDescription silent
----------------------------------------------------------------
-- Causes error, catched in the upper function.
2013-03-01 04:14:46 +00:00
cabalBuildInfo :: GenericPackageDescription -> BuildInfo
cabalBuildInfo pd = fromJust $ fromLibrary pd <|> fromExecutable pd
where
fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c
fromExecutable c = buildInfo . condTreeData . snd <$> toMaybe (condExecutables c)
toMaybe [] = Nothing
toMaybe (x:_) = Just x
----------------------------------------------------------------
cabalAllDependPackages :: GenericPackageDescription -> [Package]
2013-03-01 06:25:43 +00:00
cabalAllDependPackages pd = uniqueAndSort pkgs
where
2013-03-01 06:25:43 +00:00
pkgs = map getDependencyPackageName $ cabalAllDependency pd
2013-03-01 06:25:43 +00:00
cabalAllDependency :: GenericPackageDescription -> [Dependency]
cabalAllDependency = fromPackageDescription getDeps getDeps getDeps getDeps
where
getDeps :: [Tree a] -> [Dependency]
getDeps = concatMap condTreeConstraints
getDependencyPackageName :: Dependency -> Package
2013-03-01 06:25:43 +00:00
getDependencyPackageName (Dependency (PackageName nm) _) = nm
----------------------------------------------------------------
cabalAllExtentions :: GenericPackageDescription -> [LangExt]
2013-03-01 06:25:43 +00:00
cabalAllExtentions pd = uniqueAndSort exts
where
buildInfos = cabalAllBuildInfos pd
eexts = concatMap oldExtensions buildInfos
++ concatMap defaultExtensions buildInfos
exts = mapMaybe getExtensionName eexts
2013-03-01 06:25:43 +00:00
getExtensionName :: Extension -> Maybe LangExt
2013-03-01 06:25:43 +00:00
getExtensionName (EnableExtension nm) = Just (display nm)
getExtensionName _ = Nothing
----------------------------------------------------------------
2013-03-01 06:25:43 +00:00
cabalAllBuildInfos :: GenericPackageDescription -> [BuildInfo]
cabalAllBuildInfos = fromPackageDescription f1 f2 f3 f4
where
f1 = map (libBuildInfo . condTreeData)
f2 = map (buildInfo . condTreeData)
f3 = map (testBuildInfo . condTreeData)
f4 = map (benchmarkBuildInfo . condTreeData)
----------------------------------------------------------------
type Tree = CondTree ConfVar [Dependency]
fromPackageDescription :: ([Tree Library] -> [a])
-> ([Tree Executable] -> [a])
-> ([Tree TestSuite] -> [a])
-> ([Tree Benchmark] -> [a])
-> GenericPackageDescription
-> [a]
fromPackageDescription f1 f2 f3 f4 pd = lib ++ exe ++ tests ++ bench
where
lib = f1 . maybeToList . condLibrary $ pd
exe = f2 . map snd . condExecutables $ pd
tests = f3 . map snd . condTestSuites $ pd
bench = f4 . map snd . condBenchmarks $ pd
2013-03-01 06:25:43 +00:00
----------------------------------------------------------------
uniqueAndSort :: [String] -> [String]
uniqueAndSort = toList . fromList
2013-03-04 04:55:03 +00:00
----------------------------------------------------------------
getGHCVersion :: IO (String, Int)
getGHCVersion = ghcVer >>= toTupple
where
ghcVer = programFindVersion ghcProgram silent (programName ghcProgram)
toTupple Nothing = throwIO $ userError "ghc not found"
toTupple (Just v)
| length vs < 2 = return (verstr, 0)
| otherwise = return (verstr, ver)
where
vs = versionBranch v
ver = (vs !! 0) * 100 + (vs !! 1)
verstr = intercalate "." . map show $ vs