-- 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 #-}
module GHC.SourceGen.Binds.Internal where

#if MIN_VERSION_ghc(9,0,0)
import GHC.Types.Basic (Origin(Generated))
import GHC.Data.Bag (listToBag)
#else
import BasicTypes (Origin(Generated))
import Bag (listToBag)
#endif
import GHC.Hs.Binds
import GHC.Hs.Decls
import GHC.Hs.Expr (MatchGroup(..), Match(..), GRHSs(..))

#if !MIN_VERSION_ghc(8,6,0)
import PlaceHolder (PlaceHolder(..))
#endif

import GHC.SourceGen.Pat.Internal (parenthesize)
import GHC.SourceGen.Syntax.Internal

-- | A binding definition inside of a @let@ or @where@ clause.
--
-- 'RawValBind' definitions may be constructed using its instance of
-- 'HasValBind'.  For more details, see the documentation of that function, and
-- of "GHC.SourceGen.Binds" overall.
data RawValBind
    = SigV Sig'
    | BindV HsBind'

valBinds :: [RawValBind] -> HsLocalBinds'
-- This case prevents GHC from printing an empty "where" clause:
valBinds :: [RawValBind] -> HsLocalBinds'
valBinds [] = (NoExtField -> HsLocalBinds') -> HsLocalBinds'
forall a. (NoExtField -> a) -> a
noExt XEmptyLocalBinds GhcPs GhcPs -> HsLocalBinds'
NoExtField -> HsLocalBinds'
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds
valBinds [RawValBind]
vbs =
    (EpAnn AnnList -> HsValBindsLR GhcPs GhcPs -> HsLocalBinds')
-> HsValBindsLR GhcPs GhcPs -> HsLocalBinds'
forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBinds'
EpAnn AnnList -> HsValBindsLR GhcPs GhcPs -> HsLocalBinds'
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds
#if MIN_VERSION_ghc(8,6,0)
        (HsValBindsLR GhcPs GhcPs -> HsLocalBinds')
-> HsValBindsLR GhcPs GhcPs -> HsLocalBinds'
forall a b. (a -> b) -> a -> b
$ (AnnSortKey
 -> Bag (GenLocated (SrcSpanAnn AnnListItem) HsBind')
 -> [GenLocated (SrcSpanAnn AnnListItem) Sig']
 -> HsValBindsLR GhcPs GhcPs)
-> Bag (GenLocated (SrcSpanAnn AnnListItem) HsBind')
-> [GenLocated (SrcSpanAnn AnnListItem) Sig']
-> HsValBindsLR GhcPs GhcPs
forall a. (AnnSortKey -> a) -> a
withNoAnnSortKey XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
AnnSortKey
-> Bag (GenLocated (SrcSpanAnn AnnListItem) HsBind')
-> [GenLocated (SrcSpanAnn AnnListItem) Sig']
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds
#else
        $ noExt ValBindsIn
#endif
            ([GenLocated (SrcSpanAnn AnnListItem) HsBind']
-> Bag (GenLocated (SrcSpanAnn AnnListItem) HsBind')
forall a. [a] -> Bag a
listToBag ([GenLocated (SrcSpanAnn AnnListItem) HsBind']
 -> Bag (GenLocated (SrcSpanAnn AnnListItem) HsBind'))
-> [GenLocated (SrcSpanAnn AnnListItem) HsBind']
-> Bag (GenLocated (SrcSpanAnn AnnListItem) HsBind')
forall a b. (a -> b) -> a -> b
$ (HsBind' -> GenLocated (SrcSpanAnn AnnListItem) HsBind')
-> [HsBind'] -> [GenLocated (SrcSpanAnn AnnListItem) HsBind']
forall a b. (a -> b) -> [a] -> [b]
map HsBind' -> GenLocated (SrcSpanAnn AnnListItem) HsBind'
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated [HsBind']
binds)
            ((Sig' -> GenLocated (SrcSpanAnn AnnListItem) Sig')
-> [Sig'] -> [GenLocated (SrcSpanAnn AnnListItem) Sig']
forall a b. (a -> b) -> [a] -> [b]
map Sig' -> GenLocated (SrcSpanAnn AnnListItem) Sig'
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated [Sig']
sigs)
  where
    sigs :: [Sig']
sigs = [Sig'
s | SigV Sig'
s <- [RawValBind]
vbs]
    binds :: [HsBind']
binds = [HsBind'
b | BindV HsBind'
b <- [RawValBind]
vbs]

-- | A single function pattern match, including an optional "where" clause.
--
-- For example:
--
-- > f x
-- >    | cond = y
-- >    | otherwise = z
-- >  where
-- >    y = ...
-- >    z = ...
data RawMatch = RawMatch
    { RawMatch -> [Pat']
rawMatchPats :: [Pat']
    , RawMatch -> RawGRHSs
rawMatchGRHSs :: RawGRHSs
    }

-- | A set of match guards plus an optional "where" clause.
--
-- This type is used in matches and in multi-way if expressions.
--
-- For example:
--
-- >    | cond = y
-- >    | otherwise = z
-- >  where
-- >    y = ...
-- >    z = ...
data RawGRHSs = RawGRHSs
    { RawGRHSs -> [GuardedExpr]
rawGRHSs :: [GuardedExpr]
    , RawGRHSs -> [RawValBind]
rawGRHSWhere :: [RawValBind]
    }

matchGroup :: HsMatchContext' -> [RawMatch] -> MatchGroup' LHsExpr'
matchGroup :: HsMatchContext' -> [RawMatch] -> MatchGroup' LHsExpr'
matchGroup HsMatchContext'
context [RawMatch]
matches =
#if MIN_VERSION_ghc(9,6,0)
    XMG GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
-> XRec
     GhcPs
     [LMatch GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))]
-> MatchGroup
     GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
forall p body.
XMG p body -> XRec p [LMatch p body] -> MatchGroup p body
MG XMG GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
Origin
Generated
#else
    noExt MG
#endif
                            XRec
  GhcPs
  [LMatch GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))]
GenLocated
  (SrcSpanAnn AnnList)
  [GenLocated
     (SrcSpanAnn AnnListItem)
     (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
forall {ann} {ann}.
GenLocated
  (SrcSpanAnn ann)
  [GenLocated
     (SrcSpanAnn ann)
     (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
matches'
#if !MIN_VERSION_ghc(8,6,0)
                            [] PlaceHolder
#elif !MIN_VERSION_ghc(9,6,0)
                            Generated
#endif                            
  where
    matches' :: GenLocated
  (SrcSpanAnn ann)
  [GenLocated
     (SrcSpanAnn ann)
     (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
matches' = [GenLocated
   (SrcSpanAnn ann)
   (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
-> GenLocated
     (SrcSpanAnn ann)
     [GenLocated
        (SrcSpanAnn ann)
        (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated ([GenLocated
    (SrcSpanAnn ann)
    (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
 -> GenLocated
      (SrcSpanAnn ann)
      [GenLocated
         (SrcSpanAnn ann)
         (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))])
-> [GenLocated
      (SrcSpanAnn ann)
      (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
-> GenLocated
     (SrcSpanAnn ann)
     [GenLocated
        (SrcSpanAnn ann)
        (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ (RawMatch
 -> GenLocated
      (SrcSpanAnn ann)
      (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))))
-> [RawMatch]
-> [GenLocated
      (SrcSpanAnn ann)
      (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
-> GenLocated
     (SrcSpanAnn ann)
     (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
 -> GenLocated
      (SrcSpanAnn ann)
      (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))))
-> (RawMatch
    -> Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))
-> RawMatch
-> GenLocated
     (SrcSpanAnn ann)
     (Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawMatch -> Match' LHsExpr'
RawMatch
-> Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
mkMatch) [RawMatch]
matches
    mkMatch :: RawMatch -> Match' LHsExpr'
    mkMatch :: RawMatch -> Match' LHsExpr'
mkMatch RawMatch
r = (EpAnn [AddEpAnn]
 -> HsMatchContext'
 -> [GenLocated (SrcSpanAnn AnnListItem) Pat']
 -> GRHSs GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
 -> Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))
-> HsMatchContext'
-> [GenLocated (SrcSpanAnn AnnListItem) Pat']
-> GRHSs GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
-> Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed XCMatch GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
-> HsMatchContext'
-> [LPat GhcPs]
-> GRHSs GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
-> Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
EpAnn [AddEpAnn]
-> HsMatchContext'
-> [GenLocated (SrcSpanAnn AnnListItem) Pat']
-> GRHSs GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
-> Match' (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Match HsMatchContext'
context
                    ((Pat' -> GenLocated (SrcSpanAnn AnnListItem) Pat')
-> [Pat'] -> [GenLocated (SrcSpanAnn AnnListItem) Pat']
forall a b. (a -> b) -> [a] -> [b]
map Pat' -> LPat GhcPs
Pat' -> GenLocated (SrcSpanAnn AnnListItem) Pat'
builtPat ([Pat'] -> [GenLocated (SrcSpanAnn AnnListItem) Pat'])
-> [Pat'] -> [GenLocated (SrcSpanAnn AnnListItem) Pat']
forall a b. (a -> b) -> a -> b
$ (Pat' -> Pat') -> [Pat'] -> [Pat']
forall a b. (a -> b) -> [a] -> [b]
map Pat' -> Pat'
parenthesize ([Pat'] -> [Pat']) -> [Pat'] -> [Pat']
forall a b. (a -> b) -> a -> b
$ RawMatch -> [Pat']
rawMatchPats RawMatch
r)
                    (RawGRHSs -> GRHSs' LHsExpr'
mkGRHSs (RawGRHSs -> GRHSs' LHsExpr') -> RawGRHSs -> GRHSs' LHsExpr'
forall a b. (a -> b) -> a -> b
$ RawMatch -> RawGRHSs
rawMatchGRHSs RawMatch
r)

mkGRHSs :: RawGRHSs -> GRHSs' LHsExpr'
mkGRHSs :: RawGRHSs -> GRHSs' LHsExpr'
mkGRHSs RawGRHSs
g = (EpAnnComments
 -> [GenLocated
       (SrcSpanAnn NoEpAnns)
       (GRHS GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
 -> HsLocalBinds'
 -> GRHSs
      GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))
-> [GenLocated
      (SrcSpanAnn NoEpAnns)
      (GRHS GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
-> HsLocalBinds'
-> GRHSs GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
forall a. (EpAnnComments -> a) -> a
withEmptyEpAnnComments XCGRHSs GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
-> [LGRHS
      GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))]
-> HsLocalBinds'
-> GRHSs GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
EpAnnComments
-> [GenLocated
      (SrcSpanAnn NoEpAnns)
      (GRHS GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
-> HsLocalBinds'
-> GRHSs GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs
#if MIN_VERSION_ghc(9,4,0)
                ((GuardedExpr
 -> GenLocated
      (SrcSpanAnn NoEpAnns)
      (GRHS GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))))
-> [GuardedExpr]
-> [GenLocated
      (SrcSpanAnn NoEpAnns)
      (GRHS GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map GuardedExpr
-> GenLocated
     (SrcSpanAnn NoEpAnns)
     (GRHS GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))
GRHS GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs))
-> GenLocated
     (SrcSpanAnn NoEpAnns)
     (GRHS GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))
forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated ([GuardedExpr]
 -> [GenLocated
       (SrcSpanAnn NoEpAnns)
       (GRHS GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))])
-> [GuardedExpr]
-> [GenLocated
      (SrcSpanAnn NoEpAnns)
      (GRHS GhcPs (GenLocated (SrcSpanAnn AnnListItem) (HsExpr GhcPs)))]
forall a b. (a -> b) -> a -> b
$ RawGRHSs -> [GuardedExpr]
rawGRHSs RawGRHSs
g)
#else
                (map builtLoc $ rawGRHSs g)
#endif
                (HsLocalBinds' -> HsLocalBinds'
forall {a}. a -> a
fromLocalBinds (HsLocalBinds' -> HsLocalBinds') -> HsLocalBinds' -> HsLocalBinds'
forall a b. (a -> b) -> a -> b
$ [RawValBind] -> HsLocalBinds'
valBinds ([RawValBind] -> HsLocalBinds') -> [RawValBind] -> HsLocalBinds'
forall a b. (a -> b) -> a -> b
$ RawGRHSs -> [RawValBind]
rawGRHSWhere RawGRHSs
g)
  where
#if MIN_VERSION_ghc(9,2,0)
    fromLocalBinds :: a -> a
fromLocalBinds = a -> a
forall {a}. a -> a
id
#else
    fromLocalBinds = builtLoc
#endif

-- | An expression with a single guard.
--
-- For example:
--
-- > | otherwise = ()
type GuardedExpr = GRHS' LHsExpr'

-- | Syntax types which can declare/define functions.  For example:
-- declarations, or the body of a class declaration or class instance.
--
-- To declare the type of a function or value, use
-- 'GHC.SourceGen.Binds.typeSig' or 'GHC.SourceGen.Binds.typeSigs'.
--
-- To define a function, use 
-- 'GHC.SourceGen.Binds.funBind' or 'GHC.SourceGen.Binds.funBinds'.
--
-- To define a value, use
-- 'GHC.SourceGen.Binds.valBind' or 'GHC.SourceGen.Binds.valBindGuarded'.
class HasValBind t where
    sigB :: Sig' -> t
    bindB :: HsBind' -> t

instance HasValBind HsDecl' where
    sigB :: Sig' -> HsDecl'
sigB = (NoExtField -> Sig' -> HsDecl') -> Sig' -> HsDecl'
forall a. (NoExtField -> a) -> a
noExt XSigD GhcPs -> Sig' -> HsDecl'
NoExtField -> Sig' -> HsDecl'
forall p. XSigD p -> Sig p -> HsDecl p
SigD
    bindB :: HsBind' -> HsDecl'
bindB = (NoExtField -> HsBind' -> HsDecl') -> HsBind' -> HsDecl'
forall a. (NoExtField -> a) -> a
noExt XValD GhcPs -> HsBind' -> HsDecl'
NoExtField -> HsBind' -> HsDecl'
forall p. XValD p -> HsBind p -> HsDecl p
ValD

instance HasValBind RawValBind where
    sigB :: Sig' -> RawValBind
sigB = Sig' -> RawValBind
SigV
    bindB :: HsBind' -> RawValBind
bindB = HsBind' -> RawValBind
BindV