-- 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.Types
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 (sigWcType)

-- | A wild pattern (@_@).
wildP :: Pat'
wildP :: Pat'
wildP = (NoExtField -> Pat') -> Pat'
forall a. (NoExtField -> a) -> a
noExtOrPlaceHolder 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 = (NoExtField -> Located RdrName -> Located Pat' -> Pat')
-> Located RdrName -> Located Pat' -> Pat'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> Located RdrName -> Located Pat' -> Pat'
forall p. XAsPat p -> Located (IdP p) -> LPat p -> Pat p
AsPat (RdrNameStr -> Located RdrName
valueRdrName RdrNameStr
v) (Located Pat' -> Pat') -> Located Pat' -> Pat'
forall a b. (a -> b) -> a -> b
$ Pat' -> LPat'
builtPat (Pat' -> LPat') -> Pat' -> LPat'
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 [Pat']
xs = Located (IdP GhcPs) -> HsConPatDetails GhcPs -> Pat'
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn (RdrNameStr -> Located RdrName
valueRdrName RdrNameStr
c) (HsConPatDetails GhcPs -> Pat') -> HsConPatDetails GhcPs -> Pat'
forall a b. (a -> b) -> a -> b
$ [Located Pat']
-> HsConDetails (Located Pat') (HsRecFields GhcPs (Located Pat'))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon
                ([Located Pat']
 -> HsConDetails (Located Pat') (HsRecFields GhcPs (Located Pat')))
-> [Located Pat']
-> HsConDetails (Located Pat') (HsRecFields GhcPs (Located Pat'))
forall a b. (a -> b) -> a -> b
$ (Pat' -> Located Pat') -> [Pat'] -> [Located Pat']
forall a b. (a -> b) -> [a] -> [b]
map (Pat' -> LPat'
Pat' -> Located Pat'
builtPat (Pat' -> Located Pat') -> (Pat' -> Pat') -> Pat' -> Located Pat'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat' -> Pat'
parenthesize) [Pat']
xs

-- | 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
    = Located (IdP GhcPs) -> HsConPatDetails GhcPs -> Pat'
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn (RdrNameStr -> Located RdrName
valueRdrName RdrNameStr
c)
        (HsConPatDetails GhcPs -> Pat') -> HsConPatDetails GhcPs -> Pat'
forall a b. (a -> b) -> a -> b
$ HsRecFields GhcPs (Located Pat')
-> HsConDetails (Located Pat') (HsRecFields GhcPs (Located Pat'))
forall arg rec. rec -> HsConDetails arg rec
RecCon (HsRecFields GhcPs (Located Pat')
 -> HsConDetails (Located Pat') (HsRecFields GhcPs (Located Pat')))
-> HsRecFields GhcPs (Located Pat')
-> HsConDetails (Located Pat') (HsRecFields GhcPs (Located Pat'))
forall a b. (a -> b) -> a -> b
$ [LHsRecField GhcPs (Located Pat')]
-> Maybe (Located Int) -> HsRecFields GhcPs (Located Pat')
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields (((RdrNameStr, Pat') -> LHsRecField GhcPs (Located Pat'))
-> [(RdrNameStr, Pat')] -> [LHsRecField GhcPs (Located Pat')]
forall a b. (a -> b) -> [a] -> [b]
map (RdrNameStr, Pat') -> LHsRecField' LPat'
(RdrNameStr, Pat') -> LHsRecField GhcPs (Located Pat')
mkRecField [(RdrNameStr, Pat')]
fs) Maybe (Located Int)
forall a. Maybe a
Nothing -- No ".."
  where
    mkRecField :: (RdrNameStr, Pat') -> LHsRecField' LPat'
    mkRecField :: (RdrNameStr, Pat') -> LHsRecField' LPat'
mkRecField (RdrNameStr
f, Pat'
p) =
        HsRecField' (FieldOcc GhcPs) (Located Pat')
-> LHsRecField GhcPs (Located Pat')
forall e. e -> Located e
builtLoc (HsRecField' (FieldOcc GhcPs) (Located Pat')
 -> LHsRecField GhcPs (Located Pat'))
-> HsRecField' (FieldOcc GhcPs) (Located Pat')
-> LHsRecField GhcPs (Located Pat')
forall a b. (a -> b) -> a -> b
$ HsRecField :: forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField
            { hsRecFieldLbl :: Located (FieldOcc GhcPs)
hsRecFieldLbl =
                FieldOcc GhcPs -> Located (FieldOcc GhcPs)
forall e. e -> Located e
builtLoc (FieldOcc GhcPs -> Located (FieldOcc GhcPs))
-> FieldOcc GhcPs -> Located (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 -> Located RdrName -> FieldOcc GhcPs)
-> Located RdrName -> FieldOcc GhcPs
forall a. (NoExtField -> a) -> a
noExt NoExtField -> Located RdrName -> FieldOcc GhcPs
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc (Located RdrName -> FieldOcc GhcPs)
-> Located RdrName -> FieldOcc GhcPs
forall a b. (a -> b) -> a -> b
$ RdrNameStr -> Located RdrName
valueRdrName RdrNameStr
f
            , hsRecFieldArg :: Located Pat'
hsRecFieldArg = Pat' -> LPat'
builtPat Pat'
p
            , hsRecPun :: Bool
hsRecPun = Bool
False
            }

-- | A bang-pattern.
--
-- > !x
-- > =====
-- > strictP (bvar x)
strictP :: Pat' -> Pat'
strictP :: Pat' -> Pat'
strictP = (NoExtField -> Located Pat' -> Pat') -> Located Pat' -> Pat'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> Located Pat' -> Pat'
forall p. XBangPat p -> LPat p -> Pat p
BangPat (Located Pat' -> Pat') -> (Pat' -> Located Pat') -> Pat' -> Pat'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat' -> LPat'
Pat' -> Located Pat'
builtPat (Pat' -> Located Pat') -> (Pat' -> Pat') -> Pat' -> Located 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 = (NoExtField -> Located Pat' -> Pat') -> Located Pat' -> Pat'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> Located Pat' -> Pat'
forall p. XLazyPat p -> LPat p -> Pat p
LazyPat (Located Pat' -> Pat') -> (Pat' -> Located Pat') -> Pat' -> Pat'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat' -> LPat'
Pat' -> Located Pat'
builtPat (Pat' -> Located Pat') -> (Pat' -> Pat') -> Pat' -> Located 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 = (NoExtField -> Located Pat' -> LHsSigWcType' -> Pat')
-> Located Pat' -> LHsSigWcType' -> Pat'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> Located Pat' -> LHsSigWcType' -> Pat'
forall p. XSigPat p -> LPat p -> LHsSigWcType (NoGhcTc p) -> Pat p
SigPat (Pat' -> LPat'
builtPat Pat'
p) (HsType' -> LHsSigWcType'
sigWcType HsType'
t)
#elif MIN_VERSION_ghc(8,6,0)
sigP p t = SigPat (sigWcType t) (builtPat p)
#else
sigP p t = SigPatIn (builtPat p) (sigWcType t)
#endif