{-# LANGUAGE CPP              #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE PatternSynonyms  #-}
{-# LANGUAGE RankNTypes       #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TupleSections    #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
module Ide.Plugin.GHC where

import           Data.Functor                            ((<&>))
import           Data.List.Extra                         (stripInfix)
import qualified Data.Text                               as T
import           Development.IDE
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.ExactPrint
import           Ide.PluginUtils                         (subRange)
import           Language.Haskell.GHC.ExactPrint.Parsers (parseDecl)

#if MIN_VERSION_ghc(9,2,1)
import           GHC.Parser.Annotation                   (AddEpAnn (..),
                                                          Anchor (Anchor),
                                                          AnchorOperation (MovedAnchor),
                                                          DeltaPos (..),
                                                          EpAnn (..),
                                                          EpAnnComments (EpaComments),
                                                          EpaLocation (EpaDelta),
                                                          SrcSpanAnn' (SrcSpanAnn),
                                                          spanAsAnchor)
import           Language.Haskell.GHC.ExactPrint         (showAst)
#else
import qualified Data.Map.Lazy                           as Map
import           Language.Haskell.GHC.ExactPrint.Types   (AnnConName (CN),
                                                          AnnKey (AnnKey),
                                                          Annotation (..),
                                                          DeltaPos (DP),
                                                          KeywordId (G),
                                                          deltaColumn)
#endif

type GP = GhcPass Parsed

-- | Check if a given range is in the range of located item
inRange :: HasSrcSpan a => Range -> a -> Bool
inRange :: forall a. HasSrcSpan a => Range -> a -> Bool
inRange Range
range a
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Range -> Range -> Bool
subRange Range
range) (SrcSpan -> Maybe Range
srcSpanToRange (forall a. HasSrcSpan a => a -> SrcSpan
getLoc a
s))

-- | Get data decl and its location
getDataDecl :: LHsDecl GP -> Maybe (LTyClDecl GP)
getDataDecl :: LHsDecl GP -> Maybe (LTyClDecl GP)
getDataDecl (L SrcSpanAnnA
l (TyClD XTyClD GP
_ d :: TyClDecl GP
d@DataDecl{})) = forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l TyClDecl GP
d)
getDataDecl LHsDecl GP
_                            = forall a. Maybe a
Nothing

isConDeclH98 :: ConDecl GP -> Bool
isConDeclH98 :: ConDecl GP -> Bool
isConDeclH98 ConDeclH98{} = Bool
True
isConDeclH98 ConDecl GP
_            = Bool
False

isH98DataDecl :: LTyClDecl GP -> Bool
isH98DataDecl :: LTyClDecl GP -> Bool
isH98DataDecl (L SrcSpanAnnA
_ decl :: TyClDecl GP
decl@DataDecl{}) =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ConDecl GP -> Bool
isConDeclH98 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(L SrcSpanAnnA
_ ConDecl GP
r) -> ConDecl GP
r)) (forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons forall a b. (a -> b) -> a -> b
$ forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn TyClDecl GP
decl)
isH98DataDecl LTyClDecl GP
_ = Bool
False

-- | Convert H98 data type definition to GADT's
h98ToGADTDecl :: TyClDecl GP -> TyClDecl GP
h98ToGADTDecl :: TyClDecl GP -> TyClDecl GP
h98ToGADTDecl = \case
    DataDecl{HsDataDefn GP
LHsQTyVars GP
XRec GP (IdP GP)
XDataDecl GP
LexicalFixity
tcdDExt :: forall pass. TyClDecl pass -> XDataDecl pass
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdDataDefn :: HsDataDefn GP
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars GP
tcdLName :: XRec GP (IdP GP)
tcdDExt :: XDataDecl GP
tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
..} -> DataDecl
        { tcdDataDefn :: HsDataDefn GP
tcdDataDefn = GenLocated SrcSpanAnnN RdrName
-> LHsQTyVars GP -> HsDataDefn GP -> HsDataDefn GP
updateDefn XRec GP (IdP GP)
tcdLName LHsQTyVars GP
tcdTyVars HsDataDefn GP
tcdDataDefn
        , LHsQTyVars GP
XRec GP (IdP GP)
XDataDecl GP
LexicalFixity
tcdDExt :: XDataDecl GP
tcdFixity :: LexicalFixity
tcdLName :: XRec GP (IdP GP)
tcdTyVars :: LHsQTyVars GP
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars GP
tcdLName :: XRec GP (IdP GP)
tcdDExt :: XDataDecl GP
..
        }
    TyClDecl GP
