#2326, GHC 8.4 compatibility (#2796)

* #2326, GHC 8.4 compatibility * Fix up CI * Add a Shake lower bound * Upgrade to a hie-bios which is GHC 8.4 compatible * Add a GHC 8.4 stack * Fix HLint again
digital-asset · Sep 7, 2019 · bdcbf16 · bdcbf16
1 parent aa1e951
commit bdcbf16
Show file tree

Hide file tree

Showing 12 changed files with 120 additions and 52 deletions.
diff --git a/.hlint.yaml b/.hlint.yaml
@@ -79,6 +79,7 @@
   - {name: ViewPatterns, within: []}
 
   # Shady extensions
+  - {name: ImplicitParams, within: []}
   - name: CPP
     within:
     - Development.IDE.Core.FileStore
@@ -89,12 +90,14 @@
     - DA.Signals
     - Development.IDE.Core.Compile
     - Development.IDE.GHC.Compat
-  - {name: ImplicitParams, within: []}
+    - Development.IDE.GHC.Util
+    - Development.IDE.Import.FindImports
+    - Development.IDE.Spans.Calculate
 
 - flags:
   - default: false
   - {name: [-Wno-missing-signatures, -Wno-orphans, -Wno-overlapping-patterns, -Wno-incomplete-patterns, -Wno-missing-fields, -Wno-unused-matches]}
-
+  - {name: [-Wno-dodgy-imports], within: Main}
 # - modules:
 #   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
 #   - {name: Control.Arrow, within: []} # Certain modules are banned entirely

diff --git a/compiler/hie-core/exe/Main.hs b/compiler/hie-core/exe/Main.hs
@@ -1,5 +1,6 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
+{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
 
 module Main(main) where
 
@@ -26,6 +27,8 @@ import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Language.Haskell.LSP.Messages
 import Linker
+import System.Info
+import Data.Version
 import Development.IDE.LSP.LanguageServer
 import System.Directory.Extra as IO
 import System.Environment
@@ -36,7 +39,7 @@ import qualified Data.Set as Set
 -- import CmdLineParser
 -- import DynFlags
 -- import Panic
-import GHC
+import GHC hiding (def)
 import qualified GHC.Paths
 
 import HIE.Bios
@@ -49,7 +52,7 @@ main :: IO ()
 main = do
     -- WARNING: If you write to stdout before runLanguageServer
     --          then the language server will not work
-    hPutStrLn stderr "Starting hie-core"
+    hPutStrLn stderr $ "Starting hie-core (GHC v" ++ showVersion compilerVersion ++ ")"
     Arguments{..} <- getArguments
 
     -- lock to avoid overlapping output on stdout

diff --git a/compiler/hie-core/hie-core.cabal b/compiler/hie-core/hie-core.cabal
@@ -34,7 +34,7 @@ library
         filepath,
         ghc-boot-th,
         ghc-boot,
-        ghc >= 8.6,
+        ghc >= 8.4,
         hashable,
         haskell-lsp-types,
         haskell-lsp,
@@ -45,7 +45,7 @@ library
         prettyprinter,
         rope-utf16-splay,
         safe-exceptions,
-        shake,
+        shake >= 0.17.5,
         sorted-list,
         stm,
         syb,

diff --git a/compiler/hie-core/src/Development/IDE/Core/Compile.hs b/compiler/hie-core/src/Development/IDE/Core/Compile.hs
@@ -278,8 +278,7 @@ runCpp dflags filename contents = withTempDir $ \dir -> do
             -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
 
             -- Relative includes aren't going to work, so we fix that by adding to the include path.
-            let addSelf (IncludeSpecs quote global) = IncludeSpecs (takeDirectory filename : quote) global
-            dflags <- return dflags{includePaths = addSelf $ includePaths dflags}
+            dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
 
             -- Location information is wrong, so we fix that by patching it afterwards.
             let inp = dir </> "___HIE_CORE_MAGIC___"

diff --git a/compiler/hie-core/src/Development/IDE/GHC/CPP.hs b/compiler/hie-core/src/Development/IDE/GHC/CPP.hs
@@ -20,6 +20,7 @@
 
 module Development.IDE.GHC.CPP(doCpp) where
 
+import Development.IDE.GHC.Compat
 import Packages
 import SysTools
 import Module

diff --git a/compiler/hie-core/src/Development/IDE/GHC/Compat.hs b/compiler/hie-core/src/Development/IDE/GHC/Compat.hs
@@ -10,10 +10,16 @@ module Development.IDE.GHC.Compat(
     mkHieFile,
     writeHieFile,
     readHieFile,
-    hPutStringBuffer
+    hPutStringBuffer,
+    includePathsGlobal,
+    includePathsQuote,
+    addIncludePathsQuote,
+    ghcEnumerateExtensions
     ) where
 
 import StringBuffer
+import DynFlags
+import GHC.LanguageExtensions.Type
 
 #ifndef GHC_STABLE
 import HieAst
@@ -46,3 +52,27 @@ readHieFile _ _ = return (HieFileResult (HieFile () []), ())
 data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}
 data HieFileResult = HieFileResult { hie_file_result :: HieFile }
 #endif
