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

Apply #686

Browse Source
This commit is contained in:
Andrei Barbu 2017-03-05 10:12:24 -05:00
parent 00478f3b8f
commit e97b70198f
15 changed files with 164 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
ghc-parser/ghc-parser.cabal
View File

@ -33,8 +33,8 @@ library
Language.Haskell.GHC.HappyParser
-- other-modules:
-- other-extensions:
build-depends: base >=4.6 && <4.9,
ghc >=7.6 && <7.11
build-depends: base >=4.6 && <4.10,
ghc >=7.6 && <8.1
if impl(ghc >= 7.6) && impl(ghc < 7.8)
hs-source-dirs: generic-src src-7.6
@ -45,6 +45,9 @@ library
if impl(ghc < 7.10)
hs-source-dirs: generic-src src-7.8.3
else
hs-source-dirs: generic-src src-7.10
if impl(ghc < 8.0)
hs-source-dirs: generic-src src-7.10
else
hs-source-dirs: generic-src src-8.0
default-language: Haskell2010

42
ghc-parser/src-8.0/Language/Haskell/GHC/HappyParser.hs Normal file
View File

@ -0,0 +1,42 @@
module Language.Haskell.GHC.HappyParser
( fullStatement
, fullImport
, fullDeclaration
, fullExpression
, fullTypeSignature
, fullModule
) where
import Parser
import SrcLoc
-- compiler/hsSyn
import HsSyn
-- compiler/utils
import OrdList
-- compiler/parser
import RdrHsSyn
import Lexer
-- compiler/basicTypes
import RdrName
fullStatement :: P (Maybe (LStmt RdrName (LHsExpr RdrName)))
fullStatement = parseStmt
fullImport :: P (LImportDecl RdrName)
fullImport = parseImport
fullDeclaration :: P (OrdList (LHsDecl RdrName))
fullDeclaration = fmap unitOL parseDeclaration
fullExpression :: P (LHsExpr RdrName)
fullExpression = parseExpression
fullTypeSignature :: P (Located (OrdList (LHsDecl RdrName)))
fullTypeSignature = fmap (noLoc . unitOL) parseTypeSignature
fullModule :: P (Located (HsModule RdrName))
fullModule = parseModule

2
ihaskell-display/ihaskell-aeson/ihaskell-aeson.cabal
View File

@ -57,7 +57,7 @@ library
OverloadedStrings
-- Other library packages from which modules are imported.
build-depends: base >=4.6 && <4.9,
build-depends: base >=4.6 && <4.10,
here,
text,
bytestring,

2
ihaskell-display/ihaskell-diagrams/ihaskell-diagrams.cabal
View File

@ -58,7 +58,7 @@ library
OverloadedStrings
-- Other library packages from which modules are imported.
build-depends: base >=4.6 && <4.9,
build-depends: base >=4.6 && <4.10,
text,
bytestring,
directory,

2
ihaskell-display/ihaskell-gnuplot/ihaskell-gnuplot.cabal
View File

@ -58,7 +58,7 @@ library
OverloadedStrings
-- Other library packages from which modules are imported.
build-depends: base >=4.6 && <4.9,
build-depends: base >=4.6 && <4.10,
bytestring,
gnuplot >= 0.5.4,
ihaskell >= 0.6.2

2
ihaskell-display/ihaskell-hatex/ihaskell-hatex.cabal
View File

@ -14,7 +14,7 @@ cabal-version: >=1.16
library
exposed-modules: IHaskell.Display.Hatex
build-depends: base >=4.6 && <4.9,
build-depends: base >=4.6 && <4.10,
text,
HaTeX >= 3.9,
ihaskell >= 0.5

2
ihaskell-display/ihaskell-magic/ihaskell-magic.cabal
View File

@ -61,7 +61,7 @@ library
OverloadedStrings
-- Other library packages from which modules are imported.
build-depends: base >=4.6 && <4.9,
build-depends: base >=4.6 && <4.10,
magic >= 1.0.8,
text,
bytestring,

7
ihaskell.cabal
View File

@ -55,7 +55,7 @@ library
default-language: Haskell2010
build-depends:
aeson >=0.7 && < 0.12,
base >=4.6 && < 4.9,
base >=4.6 && < 4.10,
base64-bytestring >=1.0,
bytestring >=0.10,
cereal >=0.3,
@ -91,6 +91,9 @@ library
if flag(binPkgDb)
build-depends: bin-package-db
if impl(ghc >= 8.0)
build-depends: ghc-boot >=8.0 && <8.1
exposed-modules: IHaskell.Display
IHaskell.Convert
IHaskell.Convert.Args
@ -137,7 +140,7 @@ executable ihaskell
default-language: Haskell2010
build-depends:
ihaskell -any,
base >=4.6 && < 4.9,
base >=4.6 && < 4.10,
text >=0.11,
transformers -any,
ghc >=7.6 || < 7.11,

