module Distribution.Dev.Interactive (
cabalSet, packageOpts, loadCabal, lookForCabalFile, withOpts, LoadCabalRet(..)
) where
import Distribution.Text
import Distribution.Compiler
import Distribution.Verbosity
import Distribution.System
import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse
import Distribution.PackageDescription.Configuration
import Distribution.Simple.PackageIndex
import Distribution.Simple.LocalBuildInfo hiding (compiler)
import Data.Version
import System.FilePath
import System.Directory
import System.Info
import Data.Maybe
import Data.Either
import Control.Exception
import Data.List
type Deps = [(PackageName, Version)]
data LoadCabalRet =
NoCabalFile |
MissingDeps [Dependency] |
Pkg FilePath PackageDescription (Maybe LocalBuildInfo)
deriving Show
compiler ∷ CompilerId
compiler = CompilerId buildCompilerFlavor compilerVersion
packageOpts
∷ FilePath
→ PackageDescription
→ Maybe LocalBuildInfo
→ String
→ Maybe [String]
packageOpts path pkg mlbi executable =
maybe Nothing (\bi → Just $ ghcOpts path bi (listDeps bi =<< mlbi)) $
listToMaybe $
if executable == ""
then allBuildInfo pkg
else
fmap buildInfo .
filter (\x → exeName x == executable) .
executables $ pkg
listDeps ∷ BuildInfo → LocalBuildInfo → Maybe Deps
listDeps bi lbi = sequence $ map find reqs
where
reqs = targetBuildDepends bi
db = installedPkgs lbi
find dep@(Dependency pkg _) = do
(fst . head → ver) ← return $ lookupDependency db dep
return (pkg, ver)
ghcOpts ∷ FilePath → BuildInfo → Maybe Deps → [String]
ghcOpts path bi deps = concat $
maybe [] ((noPkgs:) . add "-package=" . map addDep) deps :
map ($ bi) [
hcOptions buildCompilerFlavor,
addf "-X" display . allExtensions,
addf "-i" (combine dir) . ("/dist/build/autogen":) . hsSourceDirs,
add "-optP" . cppOptions,
add "-optc" . ccOptions,
add "-optl" . ldOptions
]
where
dir = takeDirectory path
add s = map (s++)
addf ∷ String → (a → String) → [a] → [String]
addf s f = map ((s++) . f)
noPkgs = "-hide-all-packages"
addDep (PackageName pkg, showVersion → ver) = pkg ++ "-" ++ ver
loadCabal
∷ FilePath
→ FlagAssignment
→ IO LoadCabalRet
loadCabal path flags = do
mCabalFile ← lookForCabalFile =<< canonicalizePath path
flip (maybe (return NoCabalFile))
mCabalFile $ \cabalFile → do
gdescr ← readPackageDescription normal cabalFile
mlbi ← loadCabalConfig (takeDirectory cabalFile `combine` "dist" `combine` "setup-config")
case finalizePackageDescription flags (const True)
buildPlatform compiler [] gdescr of
Left deps → return $ MissingDeps deps
Right (descr, _) → return $ Pkg cabalFile descr mlbi
maybeNth ∷ Int → [a] → Maybe a
maybeNth 0 (x:_) = Just x
maybeNth n (_:xs) = maybeNth (n1) xs
maybeNth _ _ = Nothing
maybeRead s = case reads s of [(a, "")] → Just a; _ → Nothing
loadCabalConfig ∷ FilePath → IO (Maybe LocalBuildInfo)
loadCabalConfig path =
fmap (either ignore id) $ try $
fmap ((maybeRead =<<) . maybeNth 1 . lines) $ readFile path
where
ignore ∷ SomeException → Maybe a
ignore _ = Nothing
lookForCabalFile
∷ FilePath
→ IO (Maybe FilePath)
lookForCabalFile "/" = return Nothing
lookForCabalFile path = do
files ← getDirectoryContents path
let cabals = filter (\f →
takeExtension f == ".cabal"
&& f /= ".cabal") files
case cabals of
[] → lookForCabalFile (takeDirectory path)
[a] → return $ Just $ combine path a
_ → return Nothing
cabalSet
∷ String
→ IO String
cabalSet args =
withOpts (words args)
(\x → putStrLn x >> return "")
((\x → putStrLn x >> return x) .
unlines . (map (":set "++)) . map show )
withOpts
∷ [String]
→ (String → IO a)
→ ([String] → IO a)
→ IO a
withOpts args err go = do
let (flags, executable) = parseArgs args
here ← getCurrentDirectory
ret ← loadCabal here flags
case ret of
NoCabalFile → err "Current directory is not a cabal project"
MissingDeps deps → err $ "Missing dependencies: " ++ unwords (map show deps)
Pkg path descr mlbi → do
let mopts = packageOpts path descr mlbi executable
case mopts of
Nothing → err (
if executable /= ""
then "No such executable in cabal file"
else "No library defined in cabal file")
Just opts → go opts
parseArgs ∷ [String] → (FlagAssignment, String)
parseArgs args =
(map (makeFlag . drop 2) . filter flag $ args,
fromMaybe "" . listToMaybe . filter (not . flag) $ args)
where
flag x = take 2 x == "-f"
makeFlag ∷ String → (FlagName, Bool)
makeFlag ('-':f) = (FlagName f, False)
makeFlag f = (FlagName f, True)