Add GHC 9 support

.circleci/config.yml

@@ -68,6 +68,23 @@ jobs:
                 - ~/.stack
                 - .stack-work
 
+  build-ghc-9.0:
+    docker:
+    - image: circleci/rust:1.36-stretch
+    steps:
+    - checkout
+    - restore_cache:
+        keys:
+            - stack-cache-v2-ghc-9.0-{{ arch }}-{{ .Branch }}
+            - stack-cache-v2-ghc-9.0-{{ arch }}-master
+    - run: .circleci/install-stack.sh
+    - run: stack test --no-terminal --resolver=ghc-9.0.1
+    - save_cache:
+            key: stack-cache-v2-ghc-9.0-{{ arch }}-{{ .Branch }}-{{ epoch }}
+            paths:
+                - ~/.stack
+                - .stack-work
+
   build-success:
     docker:
     - image: circleci/rust:1.36-stretch
@@ -82,9 +99,11 @@ workflows:
         - build-13.23
         - build-15.13
         - build-ghc-8.10
+        - build-ghc-9.0
         - build-success:
             requires:
             - build-12.8
             - build-13.23
             - build-15.13
             - build-ghc-8.10
+            - build-ghc-9.0

.circleci/install-stack.sh

@@ -2,7 +2,7 @@
 
 set -xueo pipefail
 mkdir -p $HOME/.local/bin
-curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.1/stack-2.1.1-linux-x86_64.tar.gz \
+curl -L https://github.com/commercialhaskell/stack/releases/download/v2.7.3/stack-2.7.3-linux-x86_64.tar.gz \
     | tar xz --wildcards --strip-components=1 -C "$HOME/.local/bin" '*/stack'
 echo 'export PATH=$HOME/.local/bin:$PATH' >> $BASH_ENV
 

ghc-show-ast/Main.hs

@@ -13,8 +13,13 @@ import Data.Typeable (cast)
 import System.Environment (getArgs)
 import Text.PrettyPrint
 
+#if MIN_VERSION_ghc(9,0,1)
+import GHC.Data.FastString
+import GHC.Types.Name
+#else
 import FastString
 import Name
+#endif
     ( Name
     , isExternalName
     , isInternalName
@@ -23,7 +28,11 @@ import Name
     , nameOccName
     , nameUnique
     )
+#if MIN_VERSION_ghc(9,0,1)
+import GHC.Types.Name.Occurrence
+#else
 import OccName
+#endif
     ( OccName
     , occNameSpace
     , occNameString
@@ -34,6 +43,17 @@ import OccName
     , tcClsName
     )
 
+#if MIN_VERSION_ghc(9,0,1)
+import qualified GHC.Driver.Session as GHC
+import qualified GHC.Data.FastString as GHC
+import qualified GHC as GHC
+import qualified GHC.Driver.Monad as GHC
+import qualified GHC.Parser.Header as GHC
+import qualified GHC.Parser.Lexer as GHC
+import qualified GHC.Parser as Parser
+import qualified GHC.Types.SrcLoc as GHC
+import qualified GHC.Data.StringBuffer as GHC
+#else
 import qualified DynFlags as GHC
 import qualified FastString as GHC
 import qualified GHC as GHC
@@ -43,11 +63,17 @@ import qualified Lexer as GHC
 import qualified Parser as Parser
 import qualified SrcLoc as GHC
 import qualified StringBuffer as GHC
+#endif
 import GHC.Paths (libdir)
 #if MIN_VERSION_ghc(8,10,0)
 import System.Exit (exitFailure)
+#if     MIN_VERSION_ghc(9,0,1)
+import GHC.Driver.Monad (liftIO)
+import qualified GHC.Utils.Error as Error
+#else
 import GhcMonad (liftIO)
-import qualified ErrUtils
+import qualified ErrUtils as Error
+#endif
 #else
 import qualified Outputable as GHC
 #endif
@@ -58,7 +84,11 @@ main = do
     result <- parseModule f
     print $ gPrint result
 
-parseModule :: FilePath -> IO (GHC.HsModule GHC.GhcPs)
+#if MIN_VERSION_ghc(9,0,1)
+parseModule :: FilePath -> IO GHC.HsModule
+#else
+parseModule :: FilePath -> IO (GHC.HsModule GHC.GhcPs) 
+#endif
 parseModule f = GHC.runGhc (Just libdir) $ do
     dflags <- GHC.getDynFlags
     contents <- GHC.liftIO $ GHC.stringToStringBuffer <$> readFile f
@@ -70,7 +100,7 @@ parseModule f = GHC.runGhc (Just libdir) $ do
 #if MIN_VERSION_ghc(8,10,0)
         GHC.PFailed s -> liftIO $ do
                 let (_warnings, errors) = GHC.messages s dflags
-                ErrUtils.printBagOfErrors dflags errors
+                Error.printBagOfErrors dflags errors
                 exitFailure
 #else
         GHC.PFailed