6
ipython-kernel/ipython-kernel.cabal
View File

@ -34,7 +34,7 @@ library
other-extensions: OverloadedStrings
hs-source-dirs: src
default-language: Haskell2010
build-depends: base >=4.6 && < 4.9,
build-depends: base >=4.6 && < 4.10,
aeson >=0.6 && < 0.12,
bytestring >=0.10,
cereal >=0.3,
@ -56,7 +56,7 @@ executable simple-calc-example
hs-source-dirs: examples
main-is: Calc.hs
build-depends: ipython-kernel,
base >=4.6 && <4.9,
base >=4.6 && <4.10,
filepath >=1.2,
mtl >=2.1,
parsec >=3.1,
@ -70,7 +70,7 @@ executable fun-calc-example
hs-source-dirs: examples
main-is: Simple.hs
build-depends: ipython-kernel,
base >=4.6 && <4.9,
base >=4.6 && <4.10,
filepath >=1.2,
mtl >=2.1,
parsec >=3.1,

4
main/IHaskellPrelude.hs
View File

@ -78,7 +78,9 @@ import GHC.Enum as X
import GHC.Num as X
import GHC.Real as X
import GHC.Err as X hiding (absentErr)
#if MIN_VERSION_ghc(7,10,0)
#if MIN_VERSION_ghc(8,0,0)
import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>), Module(..))
#elif MIN_VERSION_ghc(7,10,0)
import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>))
#else
import GHC.Base as X hiding (Any)

3
main/Main.hs
View File

@ -128,7 +128,8 @@ runKernel kernelOpts profileSrc = do
useStack = kernelSpecUseStack kernelOpts
-- Parse the profile file.
Just profile <- liftM decode $ LBS.readFile profileSrc
let profileErr = error $ "ihaskell: "++profileSrc++": Failed to parse profile file"
profile <- liftM (fromMaybe profileErr . decode) $ LBS.readFile profileSrc
-- Necessary for `getLine` and their ilk to work.
dir <- getIHaskellDir

10
src/IHaskell/Eval/Completion.hs
View File

@ -22,7 +22,7 @@ import qualified Data.ByteString.Char8 as CBS
import Control.Applicative ((<$>))
import Data.ByteString.UTF8 hiding (drop, take, lines, length)
import Data.Char
import Data.List (nub, init, last, head, elemIndex)
import Data.List (nub, init, last, head, elemIndex, concatMap)
import qualified Data.List.Split as Split
import qualified Data.List.Split.Internals as Split
import Data.Maybe (fromJust)
@ -88,7 +88,11 @@ complete code posOffset = do
let Just db = pkgDatabase flags
getNames = map (moduleNameString . exposedName) . exposedModules
#if MIN_VERSION_ghc(8,0,0)
moduleNames = nub $ concatMap getNames $ concatMap snd db
#else
moduleNames = nub $ concatMap getNames db
#endif
let target = completionTarget line pos
completion = completionType line pos target
@ -124,7 +128,11 @@ complete code posOffset = do
otherNames = ["-package", "-Wall", "-w"]
fNames = map extName fFlags ++
#if MIN_VERSION_ghc(8,0,0)
map extName wWarningFlags ++
#else
map extName fWarningFlags ++
#endif
map extName fLangFlags
fNoNames = map ("no" ++) fNames
fAllNames = map ("-f" ++) (fNames ++ fNoNames)

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