+
+#if __GLASGOW_HASKELL__ < 806
+includePathsGlobal, includePathsQuote :: [String] -> [String]
+includePathsGlobal = id
+includePathsQuote = const []
+#endif
+
+
+addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags
+#if __GLASGOW_HASKELL__ >= 806
+addIncludePathsQuote path x = x{includePaths = f $ includePaths x}
+    where f i = i{includePathsQuote = path : includePathsQuote i}
+#else
+addIncludePathsQuote path x = x{includePaths = path : includePaths x}
+#endif
+
+ghcEnumerateExtensions :: [Extension]
+#if __GLASGOW_HASKELL__ >= 808
+ghcEnumerateExtensions = enumerate
+#elif __GLASGOW_HASKELL__ >= 806
+ghcEnumerateExtensions = [Cpp .. StarIsType]
+#else
+ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving]
+#endif
diff --git a/compiler/hie-core/src/Development/IDE/GHC/Util.hs b/compiler/hie-core/src/Development/IDE/GHC/Util.hs
@@ -2,6 +2,7 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 {-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint
+{-# LANGUAGE CPP #-}
 
 -- | GHC utility functions. Importantly, code using our GHC should never:
 --
@@ -20,7 +21,9 @@ module Development.IDE.GHC.Util(
 
 import Config
 import Data.List.Extra
+#if __GLASGOW_HASKELL__ >= 806
 import Fingerprint
+#endif
 import GHC
 import GhcMonad
 import GhcPlugins
@@ -75,15 +78,17 @@ runGhcEnv env act = do
 -- Fake DynFlags which are mostly undefined, but define enough to do a
 -- little bit.
 fakeDynFlags :: DynFlags
-fakeDynFlags = defaultDynFlags settings ([], [])
+fakeDynFlags = defaultDynFlags settings mempty
     where
         settings = Settings
                    { sTargetPlatform = platform
                    , sPlatformConstants = platformConstants
                    , sProgramName = "ghc"
                    , sProjectVersion = cProjectVersion
-                   , sOpt_P_fingerprint = fingerprint0
-                   }
+#if __GLASGOW_HASKELL__ >= 806
+                    , sOpt_P_fingerprint = fingerprint0
+#endif
+                    }
         platform = Platform
           { platformWordSize=8
           , platformOS=OSUnknown

diff --git a/compiler/hie-core/src/Development/IDE/Import/FindImports.hs b/compiler/hie-core/src/Development/IDE/Import/FindImports.hs
@@ -1,6 +1,7 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
+{-# LANGUAGE CPP #-}
 
 module Development.IDE.Import.FindImports
   ( locateModule
@@ -87,35 +88,31 @@ notFoundErr dfs modName reason =
       \case
         LookupFound _m _pkgConfig ->
           pprPanic "Impossible: called lookupToFind on found module." (ppr modName0)
-        LookupMultiple rs -> (FoundMultiple rs)
+        LookupMultiple rs -> FoundMultiple rs
         LookupHidden pkg_hiddens mod_hiddens ->
-          (NotFound
-             { fr_paths = []
-             , fr_pkg = Nothing
-             , fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens
+          notFound
+             { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens
              , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens
-             , fr_unusables = []
-             , fr_suggestions = []
-             })
+             }
+#if __GLASGOW_HASKELL__ >= 806
         LookupUnusable unusable ->
           let unusables' = map get_unusable unusable
               get_unusable (m, ModUnusable r) = (moduleUnitId m, r)
               get_unusable (_, r) =
                 pprPanic "findLookupResult: unexpected origin" (ppr r)
-           in (NotFound
-                 { fr_paths = []
-                 , fr_pkg = Nothing
-                 , fr_pkgs_hidden = []
-                 , fr_mods_hidden = []
-                 , fr_unusables = unusables'
-                 , fr_suggestions = []
-                 })
+           in notFound {fr_unusables = unusables'}
+#endif
         LookupNotFound suggest ->
-          (NotFound
-             { fr_paths = []
-             , fr_pkg = Nothing
-             , fr_pkgs_hidden = []
-             , fr_mods_hidden = []
-             , fr_unusables = []
-             , fr_suggestions = suggest
-             })
+          notFound {fr_suggestions = suggest}
+
+notFound :: FindResult
+notFound = NotFound
+  { fr_paths = []
+  , fr_pkg = Nothing
+  , fr_pkgs_hidden = []
+  , fr_mods_hidden = []
+#if __GLASGOW_HASKELL__ >= 806
+  , fr_unusables = []
+#endif
+  , fr_suggestions = []
+  }
diff --git a/compiler/hie-core/src/Development/IDE/LSP/CodeAction.hs b/compiler/hie-core/src/Development/IDE/LSP/CodeAction.hs
@@ -9,7 +9,7 @@ module Development.IDE.LSP.CodeAction
     ) where
 
 import           Language.Haskell.LSP.Types
-import GHC.LanguageExtensions.Type
+import Development.IDE.GHC.Compat
 import Development.IDE.Core.Rules
 import Development.IDE.LSP.Server
 import qualified Data.HashMap.Strict as Map
@@ -80,7 +80,7 @@ suggestAction _ _ = []
 
 -- | All the GHC extensions
 ghcExtensions :: Set.HashSet T.Text
-ghcExtensions = Set.fromList $ map (T.pack . show) [Cpp .. StarIsType] -- use enumerate from GHC 8.8 and beyond
+ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions
 
 
 textAtPosition :: Position -> T.Text -> (T.Text, T.Text)

diff --git a/compiler/hie-core/src/Development/IDE/Spans/Calculate.hs b/compiler/hie-core/src/Development/IDE/Spans/Calculate.hs
@@ -3,6 +3,7 @@
 
 -- ORIGINALLY COPIED FROM https://github.com/commercialhaskell/intero
 
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE RankNTypes #-}
 
 -- | Get information on modules, identifiers, etc.
@@ -31,6 +32,14 @@ import Development.IDE.Core.Compile
 import Development.IDE.GHC.Util
 
 
+-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore
+-- this U ignores that arg in 8.6, but is hidden in 8.4
+#if __GLASGOW_HASKELL__ >= 806
+#define U _
+#else
+#define U
+#endif
+
 -- | Get source span info, used for e.g. AtPoint and Goto Definition.
 getSrcSpanInfos
     :: HscEnv
@@ -75,20 +84,20 @@ getExports m
     ]
 getExports _ = []
 
--- | Variant of GHC’s ieNames that produces LIdP instead of IdP
-ieLNames :: IE pass -> [LIdP pass]
-ieLNames (IEVar       _ n   )     = [ieLWrappedName n]
-ieLNames (IEThingAbs  _ n   )     = [ieLWrappedName n]
-ieLNames (IEThingAll  _ n   )     = [ieLWrappedName n]
-ieLNames (IEThingWith _ n _ ns _) = ieLWrappedName n : map ieLWrappedName ns
+-- | Variant of GHC's ieNames that produces LIdP instead of IdP
+ieLNames :: IE pass -> [Located (IdP pass)]
+ieLNames (IEVar       U n   )     = [ieLWrappedName n]
+ieLNames (IEThingAbs  U n   )     = [ieLWrappedName n]
+ieLNames (IEThingAll  U n   )     = [ieLWrappedName n]
+ieLNames (IEThingWith U n _ ns _) = ieLWrappedName n : map ieLWrappedName ns
 ieLNames _ = []
 
 -- | Get the name and type of a binding.
 getTypeLHsBind :: (GhcMonad m)
                => TypecheckedModule
                -> LHsBind GhcTc
                -> m [(SpanSource, SrcSpan, Maybe Type)]
-getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ}) =
+getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =
   return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))]
 getTypeLHsBind _ _ = return []
 