x -> TyClDecl GP
x
    where
        updateDefn :: GenLocated SrcSpanAnnN RdrName
-> LHsQTyVars GP -> HsDataDefn GP -> HsDataDefn GP
updateDefn GenLocated SrcSpanAnnN RdrName
dataName LHsQTyVars GP
tyVars = \case
            HsDataDefn{HsDeriving GP
[LConDecl GP]
Maybe (LHsContext GP)
Maybe (XRec GP (HsType GP))
Maybe (XRec GP CType)
NewOrData
XCHsDataDefn GP
dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_ext :: forall pass. HsDataDefn pass -> XCHsDataDefn pass
dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_derivs :: HsDeriving GP
dd_cons :: [LConDecl GP]
dd_kindSig :: Maybe (XRec GP (HsType GP))
dd_cType :: Maybe (XRec GP CType)
dd_ctxt :: Maybe (LHsContext GP)
dd_ND :: NewOrData
dd_ext :: XCHsDataDefn GP
dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
..} -> HsDataDefn
                { dd_cons :: [LConDecl GP]
dd_cons =
                    (ConDecl GP -> ConDecl GP)
-> GenLocated (Anno (ConDecl GP)) (ConDecl GP)
-> GenLocated (Anno (ConDecl GP)) (ConDecl GP)
mapX (XRec GP (IdP GP)
-> LHsQTyVars GP
-> Maybe (LHsContext GP)
-> ConDecl GP
-> ConDecl GP
h98ToGADTConDecl GenLocated SrcSpanAnnN RdrName
dataName LHsQTyVars GP
tyVars (forall {a}. a -> a
wrapCtxt Maybe (LHsContext GP)
dd_ctxt)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LConDecl GP]
dd_cons
                , dd_ctxt :: Maybe (LHsContext GP)
dd_ctxt = forall a. Maybe a
emptyCtxt -- Context can't appear at the data name in GADT
                , HsDeriving GP
Maybe (XRec GP (HsType GP))
Maybe (XRec GP CType)
NewOrData
XCHsDataDefn GP
dd_ND :: NewOrData
dd_cType :: Maybe (XRec GP CType)
dd_derivs :: HsDeriving GP
dd_ext :: XCHsDataDefn GP
dd_kindSig :: Maybe (XRec GP (HsType GP))
dd_derivs :: HsDeriving GP
dd_kindSig :: Maybe (XRec GP (HsType GP))
dd_cType :: Maybe (XRec GP CType)
dd_ND :: NewOrData
dd_ext :: XCHsDataDefn GP
..
                }
            HsDataDefn GP
x -> HsDataDefn GP
x

-- | Convert H98 data constuctor to GADT data constructor
h98ToGADTConDecl ::
    LIdP GP -- ^Type constuctor name,
            -- used for constucting final result type in GADT
    -> LHsQTyVars GP
            -- ^Type variable names
            -- used for constucting final result type in GADT
    -> Maybe (LHsContext GP)
            -- ^Data type context
    -> ConDecl GP
    -> ConDecl GP
h98ToGADTConDecl :: XRec GP (IdP GP)
-> LHsQTyVars GP
-> Maybe (LHsContext GP)
-> ConDecl GP
-> ConDecl GP
h98ToGADTConDecl XRec GP (IdP GP)
dataName LHsQTyVars GP
tyVars Maybe (LHsContext GP)
ctxt = \case
    ConDeclH98{Bool
[LHsTyVarBndr Specificity GP]
Maybe (LHsContext GP)
Maybe LHsDocString
HsConDeclH98Details GP
XRec GP (IdP GP)
XConDeclH98 GP
con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_doc :: forall pass. ConDecl pass -> Maybe LHsDocString
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
con_forall :: forall pass. ConDecl pass -> Bool
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_name :: forall pass. ConDecl pass -> LIdP pass
con_doc :: Maybe LHsDocString
con_args :: HsConDeclH98Details GP
con_mb_cxt :: Maybe (LHsContext GP)
con_ex_tvs :: [LHsTyVarBndr Specificity GP]
con_forall :: Bool
con_name :: XRec GP (IdP GP)
con_ext :: XConDeclH98 GP
..} ->
        forall pass.