@ -26,6 +26,7 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Concurrent (forkIO, threadDelay)
import Data.Foldable (foldMap)
import Prelude (putChar, head, tail, last, init, (!!))
import Data.List (findIndex, and, foldl1, nubBy)
import Text.Printf
@ -77,7 +78,7 @@ import Module hiding (Module)
import qualified Pretty
import FastString
import Bag
import ErrUtils (errMsgShortDoc, errMsgExtraInfo)
import qualified ErrUtils
import IHaskell.Types
import IHaskell.IPython
@ -184,13 +185,29 @@ interpret libdir allowedStdin action = runGhc (Just libdir) $ do
-- Run the rest of the interpreter
action hasSupportLibraries
#if MIN_VERSION_ghc(7,10,2)
packageIdString' dflags pkg_key = fromMaybe "(unknown)" (packageKeyPackageIdString dflags pkg_key)
packageIdString' :: DynFlags -> PackageConfig -> String
packageIdString' dflags pkg_cfg =
#if MIN_VERSION_ghc(8,0,0)
fromMaybe "(unknown)" (unitIdPackageIdString dflags $ packageConfigId pkg_cfg)
#elif MIN_VERSION_ghc(7,10,2)
fromMaybe "(unknown)" (packageKeyPackageIdString dflags $ packageConfigId pkg_cfg)
#elif MIN_VERSION_ghc(7,10,0)
packageIdString' dflags = packageKeyPackageIdString dflags
packageKeyPackageIdString dflags . packageConfigId
#else
packageIdString' dflags = packageIdString
packageIdString . packageConfigId
#endif
getPackageConfigs :: DynFlags -> [PackageConfig]
getPackageConfigs dflags =
#if MIN_VERSION_ghc(8,0,0)
foldMap snd pkgDb
#else
pkgDb
#endif
where
Just pkgDb = pkgDatabase dflags
-- | Initialize our GHC session with imports and a value for 'it'. Return whether the IHaskell
-- support libraries are available.
initializeImports :: Interpreter Bool
@ -200,19 +217,23 @@ initializeImports = do
dflags <- getSessionDynFlags
broken <- liftIO getBrokenPackages
(dflags, _) <- liftIO $ initPackages dflags
let Just db = pkgDatabase dflags
packageNames = map (packageIdString' dflags . packageConfigId) db
let db = getPackageConfigs dflags
packageNames = map (packageIdString' dflags) db
initStr = "ihaskell-"
-- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4"
iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version))
#if !MIN_VERSION_ghc(8,0,0)
unitId = packageId
#endif
dependsOnRight pkg = not $ null $ do
pkg <- db
depId <- depends pkg
dep <- filter ((== depId) . installedPackageId) db
let idString = packageIdString' dflags (packageConfigId dep)
dep <- filter ((== depId) . unitId) db
let idString = packageIdString' dflags dep
guard (iHaskellPkgName `isPrefixOf` idString)
displayPkgs = [ pkgName
@ -411,6 +432,14 @@ flushWidgetMessages state evalMsgs widgetHandler = do
let commMessages = evalMsgs ++ messages
widgetHandler state commMessages
getErrMsgDoc :: ErrUtils.ErrMsg -> SDoc
#if MIN_VERSION_ghc(8,0,0)
getErrMsgDoc = ErrUtils.pprLocErrMsg
#else
getErrMsgDoc msg = ErrUtils.errMsgShortString msg $$ ErrUtils.errMsgContext msg
#endif
safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut
safely state = ghandle handler . ghandle sourceErrorHandler
where
@ -428,10 +457,7 @@ safely state = ghandle handler . ghandle sourceErrorHandler
sourceErrorHandler :: SourceError -> Interpreter EvalOut
sourceErrorHandler srcerr = do
let msgs = bagToList $ srcErrorMessages srcerr
errStrs <- forM msgs $ \msg -> do
shortStr <- doc $ errMsgShortDoc msg
contextStr <- doc $ errMsgExtraInfo msg
return $ unlines [shortStr, contextStr]
errStrs <- forM msgs $ doc . getErrMsgDoc
let fullErr = unlines errStrs
@ -1027,7 +1053,11 @@ doLoadModule name modName = do
setSessionDynFlags
flags
{ hscTarget = objTarget flags
#if MIN_VERSION_ghc(8,0,0)
, log_action = \dflags sev srcspan ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :)
#else
, log_action = \dflags sev srcspan ppr msg -> modifyIORef' errRef (showSDoc flags msg :)
#endif
}
-- Load the new target.
@ -1142,7 +1172,6 @@ capturedEval output stmt = do
, voidpf "IHaskellIO.closeFd %s" writeVariable
, printf "let it = %s" itVariable
]
pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable
goStmt :: String -> Ghc RunResult
goStmt s = runStmt s RunToCompletion
@ -1156,22 +1185,37 @@ capturedEval output stmt = do
AnyException e -> RunException e
-- Initialize evaluation context.
void $ forM initStmts goStmt
results <- forM initStmts goStmt
#if __GLASGOW_HASKELL__ >= 800
-- This works fine on GHC 8.0 and newer
dyn <- dynCompileExpr readVariable
pipe <- case fromDynamic dyn of
Nothing -> fail "Evaluate: Bad pipe"
Just fd -> liftIO $ do
handle <- fdToHandle fd
hSetEncoding handle utf8
return handle
#else
-- Get the pipe to read printed output from. This is effectively the source code of dynCompileExpr
-- from GHC API's InteractiveEval. However, instead of using a `Dynamic` as an intermediary, it just
-- directly reads the value. This is incredibly unsafe! However, for some reason the `getContext`
-- and `setContext` required by dynCompileExpr (to import and clear Data.Dynamic) cause issues with
-- data declarations being updated (e.g. it drops newer versions of data declarations for older ones
-- for unknown reasons). First, compile down to an HValue.
let pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable
Just (_, hValues, _) <- withSession $ liftIO . flip hscStmt pipeExpr
-- Then convert the HValue into an executable bit, and read the value.
pipe <- liftIO $ do
fd <- head <$> unsafeCoerce hValues
fds <- unsafeCoerce hValues
fd <- case fds of
fd : _ -> return fd
[] -> fail "Failed to evaluate pipes"
_ -> fail $ "Expected one fd, saw "++show (length fds)
handle <- fdToHandle fd
hSetEncoding handle utf8
return handle
#endif
-- Keep track of whether execution has completed.
completed <- liftIO $ newMVar False
finishedReading <- liftIO newEmptyMVar

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