package.yaml

@@ -30,7 +30,7 @@ description: |
 
 dependencies:
 - base >= 4.7 && < 5
-- ghc >= 8.4 && < 8.11
+- ghc >= 8.4 && < 9.1
 
 default-extensions:
 - DataKinds

src/GHC/SourceGen/Binds.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 -- Copyright 2019 Google LLC
 --
 -- Use of this source code is governed by a BSD-style
@@ -45,14 +47,21 @@ module GHC.SourceGen.Binds
     , (<--)
     ) where
 
-import BasicTypes (LexicalFixity(..))
 import Data.Bool (bool)
 import Data.Maybe (fromMaybe)
 import GHC.Hs.Binds
 import GHC.Hs.Expr
+
+#if MIN_VERSION_ghc(9,0,1)
+import GHC.Types.Basic (LexicalFixity(..))
+import GHC.Hs.Type
+import GHC.Plugins (isSymOcc)
+#else
+import BasicTypes (LexicalFixity(..))
 import GHC.Hs.Types
 import GhcPlugins (isSymOcc)
 import TcEvidence (HsWrapper(WpHole))
+#endif
 
 import GHC.SourceGen.Binds.Internal
 import GHC.SourceGen.Name
@@ -94,8 +103,13 @@ typeSig n = typeSigs [n]
 -- >   ]
 funBindsWithFixity :: HasValBind t => Maybe LexicalFixity -> OccNameStr -> [RawMatch] -> t
 funBindsWithFixity fixity name matches = bindB $ withPlaceHolder
-        (noExt FunBind name'
-            (matchGroup context matches) WpHole)
+        (noExt FunBind
+          name'
+          (matchGroup context matches)
+#if !MIN_VERSION_ghc(9,0,1)
+          WpHole
+#endif
+        )
         []
   where
     name' = valueRdrName $ unqual name
@@ -288,7 +302,15 @@ stmt e =
 -- > =====
 -- > bvar "x" <-- var "act"
 (<--) :: Pat' -> HsExpr' -> Stmt'
-p <-- e = withPlaceHolder $ noExt BindStmt (builtPat p) (builtLoc e) noSyntaxExpr noSyntaxExpr
+p <-- e =
+  withPlaceHolder $
+    noExt BindStmt
+      (builtPat p)
+      (builtLoc e) 
+#if !MIN_VERSION_ghc(9,0,1)
+      noSyntaxExpr
+      noSyntaxExpr
+#endif
 infixl 1 <--
 
 -- | Syntax types which can declare/define pattern bindings.

src/GHC/SourceGen/Binds/Internal.hs

@@ -7,12 +7,19 @@
 {-# LANGUAGE CPP #-}
 module GHC.SourceGen.Binds.Internal where
 
-import BasicTypes (Origin(Generated))
-import Bag (listToBag)
+
 import GHC.Hs.Binds
 import GHC.Hs.Decls
 import GHC.Hs.Expr (MatchGroup(..), Match(..), GRHSs(..))
+#if MIN_VERSION_ghc(9,0,1)
+import GHC.Types.Basic (Origin(Generated))
+import GHC.Data.Bag (listToBag)
+import GHC.Types.SrcLoc (Located)
+#else
+import BasicTypes (Origin(Generated))
+import Bag (listToBag)
 import SrcLoc (Located)
+#endif
 
 #if !MIN_VERSION_ghc(8,6,0)
 import PlaceHolder (PlaceHolder(..))

src/GHC/SourceGen/Decl.hs

@@ -49,14 +49,27 @@ module GHC.SourceGen.Decl
     , patSynBind
     ) where
 
+#if MIN_VERSION_ghc(9,0,1)
+import GHC.Types.Basic (LexicalFixity(Prefix))
+import GHC.Data.Bag (listToBag)
+import GHC.Types.SrcLoc (Located, LayoutInfo(NoLayoutInfo))
+import GHC.Parser.Annotation (IsUnicodeSyntax(NormalSyntax))
+#else
 import BasicTypes (LexicalFixity(Prefix))
+import Bag (listToBag)
+import SrcLoc (Located)
+#endif
+
 #if !MIN_VERSION_ghc(8,6,0)
 import BasicTypes (DerivStrategy(..))
 #endif
-import Bag (listToBag)
 import GHC.Hs.Binds
 import GHC.Hs.Decls
+#if MIN_VERSION_ghc(9,0,1)
+import GHC.Hs.Type
+#else
 import GHC.Hs.Types
+#endif
     ( ConDeclField(..)
     , FieldOcc(..)
     , HsConDetails(..)
@@ -71,8 +84,11 @@ import GHC.Hs.Types
 #endif
     , SrcStrictness(..)
     , SrcUnpackedness(..)
+#if MIN_VERSION_ghc(9,0,1)
+    , HsScaled (HsScaled)
+    , HsArrow (HsUnrestrictedArrow)
+#endif
     )