@@ -107,11 +116,11 @@ getTypeLHsExpr _ e = do
       Nothing -> Nothing
   where
     getSpanSource :: HsExpr GhcTc -> SpanSource
-    getSpanSource (HsVar _ (L _ i)) = Named (getName i)
-    getSpanSource (HsConLikeOut _ (RealDataCon dc)) = Named (dataConName dc)
+    getSpanSource (HsVar U (L _ i)) = Named (getName i)
+    getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
     getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
-    getSpanSource (HsWrap _ _ xpr) = getSpanSource xpr
-    getSpanSource (HsPar _ xpr) = getSpanSource (unLoc xpr)
+    getSpanSource (HsWrap U _ xpr) = getSpanSource xpr
+    getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
     getSpanSource _ =  NoSource
 
 -- | Get the name and type of a pattern.
@@ -124,7 +133,7 @@ getTypeLPat _ pat =
   return $ Just (src, spn, Just (hsPatType pat))
   where
     getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
-    getSpanSource (VarPat _ (L spn vid)) = (Named (getName vid), spn)
+    getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)
     getSpanSource (ConPatOut (L spn (RealDataCon dc)) _ _ _ _ _ _) =
       (Named (dataConName dc), spn)
     getSpanSource _ = (NoSource, noSrcSpan)
