pure and applicative style.

This commit is contained in:
Kazu Yamamoto 2013-03-05 10:21:55 +09:00
parent 5b6924d36a
commit b7cacee767

View File

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module CabalApi (
fromCabalFile
@ -30,28 +30,24 @@ import Types
fromCabalFile :: [GHCOption]
-> Cradle
-> IO ([GHCOption]
,[IncludeDir]
,[Package]
,[LangExt])
fromCabalFile ghcOptions cradle = do
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)
-> 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)
@ -65,6 +61,16 @@ 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
@ -133,6 +139,12 @@ fromPackageDescription f1 f2 f3 f4 pd = lib ++ exe ++ tests ++ bench
----------------------------------------------------------------
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