XConDeclGADT pass
-> [LIdP pass]
-> XRec pass (HsOuterSigTyVarBndrs pass)
-> Maybe (LHsContext pass)
-> HsConDeclGADTDetails pass
-> LHsType pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclGADT
            XConDeclH98 GP
con_ext
            [XRec GP (IdP GP)
con_name]
#if !MIN_VERSION_ghc(9,2,1)
            con_forall
#endif
            -- Ignore all existential type variable since GADT not needed
            forall {flag}. GenLocated SrcSpanAnnA (HsOuterTyVarBndrs flag GP)
implicitTyVars
            (Maybe (LHsContext GP)
-> Maybe (LHsContext GP) -> Maybe (LHsContext GP)
mergeContext Maybe (LHsContext GP)
ctxt Maybe (LHsContext GP)
con_mb_cxt)
            (HsConDeclH98Details GP -> HsConDeclGADTDetails GP
renderDetails HsConDeclH98Details GP
con_args)
            XRec GP (HsType GP)
renderResultTy
            Maybe LHsDocString
con_doc
    ConDecl GP
x -> ConDecl GP
x
    where
        -- Parameters in the data constructor
#if MIN_VERSION_ghc(9,2,1)
        renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP
        renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP
renderDetails (PrefixCon [Void]
_ [HsScaled GP (XRec GP (HsType GP))]
args)   = forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT [HsScaled GP (XRec GP (HsType GP))]
args
        renderDetails (InfixCon HsScaled GP (XRec GP (HsType GP))
arg1 HsScaled GP (XRec GP (HsType GP))
arg2) = forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT [HsScaled GP (XRec GP (HsType GP))
arg1, HsScaled GP (XRec GP (HsType GP))
arg2]
        renderDetails (RecCon XRec GP [LConDeclField GP]
recs)        = forall pass.
XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass
RecConGADT XRec GP [LConDeclField GP]
recs
#else
        renderDetails (PrefixCon args)     = PrefixCon args
        renderDetails (InfixCon arg1 arg2) = PrefixCon [arg1, arg2]
        renderDetails (RecCon recs)        = RecCon recs
#endif

        -- | Construct GADT result type
        renderResultTy :: LHsType GP
        renderResultTy :: XRec GP (HsType GP)
renderResultTy = case LHsQTyVars GP
tyVars of
            -- Without type variable
            HsQTvs XHsQTvs GP
_ []   -> XRec GP (HsType GP)
wrappedDataName
            -- With type variable
            HsQTvs XHsQTvs GP
_ [LHsTyVarBndr () GP]
vars -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {pass} {an} {ann} {pass} {l} {flag}.
(Anno (HsType pass) ~ SrcSpanAnn' (EpAnn an),
 XTyVar pass ~ EpAnn ann, XAppTy pass ~ NoExtField,
 XRec pass (IdP pass) ~ XRec pass (IdP pass),
 XRec pass (HsType pass)
 ~ GenLocated (Anno (HsType pass)) (HsType pass)) =>
XRec pass (HsType pass)
-> GenLocated l (HsTyVarBndr flag pass)
-> GenLocated (Anno (HsType pass)) (HsType pass)
go XRec GP (HsType GP)
wrappedDataName [LHsTyVarBndr () GP]
vars
            LHsQTyVars GP
_             -> XRec GP (HsType GP)
wrappedDataName
            where
                wrappedDataName :: XRec GP (HsType GP)
wrappedDataName = forall a. WrapXRec GP a => a -> XRec GP a
wrap (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall {ann}. EpAnn ann
noUsed PromotionFlag
NotPromoted XRec GP (IdP GP)
dataName)

                -- Bundle data name with type vars by `HsAppTy`
                go :: XRec pass (HsType pass)
-> GenLocated l (HsTyVarBndr flag pass) -> XRec GP (HsType pass)
go XRec pass (HsType pass)
acc (L l
_(UserTyVar' XRec pass (IdP pass)
var)) =
                    forall a. WrapXRec GP a => a -> XRec GP a
