{-# LANGUAGE CPP             #-}
{-# LANGUAGE GADTs           #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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           GHC.Parser.Annotation                   (AddEpAnn (..),
                                                          Anchor (Anchor),
                                                          AnchorOperation (MovedAnchor),
                                                          DeltaPos (..),
                                                          EpAnn (..),
                                                          EpAnnComments (EpaComments),
                                                          EpaLocation (EpaDelta),
                                                          SrcSpanAnn' (SrcSpanAnn),
                                                          spanAsAnchor)
import           Ide.PluginUtils                         (subRange)
import           Language.Haskell.GHC.ExactPrint         (showAst)
import           Language.Haskell.GHC.ExactPrint.Parsers (parseDecl)

#if MIN_VERSION_ghc(9,5,0)
import qualified Data.List.NonEmpty                      as NE
import           GHC.Parser.Annotation                   (TokenLocation (..))
#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 = Bool -> (Range -> Bool) -> Maybe Range -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Range -> Range -> Bool
subRange Range
range) (SrcSpan -> Maybe Range
srcSpanToRange (a -> SrcSpan
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{})) = GenLocated SrcSpanAnnA (TyClDecl GP)
-> Maybe (GenLocated SrcSpanAnnA (TyClDecl GP))
forall a. a -> Maybe a
Just (SrcSpanAnnA -> TyClDecl GP -> GenLocated SrcSpanAnnA (TyClDecl GP)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l TyClDecl GP
d)
getDataDecl LHsDecl GP
_                            = Maybe (LTyClDecl GP)
Maybe (GenLocated SrcSpanAnnA (TyClDecl 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{}) =
    (GenLocated SrcSpanAnnA (ConDecl GP) -> Bool)
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GP)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ConDecl GP -> Bool
isConDeclH98 (ConDecl GP -> Bool)
-> (GenLocated SrcSpanAnnA (ConDecl GP) -> ConDecl GP)
-> GenLocated SrcSpanAnnA (ConDecl GP)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(L SrcSpanAnnA
_ ConDecl GP
r) -> ConDecl GP
r)) (HsDataDefn GP -> DataDefnCons (LConDecl GP)
forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons (HsDataDefn GP -> DataDefnCons (LConDecl GP))
-> HsDataDefn GP -> DataDefnCons (LConDecl GP)
forall a b. (a -> b) -> a -> b
$ TyClDecl GP -> HsDataDefn GP
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{XDataDecl GP
XRec GP (IdP GP)
LexicalFixity
LHsQTyVars GP
HsDataDefn GP
tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDExt :: XDataDecl GP
tcdLName :: XRec GP (IdP GP)
tcdTyVars :: LHsQTyVars GP
tcdFixity :: LexicalFixity
tcdDataDefn :: HsDataDefn GP
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdDExt :: forall pass. TyClDecl pass -> XDataDecl pass
..} -> DataDecl
        { tcdDataDefn :: HsDataDefn GP
tcdDataDefn = GenLocated SrcSpanAnnN RdrName
-> LHsQTyVars GP -> HsDataDefn GP -> HsDataDefn GP
updateDefn XRec GP (IdP GP)
GenLocated SrcSpanAnnN RdrName
tcdLName LHsQTyVars GP
tcdTyVars HsDataDefn GP
tcdDataDefn
        , XDataDecl GP
XRec GP (IdP GP)
LexicalFixity
LHsQTyVars GP
tcdDExt :: XDataDecl GP
tcdLName :: XRec GP (IdP GP)
tcdTyVars :: LHsQTyVars GP
tcdFixity :: LexicalFixity
tcdLName :: XRec GP (IdP GP)
tcdTyVars :: LHsQTyVars GP
tcdFixity :: LexicalFixity
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
Maybe (LHsContext GP)
Maybe (XRec GP CType)
Maybe (XRec GP (HsType GP))
XCHsDataDefn GP
DataDefnCons (LConDecl GP)
dd_cons :: forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_ext :: XCHsDataDefn GP
dd_ctxt :: Maybe (LHsContext GP)
dd_cType :: Maybe (XRec GP CType)
dd_kindSig :: Maybe (XRec GP (HsType GP))
dd_cons :: DataDefnCons (LConDecl GP)
dd_derivs :: HsDeriving GP
dd_ext :: forall pass. HsDataDefn pass -> XCHsDataDefn pass
dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
..} -> HsDataDefn
                { dd_cons :: DataDefnCons (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 XRec GP (IdP GP)
GenLocated SrcSpanAnnN RdrName
dataName LHsQTyVars GP
tyVars (Maybe
  (GenLocated
     (SrcSpanAnn' (EpAnn AnnContext))
     [GenLocated SrcSpanAnnA (HsType GP)])
-> Maybe
     (GenLocated
        (SrcSpanAnn' (EpAnn AnnContext))
        [GenLocated SrcSpanAnnA (HsType GP)])
forall {a}. a -> a
wrapCtxt Maybe (LHsContext GP)
Maybe
  (GenLocated
     (SrcSpanAnn' (EpAnn AnnContext))
     [GenLocated SrcSpanAnnA (HsType GP)])
dd_ctxt)) (GenLocated SrcSpanAnnA (ConDecl GP)
 -> GenLocated SrcSpanAnnA (ConDecl GP))
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GP))
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GP))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DataDefnCons (LConDecl GP)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GP))
dd_cons
                , dd_ctxt :: Maybe (LHsContext GP)
