{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

#if __GLASGOW_HASKELL__ >= 914
{-# OPTIONS_GHC -Wno-pattern-namespace-specifier #-}
#endif

-- | Compatibility layer for GHC 9.6 through 9.14.
--
-- Isolates all compiler AST and builtin namespace churn behind a uniform
-- interface, keeping the solver and source desugaring logic clean.
module Polytropos.Plugin.Compat
  ( modBase
  , modShow
  , modRecords
  , CompatRecUpdField
  , matchRecordUpd
  , extractRecUpdField
  , pattern PrefixConPat
  , stripHsPar
  , polyLabel
  , mkPolytroposImportDecl
  , mkHsApp
  , mkTupArg
  , mkLambda
  ) where

import GHC.Unit.Types
  ( mkModule
  , moduleUnit
  )

import GHC.Plugins
  ( Module
  , FastString
  , unLoc
  , mkModuleName
  , rdrNameOcc
  , occNameFS
  , RawPkgQual(..)
  )

import GHC.Hs.Extension
  ( GhcPs
  )

import GHC.Hs
  ( LHsExpr
  , LHsRecUpdField
  , LImportDecl
  , ImportDecl(..)
  , ImportDeclQualifiedStyle(..)
  , IsBootInterface(..)
  , noAnn
  , noLocA
#if __GLASGOW_HASKELL__ >= 910
  , noExtField
#endif
  , HsExpr(..)
  , HsFieldBind(..)
  , HsConDetails(..)
  , LPat
  , mkHsLam
#if __GLASGOW_HASKELL__ >= 908
  , LHsRecUpdFields(..)
#endif
#if __GLASGOW_HASKELL__ >= 914
  , ImportDeclLevelStyle(..)
#endif
#if __GLASGOW_HASKELL__ >= 912
  , FieldOcc(..)
#else
  , AmbiguousFieldOcc(..)
#endif
  )

import Language.Haskell.Syntax.Expr
  ( HsTupArg(..)
  )

import GHC.Hs.ImpExp
  ( XImportDeclPass(..)
  )

import GHC.Types.SourceText
  ( SourceText(..)
  )

#if __GLASGOW_HASKELL__ >= 910
import GHC.Builtin.Names
  ( gHC_INTERNAL_BASE
  , gHC_INTERNAL_SHOW
  )
#else
import GHC.Builtin.Names
  ( gHC_BASE
  , gHC_SHOW
  )
#endif

-------------------------------------------------------------------------------
-- Module locations for base / show / records
-------------------------------------------------------------------------------

-- | Location of GHC.Base (or GHC.Internal.Base in 9.10+)
modBase :: Module
#if __GLASGOW_HASKELL__ >= 910
modBase :: Module
modBase = Module
gHC_INTERNAL_BASE
#else
modBase = gHC_BASE
#endif

-- | Location of GHC.Show (or GHC.Internal.Show in 9.10+)
modShow :: Module
#if __GLASGOW_HASKELL__ >= 910
modShow :: Module
modShow = Module
gHC_INTERNAL_SHOW
#else
modShow = gHC_SHOW
#endif

-- | Location of GHC.Records (or GHC.Internal.Records in 9.10+)
modRecords :: Module
#if __GLASGOW_HASKELL__ >= 910
modRecords :: Module
modRecords = Unit -> ModuleName -> Module
forall u. u -> ModuleName -> GenModule u
mkModule (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
modBase) (String -> ModuleName
mkModuleName String
"GHC.Internal.Records")
#else
modRecords = mkModule (moduleUnit modBase) (mkModuleName "GHC.Records")
#endif

-------------------------------------------------------------------------------
-- Record Update Compatibility (GHC 9.6 vs 9.8 vs 9.14)
-------------------------------------------------------------------------------

#if __GLASGOW_HASKELL__ >= 908
type CompatRecUpdField = LHsRecUpdField GhcPs GhcPs
#else
type CompatRecUpdField = LHsRecUpdField GhcPs
#endif

-- | Extract the updated record expression and fields from RecordUpd.
matchRecordUpd :: HsExpr GhcPs -> Maybe (LHsExpr GhcPs, [CompatRecUpdField])
#if __GLASGOW_HASKELL__ >= 908
matchRecordUpd :: HsExpr (GhcPass 'Parsed)
-> Maybe (LHsExpr (GhcPass 'Parsed), [CompatRecUpdField])
matchRecordUpd (RecordUpd XRecordUpd (GhcPass 'Parsed)
_ LHsExpr (GhcPass 'Parsed)
r (RegularRecUpdFields XLHsRecUpdLabels (GhcPass 'Parsed)
_ [CompatRecUpdField]
flds)) = (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
 [GenLocated
    SrcSpanAnnA
    (HsFieldBind
       (GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Parsed)))
       (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))])
-> Maybe
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
      [GenLocated
         SrcSpanAnnA
         (HsFieldBind
            (GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Parsed)))
            (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))])
forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
LHsExpr (GhcPass 'Parsed)
r, [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Parsed)))
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))]
[CompatRecUpdField]
flds)
matchRecordUpd HsExpr (GhcPass 'Parsed)
_ = Maybe
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)),
   [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Parsed)))
         (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))])
