Interactive.hs

-- | Retrieve ghci options for your cabal project
module Distribution.Dev.Interactive ( 
  -- * Installing into your .ghci
  -- $install
  
  -- * Arguments
  -- $args
  
  -- * Exported functions
  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)]

-- | Return value for 'loadCabal'
data LoadCabalRet =
  NoCabalFile | -- ^ No cabal file found
  MissingDeps [Dependency] | -- ^ Missing dependencies
  Pkg FilePath PackageDescription (Maybe LocalBuildInfo) -- ^ Successful loading and parsing of cabal file
  deriving Show

compiler ∷ CompilerId
compiler = CompilerId buildCompilerFlavor compilerVersion

-- | Build a list of ghci options needed to load files from a cabal project
packageOpts
  ∷ FilePath -- ^ path to the .cabal file
  → PackageDescription -- ^ parsed package description
  → Maybe LocalBuildInfo -- ^ parsed build config
  → String -- ^ name of executable
  → 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)

-- | GHC options for a 'BuildInfo'
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
  -- TODO frameworks cSources otherModules extraLibs extraLibsDirs includes 
  ]
  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

-- | Load the current cabal project file and parse it
loadCabal
  ∷ FilePath -- ^ usually the current directory
  → FlagAssignment -- ^ list of cabal flag assignments
  → 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 (n-1) xs
maybeNth _ _ = Nothing

maybeRead s = case reads s of [(a, "")] → Just a; _ → Nothing

-- | Load the 'LocalBuildInfo' from dist/setup-config
loadCabalConfig ∷ FilePath → IO (Maybe LocalBuildInfo)
loadCabalConfig path = 
  -- TODO: don't ignore all exceptions
  fmap (either ignore id) $ try $
  fmap ((maybeRead =<<) . maybeNth 1 . lines) $ readFile path
  where
    ignore ∷ SomeException → Maybe a
    ignore _ = Nothing

-- | Find a .cabal file in the path or any of it's parent directories
lookForCabalFile
  ∷ FilePath -- ^ canonicalised path
  → 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' returns a list of ghci commands (seperated by newlines) that :set the 'packageOpts' of the current cabal project
cabalSet
  ∷ String -- ^ arguments seperated by spaces
  → IO String
cabalSet args =
  withOpts (words args)
    (\x → putStrLn x >> return "")
    ((\x → putStrLn x >> return x) .
        unlines . (map (":set "++)) . map show )

-- | Generalised version of 'cabalSet'
withOpts
  ∷ [String] -- ^ List of cabal flag arguments and executable name
  → (String → IO a) -- ^ Error continuation. Recieves an error message.
  → ([String] → IO a) -- ^ Success continuation. Recieves a list of ghci arguments.
  → 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)

-- $install
-- @
--   $ head -n 4 >> ~/.ghci
--   :m + Distribution.Dev.Interactive
--   :def cabalset cabalSet
--   :cabalset -fcabal-ghci
--   :m - Distribution.Dev.Interactive
-- @

-- $args
-- [@-fflag@] enable flag
-- 
-- [@-f-flag@] disable flag
-- 
-- [@exec@] load options for the exec executable