wrap
                        (forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
noExtField XRec pass (HsType pass)
acc
                            (forall a. WrapXRec GP a => a -> XRec GP a
wrap (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall {ann}. EpAnn ann
noUsed PromotionFlag
NotPromoted XRec pass (IdP pass)
var)))
                go XRec pass (HsType pass)
acc GenLocated l (HsTyVarBndr flag pass)
_ = XRec pass (HsType pass)
acc

        -- Merge data type context and constructor type context
        mergeContext :: Maybe (LHsContext GP) -> Maybe (LHsContext GP) -> Maybe (LHsContext GP)
        mergeContext :: Maybe (LHsContext GP)
-> Maybe (LHsContext GP) -> Maybe (LHsContext GP)
mergeContext Maybe (LHsContext GP)
ctxt1 Maybe (LHsContext GP)
ctxt2 =
            (forall a. WrapXRec GP a => a -> XRec GP a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. WrapXRec GP a => a -> XRec GP a
wrap) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map HsType GP -> HsType GP
unParTy
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (LHsContext GP) -> Maybe [HsType GP]
getContextType Maybe (LHsContext GP)
ctxt1 forall a. Semigroup a => a -> a -> a
<> Maybe (LHsContext GP) -> Maybe [HsType GP]
getContextType Maybe (LHsContext GP)
ctxt2)
            where
                getContextType :: Maybe (LHsContext GP) -> Maybe [HsType GP]
                getContextType :: Maybe (LHsContext GP) -> Maybe [HsType GP]
getContextType Maybe (LHsContext GP)
ctxt = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. GenLocated (Anno a) a -> a
unWrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. GenLocated (Anno a) a -> a
unWrap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LHsContext GP)
ctxt

                -- Unparen the outmost, it only occurs at the outmost
                -- for a valid type.
                --
                -- Note for context paren rule:
                --
                -- If only one element, it __can__ have a paren type.
                -- If not, there can't have a parent type.
                unParTy :: HsType GP -> HsType GP
                unParTy :: HsType GP -> HsType GP
unParTy (HsParTy XParTy GP
_ XRec GP (HsType GP)
ty) = forall {a}. GenLocated (Anno a) a -> a
unWrap XRec GP (HsType GP)
ty
                unParTy HsType GP
x              = HsType GP
x
{- |
We use `printOutputable` to print H98 data decl as GADT syntax,
this print is not perfect, it will:

1. Make data name and the `where` key word in different lines.
2. Make the whole data decl prints in one line if there is only one data constructor.
3. The ident size of every data constructor depends on its origin
   format, and may have different ident size between constructors.

Hence, we first use `printOutputable` to get an initial GADT syntax,
then use `ghc-exactprint` to parse the initial result, and finally
adjust the details that mentioned above.

The adjustment includes:

1. Make the `where` key word at the same line of data name.
2. Remove the extra blank line caused by adjustment of `where`.
3. Make every data constructor start with a new line and 2 spaces
-}
prettyGADTDecl :: DynFlags -> TyClDecl GP -> Either String String
#if MIN_VERSION_ghc(9,2,1)
prettyGADTDecl :: DynFlags -> TyClDecl GP -> Either String String
prettyGADTDecl DynFlags
df TyClDecl GP
decl =
    let old :: Text
old = forall a. Outputable a => a -> Text
printOutputable TyClDecl GP
decl
        hsDecl :: ParseResult (LHsDecl GP)
hsDecl = Parser (LHsDecl GP)
parseDecl DynFlags
df String
"unused" (Text -> String
T.unpack Text
old)
        tycld :: Either String (TyClDecl GP)
tycld = Either ErrorMessages (GenLocated SrcSpanAnnA (HsDecl GP))
-> Either String (TyClDecl GP)
adjustTyClD ParseResult (LHsDecl GP)
hsDecl
    in String -> String
removeExtraEmptyLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ast. ExactPrint ast => ast -> String
exactPrint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String (TyClDecl GP)
tycld
    where
        adjustTyClD :: Either ErrorMessages (GenLocated SrcSpanAnnA (HsDecl GP))
