-- Copyright 2019 Google LLC
--
-- Use of this source code is governed by a BSD-style
-- license that can be found in the LICENSE file or at
-- https://developers.google.com/open-source/licenses/bsd

{-# LANGUAGE CPP #-}
-- | This module provides combinators for constructing Haskell patterns.
module GHC.SourceGen.Pat
    ( Pat'
    , wildP
    , asP
    , conP
    , conP_
    , recordConP
    , strictP
    , lazyP
    , sigP
    ) where

import GHC.Hs.Type
import GHC.Hs.Pat hiding (LHsRecField')

import GHC.SourceGen.Name.Internal
import GHC.SourceGen.Pat.Internal
import GHC.SourceGen.Syntax.Internal
import GHC.SourceGen.Type.Internal (patSigType)

#if MIN_VERSION_ghc(9,2,0)
import GHC.Parser.Annotation (EpAnn(..))
#endif
#if MIN_VERSION_ghc(9,6,0)
import GHC (noHsTok)
#endif

-- | A wild pattern (@_@).
wildP :: Pat'
wildP :: Pat'
wildP = (NoExtField -> Pat') -> Pat'
forall a. (NoExtField -> a) -> a
noExtOrPlaceHolder XWildPat GhcPs -> Pat'
NoExtField -> Pat'
forall p. XWildPat p -> Pat p
WildPat

-- | An as-pattern.
--
-- > a@B
-- > =====
-- > asP "a" (var "B")
asP :: RdrNameStr -> Pat' -> Pat'
RdrNameStr
v asP :: RdrNameStr -> Pat' -> Pat'
`asP` Pat'
p =
  (EpAnn NoEpAnns
 -> LocatedN RdrName
 -> GenLocated TokenLocation (HsToken "@")
 -> GenLocated SrcSpanAnnA Pat'
 -> Pat')
-> LocatedN RdrName
-> GenLocated TokenLocation (HsToken "@")
-> GenLocated SrcSpanAnnA Pat'
-> Pat'
forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed XAsPat GhcPs
-> LIdP GhcPs -> LHsToken "@" GhcPs -> LPat GhcPs -> Pat'
EpAnn NoEpAnns
-> LocatedN RdrName
-> GenLocated TokenLocation (HsToken "@")
-> GenLocated SrcSpanAnnA Pat'
-> Pat'
forall p. XAsPat p -> LIdP p -> LHsToken "@" p -> LPat p -> Pat p
AsPat (RdrNameStr -> LocatedN RdrName
valueRdrName RdrNameStr
v)
#if MIN_VERSION_ghc(9,6,0)
  GenLocated TokenLocation (HsToken "@")
forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok
#endif
  (Pat' -> LPat GhcPs
builtPat (Pat' -> LPat GhcPs) -> Pat' -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ Pat' -> Pat'
parenthesize Pat'
p)

-- | A pattern constructor.
--
-- > A b c
-- > =====
-- > conP "A" [bvar "b", bvar "c"]
conP :: RdrNameStr -> [Pat'] -> Pat'
conP :: RdrNameStr -> [Pat'] -> Pat'
conP RdrNameStr
c = XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat'
conPat (RdrNameStr -> LocatedN RdrName
valueRdrName RdrNameStr
c) (HsConDetails
   (HsConPatTyArg GhcPs)
   (GenLocated SrcSpanAnnA Pat')
   (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat'))
 -> Pat')
-> ([Pat']
    -> HsConDetails
         (HsConPatTyArg GhcPs)
         (GenLocated SrcSpanAnnA Pat')
         (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat')))
-> [Pat']
-> Pat'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenLocated SrcSpanAnnA Pat']
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA Pat')
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat'))
forall {arg} {tyarg} {rec}. [arg] -> HsConDetails tyarg arg rec
prefixCon ([GenLocated SrcSpanAnnA Pat']
 -> HsConDetails
      (HsConPatTyArg GhcPs)
      (GenLocated SrcSpanAnnA Pat')
      (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat')))
-> ([Pat'] -> [GenLocated SrcSpanAnnA Pat'])
-> [Pat']
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA Pat')
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat'))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pat' -> GenLocated SrcSpanAnnA Pat')
-> [Pat'] -> [GenLocated SrcSpanAnnA Pat']
forall a b. (a -> b) -> [a] -> [b]
map (Pat' -> LPat GhcPs
Pat' -> GenLocated SrcSpanAnnA Pat'
builtPat (Pat' -> GenLocated SrcSpanAnnA Pat')
-> (Pat' -> Pat') -> Pat' -> GenLocated SrcSpanAnnA Pat'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat' -> Pat'
parenthesize)
  where
#if MIN_VERSION_ghc(9,0,0)
    conPat :: XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat'
conPat = (EpAnn [AddEpAnn]
 -> XRec GhcPs (ConLikeP GhcPs)
 -> HsConDetails
      (HsConPatTyArg (NoGhcTc GhcPs))
      (LPat GhcPs)
      (HsRecFields GhcPs (LPat GhcPs))
 -> Pat')
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat'
forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat'
EpAnn [AddEpAnn]
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat'
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
#else
    conPat = ConPatIn
#endif
#if MIN_VERSION_ghc(9,2,0)
    prefixCon :: [arg] -> HsConDetails tyarg arg rec
prefixCon = [tyarg] -> [arg] -> HsConDetails tyarg arg rec
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon []
#else
    prefixCon = PrefixCon
#endif

-- | A pattern constructor with no arguments.
--
-- > A
-- > =====
-- > conP_ "A"
conP_ :: RdrNameStr -> Pat'
conP_ :: RdrNameStr -> Pat'
conP_ RdrNameStr
c = RdrNameStr -> [Pat'] -> Pat'
conP RdrNameStr
c []

recordConP :: RdrNameStr -> [(RdrNameStr, Pat')] -> Pat'
recordConP :: RdrNameStr -> [(RdrNameStr, Pat')] -> Pat'
recordConP RdrNameStr
c [(RdrNameStr, Pat')]
fs =
#if MIN_VERSION_ghc(9,0,0)
  (EpAnn [AddEpAnn]
 -> LocatedN RdrName
 -> HsConDetails
      (HsConPatTyArg GhcPs)
      (GenLocated SrcSpanAnnA Pat')
      (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat'))
 -> Pat')
-> LocatedN RdrName
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA Pat')
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat'))
-> Pat'
forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed XConPat GhcPs
-> XRec GhcPs (ConLikeP GhcPs)
-> HsConDetails
     (HsConPatTyArg (NoGhcTc GhcPs))
     (LPat GhcPs)
     (HsRecFields GhcPs (LPat GhcPs))
-> Pat'
EpAnn [AddEpAnn]
-> LocatedN RdrName
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA Pat')
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat'))
-> Pat'
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
#else
  ConPatIn
#endif
  (RdrNameStr -> LocatedN RdrName
valueRdrName RdrNameStr
c)
        (HsConDetails
   (HsConPatTyArg GhcPs)
   (GenLocated SrcSpanAnnA Pat')
   (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat'))
 -> Pat')
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA Pat')
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat'))
-> Pat'
forall a b. (a -> b) -> a -> b
$ HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat')
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA Pat')
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat'))
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat')
 -> HsConDetails
      (HsConPatTyArg GhcPs)
      (GenLocated SrcSpanAnnA Pat')
      (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat')))
-> HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat')
-> HsConDetails
     (HsConPatTyArg GhcPs)
     (GenLocated SrcSpanAnnA Pat')
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat'))
forall a b. (a -> b) -> a -> b
$ [LHsRecField GhcPs (GenLocated SrcSpanAnnA Pat')]
-> Maybe (XRec GhcPs RecFieldsDotDot)
-> HsRecFields GhcPs (GenLocated SrcSpanAnnA Pat')
forall p arg.
[LHsRecField p arg]
-> Maybe (XRec p RecFieldsDotDot) -> HsRecFields p arg
HsRecFields (((RdrNameStr, Pat')
 -> GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA Pat')))
-> [(RdrNameStr, Pat')]
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA Pat'))]
forall a b. (a -> b) -> [a] -> [b]
map (RdrNameStr, Pat') -> LHsRecField' (LPat GhcPs)
(RdrNameStr, Pat')
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
        (GenLocated SrcSpanAnnA Pat'))
mkRecField [(RdrNameStr, Pat')]
fs) Maybe (XRec GhcPs RecFieldsDotDot)
Maybe (GenLocated SrcSpan RecFieldsDotDot)
forall a. Maybe a
Nothing -- No ".."
  where
    mkRecField :: (RdrNameStr, Pat') -> LHsRecField' LPat'
    mkRecField :: (RdrNameStr, Pat') -> LHsRecField' (LPat GhcPs)
mkRecField (RdrNameStr
f, Pat'
p) =
#if MIN_VERSION_ghc(9,4,0)
        HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
  (GenLocated SrcSpanAnnA Pat')
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
        (GenLocated SrcSpanAnnA Pat'))
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated (HsFieldBind
   (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
   (GenLocated SrcSpanAnnA Pat')
 -> GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA Pat')))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
     (GenLocated SrcSpanAnnA Pat')
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
        (GenLocated SrcSpanAnnA Pat'))
forall a b. (a -> b) -> a -> b
$ HsFieldBind
            { hfbAnn :: XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
hfbAnn = XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
EpAnn [AddEpAnn]
forall ann. EpAnn ann
EpAnnNotUsed
            , hfbLHS :: GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)
hfbLHS = FieldOcc GhcPs -> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated (FieldOcc GhcPs -> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
-> FieldOcc GhcPs -> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)
forall a b. (a -> b) -> a -> b
$ FieldOcc GhcPs -> FieldOcc GhcPs
forall a. a -> a
withPlaceHolder (FieldOcc GhcPs -> FieldOcc GhcPs)
-> FieldOcc GhcPs -> FieldOcc GhcPs
forall a b. (a -> b) -> a -> b
$ (NoExtField -> LocatedN RdrName -> FieldOcc GhcPs)
-> LocatedN RdrName -> FieldOcc GhcPs
forall a. (NoExtField -> a) -> a
noExt XCFieldOcc GhcPs -> XRec GhcPs RdrName -> FieldOcc GhcPs
NoExtField -> LocatedN RdrName -> FieldOcc GhcPs
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc (LocatedN RdrName -> FieldOcc GhcPs)
-> LocatedN RdrName -> FieldOcc GhcPs
forall a b. (a -> b) -> a -> b
$ RdrNameStr -> LocatedN RdrName
valueRdrName RdrNameStr
f
            , hfbRHS :: GenLocated SrcSpanAnnA Pat'
hfbRHS = Pat' -> LPat GhcPs
builtPat Pat'
p
            , hfbPun :: Bool
hfbPun = Bool
False
#else
        mkLocated $ HsRecField
            { hsRecFieldLbl =
                builtLoc $ withPlaceHolder $ noExt FieldOcc $ valueRdrName f
            , hsRecFieldArg = builtPat p
            , hsRecPun = False
#if MIN_VERSION_ghc(9,2,0)
            , hsRecFieldAnn = EpAnnNotUsed
#endif
#endif
            }

-- | A bang-pattern.
--
-- > !x
-- > =====
-- > strictP (bvar x)
strictP :: Pat' -> Pat'
strictP :: Pat' -> Pat'
strictP = (EpAnn [AddEpAnn] -> GenLocated SrcSpanAnnA Pat' -> Pat')
-> GenLocated SrcSpanAnnA Pat' -> Pat'
forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed XBangPat GhcPs -> LPat GhcPs -> Pat'
EpAnn [AddEpAnn] -> GenLocated SrcSpanAnnA Pat' -> Pat'
forall p. XBangPat p -> LPat p -> Pat p
BangPat (GenLocated SrcSpanAnnA Pat' -> Pat')
-> (Pat' -> GenLocated SrcSpanAnnA Pat') -> Pat' -> Pat'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat' -> LPat GhcPs
Pat' -> GenLocated SrcSpanAnnA Pat'
builtPat (Pat' -> GenLocated SrcSpanAnnA Pat')
-> (Pat' -> Pat') -> Pat' -> GenLocated SrcSpanAnnA Pat'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat' -> Pat'
parenthesize

-- | A lazy pattern match.
--
-- > ~(A x)
-- > =====
-- > lazyP (conP "A" [bvar x])
lazyP :: Pat' -> Pat'
lazyP :: Pat' -> Pat'
lazyP = (EpAnn [AddEpAnn] -> GenLocated SrcSpanAnnA Pat' -> Pat')
-> GenLocated SrcSpanAnnA Pat' -> Pat'
forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed XLazyPat GhcPs -> LPat GhcPs -> Pat'
EpAnn [AddEpAnn] -> GenLocated SrcSpanAnnA Pat' -> Pat'
forall p. XLazyPat p -> LPat p -> Pat p
LazyPat (GenLocated SrcSpanAnnA Pat' -> Pat')
-> (Pat' -> GenLocated SrcSpanAnnA Pat') -> Pat' -> Pat'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat' -> LPat GhcPs
Pat' -> GenLocated SrcSpanAnnA Pat'
builtPat (Pat' -> GenLocated SrcSpanAnnA Pat')
-> (Pat' -> Pat') -> Pat' -> GenLocated SrcSpanAnnA Pat'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat' -> Pat'
parenthesize

-- | A pattern type signature
--
-- > x :: y
-- > =====
-- > sigPat (bvar "x") (var "y")
sigP :: Pat' -> HsType' -> Pat'
#if MIN_VERSION_ghc(8,8,0)
sigP :: Pat' -> HsType' -> Pat'
sigP Pat'
p HsType'
t = (EpAnn [AddEpAnn]
 -> GenLocated SrcSpanAnnA Pat' -> HsPatSigType' -> Pat')
-> GenLocated SrcSpanAnnA Pat' -> HsPatSigType' -> Pat'
forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed XSigPat GhcPs -> LPat GhcPs -> HsPatSigType (NoGhcTc GhcPs) -> Pat'
EpAnn [AddEpAnn]
-> GenLocated SrcSpanAnnA Pat' -> HsPatSigType' -> Pat'
forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat (Pat' -> LPat GhcPs
builtPat Pat'
p) (HsType' -> HsPatSigType'
patSigType HsType'
t)
#elif MIN_VERSION_ghc(8,6,0)
sigP p t = SigPat (patSigType t) (builtPat p)
#else
sigP p t = SigPatIn (builtPat p) (patSigType t)
#endif