From e97b70198fe6b56c81a15430c37e777b4979c61c Mon Sep 17 00:00:00 2001 From: Andrei Barbu Date: Sun, 5 Mar 2017 10:12:24 -0500 Subject: [PATCH] Apply #686 --- ghc-parser/ghc-parser.cabal | 9 ++- .../Language/Haskell/GHC/HappyParser.hs | 42 ++++++++++ .../ihaskell-aeson/ihaskell-aeson.cabal | 2 +- .../ihaskell-diagrams/ihaskell-diagrams.cabal | 2 +- .../ihaskell-gnuplot/ihaskell-gnuplot.cabal | 2 +- .../ihaskell-hatex/ihaskell-hatex.cabal | 2 +- .../ihaskell-magic/ihaskell-magic.cabal | 2 +- ihaskell.cabal | 7 +- ipython-kernel/ipython-kernel.cabal | 6 +- main/IHaskellPrelude.hs | 4 +- main/Main.hs | 3 +- src/IHaskell/Eval/Completion.hs | 10 ++- src/IHaskell/Eval/Evaluate.hs | 78 +++++++++++++++---- src/IHaskell/Eval/Util.hs | 27 ++++++- src/IHaskellPrelude.hs | 4 +- 15 files changed, 164 insertions(+), 36 deletions(-) create mode 100644 ghc-parser/src-8.0/Language/Haskell/GHC/HappyParser.hs diff --git a/ghc-parser/ghc-parser.cabal b/ghc-parser/ghc-parser.cabal index 385d2def..2613f634 100644 --- a/ghc-parser/ghc-parser.cabal +++ b/ghc-parser/ghc-parser.cabal @@ -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 diff --git a/ghc-parser/src-8.0/Language/Haskell/GHC/HappyParser.hs b/ghc-parser/src-8.0/Language/Haskell/GHC/HappyParser.hs new file mode 100644 index 00000000..b07515f5 --- /dev/null +++ b/ghc-parser/src-8.0/Language/Haskell/GHC/HappyParser.hs @@ -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 diff --git a/ihaskell-display/ihaskell-aeson/ihaskell-aeson.cabal b/ihaskell-display/ihaskell-aeson/ihaskell-aeson.cabal index 061dc054..91ea4197 100644 --- a/ihaskell-display/ihaskell-aeson/ihaskell-aeson.cabal +++ b/ihaskell-display/ihaskell-aeson/ihaskell-aeson.cabal @@ -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, diff --git a/ihaskell-display/ihaskell-diagrams/ihaskell-diagrams.cabal b/ihaskell-display/ihaskell-diagrams/ihaskell-diagrams.cabal index ac670494..ca0d5463 100644 --- a/ihaskell-display/ihaskell-diagrams/ihaskell-diagrams.cabal +++ b/ihaskell-display/ihaskell-diagrams/ihaskell-diagrams.cabal @@ -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, diff --git a/ihaskell-display/ihaskell-gnuplot/ihaskell-gnuplot.cabal b/ihaskell-display/ihaskell-gnuplot/ihaskell-gnuplot.cabal index 543aa1fd..069718d0 100644 --- a/ihaskell-display/ihaskell-gnuplot/ihaskell-gnuplot.cabal +++ b/ihaskell-display/ihaskell-gnuplot/ihaskell-gnuplot.cabal @@ -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 diff --git a/ihaskell-display/ihaskell-hatex/ihaskell-hatex.cabal b/ihaskell-display/ihaskell-hatex/ihaskell-hatex.cabal index 0ded91db..a72a4200 100644 --- a/ihaskell-display/ihaskell-hatex/ihaskell-hatex.cabal +++ b/ihaskell-display/ihaskell-hatex/ihaskell-hatex.cabal @@ -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 diff --git a/ihaskell-display/ihaskell-magic/ihaskell-magic.cabal b/ihaskell-display/ihaskell-magic/ihaskell-magic.cabal index 1b9b8ef1..66cfc1a0 100644 --- a/ihaskell-display/ihaskell-magic/ihaskell-magic.cabal +++ b/ihaskell-display/ihaskell-magic/ihaskell-magic.cabal @@ -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, diff --git a/ihaskell.cabal b/ihaskell.cabal index d95a82f7..96950815 100644 --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -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, diff --git a/ipython-kernel/ipython-kernel.cabal b/ipython-kernel/ipython-kernel.cabal index f719d757..f6a596bd 100644 --- a/ipython-kernel/ipython-kernel.cabal +++ b/ipython-kernel/ipython-kernel.cabal @@ -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, diff --git a/main/IHaskellPrelude.hs b/main/IHaskellPrelude.hs index 4938a5a4..da618fad 100644 --- a/main/IHaskellPrelude.hs +++ b/main/IHaskellPrelude.hs @@ -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) diff --git a/main/Main.hs b/main/Main.hs index 196b9aa0..2b744465 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -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 diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs index 223f095c..d470fb42 100644 --- a/src/IHaskell/Eval/Completion.hs +++ b/src/IHaskell/Eval/Completion.hs @@ -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) diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs index a40da61d..518f6bfb 100644 --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -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 diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs index 7a1316ae..a1f17a9c 100644 --- a/src/IHaskell/Eval/Util.hs +++ b/src/IHaskell/Eval/Util.hs @@ -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 diff --git a/src/IHaskellPrelude.hs b/src/IHaskellPrelude.hs index 4938a5a4..da618fad 100644 --- a/src/IHaskellPrelude.hs +++ b/src/IHaskellPrelude.hs @@ -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)