-import SrcLoc (Located)
 
 #if MIN_VERSION_ghc(8,10,0)
 import GHC.Hs.Extension (NoExtField(NoExtField))
@@ -148,14 +164,16 @@ funDep = ClassFunDep
 class'
     :: [HsType'] -- ^ Context
     -> OccNameStr -- ^ Class name
-    -> [HsTyVarBndr'] -- ^ Type parameters
+    -> [HsTyVarBndrUnit'] -- ^ Type parameters
     -> [ClassDecl] -- ^ Class declarations
     -> HsDecl'
 class' context name vars decls
     = noExt TyClD $ ClassDecl
             { tcdCtxt = builtLoc $ map builtLoc context
-#if MIN_VERSION_ghc(8,10,0)
-            , tcdCExt = NoExtField
+#if MIN_VERSION_ghc(9,0,1)
+            , tcdCExt = NoLayoutInfo
+#elif MIN_VERSION_ghc(8,10,0)
+            , tcdCExt = NoExtField 
 #elif MIN_VERSION_ghc(8,6,0)
             , tcdCExt = NoExt
 #else
@@ -253,7 +271,7 @@ tyFamInst name params ty = tyFamInstD
 -- > type A a b = B b a
 -- > =====
 -- > type' "A" [bvar "a", bvar "b"] $ var "B" @@ var "b" @@ var "a"
-type' :: OccNameStr -> [HsTyVarBndr'] -> HsType' -> HsDecl'
+type' :: OccNameStr -> [HsTyVarBndrUnit'] -> HsType' -> HsDecl'
 type' name vars t =
     noExt TyClD $ withPlaceHolder $ noExt SynDecl (typeRdrName $ unqual name)
         (mkQTyVars vars)
@@ -263,7 +281,7 @@ type' name vars t =
 newOrDataType
     :: NewOrData
     -> OccNameStr
-    -> [HsTyVarBndr']
+    -> [HsTyVarBndrUnit']
     -> [ConDecl']
     -> [HsDerivingClause']
     -> HsDecl'
@@ -285,7 +303,7 @@ newOrDataType newOrData name vars conDecls derivs
 -- > newtype' "Const" [bvar "a", bvar "b"]
 -- >    (conDecl "Const" [var "a"])
 -- >    [var "Show"]
-newtype' :: OccNameStr -> [HsTyVarBndr'] -> ConDecl' -> [HsDerivingClause'] -> HsDecl'
+newtype' :: OccNameStr -> [HsTyVarBndrUnit'] -> ConDecl' -> [HsDerivingClause'] -> HsDecl'
 newtype' name vars conD = newOrDataType NewType name vars [conD]
 
 -- | A data declaration.
@@ -298,7 +316,7 @@ newtype' name vars conD = newOrDataType NewType name vars [conD]
 -- >   , conDecl "Right" [var "b"]
 -- >   ]
 -- >   [var "Show"]
-data' :: OccNameStr -> [HsTyVarBndr'] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl'
+data' :: OccNameStr -> [HsTyVarBndrUnit'] -> [ConDecl'] -> [HsDerivingClause'] -> HsDecl'
 data' = newOrDataType DataType
 
 -- | Declares a Haskell-98-style prefix constructor for a data or type
@@ -308,8 +326,16 @@ data' = newOrDataType DataType
 -- > =====
 -- > conDecl "Foo" [field (var "a"), field (var "Int")]
 prefixCon :: OccNameStr -> [Field] -> ConDecl'
-prefixCon name fields = renderCon98Decl name
-    $ PrefixCon $ map renderField fields
+prefixCon name fields =
+    renderCon98Decl
+        name
+            $ PrefixCon
+#if MIN_VERSION_ghc(9,0,1)
+                $ map (HsScaled (HsUnrestrictedArrow NormalSyntax) . renderField)
+#else
+                $ map renderField
+#endif
+                     fields
 
 -- | Declares a Haskell-98-style infix constructor for a data or type
 -- declaration.
@@ -319,7 +345,19 @@ prefixCon name fields = renderCon98Decl name
 -- > infixCon (field (var "A" @@ var "b")) ":+:" (field (Var "C" @@ var "d"))
 infixCon :: Field -> OccNameStr -> Field -> ConDecl'
 infixCon f name f' = renderCon98Decl name
-    $ InfixCon (renderField f) (renderField f')
+    $ InfixCon
+        (
+#if MIN_VERSION_ghc(9,0,1)
+            HsScaled (HsUnrestrictedArrow NormalSyntax) $
+#endif
+                renderField f
+        )
+        (
+#if MIN_VERSION_ghc(9,0,1)
+            HsScaled (HsUnrestrictedArrow NormalSyntax) $ 
+#endif
+                renderField f'
+        )
 
 -- | Declares Haskell-98-style record constructor for a data or type
 -- declaration.