module IHaskell.Eval.Util (
initGhci,
extensionFlag, setExtension,
ExtFlag(..),
setFlags,
evalImport,
evalDeclarations,
getType,
getDescription,
doc,
) where
import ClassyPrelude
import DynFlags
import FastString
import GHC
import GhcMonad
import HsImpExp
import HscTypes
import InteractiveEval
import Module
import Outputable
import Packages
import RdrName
import NameSet
import Name
import PprTyThing
import qualified Pretty
import Control.Monad (void)
import Data.Function (on)
import Data.String.Utils (replace)
data ExtFlag
= SetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
extensionFlag :: String
-> Maybe ExtFlag
extensionFlag ext =
case find (flagMatches ext) xFlags of
Just (_, flag, _) -> Just $ SetFlag flag
Nothing ->
case find (flagMatchesNo ext) xFlags of
Just (_, flag, _) -> Just $ UnsetFlag flag
Nothing -> Nothing
where
flagMatches ext (name, _, _) = ext == name
flagMatchesNo ext (name, _, _) = ext == "No" ++ name
setExtension :: GhcMonad m => String -> m (Maybe String)
setExtension ext = do
flags <- getSessionDynFlags
case extensionFlag ext of
Nothing -> return $ Just $ "Could not parse extension name: " ++ ext
Just flag -> do
setSessionDynFlags $
case flag of
SetFlag ghcFlag -> xopt_set flags ghcFlag
UnsetFlag ghcFlag -> xopt_unset flags ghcFlag
return Nothing
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
doc :: GhcMonad m => SDoc -> m String
doc sdoc = do
flags <- getSessionDynFlags
unqual <- getPrintUnqual
let style = mkUserStyle unqual AllTheWay
let cols = pprCols flags
d = runSDoc sdoc (initSDocContext flags style)
return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d
where
string_txt :: Pretty.TextDetails -> String -> String
string_txt (Pretty.Chr c) s = c:s
string_txt (Pretty.Str s1) s2 = s1 ++ s2
string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2
string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2
initGhci :: GhcMonad m => Maybe String -> m ()
initGhci sandboxPackages = do
originalFlags <- getSessionDynFlags
let flag = flip xopt_set
unflag = flip xopt_unset
dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags
pkgConfs = case sandboxPackages of
Nothing -> extraPkgConfs originalFlags
Just path ->
let pkg = PkgConfFile path in
(pkg:) . extraPkgConfs originalFlags
void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted,
ghcLink = LinkInMemory,
pprCols = 300,
extraPkgConfs = pkgConfs }
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 && not (ideclQualified decl)
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
getType :: GhcMonad m => String -> m String
getType expr = do
result <- exprType expr
flags <- getSessionDynFlags
let typeStr = showSDocUnqual flags $ ppr result
return typeStr
getDescription :: GhcMonad m => String -> m [String]
getDescription str = do
names <- parseName str
maybeInfos <- mapM getInfo' names
let infos = catMaybes maybeInfos
allNames = mkNameSet $ map (getName . getType) infos
hasParent info = case tyThingParent_maybe (getType info) of
Just parent -> getName parent `elemNameSet` allNames
Nothing -> False
filteredOutput = filter (not . hasParent) infos
mapM (doc . printInfo) filteredOutput
where
#if MIN_VERSION_ghc(7,8,0)
getInfo' = getInfo False
#else
getInfo' = getInfo
#endif
#if MIN_VERSION_ghc(7,8,0)
getType (theType, _, _, _) = theType
#else
getType (theType, _, _) = theType
#endif
#if MIN_VERSION_ghc(7,8,0)
printInfo (thing, fixity, classInstances, famInstances) =
pprTyThingInContextLoc thing $$
showFixity thing fixity $$
vcat (map GHC.pprInstance classInstances) $$
vcat (map GHC.pprFamInst famInstances)
#else
printInfo (thing, fixity, classInstances) =
pprTyThingInContextLoc False thing $$ showFixity thing fixity $$ vcat (map GHC.pprInstance classInstances)
#endif
showFixity thing fixity =
if fixity == GHC.defaultFixity
then empty
else ppr fixity <+> pprInfixName (getName thing)