{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE TupleSections #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE RecordWildCards #-}

-- | Run a GHCi configured with the user's project(s).

module Stack.Ghci (GhciOpts(..),GhciPkgInfo(..), ghciSetup, ghci) where

import Control.Monad.Catch

import Control.Monad.IO.Class

import Control.Monad.Logger

import Control.Monad.Reader

import Control.Monad.Trans.Resource

import Data.Function

import Data.List

import Data.Map.Strict (Map)

import qualified Data.Map.Strict as M

import Data.Maybe

import Data.Monoid

import Data.Set (Set)

import qualified Data.Set as S

import Data.Text (Text)

import qualified Data.Text as T

import Distribution.ModuleName (ModuleName)

import Distribution.Text (display)

import Network.HTTP.Client.Conduit

import Path

import Prelude

import Stack.Build

import Stack.Build.Source

import Stack.Build.Target

import Stack.Constants

import Stack.Exec

import Stack.Package

import Stack.Types

import Stack.Types.Internal

-- | Command-line options for GHC.

data GhciOpts = GhciOpts

{ghciTargets :: ![Text]

,ghciArgs :: ![String]

,ghciGhcCommand :: !(Maybe FilePath)

,ghciNoLoadModules :: !Bool

,ghciAdditionalPackages :: ![String]

,ghciMainIs :: !(Maybe Text)

} deriving (Show,Eq)

-- | Necessary information to load a package or its components.

data GhciPkgInfo = GhciPkgInfo

{ ghciPkgName :: PackageName

, ghciPkgOpts :: [String]

, ghciPkgDir :: Path Abs Dir

, ghciPkgModules :: Set ModuleName

, ghciPkgModFiles :: Set (Path Abs File) -- ^ Module file paths.

, ghciPkgCFiles :: Set (Path Abs File) -- ^ C files.

, ghciPkgMainIs :: Map NamedComponent (Set (Path Abs File))

}

-- | Launch a GHCi session for the given local project targets with the

-- given options and configure it with the load paths and extensions

-- of those targets.

ghci

:: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m)

=> GhciOpts -> m ()

ghci GhciOpts{..} = do

(targets,mainIsTargets,pkgs) <- ghciSetup ghciMainIs ghciTargets

bconfig <- asks getBuildConfig

mainFile <- figureOutMainFile mainIsTargets targets pkgs

wc <- getWhichCompiler

let pkgopts = concatMap ghciPkgOpts pkgs

srcfiles

| ghciNoLoadModules = []

| otherwise =

nub (maybe [] (return . toFilePath) mainFile <>

concatMap (map display . S.toList . ghciPkgModules) pkgs)

odir =

[ "-odir=" <> toFilePath (objectInterfaceDir bconfig)

, "-hidir=" <> toFilePath (objectInterfaceDir bconfig)]

$logInfo

("Configuring GHCi with the following packages: " <>

T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs))

exec

defaultEnvSettings

(fromMaybe (compilerExeName wc) ghciGhcCommand)

("--interactive" : odir <> pkgopts <> srcfiles <> ghciArgs)

-- | Figure out the main-is file to load based on the targets. Sometimes there

-- is none, sometimes it's unambiguous, sometimes it's

-- ambiguous. Warns and returns nothing if it's ambiguous.

figureOutMainFile

:: (Monad m, MonadLogger m)

=> Maybe (Map PackageName SimpleTarget)

-> Map PackageName SimpleTarget

-> [GhciPkgInfo]

-> m (Maybe (Path Abs File))

figureOutMainFile mainIsTargets targets0 packages = do

case candidates of

[] -> return Nothing

[c@(_,_,fp)] -> do $logInfo ("Using main module: " <> renderCandidate c)

return (Just fp)

candidate:_ -> do

let border = $logWarn "* * * * * * * *"

border

$logWarn ("The main module to load is ambiguous. Candidates are: ")

forM_ (map renderCandidate candidates) $logWarn

$logWarn

"None will be loaded. You can specify which one to pick by: "

$logWarn

(" 1) Specifying targets to stack ghci e.g. stack ghci " <>

sampleTargetArg candidate)

$logWarn

(" 2) Specifying what the main is e.g. stack ghci " <>

sampleMainIsArg candidate)

border

return Nothing

where

targets = fromMaybe targets0 mainIsTargets

candidates = do

pkg <- packages

case M.lookup (ghciPkgName pkg) targets of

Nothing -> []

Just target -> do

(component,mains) <-

M.toList

(M.filterWithKey wantedComponent (ghciPkgMainIs pkg))

main <- S.toList mains

return (ghciPkgName pkg, component, main)

where wantedComponent namedC _ =

case target of

STLocalAll -> True

STLocalComps cs -> S.member namedC cs

_ -> False

renderCandidate (pkgName,namedComponent,mainIs) =