dd_ctxt = Maybe (LHsContext GP)
Maybe
  (GenLocated
     (SrcSpanAnn' (EpAnn AnnContext))
     [GenLocated SrcSpanAnnA (HsType GP)])
forall a. Maybe a
emptyCtxt -- Context can't appear at the data name in GADT
                , HsDeriving GP
Maybe (XRec GP CType)
Maybe (XRec GP (HsType GP))
XCHsDataDefn GP
dd_ext :: XCHsDataDefn GP
dd_cType :: Maybe (XRec GP CType)
dd_kindSig :: Maybe (XRec GP (HsType GP))
dd_derivs :: HsDeriving GP
dd_ext :: XCHsDataDefn GP
dd_cType :: Maybe (XRec GP CType)
dd_kindSig :: Maybe (XRec GP (HsType GP))
dd_derivs :: HsDeriving GP
..
                }
            HsDataDefn GP
x -> HsDataDefn GP
x

-- | Convert H98 data constructor to GADT data constructor
h98ToGADTConDecl ::
    LIdP GP -- ^Type constructor name,
            -- used for constructing final result type in GADT
    -> LHsQTyVars GP
            -- ^Type variable names
            -- used for constructing 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 (LHsDoc GP)
XConDeclH98 GP
XRec GP (IdP GP)
HsConDeclH98Details GP
con_ext :: XConDeclH98 GP
con_name :: XRec GP (IdP GP)
con_forall :: Bool
con_ex_tvs :: [LHsTyVarBndr Specificity GP]
con_mb_cxt :: Maybe (LHsContext GP)
con_args :: HsConDeclH98Details GP
con_doc :: Maybe (LHsDoc GP)
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
con_name :: forall pass. ConDecl pass -> LIdP pass
con_forall :: forall pass. ConDecl pass -> Bool
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
..} ->
        XConDeclGADT GP
-> NonEmpty (XRec GP (IdP GP))
-> LHsUniToken "::" "\8759" GP
-> XRec GP (HsOuterSigTyVarBndrs GP)
-> Maybe (LHsContext GP)
-> HsConDeclGADTDetails GP
-> XRec GP (HsType GP)
-> Maybe (LHsDoc GP)
-> ConDecl GP
forall pass.
XConDeclGADT pass
-> NonEmpty (LIdP pass)
-> LHsUniToken "::" "\8759" pass
-> XRec pass (HsOuterSigTyVarBndrs pass)
-> Maybe (LHsContext pass)
-> HsConDeclGADTDetails pass
-> LHsType pass
-> Maybe (LHsDoc pass)
-> ConDecl pass
ConDeclGADT
            XConDeclH98 GP
XConDeclGADT GP
con_ext
#if MIN_VERSION_ghc(9,5,0)
            (GenLocated SrcSpanAnnN RdrName
-> NonEmpty (GenLocated SrcSpanAnnN RdrName)
forall a. a -> NonEmpty a
NE.singleton XRec GP (IdP GP)
GenLocated SrcSpanAnnN RdrName
con_name)
#else
            [con_name]
#endif

#if MIN_VERSION_ghc(9,5,0)
            (TokenLocation
-> HsUniToken "::" "\8759"
-> GenLocated TokenLocation (HsUniToken "::" "\8759")
forall l e. l -> e -> GenLocated l e
L TokenLocation
NoTokenLoc HsUniToken "::" "\8759"
forall (tok :: Symbol) (utok :: Symbol). HsUniToken tok utok
HsNormalTok)
#endif
            -- Ignore all existential type variable since GADT not needed
            XRec GP (HsOuterSigTyVarBndrs GP)
GenLocated SrcSpanAnnA (HsOuterSigTyVarBndrs GP)
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 (LHsDoc GP)
con_doc
    ConDecl GP
