{-# LANGUAGE PatternGuards, PackageImports #-}

module HsDev.Tools.Ghc.Base (
	-- * Running Ghc
	ghcRun, ghcRunWith,
	-- * Commonly used DynFlags
	interpretedFlags, noLinkFlags,
	-- * Setting DynFlags
	withFlags, modifyFlags,
	-- * Loading targets
	clearTargets, makeTarget, loadTargets,
	loadInteractive, reload,
	-- * Logging messages
	collectMessages, collectMessages_,

	-- * Util
	formatType,
	spanRegion,
	withCurrentDirectory,
	logToChan, logToNull
	) where

import Control.Lens (view, over)
import Control.Monad
import Control.Monad.Except
import Data.Time.Clock (getCurrentTime)
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import System.FilePath

import "ghc" Exception (ExceptionMonad(..))
import "ghc" GHC hiding (Warning, Module)
import "ghc" Outputable
import "ghc" FastString (unpackFS)
import "ghc" StringBuffer
import "ghc" Type
import qualified "ghc" Pretty

import Control.Concurrent.FiniteChan
import System.Directory.Paths
import HsDev.Symbols.Location (Position(..), Region(..), region, ModuleLocation(..))
import HsDev.Tools.Types
import HsDev.Tools.Ghc.Compat
import qualified HsDev.Tools.Ghc.Compat as C (setLogAction, addLogAction, unqualStyle, mkFunTy)

-- | Run ghc
ghcRun :: GhcMonad m => [String] -> m a -> m a
ghcRun :: [String] -> m a -> m a
ghcRun = (DynFlags -> DynFlags) -> [String] -> m a -> m a
forall (m :: * -> *) a.
GhcMonad m =>
(DynFlags -> DynFlags) -> [String] -> m a -> m a
ghcRunWith DynFlags -> DynFlags
interpretedFlags

-- | Run ghc
ghcRunWith :: GhcMonad m => (DynFlags -> DynFlags) -> [String] -> m a -> m a
ghcRunWith :: (DynFlags -> DynFlags) -> [String] -> m a -> m a
ghcRunWith DynFlags -> DynFlags
onFlags [String]
opts m a
act = do
	DynFlags
fs <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
	DynFlags -> m a -> m a
forall (m :: * -> *) a. DynFlags -> m a -> m a
cleanupHandler DynFlags
fs (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
		(DynFlags
fs', [Located String]
_, [Warn]
_) <- DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlags DynFlags
fs ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [String]
opts)
		m [InstalledUnitId] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [InstalledUnitId] -> m ()) -> m [InstalledUnitId] -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags (DynFlags -> m [InstalledUnitId])
-> DynFlags -> m [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
onFlags DynFlags
fs'
		(DynFlags -> DynFlags) -> m ()
forall (m :: * -> *). GhcMonad m => (DynFlags -> DynFlags) -> m ()
modifyFlags ((DynFlags -> DynFlags) -> m ()) -> (DynFlags -> DynFlags) -> m ()
forall a b. (a -> b) -> a -> b
$ LogAction -> DynFlags -> DynFlags
C.setLogAction LogAction
logToNull
		m a
act

interpretedFlags :: DynFlags -> DynFlags
interpretedFlags :: DynFlags -> DynFlags
interpretedFlags DynFlags
fs = DynFlags
fs {
	ghcMode :: GhcMode
ghcMode = GhcMode
CompManager,
	ghcLink :: GhcLink
ghcLink = GhcLink
LinkInMemory,
	hscTarget :: HscTarget
hscTarget = HscTarget
HscInterpreted }

noLinkFlags :: DynFlags -> DynFlags
noLinkFlags :: DynFlags -> DynFlags
noLinkFlags DynFlags
fs = DynFlags
fs {
	ghcMode :: GhcMode
ghcMode = GhcMode
CompManager,
	ghcLink :: GhcLink
ghcLink = GhcLink
NoLink,
	hscTarget :: HscTarget
hscTarget = HscTarget
HscNothing }

-- | Alter @DynFlags@ temporary
withFlags :: GhcMonad m => m a -> m a
withFlags :: m a -> m a
withFlags = m DynFlags -> (DynFlags -> m ()) -> (DynFlags -> m a) -> m a
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags (m [InstalledUnitId] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [InstalledUnitId] -> m ())
-> (DynFlags -> m [InstalledUnitId]) -> DynFlags -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags) ((DynFlags -> m a) -> m a)
-> (m a -> DynFlags -> m a) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> DynFlags -> m a
forall a b. a -> b -> a
const