"Package `" <> packageNameText pkgName <> "' component " <>

renderComp namedComponent <>

" with main-is file: " <>

T.pack (toFilePath mainIs)

renderComp c =

case c of

CLib -> "lib"

CExe name -> "exe:" <> name

CTest name -> "test:" <> name

CBench name -> "bench:" <> name

sampleTargetArg (pkg,comp,_) =

packageNameText pkg <> ":" <> renderComp comp

sampleMainIsArg (pkg,comp,_) =

"--main-is " <> packageNameText pkg <> ":" <> renderComp comp

-- | Create a list of infos for each target containing necessary

-- information to load that package/components.

ghciSetup

:: (HasConfig r, HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m)

=> Maybe Text

-> [Text]

-> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo])

ghciSetup mainIs stringTargets = do

(_,_,targets) <-

parseTargetsFromBuildOpts

AllowNoTargets

defaultBuildOpts

{ boptsTargets = stringTargets

}

mainIsTargets <-

case mainIs of

Nothing -> return Nothing

Just target -> do

(_,_,targets') <-

parseTargetsFromBuildOpts

AllowNoTargets

defaultBuildOpts

{ boptsTargets = [target]

}

return (Just targets')

let bopts = makeBuildOpts targets

econfig <- asks getEnvConfig

(realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets bopts

locals <-

liftM catMaybes $

forM (M.toList (envConfigPackages econfig)) $

\(dir,validWanted) ->

do cabalfp <- getCabalFileName dir

name <- parsePackageNameFromFilePath cabalfp

if validWanted

then case M.lookup name targets of

Just simpleTargets ->

return (Just (name, (cabalfp, simpleTargets)))

Nothing -> return Nothing

else return Nothing

infos <-

forM locals $

\(name,(cabalfp,components)) ->

makeGhciPkgInfo sourceMap (map fst locals) name cabalfp components

unless (M.null realTargets) (build (const (return ())) Nothing bopts)

return (realTargets, mainIsTargets, infos)

where

makeBuildOpts targets =

base

{ boptsTargets = stringTargets

, boptsTests = any (hasLocalComp isCTest) elems

, boptsBenchmarks = any (hasLocalComp isCBench) elems

, boptsTestOpts = (boptsTestOpts base)

{ toDisableRun = True

, toRerunTests = False

}

, boptsBenchmarkOpts = (boptsBenchmarkOpts base)

{ beoDisableRun = True

}

, boptsBuildSubset = BSOnlyDependencies

}

where

base = defaultBuildOpts

elems = M.elems targets

hasLocalComp p t =

case t of

STLocalComps s -> any p (S.toList s)

STLocalAll -> True

_ -> False

isCTest nc =

case nc of

CTest{} -> True

_ -> False

isCBench nc =

case nc of

CBench{} -> True

_ -> False

-- | Make information necessary to load the given package in GHCi.

makeGhciPkgInfo

:: (MonadReader r m, HasEnvConfig r, MonadLogger m, MonadIO m, MonadCatch m)

=> SourceMap

-> [PackageName]

-> PackageName

-> Path Abs File

-> SimpleTarget

-> m GhciPkgInfo

makeGhciPkgInfo sourceMap locals name cabalfp components = do

econfig <- asks getEnvConfig

bconfig <- asks getBuildConfig

let config =

PackageConfig

{ packageConfigEnableTests = True

, packageConfigEnableBenchmarks = True

, packageConfigFlags = localFlags mempty bconfig name

, packageConfigCompilerVersion = envConfigCompilerVersion econfig

, packageConfigPlatform = configPlatform (getConfig bconfig)

}

(warnings,pkg) <- readPackage config cabalfp

mapM_ (printCabalFileWarning cabalfp) warnings

(componentsModules,componentFiles,componentsOpts,generalOpts) <-

getPackageOpts (packageOpts pkg) sourceMap locals cabalfp

let filterWithinWantedComponents m =

M.elems

(M.filterWithKey

(\k _ ->

case components of

STLocalComps cs -> S.member k cs

_ -> True)

m)

return

GhciPkgInfo

{ ghciPkgName = packageName pkg

, ghciPkgOpts = filter

(not . badForGhci)

(generalOpts <>

concat (filterWithinWantedComponents componentsOpts))

, ghciPkgDir = parent cabalfp

, ghciPkgModules = mconcat

(filterWithinWantedComponents componentsModules)

, ghciPkgModFiles = mconcat

(filterWithinWantedComponents

(M.map (setMapMaybe dotCabalModulePath) componentFiles))

, ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) componentFiles

, ghciPkgCFiles = mconcat

(filterWithinWantedComponents

(M.map (setMapMaybe dotCabalCFilePath) componentFiles))

}

where

badForGhci :: String -> Bool

badForGhci x =

isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky")

setMapMaybe f = S.fromList . mapMaybe f . S.toList