ghc-mod/CabalApi.hs

144 lines
5.2 KiB
Haskell
Raw Normal View History

2013-03-05 01:21:55 +00:00
{-# LANGUAGE OverloadedStrings #-}
2013-03-03 06:47:03 +00:00
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
, cabalAllSourceDirs
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)
2013-03-13 04:17:22 +00:00
import Data.Maybe (fromJust, maybeToList)
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-03 06:47:03 +00:00
import System.FilePath
import Types
----------------------------------------------------------------
2013-03-03 06:50:09 +00:00
fromCabalFile :: [GHCOption]
-> Cradle
2013-03-13 04:17:22 +00:00
-> IO ([GHCOption],[IncludeDir],[Package])
2013-03-05 01:21:55 +00:00
fromCabalFile ghcOptions cradle =
cookInfo ghcOptions cradle <$> cabalParseFile cfile
where
Just cfile = cradleCabalFile cradle
cookInfo :: [String] -> Cradle -> GenericPackageDescription
2013-03-13 04:17:22 +00:00
-> ([GHCOption],[IncludeDir],[Package])
cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs)
2013-03-03 06:47:03 +00:00
where
2013-03-04 01:39:39 +00:00
owdir = cradleCurrentDir cradle
Just cdir = cradleCabalDir cradle
Just cfile = cradleCabalFile cradle
2013-03-05 01:21:55 +00:00
binfo = cabalBuildInfo cabal
gopts = getGHCOptions ghcOptions binfo
idirs = includeDirectroies cdir owdir $ cabalAllSourceDirs cabal
2013-03-05 01:21:55 +00:00
depPkgs = removeMe cfile $ cabalAllDependPackages cabal
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
----------------------------------------------------------------
2013-03-05 01:21:55 +00:00
getGHCOptions :: [String] -> BuildInfo -> [String]
getGHCOptions ghcOptions binfo = ghcOptions ++ exts ++ [lang] ++ libs ++ libDirs
where
exts = map (("-X" ++) . display) $ usedExtensions binfo
lang = maybe "-XHaskell98" (("-X" ++) . display) $ defaultLanguage binfo
libs = map ("-l" ++) $ extraLibs binfo
libDirs = map ("-L" ++) $ extraLibDirs binfo
----------------------------------------------------------------
-- 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
----------------------------------------------------------------
cabalAllSourceDirs :: GenericPackageDescription -> [FilePath]
cabalAllSourceDirs = fromPackageDescription (f libBuildInfo) (f buildInfo) (f testBuildInfo) (f benchmarkBuildInfo)
where
f getBuildInfo = concatMap (hsSourceDirs . getBuildInfo . condTreeData)
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
----------------------------------------------------------------
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
----------------------------------------------------------------
2013-03-05 01:21:55 +00:00
includeDirectroies :: String -> String -> [FilePath] -> [String]
includeDirectroies cdir owdir [] = uniqueAndSort [cdir,owdir]
includeDirectroies cdir owdir dirs = uniqueAndSort (map (cdir </>) dirs ++ [owdir])
----------------------------------------------------------------
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