Merge pull request #538 from commercialhaskell/ghc_8.4

GHC 8.4.1 support

.travis.yml

@@ -9,5 +9,6 @@ language: bash
 before_install:
   - if [[ $TRAVIS_OS_NAME == 'linux' ]]; then sudo apt-get update; fi
   - if [[ $TRAVIS_OS_NAME == 'linux' ]]; then sudo apt-get install -yq --no-install-suggests --no-install-recommends --force-yes -y netbase git ca-certificates xz-utils build-essential curl; fi
+  - if [[ $TRAVIS_OS_NAME == 'osx' ]]; then brew install xz; fi
   - curl -sSL https://get.haskellstack.org/ | sh
   - time sh test/test-ghcs

appveyor.yml

@@ -19,6 +19,14 @@ test_script:
 # The ugly echo "" hack is to avoid complaints about 0 being an invalid file
 # descriptor
 
+# Uncomment when the network package is fixed: https://github.com/haskell/network/issues/313
+# AND REMEMBER TO CHANGE "network-2.6.3.4" BELOW TO THE FIXED VERSION.
+#
+# - echo "GHC 8.4.1 ..."
+# - echo "" | stack clean
+# - echo "" | stack setup --resolver ghc-8.4.1
+# - echo "" | stack build . --resolver ghc-8.4.1 --test --ghc-options=-Werror --force-dirty ghc-paths-0.1.0.9 network-2.6.3.4 random-1.1 syb-0.7 hspec-2.4.8 regex-compat-0.95.1 temporary-1.2.1.1 HUnit-1.6.0.0 QuickCheck-2.11.3 call-stack-0.1.0 exceptions-0.9.0 hspec-core-2.4.8 hspec-discover-2.4.8 hspec-expectations-0.8.2 regex-base-0.93.2 regex-posix-0.95.2 ansi-terminal-0.8.0.2 quickcheck-io-0.2.0 setenv-0.1.1.3 tf-random-0.5 transformers-compat-0.6.0.6 colour-2.3.4 primitive-0.6.3.0 base-compat-0.9.3
+
 - echo "GHC 8.2.2"
 - echo "" | stack --no-terminal clean
 - echo "" | stack --no-terminal setup --verbosity error --resolver lts-10.0

intero.cabal

@@ -1,7 +1,7 @@
 name:
   intero
 version:
-  0.1.28
+  0.1.29
 synopsis:
   Complete interactive development program for Haskell
 license:
@@ -65,6 +65,7 @@ executable intero
     GhciTypes
     GhciInfo
     GhciFind
+    Intero.Compat
     Paths_intero
   build-depends:
     base < 5,
@@ -73,7 +74,7 @@ executable intero
     directory,
     filepath,
     -- We permit any 8.0.1.* or 8.0.2.* or 8.2.1
-    ghc >= 7.8 && <= 8.2.2,
+    ghc >= 7.8 && <= 8.4.1,
     ghc-paths,
     haskeline,
     process,

src/Completion.hs

@@ -31,14 +31,14 @@ import           DynFlags
 import           FastString
 import           GHC
 import           HscTypes
+import           Intero.Compat
 import           Name
 import           OccName
 import           Outputable
 import           RdrName
 import           TcRnDriver
 import           TcRnTypes (tcg_rdr_env)
 import           TyCoRep
-import           TyCon
 import           TysWiredIn
 import           Unify
 import           Unique
@@ -55,7 +55,7 @@ data CompletableModule =
 -- | All the context we need to generate completions for a declaration
 -- in a module.
 data Declaration = Declaration
-  { declarationBind :: !(HsBindLR Name Name)
+  { declarationBind :: !(HsBindLR StageReaderName StageReaderName)
     -- ^ The actual declaration, which we use to find holes and
     -- substitute them with candidate replacements.
     -- ^ A sample source, which we use merely for debugging.
@@ -168,14 +168,14 @@ declarationHoles df declaration = go declaration
                   , holeDeclaration = declaration
                   })) .
       listify (isJust . getHoleName) . declarationBind