@ -59,6 +59,12 @@ import Data.List (nubBy)
import StringUtils (replace)
#if MIN_VERSION_ghc(8,0,1)
import GHC.LanguageExtensions
type ExtensionFlag = Extension
#endif
-- | A extension flag that can be set or unset.
data ExtFlag = SetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
@ -97,10 +103,16 @@ pprDynFlags show_all dflags =
, O.text "other dynamic, non-language, flag settings:" O.$$
O.nest 2 (O.vcat (map (setting opt) others))
, O.text "warning settings:" O.$$
O.nest 2 (O.vcat (map (setting wopt) DynFlags.fWarningFlags))
O.nest 2 (O.vcat (map (setting wopt) warningFlags))
]
where
#if MIN_VERSION_ghc(8,0,0)
warningFlags = DynFlags.wWarningFlags
#else
warningFlags = DynFlags.fWarningFlags
#endif
#if MIN_VERSION_ghc(7,8,0)
opt = gopt
#else
@ -239,7 +251,11 @@ initGhci sandboxPackages = do
originalFlags <- getSessionDynFlags
let flag = flip xopt_set
unflag = flip xopt_unset
#if MIN_VERSION_ghc(8,0,0)
dflags = flag ExtendedDefaultRules . unflag MonomorphismRestriction $ originalFlags
#else
dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags
#endif
pkgConfs =
case sandboxPackages of
Nothing -> extraPkgConfs originalFlags
@ -323,8 +339,13 @@ cleanUpDuplicateInstances = modifySession $ \hscEnv ->
in hscEnv { hsc_IC = ic { ic_instances = (clsInsts', famInsts) } }
where
instEq :: ClsInst -> ClsInst -> Bool
#if MIN_VERSION_ghc(7,8,0)
#if MIN_VERSION_ghc(8,0,0)
-- Only support replacing instances on GHC 7.8 and up
instEq c1 c2
| ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys, is_cls = cls } <- c1,
ClsInst { is_tys = tpl_tys', is_cls = cls' } <- c2
= cls == cls' && isJust (tcMatchTys tpl_tys tpl_tys')
#elif MIN_VERSION_ghc(7,8,0)
instEq c1 c2
| ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys, is_cls = cls } <- c1,
ClsInst { is_tys = tpl_tys', is_cls = cls' } <- c2
@ -333,6 +354,8 @@ cleanUpDuplicateInstances = modifySession $ \hscEnv ->
#else
instEq _ _ = False
#endif
-- | Get the type of an expression and convert it to a string.
getType :: GhcMonad m => String -> m String
getType expr = do

4
src/IHaskellPrelude.hs
View File

@ -78,7 +78,9 @@ import GHC.Enum as X
import GHC.Num as X
import GHC.Real as X
import GHC.Err as X hiding (absentErr)
#if MIN_VERSION_ghc(7,10,0)
#if MIN_VERSION_ghc(8,0,0)
import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>), Module(..))
#elif MIN_VERSION_ghc(7,10,0)
import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>))
#else
import GHC.Base as X hiding (Any)