x -> ConDecl GP
x
    where
        -- Parameters in the data constructor
        renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP
        renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP
renderDetails (PrefixCon [Void]
_ [HsScaled GP (XRec GP (HsType GP))]
args)   = [HsScaled GP (XRec GP (HsType GP))] -> HsConDeclGADTDetails GP
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) = [HsScaled GP (XRec GP (HsType GP))] -> HsConDeclGADTDetails GP
forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT [HsScaled GP (XRec GP (HsType GP))
arg1, HsScaled GP (XRec GP (HsType GP))
arg2]
#if MIN_VERSION_ghc(9,3,0)
        renderDetails (RecCon XRec GP [LConDeclField GP]
recs)        = XRec GP [LConDeclField GP]
-> LHsUniToken "->" "\8594" GP -> HsConDeclGADTDetails GP
forall pass.
XRec pass [LConDeclField pass]
-> LHsUniToken "->" "\8594" pass -> HsConDeclGADTDetails pass
RecConGADT XRec GP [LConDeclField GP]
recs LHsUniToken "->" "\8594" GP
GenLocated TokenLocation (HsUniToken "->" "\8594")
forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok
#else
        renderDetails (RecCon recs)        = RecConGADT 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 -> (GenLocated SrcSpanAnnA (HsType GP)
 -> GenLocated SrcSpanAnnA (HsTyVarBndr () GP)
 -> GenLocated SrcSpanAnnA (HsType GP))
-> GenLocated SrcSpanAnnA (HsType GP)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GP)]
-> GenLocated SrcSpanAnnA (HsType GP)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl XRec GP (HsType GP)
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GP)
-> GenLocated (Anno (HsType GP)) (HsType GP)
GenLocated SrcSpanAnnA (HsType GP)
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GP)
-> GenLocated SrcSpanAnnA (HsType GP)
forall {pass} {pass} {ann} {an} {l} {flag}.
(XAppTy pass ~ NoExtField, IdP pass ~ IdP pass,
 XTyVar pass ~ EpAnn ann,
 Anno (HsType pass) ~ SrcSpanAnn' (EpAnn an),
 XRec pass (IdP pass) ~ XRec pass (IdP pass),
 XRec pass (HsType pass)
 ~ GenLocated (SrcSpanAnn' (EpAnn an)) (HsType pass)) =>
XRec pass (HsType pass)
-> GenLocated l (HsTyVarBndr flag pass)
-> GenLocated (Anno (HsType pass)) (HsType pass)
go XRec GP (HsType GP)
GenLocated SrcSpanAnnA (HsType GP)
wrappedDataName [LHsTyVarBndr () GP]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GP)]
vars
            LHsQTyVars GP
_             -> XRec GP (HsType GP)
wrappedDataName
            where
                wrappedDataName :: XRec GP (HsType GP)
wrappedDataName = HsType GP -> XRec GP (HsType GP)
forall a. WrapXRec GP a => a -> XRec GP a
wrap (XTyVar GP -> PromotionFlag -> XRec GP (IdP GP) -> HsType GP
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GP
EpAnn [AddEpAnn]
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' LIdP pass
var)) =
                    HsType pass -> XRec GP (HsType pass)
forall a. WrapXRec GP a => a -> XRec GP a
wrap
                        (XAppTy pass
-> XRec pass (HsType pass)
-> XRec pass (HsType pass)
-> HsType pass
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy pass
NoExtField
noExtField XRec pass (HsType pass)
acc
                            (HsType pass -> XRec GP (HsType pass)
forall a. WrapXRec GP a => a -> XRec GP a
wrap (XTyVar pass -> PromotionFlag -> XRec pass (IdP pass) -> HsType pass
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar pass
EpAnn ann
forall {ann}. EpAnn ann
noUsed PromotionFlag
NotPromoted LIdP pass
XRec pass (IdP pass)
var)))
                go XRec pass (HsType pass)
