mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-17 20:06:07 +00:00
Code Issues Packages Projects Releases Wiki Activity

Moved ghci-lib into IHaskell.

Browse Source
This commit is contained in:
Andrew Gibiansky 2014-05-18 16:13:23 -07:00
parent 393f87343e
commit c2121c73b6
8 changed files with 148 additions and 204 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
ghci-lib/LICENSE
View File

@ -1,20 +0,0 @@
The MIT License (MIT)
Copyright (c) 2013 Andrew Gibiansky
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Software, and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

120
ghci-lib/Language/Haskell/GHC/Interpret.hs
View File

@ -1,120 +0,0 @@
module Language.Haskell.GHC.Interpret (
-- Initialize GHC API.
initGhci,
-- Evaluation
{-
evalStatements,
evalExpression,
-}
evalImport,
evalDeclarations,
setFlags,
getType,
{-
loadFile,
-}
) 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)
-- | Initialize the GHC API. Run this as the first thing in the `runGhc`.
initGhci :: GhcMonad m => m ()
initGhci = do
-- Initialize dyn flags.
-- Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
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 }
-- | Evaluate a single import statement.
-- If this import statement is importing a module which was previously
-- imported implicitly (such as `Prelude`) or if this module has a `hiding`
-- annotation, the previous import is removed.
evalImport :: GhcMonad m => String -> m ()
evalImport imports = do
importDecl <- parseImportDecl imports
context <- getContext
-- If we've imported this implicitly, remove the old import.
let noImplicit = filter (not . implicitImportOf importDecl) context
-- If this is a `hiding` import, remove previous non-`hiding` imports.
oldImps = if isHiddenImport importDecl
then filter (not . importOf importDecl) context
else noImplicit
-- Replace the context.
setContext $ IIDecl importDecl : oldImps
where
-- Check whether an import is the same as another import (same module).
importOf :: ImportDecl RdrName -> InteractiveImport -> Bool
importOf _ (IIModule _) = False
importOf imp (IIDecl decl) = ((==) `on` (unLoc . ideclName)) decl imp
-- Check whether an import is an *implicit* import of something.
implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool
implicitImportOf _ (IIModule _) = False
implicitImportOf imp (IIDecl decl) = ideclImplicit decl && imp `importOf` IIDecl decl
-- Check whether an import is hidden.
isHiddenImport :: ImportDecl RdrName -> Bool
isHiddenImport imp = case ideclHiding imp of
Just (True, _) -> True
_ -> False
-- | Evaluate a series of declarations.
-- Return all names which were bound by these declarations.
evalDeclarations :: GhcMonad m => String -> m [String]
evalDeclarations decl = do
names <- runDecls decl
flags <- getSessionDynFlags
return $ map (replace ":Interactive." "" . showPpr flags) names
-- | Set a list of flags, as per GHCi's `:set`.
-- This was adapted from GHC's InteractiveUI.hs (newDynFlags).
-- It returns a list of error messages.
setFlags :: GhcMonad m => [String] -> m [String]
setFlags ext = do
-- Try to parse flags.
flags <- getSessionDynFlags
(flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
-- First, try to check if this flag matches any extension name.
let restorePkg x = x { packageFlags = packageFlags flags }
let restoredPkgs = flags' { packageFlags = packageFlags flags}
GHC.setProgramDynFlags restoredPkgs
GHC.setInteractiveDynFlags restoredPkgs
-- Create the parse errors.
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
-- | Get the type of an expression.
getType :: GhcMonad m => String -> m String
getType expr = do
result <- exprType expr
flags <- getSessionDynFlags
let typeStr = showSDocUnqual flags $ ppr result
return typeStr

25
ghci-lib/Language/Haskell/GHC/Util.hs
View File

@ -1,25 +0,0 @@
module Language.Haskell.GHC.Util where
import GhcMonad
import GHC
import DynFlags
import Outputable
import Packages
import Module
import qualified Pretty
import FastString
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

2
ghci-lib/Setup.hs
View File

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

28
ghci-lib/ghci-lib.cabal
View File

@ -1,28 +0,0 @@
-- Initial ghci-lib.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: ghci-lib
version: 0.1.0.0
synopsis: A library for interactively evaluating Haskell code.
-- description:
homepage: http://github.com/gibiansky/IHaskell
license: MIT
license-file: LICENSE
author: Andrew Gibiansky
maintainer: andrew.gibiansky@gmail.com
-- copyright:
category: Language
build-type: Simple
-- extra-source-files:
cabal-version: >=1.10
library
exposed-modules: Language.Haskell.GHC.Interpret,
Language.Haskell.GHC.Util
-- other-modules:
-- other-extensions:
build-depends: base >=4.6 && <4.7,
ghc==7.6.*, MissingH >= 1.2
-- hs-source-dirs:
default-language: Haskell2010

2
ihaskell.cabal
View File

@ -67,7 +67,6 @@ library
ghc ==7.6.*,
ghc-parser >=0.1.1,
ghc-paths ==0.1.*,
ghci-lib >=0.1,
haskeline -any,
here ==1.2.*,
hlint ==1.8.61,
@ -169,7 +168,6 @@ Test-Suite hspec
ghc ==7.6.*,
ghc-parser >=0.1.1,
ghc-paths ==0.1.*,
ghci-lib >=0.1,
haskeline -any,
here ==1.2.*,
hlint ==1.8.61,

3
src/IHaskell/Eval/Evaluate.hs
View File

@ -75,9 +75,6 @@ import qualified IHaskell.IPython.Message.UUID as UUID
import Paths_ihaskell (version)
import Data.Version (versionBranch)
import Language.Haskell.GHC.Interpret
import Language.Haskell.GHC.Util
data ErrorOccurred = Success | Failure deriving (Show, Eq)
debug :: Bool

152
src/IHaskell/Eval/Util.hs
View File

@ -1,20 +1,51 @@
module IHaskell.Eval.Util (
-- * Initialization
initGhci,
-- * Flags and extensions
-- ** Set and unset flags.
extensionFlag, setExtension,
ExtFlag(..),
setFlags,
-- * Code Evaluation
evalImport,
evalDeclarations,
getType,
-- * Pretty printing
doc,
) where
-- GHC imports.
import DynFlags
import FastString
import GHC
import GhcMonad
import DynFlags
import HsImpExp
import HscTypes
import InteractiveEval
import Module
import Outputable
import Packages
import RdrName
import qualified Pretty
import Control.Monad (void)
import Data.Function (on)
import Data.List (find)
import Data.String.Utils (replace)
-- | A extension flag that can be set or unset.
data ExtFlag
= SetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
extensionFlag :: String -> Maybe ExtFlag
-- | Find the extension that corresponds to a given flag. Create the
-- corresponding 'ExtFlag' via @SetFlag@ or @UnsetFlag@.
-- If no such extension exist, yield @Nothing@.
extensionFlag :: String -- Extension name, such as @"DataKinds"@
-> Maybe ExtFlag
extensionFlag ext =
case find (flagMatches ext) xFlags of
Just (_, flag, _) -> Just $ SetFlag flag
@ -33,8 +64,8 @@ extensionFlag ext =
-- In that case, we disable the extension.
flagMatchesNo ext (name, _, _) = ext == "No" ++ name
-- Set an extension and update flags.
-- Return Nothing on success. On failure, return an error message.
-- | Set an extension and update flags.
-- Return @Nothing@ on success. On failure, return an error message.
setExtension :: GhcMonad m => String -> m (Maybe String)
setExtension ext = do
flags <- getSessionDynFlags
@ -46,3 +77,116 @@ setExtension ext = do
SetFlag ghcFlag -> xopt_set flags ghcFlag
UnsetFlag ghcFlag -> xopt_unset flags ghcFlag
return Nothing
-- | Set a list of flags, as per GHCi's `:set`.
-- This was adapted from GHC's InteractiveUI.hs (newDynFlags).
-- It returns a list of error messages.
setFlags :: GhcMonad m => [String] -> m [String]
setFlags ext = do
-- Try to parse flags.
flags <- getSessionDynFlags
(flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
-- First, try to check if this flag matches any extension name.
let restorePkg x = x { packageFlags = packageFlags flags }
let restoredPkgs = flags' { packageFlags = packageFlags flags}
GHC.setProgramDynFlags restoredPkgs
GHC.setInteractiveDynFlags restoredPkgs
-- Create the parse errors.
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
-- | Convert an 'SDoc' into a string. This is similar to the family of
-- 'showSDoc' functions, but does not impose an arbitrary width limit on
-- the output (in terms of number of columns). Instead, it respsects the
-- 'pprCols' field in the structure returned by 'getSessionDynFlags', and
-- thus gives a configurable width of output.
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
-- | Initialize the GHC API. Run this as the first thing in the `runGhc`.
-- This initializes some dyn flags (@ExtendedDefaultRules@,
-- @NoMonomorphismRestriction@), sets the target to interpreted, link in
-- memory, sets a reasonable output width, and potentially a few other
-- things. It should be invoked before other functions from this module.
initGhci :: GhcMonad m => m ()
initGhci = do
-- Initialize dyn flags.
-- Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.
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 }
-- | Evaluate a single import statement.
-- If this import statement is importing a module which was previously
-- imported implicitly (such as `Prelude`) or if this module has a `hiding`
-- annotation, the previous import is removed.
evalImport :: GhcMonad m => String -> m ()
evalImport imports = do
importDecl <- parseImportDecl imports
context <- getContext
-- If we've imported this implicitly, remove the old import.
let noImplicit = filter (not . implicitImportOf importDecl) context
-- If this is a `hiding` import, remove previous non-`hiding` imports.
oldImps = if isHiddenImport importDecl
then filter (not . importOf importDecl) context
else noImplicit
-- Replace the context.
setContext $ IIDecl importDecl : oldImps
where
-- Check whether an import is the same as another import (same module).
importOf :: ImportDecl RdrName -> InteractiveImport -> Bool
importOf _ (IIModule _) = False
importOf imp (IIDecl decl) = ((==) `on` (unLoc . ideclName)) decl imp
-- Check whether an import is an *implicit* import of something.
implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool
implicitImportOf _ (IIModule _) = False
implicitImportOf imp (IIDecl decl) = ideclImplicit decl && imp `importOf` IIDecl decl
-- Check whether an import is hidden.
isHiddenImport :: ImportDecl RdrName -> Bool
isHiddenImport imp = case ideclHiding imp of
Just (True, _) -> True
_ -> False
-- | Evaluate a series of declarations.
-- Return all names which were bound by these declarations.
evalDeclarations :: GhcMonad m => String -> m [String]
evalDeclarations decl = do
names <- runDecls decl
flags <- getSessionDynFlags
return $ map (replace ":Interactive." "" . showPpr flags) names
-- | Get the type of an expression and convert it to a string.
getType :: GhcMonad m => String -> m String
getType expr = do
result <- exprType expr
flags <- getSessionDynFlags
let typeStr = showSDocUnqual flags $ ppr result
return typeStr