{-# LANGUAGE PatternGuards, PackageImports #-}
module HsDev.Tools.Ghc.Base (
ghcRun, ghcRunWith,
interpretedFlags, noLinkFlags,
withFlags, modifyFlags,
clearTargets, makeTarget, loadTargets,
loadInteractive, reload,
collectMessages, collectMessages_,
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)
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
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 }
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
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'
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
clearTargets :: GhcMonad m => m ()
clearTargets :: m ()
clearTargets = [Target] -> m ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
loadTargets []
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) }
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 ()
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 :: 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
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)
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
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)
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
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)
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
logToNull :: LogAction
logToNull :: LogAction
logToNull DynFlags
_ Severity
_ SrcSpan
_ MsgDoc
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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)