-> Either String (TyClDecl GP)
adjustTyClD = \case
                Right (L SrcSpanAnnA
_ (TyClD XTyClD GP
_ TyClDecl GP
tycld)) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ TyClDecl GP -> TyClDecl GP
adjustDataDecl TyClDecl GP
tycld
                Right GenLocated SrcSpanAnnA (HsDecl GP)
x -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expect TyClD but got " forall a. Semigroup a => a -> a -> a
<> forall a. Data a => a -> String
showAst GenLocated SrcSpanAnnA (HsDecl GP)
x
                Left ErrorMessages
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ErrorMessages
err

        adjustDataDecl :: TyClDecl GP -> TyClDecl GP
adjustDataDecl DataDecl{HsDataDefn GP
LHsQTyVars GP
XRec GP (IdP GP)
XDataDecl GP
LexicalFixity
tcdDataDefn :: HsDataDefn GP
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars GP
tcdLName :: XRec GP (IdP GP)
tcdDExt :: XDataDecl GP
tcdDExt :: forall pass. TyClDecl pass -> XDataDecl pass
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
..} = DataDecl
            { tcdDExt :: XDataDecl GP
tcdDExt = forall {f :: * -> *}. Functor f => f [AddEpAnn] -> f [AddEpAnn]
adjustWhere XDataDecl GP
tcdDExt
            , tcdDataDefn :: HsDataDefn GP
tcdDataDefn = HsDataDefn GP
tcdDataDefn
                { dd_cons :: [LConDecl GP]
dd_cons = forall a b. (a -> b) -> [a] -> [b]
map LConDecl GP -> LConDecl GP
adjustCon (forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons HsDataDefn GP
tcdDataDefn)
                }
            , LHsQTyVars GP
XRec GP (IdP GP)
LexicalFixity
tcdFixity :: LexicalFixity
tcdTyVars :: LHsQTyVars GP
tcdLName :: XRec GP (IdP GP)
tcdFixity :: LexicalFixity
tcdLName :: XRec GP (IdP GP)
tcdTyVars :: LHsQTyVars GP
..
            }
        adjustDataDecl TyClDecl GP
x = TyClDecl GP
x

        -- Make every data constructor start with a new line and 2 spaces
        adjustCon :: LConDecl GP -> LConDecl GP
        adjustCon :: LConDecl GP -> LConDecl GP
adjustCon (L (SrcSpanAnn EpAnn AnnListItem
_ SrcSpan
loc) ConDecl GP
r) =
            forall l e. l -> e -> GenLocated l e
L (forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (Anchor -> Anchor
go (SrcSpan -> Anchor
spanAsAnchor SrcSpan
loc)) ([TrailingAnn] -> AnnListItem
AnnListItem []) ([LEpaComment] -> EpAnnComments
EpaComments [])) SrcSpan
loc) ConDecl GP
r
            where
                go :: Anchor -> Anchor
go (Anchor RealSrcSpan
a AnchorOperation
_) = RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
a (DeltaPos -> AnchorOperation
MovedAnchor (Int -> Int -> DeltaPos
DifferentLine Int
1 Int
2))

        -- Adjust where annotation to the same line of the type constuctor
        adjustWhere :: f [AddEpAnn] -> f [AddEpAnn]
adjustWhere f [AddEpAnn]
tcdDExt = f [AddEpAnn]
tcdDExt forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a b. (a -> b) -> [a] -> [b]
map
            (\(AddEpAnn AnnKeywordId
ann EpaLocation
l) ->
            if AnnKeywordId
ann forall a. Eq a => a -> a -> Bool
== AnnKeywordId
AnnWhere
                then AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnWhere (DeltaPos -> [LEpaComment] -> EpaLocation
EpaDelta (Int -> DeltaPos
SameLine Int
1) [])
                else AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
ann EpaLocation
l
            )

        -- Remove the first extra line if exist
        removeExtraEmptyLine :: String -> String
removeExtraEmptyLine String
s = case forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix String
"\n\n" String
s of
            Just (String
x, String
xs) -> String
x forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<> String
xs
            Maybe (String, String)
