module Language.Haskell.GHC.Interpret (
initGhci,
evalImport,
evalDeclarations,
setFlags,
getType,
) where
import InteractiveEval
import GHC
import DynFlags
import GhcMonad
import HsImpExp
import HscTypes
import RdrName
import Outputable
import Data.Function (on)
import Control.Monad (void)
import Data.String.Utils (replace)
initGhci :: GhcMonad m => m ()
initGhci = do
originalFlags <- getSessionDynFlags
let flag = flip xopt_set
unflag = flip xopt_unset
dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags
void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted,
ghcLink = LinkInMemory,
pprCols = 300 }
evalImport :: GhcMonad m => String -> m ()
evalImport imports = do
importDecl <- parseImportDecl imports
context <- getContext
let noImplicit = filter (not . implicitImportOf importDecl) context
oldImps = if isHiddenImport importDecl
then filter (not . importOf importDecl) context
else noImplicit
setContext $ IIDecl importDecl : oldImps
where
importOf :: ImportDecl RdrName -> InteractiveImport -> Bool
importOf _ (IIModule _) = False
importOf imp (IIDecl decl) = ((==) `on` (unLoc . ideclName)) decl imp
implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool
implicitImportOf _ (IIModule _) = False
implicitImportOf imp (IIDecl decl) = ideclImplicit decl && imp `importOf` IIDecl decl
isHiddenImport :: ImportDecl RdrName -> Bool
isHiddenImport imp = case ideclHiding imp of
Just (True, _) -> True
_ -> False
evalDeclarations :: GhcMonad m => String -> m [String]
evalDeclarations decl = do
names <- runDecls decl
flags <- getSessionDynFlags
return $ map (replace ":Interactive." "" . showPpr flags) names
setFlags :: GhcMonad m => [String] -> m [String]
setFlags ext = do
flags <- getSessionDynFlags
(flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
let restorePkg x = x { packageFlags = packageFlags flags }
let restoredPkgs = flags' { packageFlags = packageFlags flags}
GHC.setProgramDynFlags restoredPkgs
GHC.setInteractiveDynFlags restoredPkgs
let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized
allWarns = map unLoc warnings ++
["-package not supported yet" | packageFlags flags /= packageFlags flags']
warnErrs = map ("Warning: " ++) allWarns
return $ noParseErrs ++ warnErrs
getType :: GhcMonad m => String -> m String
getType expr = do
result <- exprType expr
flags <- getSessionDynFlags
let typeStr = showSDocUnqual flags $ ppr result
return typeStr