-- 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 declarations.
module GHC.SourceGen.Binds
    (  -- * Bindings
      HsBind'
    , HasValBind
      -- * Type signatures
    , typeSig
    , typeSigs
      -- * Functions
    , funBind
    , funBinds
    , funBindsWithFixity
      -- * Values
    , valBind
    , valBindGRHSs
    -- ** Patterns
    , HasPatBind
    , patBind
    , patBindGRHSs
    -- * Matches
    -- $rawMatch
    , RawMatch
    , match
    , matchGRHSs
    -- * Right-hand sides
    , RawGRHSs
    , rhs
    -- ** Guards
    , guardedRhs
    , GuardedExpr
    , GRHS'
    , guards
    , guard
    -- ** Where clauses
    , where'
    , RawValBind
    -- * Statements
    , stmt
    , (<--)
    ) where

#if MIN_VERSION_ghc(9,0,0)
import GHC (LexicalFixity(..))
#else
import GHC.Types.Basic (LexicalFixity(..))
#endif
import Data.Bool (bool)
import Data.Maybe (fromMaybe)
import GHC.Hs.Binds
import GHC.Hs.Expr
import GHC.Hs.Type
import GHC.Plugins (isSymOcc)
#if !MIN_VERSION_ghc(9,0,1)
import GHC.Tc.Types.Evidence (HsWrapper(WpHole))
#endif
import GHC.SourceGen.Binds.Internal
import GHC.SourceGen.Name
import GHC.SourceGen.Name.Internal
import GHC.SourceGen.Syntax.Internal
import GHC.SourceGen.Type.Internal (sigWcType)

-- | Declares the type of multiple functions or values.
--
-- > f, g :: A
-- > =====
-- > typeSigs ["f", "g"] (var "A")
typeSigs :: HasValBind t => [OccNameStr] -> HsType' -> t
typeSigs :: [OccNameStr] -> HsType' -> t
typeSigs [OccNameStr]
names HsType'
t =
    Sig' -> t
