-- 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 = forall a. (NoExtField -> a) -> a
noExtOrPlaceHolder 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 =
  forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall p. XAsPat p -> LIdP p -> LPat p -> Pat p
AsPat (RdrNameStr -> LocatedN RdrName
valueRdrName RdrNameStr
v)
#if MIN_VERSION_ghc(9,6,0)
  noHsTok
#endif
  (Pat' -> LPat'
builtPat 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
     (HsPatSigType (NoGhcTc GhcPs)) LPat' (HsRecFields GhcPs LPat')
-> Pat'
conPat (RdrNameStr -> LocatedN RdrName
valueRdrName RdrNameStr
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {arg} {tyarg} {rec}. [arg] -> HsConDetails tyarg arg rec
prefixCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Pat' -> LPat'
builtPat 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
     (HsPatSigType (NoGhcTc GhcPs)) LPat' (HsRecFields GhcPs LPat')
-> Pat'
conPat = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed 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 = 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)
  forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
#else
  ConPatIn
#endif
  (RdrNameStr -> LocatedN RdrName
valueRdrName RdrNameStr
c)
        forall a b. (a -> b) -> a -> b
$ forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon forall a b. (a -> b) -> a -> b
$ forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields (forall a b. (a -> b) -> [a] -> [b]
map (RdrNameStr, Pat') -> LHsRecField' LPat'
mkRecField [(RdrNameStr, Pat')]
fs) forall a. Maybe a
Nothing -- No ".."
  where
    mkRecField :: (RdrNameStr, Pat') -> LHsRecField' LPat'
    mkRecField :: (RdrNameStr, Pat') -> LHsRecField' LPat'
mkRecField (RdrNameStr
f, Pat'
p) =
#if MIN_VERSION_ghc(9,4,0)
        mkLocated $ HsFieldBind
            { hfbAnn = EpAnnNotUsed
            , hfbLHS = mkLocated $ withPlaceHolder $ noExt FieldOcc $ valueRdrName f
            , hfbRHS = builtPat p
            , hfbPun = False
#else
        forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated forall a b. (a -> b) -> a -> b
$ HsRecField
            { hsRecFieldLbl :: Located (FieldOcc GhcPs)
hsRecFieldLbl =
                forall e. e -> Located e
builtLoc forall a b. (a -> b) -> a -> b
$ forall a. a -> a
withPlaceHolder forall a b. (a -> b) -> a -> b
$ forall a. (NoExtField -> a) -> a
noExt forall pass. XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass
FieldOcc forall a b. (a -> b) -> a -> b
$ RdrNameStr -> LocatedN RdrName
valueRdrName RdrNameStr
f
            , hsRecFieldArg :: GenLocated SrcSpanAnnA Pat'
hsRecFieldArg = Pat' -> LPat'
builtPat Pat'
p
            , hsRecPun :: Bool
hsRecPun = Bool
False
#if MIN_VERSION_ghc(9,2,0)
            , hsRecFieldAnn :: XHsRecField (FieldOcc GhcPs)
hsRecFieldAnn = forall ann. EpAnn ann
EpAnnNotUsed
#endif
#endif
            }

-- | A bang-pattern.
--
-- > !x
-- > =====
-- > strictP (bvar x)
strictP :: Pat' -> Pat'
strictP :: Pat' -> Pat'
strictP = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall p. XBangPat p -> LPat p -> Pat p
BangPat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat' -> LPat'
builtPat 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 = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall p. XLazyPat p -> LPat p -> Pat p
LazyPat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat' -> LPat'
builtPat 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 = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat (Pat' -> LPat'
builtPat Pat'
p) (HsType' -> HsPatSigType GhcPs
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