Support ghc-lib-parser-9.14

.github/workflows/ci.yml

@@ -15,7 +15,9 @@ jobs:
         ghc: ['9.8', '9.6', '9.4']
         include:
         - os: windows-latest
+          ghc: 9.12
         - os: macOS-latest
+          ghc: 9.12
 
     steps:
     - run: git config --global core.autocrlf false

LICENSE

@@ -1,4 +1,4 @@
-Copyright Neil Mitchell 2004-2025.
+Copyright Neil Mitchell 2004-2026.
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

hoogle.cabal

@@ -7,7 +7,7 @@ license-file:       LICENSE
 category:           Development
 author:             Neil Mitchell <ndmitchell@gmail.com>
 maintainer:         Neil Mitchell <ndmitchell@gmail.com>
-copyright:          Neil Mitchell 2004-2025
+copyright:          Neil Mitchell 2004-2026
 synopsis:           Haskell API Search
 description:
     Hoogle is a Haskell API search engine, which allows you to
@@ -46,7 +46,7 @@ library
 
     build-depends:
         QuickCheck,
-        aeson,
+        aeson >= 2,
         ansi-terminal,
         base >= 4 && < 5,
         blaze-html,
@@ -64,7 +64,7 @@ library
         directory,
         extra >= 1.6.6,
         filepath,
-        ghc-lib-parser >= 9.6.5,
+        ghc-lib-parser >= 9.6.5 && < 9.16,
         hackage-revdeps >= 0.3 && < 0.4,
         old-locale,
         hashable,

src/Input/Haddock.hs

@@ -166,6 +166,7 @@ readItem x@(x0 : _) -- constructors
     | isUpper x0 || x0 == '('
     , ParseOk (GDataDecl _ _ _ _ _ [GadtDecl s name _ _ _ ty] _) <- myParseDecl $ "data Data where " ++ x
     , let f (TyBang _ _ _ (TyParen _ x@TyApp{})) = x
+          f (TyParen _ x@TyApp{}) = x
           f (TyBang _ _ _ x) = x
           f x = x
     = Just $ TypeSig s [name] $ applyFun1 $ map f $ unapplyFun ty
@@ -253,7 +254,8 @@ input_haddock_test = testing "Input.Haddock.parseLine" $ do
     test "pattern The :: The d a => a -> d"
     test "Html :: Element \"html\" '[] (Elements [\"head\", \"body\"]) (ManifestA & '[])"
     test "instance forall k1 v1 (pk :: k1 -> GHC.Types.Constraint) (k2 :: k1) (pv :: v1 -> GHC.Types.Constraint) (v2 :: v1) . (pk k2, pv v2) => Type.Membership.KeyTargetAre pk pv (k2 'Type.Membership.Internal.:> v2)"
-    test "crDoubleBuffer :: CompactorReturn s -> {-# UNPACK #-} !DoubleBuffer s"
+    -- The following no longer parses since GHC 9.14 (which is the correct behaviour)
+    -- test "crDoubleBuffer :: CompactorReturn s -> {-# UNPACK #-} !DoubleBuffer s"
     test "expectationFailure :: (?callStack :: CallStack) => String -> Expectation"
     test "type family MapTyCon t xs = r | r -> xs"
     test "pattern Id :: CRCategory k => (β ~ α, Object k α) => k α β"

src/Input/ParseDecl.hs

@@ -51,6 +51,10 @@ pattern MyPrefixConGADT x <- PrefixConGADT x
 pattern MyRecConGADT x <- RecConGADT x _
 #endif
 
+#if !MIN_VERSION_ghc_lib_parser(9,14,0)
+#define con_outer_bndrs con_bndrs
+#endif
+
 myParseDecl :: String -> HSE.ParseResult (HSE.Decl ())
 myParseDecl str = case runGhcLibParser str of
     POk _state x -> case hsDeclToDecl (unLoc x) of
@@ -96,7 +100,7 @@ hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit
             (Just $ hsTypeToType $ unLoc kind)
             []
             []
-hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit}, tcdDataDefn = HsDataDefn{dd_cons = DataTypeCons _ [L _ (ConDeclGADT{con_names, con_bndrs, con_g_args = MyPrefixConGADT args, con_res_ty, con_mb_cxt})]}})) =
+hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit}, tcdDataDefn = HsDataDefn{dd_cons = DataTypeCons _ [L _ (ConDeclGADT{con_names, con_outer_bndrs, con_g_args = MyPrefixConGADT args, con_res_ty, con_mb_cxt})]}})) =
     Just $
         HSE.GDataDecl
             ()
@@ -116,18 +120,22 @@ hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit
                         Nothing
                         Nothing
                         Nothing
-                        ( maybe id (\bs -> applyTyForall (Just bs) Nothing) (hsOuterTyVarBndrsToFoo $ unLoc con_bndrs) $
+                        ( maybe id (\bs -> applyTyForall (Just bs) Nothing) (hsOuterTyVarBndrsToFoo $ unLoc con_outer_bndrs) $
                             maybe id (applyTyForall Nothing . Just . hsTypesToContext . unLoc) con_mb_cxt $
                                 foldr
+#if MIN_VERSION_ghc_lib_parser(9,14,0)
+                                    (\CDF{cdf_type} -> HSE.TyFun () (hsTypeToType $ unLoc cdf_type))
+#else
                                     (\(HsScaled _ a) -> HSE.TyFun () (hsTypeToType $ unLoc a))
+#endif
                                     (hsTypeToType $ unLoc con_res_ty)
                                     args
                         )
                 )
                 (NE.toList con_names)
             )
             []
-hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit}, tcdDataDefn = HsDataDefn{dd_cons = DataTypeCons _ [L _ (ConDeclGADT{con_names, con_bndrs, con_g_args = MyRecConGADT (L _ args), con_res_ty, con_mb_cxt})]}})) =
+hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit}, tcdDataDefn = HsDataDefn{dd_cons = DataTypeCons _ [L _ (ConDeclGADT{con_names, con_outer_bndrs, con_g_args = MyRecConGADT (L _ args), con_res_ty, con_mb_cxt})]}})) =
     Just $
         HSE.GDataDecl
             ()
@@ -148,7 +156,7 @@ hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit
                         Nothing
                         (Just $ map (conDeclFieldToFieldDecl . unLoc) args)
                         ( maybe id (HSE.TyForall () Nothing . Just . hsTypesToContext . unLoc) con_mb_cxt $
-                            maybe id (\bs -> HSE.TyForall () (Just bs) Nothing) (hsOuterTyVarBndrsToFoo $ unLoc con_bndrs) $
+                            maybe id (\bs -> HSE.TyForall () (Just bs) Nothing) (hsOuterTyVarBndrsToFoo $ unLoc con_outer_bndrs) $
                                 hsTypeToType $
                                     unLoc con_res_ty
                         )
@@ -253,13 +261,23 @@ injectivityAnnToInjectivityInfo = \case
     InjectivityAnn _ lhs rhs ->
         HSE.InjectivityInfo () (rdrNameToName $ unLoc lhs) (map (rdrNameToName . unLoc) rhs)
 
+#if MIN_VERSION_ghc_lib_parser(9,14,0)
+conDeclFieldToFieldDecl :: HsConDeclRecField GhcPs -> HSE.FieldDecl ()
+conDeclFieldToFieldDecl = \case
+    HsConDeclRecField{cdrf_names, cdrf_spec = CDF{cdf_type}} ->
+        HSE.FieldDecl
+            ()
+            (map (fieldOccToName . unLoc) cdrf_names)
+            (hsTypeToType $ unLoc cdf_type)
+#else
 conDeclFieldToFieldDecl :: ConDeclField GhcPs -> HSE.FieldDecl ()
 conDeclFieldToFieldDecl = \case
     ConDeclField{cd_fld_names, cd_fld_type} ->
         HSE.FieldDecl
             ()
             (map (fieldOccToName . unLoc) cd_fld_names)
             (hsTypeToType $ unLoc cd_fld_type)
+#endif
 
 fieldOccToName :: FieldOcc GhcPs -> HSE.Name ()
 fieldOccToName = \case