Maybe (LHsExpr (GhcPass 'Parsed), [CompatRecUpdField])
forall a. Maybe a
Nothing
#else
matchRecordUpd (RecordUpd _ r (Left flds)) = Just (r, flds)
matchRecordUpd _ = Nothing
#endif

-- | Extract the label FastString and value expression from a record update field.
extractRecUpdField :: CompatRecUpdField -> (FastString, LHsExpr GhcPs)
#if __GLASGOW_HASKELL__ >= 912
extractRecUpdField :: CompatRecUpdField -> (FastString, LHsExpr (GhcPass 'Parsed))
extractRecUpdField (GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Parsed)))
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))))
-> HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Parsed)))
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
CompatRecUpdField
-> HsFieldBind
     (GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Parsed)))
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed)))
forall l e. GenLocated l e -> e
unLoc -> HsFieldBind XHsFieldBind (GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Parsed)))
_ (GenLocated SrcSpanAnnA (FieldOcc (GhcPass 'Parsed))
-> FieldOcc (GhcPass 'Parsed)
forall l e. GenLocated l e -> e
unLoc -> FieldOcc XCFieldOcc (GhcPass 'Parsed)
_ (GenLocated SrcSpanAnnN RdrName -> RdrName
LIdP (GhcPass 'Parsed) -> RdrName
forall l e. GenLocated l e -> e
unLoc -> RdrName
lbl)) GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
arg Bool
_) =
  (OccName -> FastString
occNameFS (RdrName -> OccName
rdrNameOcc RdrName
lbl), GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
LHsExpr (GhcPass 'Parsed)
arg)
#else
extractRecUpdField (unLoc -> HsFieldBind _ (unLoc -> ambOcc) arg _) =
  let lbl = case ambOcc of
        Unambiguous _ (unLoc -> rdr) -> rdr
        Ambiguous _ (unLoc -> rdr)   -> rdr
  in (occNameFS (rdrNameOcc lbl), arg)
#endif

-------------------------------------------------------------------------------
-- Pattern & Expression AST Compatibility
-------------------------------------------------------------------------------

-- | Pattern synonym matching PrefixCon constructor details across GHC versions.
#if __GLASGOW_HASKELL__ >= 914
pattern PrefixConPat :: [arg] -> HsConDetails arg rec
pattern $bPrefixConPat :: forall arg rec. [arg] -> HsConDetails arg rec
$mPrefixConPat :: forall {r} {arg} {rec}.
HsConDetails arg rec -> ([arg] -> r) -> ((# #) -> r) -> r
PrefixConPat args = PrefixCon args
#else
pattern PrefixConPat :: [arg] -> HsConDetails tyarg arg rec
pattern PrefixConPat args <- PrefixCon _ args
  where PrefixConPat args = PrefixCon [] args
#endif

-- | Strip enclosing parenthesis expressions across GHC versions.
stripHsPar :: LHsExpr GhcPs -> LHsExpr GhcPs
#if __GLASGOW_HASKELL__ >= 910
stripHsPar :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
stripHsPar (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
-> HsExpr (GhcPass 'Parsed)
LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
forall l e. GenLocated l e -> e
unLoc -> HsPar XPar (GhcPass 'Parsed)
_ LHsExpr (GhcPass 'Parsed)
e) = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
stripHsPar LHsExpr (GhcPass 'Parsed)
e
#else
stripHsPar (unLoc -> HsPar _ _ e _) = stripHsPar e
#endif
stripHsPar LHsExpr (GhcPass 'Parsed)
e = LHsExpr (GhcPass 'Parsed)
e

-- | Construct an overloaded label expression across GHC 9.6-9.14.
polyLabel :: FastString -> LHsExpr GhcPs
#if __GLASGOW_HASKELL__ >= 912
polyLabel :: FastString -> LHsExpr (GhcPass 'Parsed)
polyLabel FastString
fs = HsExpr (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XOverLabel (GhcPass 'Parsed)
-> FastString -> HsExpr (GhcPass 'Parsed)
forall p. XOverLabel p -> FastString -> HsExpr p
HsOverLabel SourceText
XOverLabel (GhcPass 'Parsed)
NoSourceText FastString
fs)
#elif __GLASGOW_HASKELL__ >= 910
polyLabel fs = noLocA (HsOverLabel noExtField NoSourceText fs)
#else
polyLabel fs = noLocA (HsOverLabel noAnn NoSourceText fs)
#endif

-- | Construct the 'import qualified Polytropos as Polytropos' declaration.
mkPolytroposImportDecl :: LImportDecl GhcPs
#if __GLASGOW_HASKELL__ >= 914
mkPolytroposImportDecl :: LImportDecl (GhcPass 'Parsed)
mkPolytroposImportDecl = ImportDecl (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (ImportDecl (GhcPass 'Parsed)
 -> GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Parsed)))
-> ImportDecl (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (ImportDecl (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ ImportDecl
  { ideclExt :: XCImportDecl (GhcPass 'Parsed)
ideclExt       = EpAnn EpAnnImportDecl -> SourceText -> Bool -> XImportDeclPass
XImportDeclPass EpAnn EpAnnImportDecl
forall a. NoAnn a => a
noAnn SourceText
NoSourceText Bool
False
  , ideclName :: XRec (GhcPass 'Parsed) ModuleName
ideclName      = ModuleName -> GenLocated SrcSpanAnnA ModuleName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (String -> ModuleName
mkModuleName String
"Polytropos")
  , ideclPkgQual :: ImportDeclPkgQual (GhcPass 'Parsed)
ideclPkgQual   = RawPkgQual
ImportDeclPkgQual (GhcPass 'Parsed)
NoRawPkgQual
  , ideclSource :: IsBootInterface
ideclSource    = IsBootInterface
NotBoot
  , ideclLevelSpec :: ImportDeclLevelStyle
ideclLevelSpec = ImportDeclLevelStyle
NotLevelled
  , ideclSafe :: Bool
ideclSafe      = Bool
False
  , ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = ImportDeclQualifiedStyle
QualifiedPre
  , ideclAs :: Maybe (XRec (GhcPass 'Parsed) ModuleName)
ideclAs        = GenLocated SrcSpanAnnA ModuleName
-> Maybe (GenLocated SrcSpanAnnA ModuleName)
forall a. a -> Maybe a
Just (ModuleName -> GenLocated SrcSpanAnnA ModuleName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (String -> ModuleName
mkModuleName String
"Polytropos"))
  , ideclImportList :: Maybe
  (ImportListInterpretation,
   XRec (GhcPass 'Parsed) [LIE (GhcPass 'Parsed)])
ideclImportList = Maybe
  (ImportListInterpretation,
   XRec (GhcPass 'Parsed) [LIE (GhcPass 'Parsed)])
forall a. Maybe a
Nothing
  }
#else
mkPolytroposImportDecl = noLocA $ ImportDecl
  { ideclExt       = XImportDeclPass noAnn NoSourceText False
  , ideclName      = noLocA (mkModuleName "Polytropos")
  , ideclPkgQual   = NoRawPkgQual
  , ideclSource    = NotBoot
  , ideclSafe      = False
  , ideclQualified = QualifiedPre
  , ideclAs        = Just (noLocA (mkModuleName "Polytropos"))
  , ideclImportList = Nothing
  }
#endif

-- | Construct a function application expression across GHC 9.6-9.14.
mkHsApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
#if __GLASGOW_HASKELL__ >= 910
mkHsApp :: LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mkHsApp LHsExpr (GhcPass 'Parsed)
f LHsExpr (GhcPass 'Parsed)
x = HsExpr (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XApp (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> HsExpr (GhcPass 'Parsed)
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp (GhcPass 'Parsed)
noExtField LHsExpr (GhcPass 'Parsed)
f LHsExpr (GhcPass 'Parsed)
x)
#else
mkHsApp f x = noLocA (HsApp noAnn f x)
#endif

-- | Construct a tuple present argument across GHC 9.6-9.14.
mkTupArg :: LHsExpr GhcPs -> HsTupArg GhcPs
#if __GLASGOW_HASKELL__ >= 910
mkTupArg :: LHsExpr (GhcPass 'Parsed) -> HsTupArg (GhcPass 'Parsed)
mkTupArg LHsExpr (GhcPass 'Parsed)
e = XPresent (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> HsTupArg (GhcPass 'Parsed)
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present NoExtField
XPresent (GhcPass 'Parsed)
noExtField LHsExpr (GhcPass 'Parsed)
e
#else
mkTupArg e = Present noAnn e
#endif

-- | Construct a lambda expression across GHC 9.6-9.14.
mkLambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
#if __GLASGOW_HASKELL__ >= 912
mkLambda :: [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mkLambda [LPat (GhcPass 'Parsed)]
pats LHsExpr (GhcPass 'Parsed)
body = LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) =>
LocatedE [LPat (GhcPass p)]
-> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
[LPat (GhcPass 'Parsed)]
pats) LHsExpr (GhcPass 'Parsed)
body
#else
mkLambda pats body = mkHsLam pats body
#endif