acc GenLocated l (HsTyVarBndr flag pass)
_ = XRec pass (HsType pass)
XRec GP (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 =
            ([GenLocated SrcSpanAnnA (HsType GP)]
-> XRec GP [GenLocated SrcSpanAnnA (HsType GP)]
[GenLocated SrcSpanAnnA (HsType GP)]
-> GenLocated
     (SrcSpanAnn' (EpAnn AnnContext))
     [GenLocated SrcSpanAnnA (HsType GP)]
forall a. WrapXRec GP a => a -> XRec GP a
wrap ([GenLocated SrcSpanAnnA (HsType GP)]
 -> GenLocated
      (SrcSpanAnn' (EpAnn AnnContext))
      [GenLocated SrcSpanAnnA (HsType GP)])
-> ([HsType GP] -> [GenLocated SrcSpanAnnA (HsType GP)])
-> [HsType GP]
-> GenLocated
     (SrcSpanAnn' (EpAnn AnnContext))
     [GenLocated SrcSpanAnnA (HsType GP)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType GP -> GenLocated SrcSpanAnnA (HsType GP))
-> [HsType GP] -> [GenLocated SrcSpanAnnA (HsType GP)]
forall a b. (a -> b) -> [a] -> [b]
map HsType GP -> XRec GP (HsType GP)
HsType GP -> GenLocated SrcSpanAnnA (HsType GP)
forall a. WrapXRec GP a => a -> XRec GP a
wrap) ([HsType GP]
 -> GenLocated
      (SrcSpanAnn' (EpAnn AnnContext))
      [GenLocated SrcSpanAnnA (HsType GP)])
-> ([HsType GP] -> [HsType GP])
-> [HsType GP]
-> GenLocated
     (SrcSpanAnn' (EpAnn AnnContext))
     [GenLocated SrcSpanAnnA (HsType GP)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType GP -> HsType GP) -> [HsType GP] -> [HsType GP]
forall a b. (a -> b) -> [a] -> [b]
map HsType GP -> HsType GP
unParTy
                ([HsType GP]
 -> GenLocated
      (SrcSpanAnn' (EpAnn AnnContext))
      [GenLocated SrcSpanAnnA (HsType GP)])
-> Maybe [HsType GP]
-> Maybe
     (GenLocated
        (SrcSpanAnn' (EpAnn AnnContext))
        [GenLocated SrcSpanAnnA (HsType GP)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (LHsContext GP) -> Maybe [HsType GP]
getContextType Maybe (LHsContext GP)
ctxt1 Maybe [HsType GP] -> Maybe [HsType GP] -> Maybe [HsType GP]
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 = (GenLocated SrcSpanAnnA (HsType GP) -> HsType GP)
-> [GenLocated SrcSpanAnnA (HsType GP)] -> [HsType GP]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated (Anno (HsType GP)) (HsType GP) -> HsType GP
GenLocated SrcSpanAnnA (HsType GP) -> HsType GP
forall {a}. GenLocated (Anno a) a -> a
unWrap ([GenLocated SrcSpanAnnA (HsType GP)] -> [HsType GP])
-> (GenLocated
      (SrcSpanAnn' (EpAnn AnnContext))
      [GenLocated SrcSpanAnnA (HsType GP)]
    -> [GenLocated SrcSpanAnnA (HsType GP)])
-> GenLocated
     (SrcSpanAnn' (EpAnn AnnContext))
     [GenLocated SrcSpanAnnA (HsType GP)]
-> [HsType GP]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  (Anno [GenLocated SrcSpanAnnA (HsType GP)])
  [GenLocated SrcSpanAnnA (HsType GP)]
-> [GenLocated SrcSpanAnnA (HsType GP)]
GenLocated
  (SrcSpanAnn' (EpAnn AnnContext))
  [GenLocated SrcSpanAnnA (HsType GP)]
-> [GenLocated SrcSpanAnnA (HsType GP)]
forall {a}. GenLocated (Anno a) a -> a
unWrap (GenLocated
   (SrcSpanAnn' (EpAnn AnnContext))
   [GenLocated SrcSpanAnnA (HsType GP)]
 -> [HsType GP])
-> Maybe
     (GenLocated
        (SrcSpanAnn' (EpAnn AnnContext))
        [GenLocated SrcSpanAnnA (HsType GP)])
-> Maybe [HsType GP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LHsContext GP)
Maybe
  (GenLocated
     (SrcSpanAnn' (EpAnn AnnContext))
     [GenLocated SrcSpanAnnA (HsType 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) = GenLocated (Anno (HsType GP)) (HsType GP) -> HsType GP
forall {a}. GenLocated (Anno a) a -> a
unWrap XRec GP (HsType GP)
GenLocated (Anno (HsType 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
prettyGADTDecl :: DynFlags -> TyClDecl GP -> Either String String
prettyGADTDecl DynFlags
df TyClDecl GP
decl =
    let old :: Text
old = TyClDecl GP -> Text
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)
Either ErrorMessages (GenLocated SrcSpanAnnA (HsDecl GP))
hsDecl
    in String -> String
removeExtraEmptyLine (String -> String)
-> (TyClDecl GP -> String) -> TyClDecl GP -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GP -> String
forall ast. ExactPrint ast => ast -> String
exactPrint (TyClDecl GP -> String)
-> Either String (TyClDecl GP) -> Either String String
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)) -> TyClDecl GP -> Either String (TyClDecl GP)
forall a b. b -> Either a b
Right (TyClDecl GP -> Either String (TyClDecl GP))
-> TyClDecl GP -> Either String (TyClDecl GP)
forall a b. (a -> b) -> a -> b
$ TyClDecl GP -> TyClDecl GP
adjustDataDecl TyClDecl GP
tycld
                Right GenLocated SrcSpanAnnA (HsDecl GP)
x -> String -> Either String (TyClDecl GP)
forall a b. a -> Either a b
Left (String -> Either String (TyClDecl GP))
-> String -> Either String (TyClDecl GP)
forall a b. (a -> b) -> a -> b
$ String
"Expect TyClD but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> GenLocated SrcSpanAnnA (HsDecl GP) -> String
forall a. Data a => a -> String
showAst GenLocated SrcSpanAnnA (HsDecl GP)
x
#if MIN_VERSION_ghc(9,3,0)
                Left ErrorMessages
err -> String -> Either String (TyClDecl GP)
forall a b. a -> Either a b
Left (String -> Either String (TyClDecl GP))
-> String -> Either String (TyClDecl GP)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> String
forall a. Outputable a => a -> String
printWithoutUniques ErrorMessages
err
#else
                Left err -> Left $ show err
#endif

        adjustDataDecl :: TyClDecl GP -> TyClDecl GP
adjustDataDecl DataDecl{XDataDecl GP
XRec GP (IdP GP)
LexicalFixity
LHsQTyVars GP
HsDataDefn GP
tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdDExt :: forall pass. TyClDecl pass -> XDataDecl pass
tcdDExt :: XDataDecl GP
tcdLName :: XRec GP (IdP GP)
tcdTyVars :: LHsQTyVars GP
tcdFixity :: LexicalFixity
tcdDataDefn :: HsDataDefn GP
..} = DataDecl
            { tcdDExt :: XDataDecl GP
tcdDExt = EpAnn [AddEpAnn] -> EpAnn [AddEpAnn]
forall {f :: * -> *}. Functor f => f [AddEpAnn] -> f [AddEpAnn]
adjustWhere XDataDecl GP
EpAnn [AddEpAnn]
tcdDExt
            , tcdDataDefn :: HsDataDefn GP
tcdDataDefn = HsDataDefn GP
tcdDataDefn
                { dd_cons =
                      fmap adjustCon (dd_cons tcdDataDefn)
                }
            , XRec GP (IdP GP)
LexicalFixity
LHsQTyVars GP
tcdLName :: XRec GP (IdP GP)
tcdTyVars :: LHsQTyVars GP
tcdFixity :: LexicalFixity
tcdLName :: XRec GP (IdP GP)
tcdTyVars :: LHsQTyVars GP
tcdFixity :: LexicalFixity
..
            }
        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) =
            SrcSpanAnnA -> ConDecl GP -> GenLocated SrcSpanAnnA (ConDecl GP)
forall l e. l -> e -> GenLocated l e
L (EpAnn AnnListItem -> SrcSpan -> SrcSpanAnnA
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (Anchor -> AnnListItem -> EpAnnComments -> EpAnn AnnListItem
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 constructor
        adjustWhere :: f [AddEpAnn] -> f [AddEpAnn]
adjustWhere f [AddEpAnn]
tcdDExt = f [AddEpAnn]
tcdDExt f [AddEpAnn] -> ([AddEpAnn] -> [AddEpAnn]) -> f [AddEpAnn]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (AddEpAnn -> AddEpAnn) -> [AddEpAnn] -> [AddEpAnn]
forall a b. (a -> b) -> [a] -> [b]
map
            (\(AddEpAnn AnnKeywordId
ann EpaLocation
l) ->
            if AnnKeywordId
ann AnnKeywordId -> AnnKeywordId -> Bool
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 String -> String -> Maybe (String, String)
forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix String
"\n\n" String
s of
            Just (String
x, String
xs) -> String
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
xs
            Maybe (String, String)
Nothing      -> String
s

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 = a -> a
forall {a}. a -> a
id
emptyCtxt :: Maybe a
emptyCtxt = Maybe a
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 = EpAnn ann
forall {ann}. EpAnn ann
EpAnnNotUsed

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

implicitTyVars :: XRec GP (HsOuterTyVarBndrs flag GP)
implicitTyVars = forall p a. WrapXRec p a => a -> XRec p a
wrapXRec @GP HsOuterTyVarBndrs flag GP
forall flag. HsOuterTyVarBndrs flag GP
mkHsOuterImplicit