-- | Update @DynFlags@
modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
modifyFlags :: (DynFlags -> DynFlags) -> m ()
modifyFlags DynFlags -> DynFlags
f = do
	DynFlags
fs <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
	let
		fs' :: DynFlags
fs' = DynFlags -> DynFlags
f DynFlags
fs
	[InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
fs'
	-- _ <- liftIO $ initPackages fs'
	() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Clear loaded targets
clearTargets :: GhcMonad m => m ()
clearTargets :: m ()
clearTargets = [Target] -> m ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
loadTargets []

-- | Make target with its source code optional
makeTarget :: GhcMonad m => Text -> Maybe Text -> m Target
makeTarget :: Text -> Maybe Text -> m Target
makeTarget Text
name Maybe Text
Nothing = String -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe Phase -> m Target
guessTarget (Text -> String
T.unpack Text
name) Maybe Phase
forall a. Maybe a
Nothing
makeTarget Text
name (Just Text
cts) = do
	Target
t <- String -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe Phase -> m Target
guessTarget (Text -> String
T.unpack Text
name) Maybe Phase
forall a. Maybe a
Nothing
	UTCTime
tm <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
	Target -> m Target
forall (m :: * -> *) a. Monad m => a -> m a
return Target
t { targetContents :: Maybe (InputFileBuffer, UTCTime)
targetContents = (InputFileBuffer, UTCTime) -> Maybe (InputFileBuffer, UTCTime)
forall a. a -> Maybe a
Just (String -> InputFileBuffer
stringToStringBuffer (String -> InputFileBuffer) -> String -> InputFileBuffer
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
cts, UTCTime
tm) }

-- | Load all targets
loadTargets :: GhcMonad m => [Target] -> m ()
loadTargets :: [Target] -> m ()
loadTargets [Target]
ts = [Target] -> m ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
ts m () -> m SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LoadHowMuch -> m SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
LoadAllTargets m SuccessFlag -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Load and set interactive context
loadInteractive :: GhcMonad m => Path -> Maybe Text -> m ()
loadInteractive :: Text -> Maybe Text -> m ()
loadInteractive Text
fpath Maybe Text
mcts = do
	Text
fpath' <- IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> IO Text
forall a. Paths a => a -> IO a
canonicalize Text
fpath
	String -> m () -> m ()
forall (m :: * -> *) a. GhcMonad m => String -> m a -> m a
withCurrentDirectory (Getting String Text String -> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Text String
Lens' Text String
path (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
takeDir Text
fpath') (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
		Target
t <- Text -> Maybe Text -> m Target
forall (m :: * -> *). GhcMonad m => Text -> Maybe Text -> m Target
makeTarget (ASetter Text Text String String
-> (String -> String) -> Text -> Text
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Text Text String String
Lens' Text String
path String -> String
takeFileName Text
fpath') Maybe Text
mcts
		[Target] -> m ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
loadTargets [Target
t]
		ModuleGraph
g <- m ModuleGraph
forall (m :: * -> *). GhcMonad m => m ModuleGraph
getModuleGraph
		[InteractiveImport] -> m ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext [ModuleName -> InteractiveImport
IIModule (ModSummary -> ModuleName
ms_mod_name ModSummary
m) | ModSummary
m <- ModuleGraph -> [ModSummary]
modSummaries ModuleGraph
g]

-- | Reload targets
reload :: GhcMonad m => m ()
reload :: m ()
reload = do
	[Target]
ts <- m [Target]
forall (m :: * -> *). GhcMonad m => m [Target]
getTargets
	[InteractiveImport]
ctx <- m [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
	[InteractiveImport] -> m ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext []
	m ()
forall (m :: * -> *). GhcMonad m => m ()
clearTargets
	[Target] -> m ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target]
ts
	[InteractiveImport] -> m ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext [InteractiveImport]
ctx

-- | Collect messages from ghc for underlying computation
collectMessages :: GhcMonad m => m a -> m (a, [Note OutputMessage])
collectMessages :: m a -> m (a, [Note OutputMessage])
collectMessages m a
act = do
	Chan (Note OutputMessage)
ch <- IO (Chan (Note OutputMessage)) -> m (Chan (Note OutputMessage))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Chan (Note OutputMessage))
forall a. IO (Chan a)
newChan
	a
r <- m LogAction -> (LogAction -> m ()) -> (LogAction -> m a) -> m a
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket ((DynFlags -> LogAction) -> m DynFlags -> m LogAction
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DynFlags -> LogAction
log_action m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags) (\LogAction
action' -> (DynFlags -> DynFlags) -> m ()
forall (m :: * -> *). GhcMonad m => (DynFlags -> DynFlags) -> m ()
modifyFlags (\DynFlags
fs -> DynFlags
fs { log_action :: LogAction
log_action = LogAction
action' })) ((LogAction -> m a) -> m a) -> (LogAction -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \LogAction
_ -> do
		(DynFlags -> DynFlags) -> m ()
forall (m :: * -> *). GhcMonad m => (DynFlags -> DynFlags) -> m ()
modifyFlags (LogAction -> DynFlags -> DynFlags
C.addLogAction (LogAction -> DynFlags -> DynFlags)
-> LogAction -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ Chan (Note OutputMessage) -> LogAction
logToChan Chan (Note OutputMessage)
ch)
		m a
act
	[Note OutputMessage]
notes <- IO [Note OutputMessage] -> m [Note OutputMessage]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Note OutputMessage] -> m [Note OutputMessage])
-> IO [Note OutputMessage] -> m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ Chan (Note OutputMessage) -> IO [Note OutputMessage]
forall a. Chan a -> IO [a]
stopChan Chan (Note OutputMessage)
ch
	(a, [Note OutputMessage]) -> m (a, [Note OutputMessage])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
r, [Note OutputMessage]
notes)

-- | Same as @collectMessages@, but when no result except notes needed
collectMessages_ :: GhcMonad m => m () -> m [Note OutputMessage]
collectMessages_ :: m () -> m [Note OutputMessage]
collectMessages_ = (((), [Note OutputMessage]) -> [Note OutputMessage])
-> m ((), [Note OutputMessage]) -> m [Note OutputMessage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((), [Note OutputMessage]) -> [Note OutputMessage]
forall a b. (a, b) -> b
snd (m ((), [Note OutputMessage]) -> m [Note OutputMessage])
-> (m () -> m ((), [Note OutputMessage]))
-> m ()
-> m [Note OutputMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m ((), [Note OutputMessage])
forall (m :: * -> *) a.
GhcMonad m =>
m a -> m (a, [Note OutputMessage])
collectMessages

-- | Format type for output
formatType :: GHC.DynFlags -> GHC.Type -> String
formatType :: DynFlags -> Type -> String
formatType DynFlags
dflag Type
t = DynFlags -> Type -> String
forall a. Outputable a => DynFlags -> a -> String
showOutputable DynFlags
dflag (Type -> Type
removeForAlls Type
t)

-- | Get region of @SrcSpan@
spanRegion :: SrcSpan -> Region
spanRegion :: SrcSpan -> Region
spanRegion (RealSrcSpan RealSrcSpan
s) = Int -> Int -> Position
Position (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s) (RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s) Position -> Position -> Region
`region` Int -> Int -> Position
Position (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
s) (RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
s)
spanRegion SrcSpan
_ = Int -> Int -> Position
Position Int
0 Int
0 Position -> Position -> Region
`region` Int -> Int -> Position
Position Int
0 Int
0

-- | Set current directory and restore it after action
withCurrentDirectory :: GhcMonad m => FilePath -> m a -> m a
withCurrentDirectory :: String -> m a -> m a
withCurrentDirectory String
dir m a
act = m String -> (String -> m ()) -> (String -> m a) -> m a
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket (IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCurrentDirectory) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
setCurrentDirectory) ((String -> m a) -> m a) -> (String -> m a) -> m a
forall a b. (a -> b) -> a -> b
$
	m a -> String -> m a
forall a b. a -> b -> a
const (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
setCurrentDirectory String
dir) m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
act)

-- | Log ghc warnings and errors as to chan
-- You may have to apply recalcTabs on result notes
logToChan :: Chan (Note OutputMessage) -> LogAction
logToChan :: Chan (Note OutputMessage) -> LogAction
logToChan Chan (Note OutputMessage)
ch DynFlags
fs Severity
sev SrcSpan
src MsgDoc
msg
	| Just Severity
sev' <- Severity -> Maybe Severity
checkSev Severity
sev = do
		ModuleLocation
src' <- ModuleLocation -> IO ModuleLocation
forall a. Paths a => a -> IO a
canonicalize ModuleLocation
srcMod
		IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Chan (Note OutputMessage) -> Note OutputMessage -> IO Bool
forall a. Chan a -> a -> IO Bool
sendChan Chan (Note OutputMessage)
ch Note :: forall a. ModuleLocation -> Region -> Maybe Severity -> a -> Note a
Note {
			_noteSource :: ModuleLocation
_noteSource = ModuleLocation
src',
			_noteRegion :: Region
_noteRegion = SrcSpan -> Region
spanRegion SrcSpan
src,
			_noteLevel :: Maybe Severity
_noteLevel = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
sev',
			_note :: OutputMessage
_note = OutputMessage :: Text -> Maybe Text -> OutputMessage
OutputMessage {
				_message :: Text
_message = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> String
showSDoc DynFlags
fs MsgDoc
msg,
				_messageSuggestion :: Maybe Text
_messageSuggestion = Maybe Text
forall a. Maybe a
Nothing } }
	| Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
	where
		checkSev :: Severity -> Maybe Severity
checkSev Severity
SevWarning = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
Warning
		checkSev Severity
SevError = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
Error
		checkSev Severity
SevFatal = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
Error
		checkSev Severity
_ = Maybe Severity
forall a. Maybe a
Nothing
		srcMod :: ModuleLocation
srcMod = case SrcSpan
src of
			RealSrcSpan RealSrcSpan
s' -> Text -> Maybe Project -> ModuleLocation
FileModule (String -> Text
fromFilePath (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS (FastString -> String) -> FastString -> String
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
s') Maybe Project
forall a. Maybe a
Nothing
			SrcSpan
_ -> ModuleLocation
NoLocation

-- | Don't log ghc warnings and errors
logToNull :: LogAction
logToNull :: LogAction
logToNull DynFlags
_ Severity
_ SrcSpan
_ MsgDoc
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- TODO: Load target by @ModuleLocation@, which may cause updating @DynFlags@

removeForAlls :: Type -> Type
removeForAlls :: Type -> Type
removeForAlls Type
ty = Type -> Maybe (Type, Type) -> Type
removeForAlls' Type
ty' Maybe (Type, Type)
tty' where
	ty' :: Type
ty'  = Type -> Type
dropForAlls Type
ty
	tty' :: Maybe (Type, Type)
tty' = Type -> Maybe (Type, Type)
splitFunTy_maybe Type
ty'

removeForAlls' :: Type -> Maybe (Type, Type) -> Type
removeForAlls' :: Type -> Maybe (Type, Type) -> Type
removeForAlls' Type
ty Maybe (Type, Type)
Nothing = Type
ty
removeForAlls' Type
ty (Just (Type
pre, Type
ftype))
	| HasDebugCallStack => Type -> Bool
Type -> Bool
isPredTy Type
pre = Type -> Type -> Type
C.mkFunTy Type
pre (Type -> Type
dropForAlls Type
ftype)
	| Bool
otherwise = Type
ty

showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable :: DynFlags -> a -> String
showOutputable DynFlags
dflag = [String] -> String
unwords ([String] -> String) -> (a -> [String]) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (a -> String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> MsgDoc -> String
showUnqualifiedPage DynFlags
dflag (MsgDoc -> String) -> (a -> MsgDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr

showUnqualifiedPage :: DynFlags -> SDoc -> String
showUnqualifiedPage :: DynFlags -> MsgDoc -> String
showUnqualifiedPage DynFlags
dflag = Mode -> Int -> Doc -> String
renderStyle Mode
Pretty.LeftMode Int
0 (Doc -> String) -> (MsgDoc -> Doc) -> MsgDoc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> PprStyle -> MsgDoc -> Doc
withPprStyleDoc DynFlags
dflag (DynFlags -> PprStyle
C.unqualStyle DynFlags
dflag)