@@ -134,7 +143,7 @@ getLHsType
     => TypecheckedModule
     -> LHsType GhcRn
     -> m [(SpanSource, SrcSpan, Maybe Type)]
-getLHsType _ (L spn (HsTyVar _ _ v)) = pure [(Named $ unLoc v, spn, Nothing)]
+getLHsType _ (L spn (HsTyVar U _ v)) = pure [(Named $ unLoc v, spn, Nothing)]
 getLHsType _ _ = pure []
 
 importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]

diff --git a/compiler/hie-core/stack.yaml b/compiler/hie-core/stack.yaml
@@ -11,7 +11,7 @@ extra-deps:
 - git: https://github.com/bubba/lsp-test.git
   commit: d126623dc6895d325e3d204d74e2a22d4f515587
 - git: https://github.com/mpickering/hie-bios.git
-  commit: 7a75f520b2e7a482440edd023be8e267a0fa153f
+  commit: 89e4ba24f87aac9909d9814b0e8c51b679a0ccd4
 nix:
   packages: [zlib]
 allow-newer: true
diff --git a/compiler/hie-core/stack84.yaml b/compiler/hie-core/stack84.yaml
@@ -0,0 +1,21 @@
+resolver: lts-12.26
+packages:
+- .
+
+extra-deps:
+- rope-utf16-splay-0.3.1.0
+- shake-0.18.3
+- filepattern-0.1.1
+- js-dgtable-0.5.2
+- git: https://github.com/alanz/haskell-lsp.git
+  commit: bfbd8630504ebc57b70948689c37b85cfbe589da
+  subdirs:
+  - .
+  - haskell-lsp-types
+- git: https://github.com/bubba/lsp-test.git
+  commit: d126623dc6895d325e3d204d74e2a22d4f515587
+- git: https://github.com/mpickering/hie-bios.git
+  commit: 89e4ba24f87aac9909d9814b0e8c51b679a0ccd4
+nix:
+  packages: [zlib]
+allow-newer: true