-    typeAt :: RealSrcSpan -> LHsExpr Id -> Maybe Type
+    typeAt :: RealSrcSpan -> LHsExpr StageReaderId -> Maybe Type
     typeAt rs expr =
       if getLoc expr == RealSrcSpan rs
         then case expr of
                L _ (HsVar (L _ i)) -> pure (idType i)
                _ -> Nothing
         else Nothing
-    getHoleName :: LHsExpr Name -> Maybe (OccName, RealSrcSpan)
+    getHoleName :: LHsExpr StageReaderName -> Maybe (OccName, RealSrcSpan)
     getHoleName =
       \case
         L someSpan (HsUnboundVar (TrueExprHole name)) -> do
@@ -419,7 +419,7 @@ normalize df t0 = evalState (go t0) 1
             u <- get
             modify (+ 1)
             pure (makeTypeVariable u "was_Any")
-        FunTy (TyConApp (tyConFlavour -> "class") _) x -> go x
+        FunTy (TyConApp (ghc_tyConFlavour -> "class") _) x -> go x
         ForAllTy _ x -> go x
         CastTy x _ -> go x
         FunTy x y -> FunTy <$> (go x) <*> (go y)
@@ -443,7 +443,7 @@ tryWellTypedFill ::
      GhcMonad m
   => ParsedModule
   -> Hole
-  -> HsExpr RdrName
+  -> HsExpr StageReaderRdrName
   -> m (Maybe ParsedModule)
 tryWellTypedFill pm hole expr =
   handleSourceError
@@ -456,11 +456,11 @@ tryWellTypedFill pm hole expr =
 -- Filling holes in the AST
 
 -- | Fill the given hole in the module with the given expression.
-fillHole :: ParsedModule -> Hole -> HsExpr RdrName -> ParsedModule
+fillHole :: ParsedModule -> Hole -> HsExpr StageReaderRdrName -> ParsedModule
 fillHole pm hole expr =
   pm {pm_parsed_source = everywhere (mkT replace) (pm_parsed_source pm)}
   where
