-- 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

-- | 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

import BasicTypes (LexicalFixity(..))
import Data.Bool (bool)
import Data.Maybe (fromMaybe)
import GHC.Hs.Binds
import GHC.Hs.Expr
import GHC.Hs.Types
import GhcPlugins (isSymOcc)
import TcEvidence (HsWrapper(WpHole))

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 -> [Located RdrName] -> LHsSigWcType' -> Sig')
-> [Located RdrName] -> LHsSigWcType' -> Sig'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> [Located RdrName] -> LHsSigWcType' -> Sig'
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig ((OccNameStr -> Located RdrName)
-> [OccNameStr] -> [Located RdrName]
forall a b. (a -> b) -> [a] -> [b]
map (RdrNameStr -> Located RdrName
typeRdrName (RdrNameStr -> Located RdrName)
-> (OccNameStr -> RdrNameStr) -> OccNameStr -> Located 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
 -> Located RdrName
 -> MatchGroup' (Located HsExpr')
 -> HsWrapper
 -> [Tickish Id]
 -> HsBind')
-> Located RdrName
-> MatchGroup' (Located HsExpr')
-> HsWrapper
-> [Tickish Id]
-> HsBind'
forall a. (NoExtField -> a) -> a
noExt NoExtField
-> Located RdrName
-> MatchGroup' (Located HsExpr')
-> HsWrapper
-> [Tickish Id]
-> HsBind'
forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR idL idR
FunBind Located RdrName
name'
            (HsMatchContext' -> [RawMatch] -> MatchGroup' (Located HsExpr')
matchGroup HsMatchContext'
context [RawMatch]
matches) HsWrapper
WpHole)
        []
  where
    name' :: Located RdrName
name' = RdrNameStr -> Located RdrName
valueRdrName (RdrNameStr -> Located RdrName) -> RdrNameStr -> Located 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 = Located RdrName
-> LexicalFixity -> SrcStrictness -> HsMatchContext'
forall id.
Located id -> LexicalFixity -> SrcStrictness -> HsMatchContext id
FunRhs Located 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' (Located HsExpr')
 -> ([Tickish Id], [[Tickish Id]])
 -> HsBind')
-> GenLocated SrcSpan Pat'
-> GRHSs' (Located HsExpr')
-> ([Tickish Id], [[Tickish Id]])
-> HsBind'
forall a. (NoExtField -> a) -> a
noExt NoExtField
-> GenLocated SrcSpan Pat'
-> GRHSs' (Located HsExpr')
-> ([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' (Located HsExpr')
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] -> Located HsExpr' -> GuardedExpr)
-> [GuardLStmt GhcPs] -> Located HsExpr' -> GuardedExpr
forall a. (NoExtField -> a) -> a
noExt NoExtField -> [GuardLStmt GhcPs] -> Located HsExpr' -> 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 e. e -> Located e
builtLoc [Stmt']
stmts) (HsExpr' -> Located HsExpr'
forall e. e -> Located e
builtLoc 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
 -> Located HsExpr'
 -> SyntaxExpr GhcPs
 -> SyntaxExpr GhcPs
 -> Stmt')
-> Located HsExpr' -> SyntaxExpr GhcPs -> SyntaxExpr GhcPs -> Stmt'
forall a. (NoExtField -> a) -> a
noExt NoExtField
-> Located HsExpr' -> SyntaxExpr GhcPs -> SyntaxExpr GhcPs -> Stmt'
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt (HsExpr' -> Located HsExpr'
forall e. e -> Located e
builtLoc 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'
 -> Located HsExpr'
 -> SyntaxExpr GhcPs
 -> SyntaxExpr GhcPs
 -> Stmt')
-> GenLocated SrcSpan Pat'
-> Located HsExpr'
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> Stmt'
forall a. (NoExtField -> a) -> a
noExt NoExtField
-> GenLocated SrcSpan Pat'
-> Located HsExpr'
-> 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' -> Located HsExpr'
forall e. e -> Located e
builtLoc HsExpr'
e) SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
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