Binds.hs

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

#if MIN_VERSION_ghc(9,10,0)
import GHC.Parser.Annotation (noAnn)
#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 names t =
#if MIN_VERSION_ghc(9,10,0)
    sigB $ TypeSig ann (map (typeRdrName . unqual) names)
        $ sigWcType t
  where
#  if MIN_VERSION_ghc(9,12,0)
    ann = AnnSig noAnn Nothing Nothing
#  else
    ann = AnnSig noAnn []
#  endif
#else
    sigB $ withEpAnnNotUsed TypeSig (map (typeRdrName . unqual) names)
        $ sigWcType t
#endif

-- | Declares the type of a single function or value.
--
-- > f :: A
-- > =====
-- > typeSig "f" (var "A")
typeSig :: HasValBind t => OccNameStr -> HsType' -> t
typeSig n = typeSigs [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 fixity name matches = bindB $ withPlaceHolder
        (noExt FunBind name'
            (matchGroup context matches)
#if !MIN_VERSION_ghc(9,0,1)
            WpHole
#endif
            )
#if !MIN_VERSION_ghc(9,6,0)
        []
#endif
  where
    name' = valueRdrName $ unqual name
    occ = valueOccName name
    fixity' = fromMaybe (bool Prefix Infix $ isSymOcc occ) fixity
#if MIN_VERSION_ghc(9,12,0)
    context = FunRhs name' fixity' NoSrcStrict noAnn
#else
    context = FunRhs name' fixity' NoSrcStrict
#endif

-- | 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 = funBindsWithFixity (Just 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 name m = funBinds name [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 name = funBind name . 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 name = valBindGRHSs name . 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 p g =
    bindB
        $ withPlaceHolder
            (withPlaceHolder
#if MIN_VERSION_ghc(9,14,0)
                (noExt PatBind (builtPat p) (HsUnannotated EpPatBind) (mkGRHSs g)))
#elif MIN_VERSION_ghc(9,10,0)
                (noExt PatBind (builtPat p) (noExt HsNoMultAnn) (mkGRHSs g)))
#elif MIN_VERSION_ghc(9,6,0)
                (withEpAnnNotUsed PatBind (builtPat p) (mkGRHSs g)))
#else
                (withEpAnnNotUsed PatBind (builtPat p) (mkGRHSs g)))
        $ ([],[])
#endif

-- | Defines a pattern binding without any guards.
--
-- > (x, y) = e
-- > =====
-- > patBind (tuple [bvar "x", bvar "y"]) e
patBind :: HasPatBind t => Pat' -> HsExpr' -> t
patBind p = patBindGRHSs p . 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 = RawMatch

-- | A function match with a single case.
match :: [Pat'] -> HsExpr' -> RawMatch
match ps = matchGRHSs ps . 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' r vbs = r { rawGRHSWhere = rawGRHSWhere r ++ vbs }

-- | A right-hand side of a match, with no guards.
rhs :: HsExpr' -> RawGRHSs
rhs e = guardedRhs [guards [] 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 ss = RawGRHSs ss []

-- | An expression guarded by a single boolean statement.
--
-- >   | otherwise = ()
-- > =====
-- > guard (var "otherwise") unit
guard :: HsExpr' -> HsExpr' -> GuardedExpr
guard s = guards [stmt 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
#if MIN_VERSION_ghc(9,10,0)
guards stmts e = GRHS noAnn (map mkLocated stmts) (mkLocated e)
#else
guards stmts e = withEpAnnNotUsed GRHS (map mkLocated stmts) (mkLocated e)
#endif

-- | 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 e =
    withPlaceHolder $ noExt BodyStmt (mkLocated e) noSyntaxExpr noSyntaxExpr

-- | A statement that binds a pattern.
--
-- > x <- act
-- > =====
-- > bvar "x" <-- var "act"
(<--) :: Pat' -> HsExpr' -> Stmt'
#if MIN_VERSION_ghc(9,10,0)
p <-- e = withPlaceHolder $ BindStmt noAnn (builtPat p) (mkLocated e)
#elif MIN_VERSION_ghc(9,0,0)
p <-- e = withPlaceHolder $ withEpAnnNotUsed BindStmt (builtPat p) (mkLocated e)
#else
p <-- e = withPlaceHolder $ withEpAnnNotUsed BindStmt (builtPat p) (mkLocated e)
         noSyntaxExpr 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