Nothing      -> String
s
#else
prettyGADTDecl df decl =
    let old = printOutputable decl
        hsDecl = parseDecl df "unused" (T.unpack old)
        tycld = adjustTyClD hsDecl
    in removeExtraEmptyLine . uncurry (flip exactPrint) <$> tycld
    where
        adjustTyClD = \case
                Right (anns, t@(L _ (TyClD _ _))) -> Right (adjustDataDeclAnns anns, t)
                Right _ -> Left "Expect TyClD"
                Left err -> Left $ show err

        adjustDataDeclAnns = Map.mapWithKey go
            where
                isDataDeclAnn (AnnKey _ (CN name)) = name == "DataDecl"
                isConDeclGADTAnn (AnnKey _ (CN name)) = name == "ConDeclGADT"

                go key ann
                    | isDataDeclAnn key = adjustWhere ann
                    | isConDeclGADTAnn key = adjustCon ann
                    | otherwise = ann

                -- Adjust where annotation to the same line of the type constuctor
                adjustWhere Ann{..} = Ann
                    { annsDP = annsDP <&>
                        (\(keyword, dp) ->
                            if keyword == G AnnWhere
                                then (keyword, DP (0, 1))
                                else (keyword, dp))
                    , ..
                    }

                -- Make every data constructor start with a new line and 2 spaces
                --
                -- Here we can't force every GADT constuctor has (1, 2)
                -- delta. For the first constructor with (1, 2), it prints
                -- a new line with 2 spaces, but for other constructors
                -- with (1, 2), it will print a new line with 4 spaces.
                --
                -- The original ann parsed with `praseDecl` shows the first
                -- constructor has (1, 4) delta, but others have (1, 0).
                -- Hence, the following code only deal with the first
                -- constructor.
                adjustCon Ann{..} = let c = deltaColumn annEntryDelta
                    in Ann
                    { annEntryDelta = DP $ (1,) $ if c > 0 then 2 else 0
                    , ..
                    }

        -- Remove the first extra line if exist
        removeExtraEmptyLine s = case stripInfix "\n\n" s of
            Just (x, xs) -> x <> "\n" <> xs
            Nothing      -> s

#endif

#if MIN_VERSION_ghc(9,2,1)
wrap :: forall a. WrapXRec GP a => a -> XRec GP a
wrap :: forall a. WrapXRec GP a => a -> XRec GP a
wrap = forall p a. WrapXRec p a => a -> XRec p a
wrapXRec @GP
wrapCtxt :: a -> a
wrapCtxt = forall {a}. a -> a
id
emptyCtxt :: Maybe a
emptyCtxt = forall a. Maybe a
Nothing
unWrap :: XRec GP a -> a
unWrap = forall p a. UnXRec p => XRec p a -> a
unXRec @GP
mapX :: (ConDecl GP -> ConDecl GP) -> LConDecl GP -> LConDecl GP
mapX = forall p a b.
(MapXRec p, Anno a ~ Anno b) =>
(a -> b) -> XRec p a -> XRec p b
mapXRec @GP
noUsed :: EpAnn ann
noUsed = forall {ann}. EpAnn ann
EpAnnNotUsed
#else
wrapCtxt = Just
wrap = L noSrcSpan
emptyCtxt = wrap []
unWrap (L _ r) = r
mapX = fmap
noUsed = noExtField
#endif

#if MIN_VERSION_ghc(9,0,1)
pattern UserTyVar' :: LIdP pass -> HsTyVarBndr flag pass
pattern $mUserTyVar' :: forall {r} {pass} {flag}.
HsTyVarBndr flag pass -> (LIdP pass -> r) -> ((# #) -> r) -> r
UserTyVar' s <- UserTyVar _ _ s
#else
pattern UserTyVar' :: LIdP pass -> HsTyVarBndr pass
pattern UserTyVar' s <- UserTyVar _ s
#endif

#if MIN_VERSION_ghc(9,2,1)
implicitTyVars :: XRec GP (HsOuterTyVarBndrs flag GP)
implicitTyVars = (forall p a. WrapXRec p a => a -> XRec p a
wrapXRec @GP forall flag. HsOuterTyVarBndrs flag GP
mkHsOuterImplicit)
#elif MIN_VERSION_ghc(9,0,1)
implicitTyVars = []
#else
implicitTyVars = HsQTvs noExtField []
#endif