forall t. HasValBind t => Sig' -> t
sigB (Sig' -> t) -> Sig' -> t
forall a b. (a -> b) -> a -> b
$ (NoExtField -> [LocatedN RdrName] -> LHsSigWcType' -> Sig')
-> [LocatedN RdrName] -> LHsSigWcType' -> Sig'
forall a. (NoExtField -> a) -> a
withEpAnnNotUsed NoExtField -> [LocatedN RdrName] -> LHsSigWcType' -> Sig'
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig ((OccNameStr -> LocatedN RdrName)
-> [OccNameStr] -> [LocatedN RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (RdrNameStr -> LocatedN RdrName
typeRdrName (RdrNameStr -> LocatedN RdrName)
-> (OccNameStr -> RdrNameStr) -> OccNameStr -> LocatedN RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccNameStr -> RdrNameStr
unqual) [OccNameStr]
names)
        (LHsSigWcType' -> Sig') -> LHsSigWcType' -> Sig'
forall a b. (a -> b) -> a -> b
$ HsType' -> LHsSigWcType'
sigWcType HsType'
t

-- | Declares the type of a single function or value.
--
-- > f :: A
-- > =====
-- > typeSig "f" (var "A")
typeSig :: HasValBind t => OccNameStr -> HsType' -> t
typeSig :: OccNameStr -> HsType' -> t
typeSig OccNameStr
n = [OccNameStr] -> HsType' -> t
forall t. HasValBind t => [OccNameStr] -> HsType' -> t
typeSigs [OccNameStr
n]

-- | Defines a function or value, with an explicit fixity. When given
-- 'Nothing', use infix notation iff the given name is symbolic.
--
-- > id x = x
-- > =====
-- > funBindsWithFixity (Just Prefix) "id" [match [var "x"] (var "x")]
--
-- > True && True = True
-- > True && False = False
-- > =====
-- > funBindsWithFixity Nothing "not"
-- >   [ match [conP "True" []] (var "False")
-- >   , match [conP "False" []] (var "True")
-- >   ]
funBindsWithFixity :: HasValBind t => Maybe LexicalFixity -> OccNameStr -> [RawMatch] -> t
funBindsWithFixity :: Maybe LexicalFixity -> OccNameStr -> [RawMatch] -> t
funBindsWithFixity Maybe LexicalFixity
fixity OccNameStr
name [RawMatch]
matches = HsBind' -> t
forall t. HasValBind t => HsBind' -> t
bindB (HsBind' -> t) -> HsBind' -> t
forall a b. (a -> b) -> a -> b
$ ([Tickish Id] -> HsBind') -> [Tickish Id] -> HsBind'
forall a. a -> a
withPlaceHolder
        ((NoExtField
 -> LocatedN RdrName
 -> MatchGroup' LHsExpr'
 -> HsWrapper
 -> [Tickish Id]
 -> HsBind')
-> LocatedN RdrName
-> MatchGroup' LHsExpr'
-> HsWrapper
-> [Tickish Id]
-> HsBind'
forall a. (NoExtField -> a) -> a
noExt NoExtField
-> LocatedN RdrName
-> MatchGroup' LHsExpr'
-> HsWrapper
-> [Tickish Id]
-> HsBind'
forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR idL idR
FunBind LocatedN RdrName
name'
            (HsMatchContext' -> [RawMatch] -> MatchGroup' LHsExpr'
matchGroup HsMatchContext'
context [RawMatch]
matches) 
#if !MIN_VERSION_ghc(9,0,1)
            HsWrapper
WpHole
#endif
            )
        []
  where
    name' :: LocatedN RdrName
name' = RdrNameStr -> LocatedN RdrName
valueRdrName (RdrNameStr -> LocatedN RdrName) -> RdrNameStr -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ OccNameStr -> RdrNameStr
unqual OccNameStr
name
    occ :: OccName
occ = OccNameStr -> OccName
valueOccName OccNameStr
name
    fixity' :: LexicalFixity
fixity' = LexicalFixity -> Maybe LexicalFixity -> LexicalFixity
forall a. a -> Maybe a -> a
fromMaybe (LexicalFixity -> LexicalFixity -> Bool -> LexicalFixity
forall a. a -> a -> Bool -> a
bool LexicalFixity
Prefix LexicalFixity
Infix (Bool -> LexicalFixity) -> Bool -> LexicalFixity
forall a b. (a -> b) -> a -> b
$ OccName -> Bool
isSymOcc OccName
occ) Maybe LexicalFixity
fixity
    context :: HsMatchContext'
context = LocatedN RdrName
-> LexicalFixity -> SrcStrictness -> HsMatchContext'
forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs LocatedN RdrName
name' LexicalFixity
fixity' SrcStrictness
NoSrcStrict

-- | Defines a function or value.
--
-- > f = x
-- > =====
-- > funBinds "f" [match [] "x"]
--
-- > id x = x
-- > =====
-- > funBinds "id" [match [var "x"] (var "x")]
--
-- > not True = False
-- > not False = True
-- > =====
-- > funBinds "not"
-- >   [ match [conP "True" []] (var "False")
-- >   , match [conP "False" []] (var "True")
-- >   ]
funBinds :: HasValBind t => OccNameStr -> [RawMatch] -> t
funBinds :: OccNameStr -> [RawMatch] -> t
funBinds = Maybe LexicalFixity -> OccNameStr -> [RawMatch] -> t
forall t.
HasValBind t =>
Maybe LexicalFixity -> OccNameStr -> [RawMatch] -> t
funBindsWithFixity (LexicalFixity -> Maybe LexicalFixity
forall a. a -> Maybe a
Just LexicalFixity
Prefix)

-- | Defines a function that has a single case.
--
-- > f = x
-- > =====
-- > funBind "f" (match [] "x")
--
-- > id x = x
-- > =====
-- > funBind "id" $ match [bvar "x"] (var "x")
--
funBind :: HasValBind t => OccNameStr -> RawMatch -> t
funBind :: OccNameStr -> RawMatch -> t
funBind OccNameStr
name RawMatch
m = OccNameStr -> [RawMatch] -> t
forall t. HasValBind t => OccNameStr -> [RawMatch] -> t
funBinds OccNameStr
name [RawMatch
m]

-- | Defines a value consisting of multiple guards.
--
-- The resulting syntax is the same as a function with no arguments.
--
-- > x
-- >   | test = 1
-- >   | otherwise = 2
-- > =====
-- > valBindGRHSs "x"
-- >   $ guardedRhs
-- >       [ var "test" `guard` int 1
-- >       , var "otherwise" `guard` int 2
-- >       ]
valBindGRHSs :: HasValBind t => OccNameStr -> RawGRHSs -> t
valBindGRHSs :: OccNameStr -> RawGRHSs -> t
valBindGRHSs OccNameStr
name = OccNameStr -> RawMatch -> t
forall t. HasValBind t => OccNameStr -> RawMatch -> t
funBind OccNameStr
name (RawMatch -> t) -> (RawGRHSs -> RawMatch) -> RawGRHSs -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pat'] -> RawGRHSs -> RawMatch
matchGRHSs []

-- | Defines a value without any guards.
--
-- The resulting syntax is the same as a function with no arguments.
--
-- > x = y
-- > =====
-- > valBind "x" $ var "y"
valBind :: HasValBind t => OccNameStr -> HsExpr' -> t
valBind :: OccNameStr -> HsExpr' -> t
valBind OccNameStr
name = OccNameStr -> RawGRHSs -> t
forall t. HasValBind t => OccNameStr -> RawGRHSs -> t
valBindGRHSs OccNameStr
name (RawGRHSs -> t) -> (HsExpr' -> RawGRHSs) -> HsExpr' -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr' -> RawGRHSs
rhs

-- | Defines a pattern binding consisting of multiple guards.
--
-- > (x, y)
-- >   | test = (1, 2)
-- >   | otherwise = (2, 3)
-- > =====
-- > patBindGrhs (tuple [bvar "x", bvar "y"])
-- >   $ guardedRhs
-- >       [ var "test" `guard` tuple [int 1, int 2]
-- >       , var "otherwise" `guard` [int 2, int 3]
-- >       ]
patBindGRHSs :: HasPatBind t => Pat' -> RawGRHSs -> t
patBindGRHSs :: Pat' -> RawGRHSs -> t
patBindGRHSs Pat'
p RawGRHSs
g =
    HsBind' -> t
forall t. HasValBind t => HsBind' -> t
bindB
        (HsBind' -> t) -> HsBind' -> t
forall a b. (a -> b) -> a -> b
$ (([Tickish Id], [[Tickish Id]]) -> HsBind')
-> ([Tickish Id], [[Tickish Id]]) -> HsBind'
forall a. a -> a
withPlaceHolder
            ((([Tickish Id], [[Tickish Id]]) -> HsBind')
-> ([Tickish Id], [[Tickish Id]]) -> HsBind'
forall a. a -> a
withPlaceHolder
                ((NoExtField
 -> GenLocated SrcSpan Pat'
 -> GRHSs' LHsExpr'
 -> ([Tickish Id], [[Tickish Id]])
 -> HsBind')
-> GenLocated SrcSpan Pat'
-> GRHSs' LHsExpr'
-> ([Tickish Id], [[Tickish Id]])
-> HsBind'
forall a. (NoExtField -> a) -> a
withEpAnnNotUsed NoExtField
-> GenLocated SrcSpan Pat'
-> GRHSs' LHsExpr'
-> ([Tickish Id], [[Tickish Id]])
-> HsBind'
forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([Tickish Id], [[Tickish Id]])
-> HsBindLR idL idR
PatBind (Pat' -> LPat'
builtPat Pat'
p) (RawGRHSs -> GRHSs' LHsExpr'
mkGRHSs RawGRHSs
g)))
        (([Tickish Id], [[Tickish Id]]) -> HsBind')
-> ([Tickish Id], [[Tickish Id]]) -> HsBind'
forall a b. (a -> b) -> a -> b
$ ([],[])

-- | Defines a pattern binding without any guards.
--
-- > (x, y) = e
-- > =====
-- > patBind (tuple [bvar "x", bvar "y"]) e
patBind :: HasPatBind t => Pat' -> HsExpr' -> t
patBind :: Pat' -> HsExpr' -> t
patBind Pat'
p = Pat' -> RawGRHSs -> t
forall t. HasPatBind t => Pat' -> RawGRHSs -> t
patBindGRHSs Pat'
p (RawGRHSs -> t) -> (HsExpr' -> RawGRHSs) -> HsExpr' -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr' -> RawGRHSs
rhs

{- $rawMatch

A function definition is made up of one or more 'RawMatch' terms.  Each
'RawMatch' corresponds to a single pattern match.  For example, to define the
"not" function:

> not True = False
> not False = True

We could using a list of two 'RawMatch'es:

> funBinds "not"
>   [ match [conP "True" []] (var "False")
>   , match [conP "False" [] (var "True")
>   ]

A match may consist of one or more guarded expressions.  For example, to
define the function as:

> not x
>   | x = False
>   | otherwise = True

We would say:

> funBind "not"
>      $ matchGRHSs [bvar "x"] $ guardedRhs
>          [ guard (var "x") (var "False")
>          , guard (var "otherwise") (var "True")
>          ]
-}

-- | A function match consisting of multiple guards.
matchGRHSs :: [Pat'] -> RawGRHSs -> RawMatch
matchGRHSs :: [Pat'] -> RawGRHSs -> RawMatch
matchGRHSs = [Pat'] -> RawGRHSs -> RawMatch
RawMatch

-- | A function match with a single case.
match :: [Pat'] -> HsExpr' -> RawMatch
match :: [Pat'] -> HsExpr' -> RawMatch
match [Pat']
ps = [Pat'] -> RawGRHSs -> RawMatch
matchGRHSs [Pat']
ps (RawGRHSs -> RawMatch)
-> (HsExpr' -> RawGRHSs) -> HsExpr' -> RawMatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr' -> RawGRHSs
rhs

-- | Adds a "where" clause to an existing 'RawGRHSs'.
--
-- > f x = y
-- >   where y = x
-- > =====
-- > funBind "x"
-- >   $ matchGRHSs [bvar "x"]
-- >   $ rhs (var "y")
-- >      `where` [valBind "y" $ var "x']
where' :: RawGRHSs -> [RawValBind] -> RawGRHSs
where' :: RawGRHSs -> [RawValBind] -> RawGRHSs
where' RawGRHSs
r [RawValBind]
vbs = RawGRHSs
r { rawGRHSWhere :: [RawValBind]
rawGRHSWhere = RawGRHSs -> [RawValBind]
rawGRHSWhere RawGRHSs
r [RawValBind] -> [RawValBind] -> [RawValBind]
forall a. [a] -> [a] -> [a]
++ [RawValBind]
vbs }

-- | A right-hand side of a match, with no guards.
rhs :: HsExpr' -> RawGRHSs
rhs :: HsExpr' -> RawGRHSs
rhs HsExpr'
e = [GuardedExpr] -> RawGRHSs
guardedRhs [[Stmt'] -> HsExpr' -> GuardedExpr
guards [] HsExpr'
e]

-- | A guarded right-hand side of a match.
--
-- >   | x = False
-- >   | otherwise = True
-- > =====
-- > guardedRhs
-- >   [ guard (var "x") (var "False")
-- >   , guard (var "otherwise") (var "True")
-- >   ]
guardedRhs :: [GuardedExpr] -> RawGRHSs
guardedRhs :: [GuardedExpr] -> RawGRHSs
guardedRhs [GuardedExpr]
ss = [GuardedExpr] -> [RawValBind] -> RawGRHSs
RawGRHSs [GuardedExpr]
ss []

-- | An expression guarded by a single boolean statement.
--
-- >   | otherwise = ()
-- > =====
-- > guard (var "otherwise") unit
guard :: HsExpr' -> HsExpr' -> GuardedExpr
guard :: HsExpr' -> HsExpr' -> GuardedExpr
guard HsExpr'
s = [Stmt'] -> HsExpr' -> GuardedExpr
guards [HsExpr' -> Stmt'
stmt HsExpr'
s]

-- | An expression guarded by multiple statements, using the @PatternGuards@ extension.
--
-- >   | Just y <- x, y = ()
-- > =====
-- > guards [conP "Just" (bvar "x") <-- var "y", bvar "x"] unit
guards :: [Stmt'] -> HsExpr' -> GuardedExpr
guards :: [Stmt'] -> HsExpr' -> GuardedExpr
guards [Stmt']
stmts HsExpr'
e = (NoExtField -> [GuardLStmt GhcPs] -> LHsExpr' -> GuardedExpr)
-> [GuardLStmt GhcPs] -> LHsExpr' -> GuardedExpr
forall a. (NoExtField -> a) -> a
withEpAnnNotUsed NoExtField -> [GuardLStmt GhcPs] -> LHsExpr' -> GuardedExpr
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS ((Stmt' -> GuardLStmt GhcPs) -> [Stmt'] -> [GuardLStmt GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map Stmt' -> GuardLStmt GhcPs
forall a ann. a -> GenLocated SrcSpan a
mkLocated [Stmt']
stmts) (HsExpr' -> LHsExpr'
forall a ann. a -> GenLocated SrcSpan a
mkLocated HsExpr'
e)

-- | An expression statement.  May be used in a do expression (with 'do'') or in a
-- match (with 'guard').
--
-- TODO: also allow using statements in list comprehensions.
stmt :: HsExpr' -> Stmt'
-- For now, don't worry about rebindable syntax.
stmt :: HsExpr' -> Stmt'
stmt HsExpr'
e =
    Stmt' -> Stmt'
forall a. a -> a
withPlaceHolder (Stmt' -> Stmt') -> Stmt' -> Stmt'
forall a b. (a -> b) -> a -> b
$ (NoExtField
 -> LHsExpr' -> SyntaxExpr GhcPs -> SyntaxExpr GhcPs -> Stmt')
-> LHsExpr' -> SyntaxExpr GhcPs -> SyntaxExpr GhcPs -> Stmt'
forall a. (NoExtField -> a) -> a
noExt NoExtField
-> LHsExpr' -> SyntaxExpr GhcPs -> SyntaxExpr GhcPs -> Stmt'
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt (HsExpr' -> LHsExpr'
forall a ann. a -> GenLocated SrcSpan a
mkLocated HsExpr'
e) SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr

-- | A statement that binds a pattern.
--
-- > x <- act
-- > =====
-- > bvar "x" <-- var "act"
(<--) :: Pat' -> HsExpr' -> Stmt'
Pat'
p <-- :: Pat' -> HsExpr' -> Stmt'
<-- HsExpr'
e = Stmt' -> Stmt'
forall a. a -> a
withPlaceHolder (Stmt' -> Stmt') -> Stmt' -> Stmt'
forall a b. (a -> b) -> a -> b
$ (NoExtField
 -> GenLocated SrcSpan Pat'
 -> LHsExpr'
 -> SyntaxExpr GhcPs
 -> SyntaxExpr GhcPs
 -> Stmt')
-> GenLocated SrcSpan Pat'
-> LHsExpr'
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> Stmt'
forall a. (NoExtField -> a) -> a
withEpAnnNotUsed NoExtField
-> GenLocated SrcSpan Pat'
-> LHsExpr'
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> Stmt'
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt (Pat' -> LPat'
builtPat Pat'
p) (HsExpr' -> LHsExpr'
forall a ann. a -> GenLocated SrcSpan a
mkLocated HsExpr'
e)
#if !MIN_VERSION_ghc(9,0,0)
         SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
#endif
infixl 1 <--

-- | Syntax types which can declare/define pattern bindings.
-- For example: declarations at the top-level or in let/where clauses.
--
-- Note: this class is more restrictive than 'HasValBind' since pattern
-- bindings cannot be used in class or instance declarations.
class HasValBind t => HasPatBind t where

instance HasPatBind RawValBind where
instance HasPatBind HsDecl' where