-    replace :: LHsExpr RdrName -> LHsExpr RdrName
+    replace :: LHsExpr StageReaderRdrName -> LHsExpr StageReaderRdrName
     replace =
       (\case
          L someSpan _
@@ -471,14 +471,14 @@ fillHole pm hole expr =
 --------------------------------------------------------------------------------
 -- Helpers
 
-rdrNameToLHsExpr :: id -> GenLocated SrcSpan (HsExpr id)
+rdrNameToLHsExpr :: RdrName -> GenLocated SrcSpan (HsExpr StageReaderRdrName)
 rdrNameToLHsExpr rdrname =
   L (UnhelpfulSpan (mkFastString "Generated by rdrNameToLHsExpr"))
     (HsVar
        (L (UnhelpfulSpan (mkFastString "Generated by getWellTypedFills"))
           rdrname))
 
-rdrNameToHsExpr :: id -> HsExpr id
+rdrNameToHsExpr :: RdrName -> HsExpr StageReaderRdrName
 rdrNameToHsExpr rdrname =
   HsVar
     (L (UnhelpfulSpan (mkFastString "Generated by rdrNameToHsExpr")) rdrname)
@@ -502,7 +502,7 @@ typecheckModuleNoDeferring parsed = do
     nullLogAction _df _reason _sev _span _style _msgdoc = pure ()
 
 -- | Convert parsed source groups into one bag of binds.
-_parsedModuleToBag :: ParsedModule -> Bag (LHsBindLR RdrName RdrName)
+_parsedModuleToBag :: ParsedModule -> Bag (LHsBindLR StageReaderRdrName StageReaderRdrName)
 _parsedModuleToBag =
   listToBag . mapMaybe valD . hsmodDecls . unLoc . pm_parsed_source
   where
@@ -512,7 +512,7 @@ _parsedModuleToBag =
         _ -> Nothing
 
 -- | Convert renamed source groups into one bag of binds.
-renamedSourceToBag :: RenamedSource -> Bag (LHsBindLR Name Name)
+renamedSourceToBag :: RenamedSource -> Bag (LHsBindLR StageReaderName StageReaderName)
 renamedSourceToBag (hsGroup, _, _, _) = unHsValBindsLR (hs_valds hsGroup)
   where
     unHsValBindsLR =

src/GhciFind.hs

@@ -9,8 +9,9 @@ module GhciFind
   (findType,FindType(..),findLoc,findNameUses,findCompletions,guessModule)
   where
 
+import           Intero.Compat
 #if __GLASGOW_HASKELL__ >= 800
-import Module
+import           Module
 #endif
 import           Control.Exception
 #if __GLASGOW_HASKELL__ < 710
@@ -374,7 +375,7 @@ findType infos fp string sl sc el ec =
                         Just name ->
                           case find (reliableNameEquality name) names of
                             Just nameWithBetterType ->
-                              do result <- getInfo True nameWithBetterType
+                              do result <- ghc_getInfo True nameWithBetterType
                                  case result of
                                    Just (thing,_,_,_) ->
                                      return (FindTyThing minfo thing)

src/GhciInfo.hs

@@ -10,25 +10,29 @@ import           ConLike
 import           Control.Exception
 import           Control.Monad
 import qualified CoreUtils
-import           DataCon
 import           Data.Data
-import           Data.Generics (GenericQ, mkQ, extQ)
+import qualified Data.Generics
 import           Data.List
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import           Data.Maybe
 import           Data.Time
+import           DataCon
 import           Desugar
 import           GHC
 import           GhcMonad
 import           GhciTypes
-import           NameSet
+import           Intero.Compat
 import           Outputable
 import           Prelude hiding (mod)
 import           System.Directory
 import           TcHsSyn
 import           Var
 
+#if __GLASGOW_HASKELL__ <= 802
+import           NameSet
+#endif
+
 #if MIN_VERSION_ghc(7,8,3)
 #else
 import           Bag
@@ -95,9 +99,9 @@ processAllTypeCheckedModule :: GhcMonad m
                             => TypecheckedModule -> m [SpanInfo]
 processAllTypeCheckedModule tcm =
   do let tcs = tm_typechecked_source tcm
-         bs = listifyAllSpans tcs :: [LHsBind Id]
-         es = listifyAllSpans tcs :: [LHsExpr Id]
-         ps = listifyAllSpans tcs :: [LPat Id]
+         bs = listifyAllSpans tcs :: [LHsBind StageReaderId]
+         es = listifyAllSpans tcs :: [LHsExpr StageReaderId]
+         ps = listifyAllSpans tcs :: [LPat StageReaderId]
      bts <- mapM (getTypeLHsBind tcm) bs
      ets <- mapM (getTypeLHsExpr tcm) es
      pts <- mapM (getTypeLPat tcm) ps
@@ -109,7 +113,7 @@ processAllTypeCheckedModule tcm =
 
 getTypeLHsBind :: (GhcMonad m)
                => TypecheckedModule
-               -> LHsBind Id
+               -> LHsBind StageReaderId
                -> m [(Maybe Id,SrcSpan,Type)]
 #if MIN_VERSION_ghc(7,8,3)
 getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _}) =
@@ -133,7 +137,7 @@ getTypeLHsBind _ _ = return []
 
 getTypeLHsExpr :: (GhcMonad m)
                => TypecheckedModule
-               -> LHsExpr Id
+               -> LHsExpr StageReaderId
                -> m (Maybe (Maybe Id,SrcSpan,Type))
 getTypeLHsExpr _ e =
   do hs_env <- getSession
@@ -155,7 +159,7 @@ getTypeLHsExpr _ e =
 
 -- | Get id and type for patterns.
 getTypeLPat :: (GhcMonad m)
-            => TypecheckedModule -> LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type))
+            => TypecheckedModule -> LPat StageReaderId -> m (Maybe (Maybe Id,SrcSpan,Type))
 getTypeLPat _ (L spn pat) =
   return (Just (getMaybeId pat,spn,getPatType pat))
   where
@@ -177,14 +181,18 @@ listifyAllSpans tcs =
   where p (L spn _) = isGoodSrcSpan spn
 
 listifyStaged :: Typeable r
-              => Stage -> (r -> Bool) -> GenericQ [r]
+              => Stage -> (r -> Bool) -> Data.Generics.GenericQ [r]
+#if __GLASGOW_HASKELL__ <= 802
 listifyStaged s p =
   everythingStaged
     s
     (++)
     []
