165 lines
6.0 KiB
Haskell
165 lines
6.0 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module CabalApi (
|
|
fromCabalFile
|
|
, cabalParseFile
|
|
, cabalBuildInfo
|
|
, cabalAllDependPackages
|
|
, cabalAllExtentions
|
|
, getGHCVersion
|
|
) where
|
|
|
|
import Control.Applicative
|
|
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)
|
|
import Distribution.Simple.Program (ghcProgram)
|
|
import Distribution.Simple.Program.Types (programName, programFindVersion)
|
|
import Distribution.Text (display)
|
|
import Distribution.Verbosity (silent)
|
|
import Distribution.Version (versionBranch)
|
|
import Language.Haskell.Extension (Extension(..))
|
|
import System.FilePath
|
|
import Types
|
|
|
|
----------------------------------------------------------------
|
|
|
|
fromCabalFile :: [GHCOption]
|
|
-> Cradle
|
|
-> IO ([GHCOption],[IncludeDir],[Package],[LangExt])
|
|
fromCabalFile ghcOptions cradle =
|
|
cookInfo ghcOptions cradle <$> cabalParseFile cfile
|
|
where
|
|
Just cfile = cradleCabalFile cradle
|
|
|
|
cookInfo :: [String] -> Cradle -> GenericPackageDescription
|
|
-> ([GHCOption],[IncludeDir],[Package],[LangExt])
|
|
cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs,hdrExts)
|
|
where
|
|
owdir = cradleCurrentDir cradle
|
|
Just cdir = cradleCabalDir cradle
|
|
Just cfile = cradleCabalFile cradle
|
|
binfo = cabalBuildInfo cabal
|
|
gopts = getGHCOptions ghcOptions binfo
|
|
idirs = includeDirectroies cdir owdir $ hsSourceDirs binfo
|
|
depPkgs = removeMe cfile $ cabalAllDependPackages cabal
|
|
hdrExts = cabalAllExtentions cabal
|
|
|
|
removeMe :: FilePath -> [String] -> [String]
|
|
removeMe cabalfile = filter (/= me)
|
|
where
|
|
me = dropExtension $ takeFileName cabalfile
|
|
|
|
----------------------------------------------------------------
|
|
|
|
cabalParseFile :: FilePath -> IO GenericPackageDescription
|
|
cabalParseFile = readPackageDescription silent
|
|
|
|
----------------------------------------------------------------
|
|
|
|
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.
|
|
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]
|
|
cabalAllDependPackages pd = uniqueAndSort pkgs
|
|
where
|
|
pkgs = map getDependencyPackageName $ cabalAllDependency pd
|
|
|
|
cabalAllDependency :: GenericPackageDescription -> [Dependency]
|
|
cabalAllDependency = fromPackageDescription getDeps getDeps getDeps getDeps
|
|
where
|
|
getDeps :: [Tree a] -> [Dependency]
|
|
getDeps = concatMap condTreeConstraints
|
|
|
|
getDependencyPackageName :: Dependency -> Package
|
|
getDependencyPackageName (Dependency (PackageName nm) _) = nm
|
|
|
|
----------------------------------------------------------------
|
|
|
|
cabalAllExtentions :: GenericPackageDescription -> [LangExt]
|
|
cabalAllExtentions pd = uniqueAndSort exts
|
|
where
|
|
buildInfos = cabalAllBuildInfos pd
|
|
eexts = concatMap oldExtensions buildInfos
|
|
++ concatMap defaultExtensions buildInfos
|
|
exts = mapMaybe getExtensionName eexts
|
|
|
|
getExtensionName :: Extension -> Maybe LangExt
|
|
getExtensionName (EnableExtension nm) = Just (display nm)
|
|
getExtensionName _ = Nothing
|
|
|
|
----------------------------------------------------------------
|
|
|
|
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
|
|
|
|
----------------------------------------------------------------
|
|
|
|
includeDirectroies :: String -> String -> [FilePath] -> [String]
|
|
includeDirectroies cdir owdir [] = uniqueAndSort [cdir,owdir]
|
|
includeDirectroies cdir owdir dirs = uniqueAndSort (map (cdir </>) dirs ++ [owdir])
|
|
|
|
----------------------------------------------------------------
|
|
|
|
uniqueAndSort :: [String] -> [String]
|
|
uniqueAndSort = toList . fromList
|
|
|
|
----------------------------------------------------------------
|
|
|
|
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
|