@@ -374,11 +392,13 @@ hsTypeToType = \case
         HSE.TyTuple () (hsTupleSortToBoxed boxed) (map (hsTypeToType . unLoc) xs)
     HsStarTy _ _ ->
         HSE.TyStar ()
+#if !MIN_VERSION_ghc_lib_parser(9,14,0)
     HsBangTy _ (HsBang unpackedness strictness) x ->
         applyTyBang
             (srcStrictnessToBangType strictness)
             (srcUnpackednessToUnpackedness unpackedness)
             (hsTypeToType $ unLoc x)
+#endif
     HsParTy _ x -> case hsTypeToType (unLoc x) of
         x'@HSE.TyKind{} -> x'
         x' -> HSE.TyParen () x'
@@ -461,6 +481,7 @@ applyTyForall mArg1 mArg2 = \case
         | isNothing mArg2 -> HSE.TyForall () mArg1 mArg2' ty
     ty -> HSE.TyForall () mArg1 mArg2 ty
 
+#if !MIN_VERSION_ghc_lib_parser(9,14,0)
 applyTyBang ::
     HSE.BangType () -> HSE.Unpackedness () -> HSE.Type () -> HSE.Type ()
 applyTyBang bang unpack = \case
@@ -471,6 +492,19 @@ applyTyBang bang unpack = \case
     HSE.TyApp () x y -> HSE.TyApp () (applyTyBang bang unpack x) y
     ty -> HSE.TyBang () bang unpack ty
 
+srcStrictnessToBangType :: SrcStrictness -> HSE.BangType ()
+srcStrictnessToBangType = \case
+    SrcLazy -> HSE.LazyTy ()
+    SrcStrict -> HSE.BangedTy ()
+    NoSrcStrict -> HSE.NoStrictAnnot ()
+
+srcUnpackednessToUnpackedness :: SrcUnpackedness -> HSE.Unpackedness ()
+srcUnpackednessToUnpackedness = \case
+    SrcUnpack -> HSE.Unpack ()
+    SrcNoUnpack -> HSE.NoUnpack ()
+    NoSrcUnpack -> HSE.NoUnpackPragma ()
+#endif
+
 typeToInstHead :: HSE.Type () -> HSE.InstHead ()
 typeToInstHead = \case
     HSE.TyApp () x y -> HSE.IHApp () (typeToInstHead x) y
@@ -506,18 +540,6 @@ hsTupleSortToBoxed = \case
     HsUnboxedTuple -> HSE.Unboxed
     HsBoxedOrConstraintTuple -> HSE.Boxed
 
-srcStrictnessToBangType :: SrcStrictness -> HSE.BangType ()
-srcStrictnessToBangType = \case
-    SrcLazy -> HSE.LazyTy ()
-    SrcStrict -> HSE.BangedTy ()
-    NoSrcStrict -> HSE.NoStrictAnnot ()
-
-srcUnpackednessToUnpackedness :: SrcUnpackedness -> HSE.Unpackedness ()
-srcUnpackednessToUnpackedness = \case
-    SrcUnpack -> HSE.Unpack ()
-    SrcNoUnpack -> HSE.NoUnpack ()
-    NoSrcUnpack -> HSE.NoUnpackPragma ()
-
 runGhcLibParser ::
     String ->
     GHC.Parser.Lexer.ParseResult (GenLocated SrcSpanAnnA (HsDecl GhcPs))
@@ -566,7 +588,11 @@ runGhcLibParserWithExtensions ::
     GHC.Parser.Lexer.ParseResult (GenLocated SrcSpanAnnA (HsDecl GhcPs))
 runGhcLibParserWithExtensions extensions str = unP parseDeclaration parseState
   where
+#if MIN_VERSION_ghc_lib_parser(9,14,0)
+    opts = mkParserOpts extensions emptyDiagOpts False False False False
+#else
     opts = mkParserOpts extensions emptyDiagOpts [] False False False False
+#endif
     dummyLocation = mkRealSrcLoc mempty 1 1
     buffer = stringToStringBuffer str
     parseState = initParserState opts buffer dummyLocation