-    ([] `mkQ`
+    ([] `Data.Generics.mkQ`
      (\x -> [x | p x]))
+#else
+listifyStaged _ p = Data.Generics.listify p
+#endif
 
 ------------------------------------------------------------------------------
 -- The following was taken from 'ghc-syb-utils'
@@ -203,9 +211,10 @@ data Stage
 
 -- | Like 'everything', but avoid known potholes, based on the 'Stage' that
 --   generated the Ast.
-everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
+#if __GLASGOW_HASKELL__ <= 802
+everythingStaged :: Stage -> (r -> r -> r) -> r -> Data.Generics.GenericQ r -> Data.Generics.GenericQ r
 everythingStaged stage k z f x
-  | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z
+  | (const False `Data.Generics.extQ` postTcType `Data.Generics.extQ` fixity `Data.Generics.extQ` nameSet) x = z
   | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)
   where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
 #if __GLASGOW_HASKELL__ >= 709
@@ -214,6 +223,8 @@ everythingStaged stage k z f x
         postTcType = const (stage<TypeChecker)                 :: PostTcType -> Bool
 #endif
         fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool
+#endif
+
 
 -- | Pretty print the types into a 'SpanInfo'.
 toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo

src/GhciMonad.hs

@@ -382,7 +382,7 @@ printTimes dflags allocs psecs
    = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
             secs_str = showFFloat (Just 2) secs
         putStrLn (showSDoc dflags (
-                 parens (text (secs_str "") <+> text "secs" <> comma <+>
+                 parens (text (secs_str "") <+> text "secs" Outputable.<> comma <+>
                          text (show allocs) <+> text "bytes")))
 
 -----------------------------------------------------------------------------

src/GhciTags.hs

@@ -16,6 +16,7 @@ module GhciTags (
 import Exception
 import GHC
 import GhciMonad
+import Intero.Compat
 import Outputable
 
 -- ToDo: figure out whether we need these, and put something appropriate
@@ -59,7 +60,7 @@ ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 ghciCreateTagsFile kind file = do
   createTagsFile kind file
 
--- ToDo: 
+-- ToDo:
 --      - remove restriction that all modules must be interpreted
 --        (problem: we don't know source locations for entities unless
 --        we compiled the module.
@@ -69,7 +70,7 @@ ghciCreateTagsFile kind file = do
 --
 createTagsFile :: TagsKind -> FilePath -> GHCi ()
 createTagsFile tagskind tagsFile = do
-  graph <- GHC.getModuleGraph
+  graph <- ghc_getModuleGraph
   mtags <- mapM listModuleTags (map GHC.ms_mod graph)
   either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags
   case either_res of
@@ -203,4 +204,3 @@ showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
     ++ "\x01" ++ show lineNo
     ++ "," ++ show charPos
 showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
-

src/GhciTypes.hs

@@ -4,6 +4,7 @@ module GhciTypes where
 
 import Data.Time
 import GHC
+import Intero.Compat
 import Outputable
 
 -- | Info about a module. This information is generated every time a
@@ -21,7 +22,7 @@ data ModInfo =
            -- (exports, instances, scope) from a module.
           ,modinfoLastUpdate :: !UTCTime
            -- ^ Last time the module was updated.
-          ,modinfoImports :: ![LImportDecl Name]
+          ,modinfoImports :: ![LImportDecl StageReaderName]
            -- ^ Import declarations within this module.
           ,modinfoLocation :: !SrcSpan
            -- ^ The location of the module
@@ -49,14 +50,14 @@ data SpanInfo =
 
 instance Outputable SpanInfo where
   ppr (SpanInfo sl sc el ec ty v) =
-    (int sl <>
-     text ":" <>
-     int sc <>
-     text "-") <>
-    (int el <>
-     text ":" <>
-     int ec <>
-     text ": ") <>
-    (ppr v <>
-     text " :: " <>
+    (int sl Outputable.<>
+     text ":" Outputable.<>
+     int sc Outputable.<>
+     text "-") Outputable.<>
+    (int el Outputable.<>
+     text ":" Outputable.<>
+     int ec Outputable.<>
+     text ": ") Outputable.<>
+    (ppr v Outputable.<>
+     text " :: " Outputable.<>
      ppr ty)