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

#if MIN_VERSION_ghc(9,0,0)
import GHC.Types.Basic ( Origin(Generated)
#if MIN_VERSION_ghc(9,10,0)
                       , GenReason(OtherExpansion)
#endif
#if MIN_VERSION_ghc(9,8,0)
                       , DoPmc (DoPmc)
#endif
                       )
import GHC.Data.Bag (listToBag)
import GHC.Hs.Extension (GhcPs)
#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(9,14,0)
import qualified Data.List.NonEmpty as NonEmpty
#endif
#if MIN_VERSION_ghc(9,12,0)
import Language.Haskell.Syntax.Extension (wrapXRec, noExtField)
#endif

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

#if MIN_VERSION_ghc(9,10,0)
import GHC.Parser.Annotation (noAnn, emptyComments)
#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 [] = noExt EmptyLocalBinds
valBinds vbs =
#if MIN_VERSION_ghc(9,10,0)
    HsValBinds noAnn
        $ withNoAnnSortKey ValBinds
#  if MIN_VERSION_ghc(9,12,0)
            (map mkLocated binds)
#  else
            (listToBag $ map mkLocated binds)
#  endif
            (map mkLocated sigs)
#elif MIN_VERSION_ghc(8,6,0)
    withEpAnnNotUsed HsValBinds
        $ withNoAnnSortKey ValBinds
            (listToBag $ map mkLocated binds)
            (map mkLocated sigs)
#else
    withEpAnnNotUsed HsValBinds
        $ noExt ValBindsIn
            (listToBag $ map mkLocated binds)
            (map mkLocated sigs)
#endif
  where
    sigs = [s | SigV s <- vbs]
    binds = [b | BindV b <- 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
    { rawMatchPats :: [Pat']
    , 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]
    , rawGRHSWhere :: [RawValBind]
    }

matchGroup :: HsMatchContext' -> [RawMatch] -> MatchGroup' LHsExpr'
matchGroup context matches =
#if MIN_VERSION_ghc(9,10,0)
    MG (Generated OtherExpansion DoPmc)
#elif MIN_VERSION_ghc(9,8,0)
    MG (Generated DoPmc)
#elif MIN_VERSION_ghc(9,6,0)
    MG Generated
#else
    noExt MG
#endif
                            matches'
#if !MIN_VERSION_ghc(8,6,0)
                            [] PlaceHolder
#elif !MIN_VERSION_ghc(9,6,0)
                            Generated
#endif
  where
    matches' = mkLocated $ map (mkLocated . mkMatch) matches
    mkMatch :: RawMatch -> Match' LHsExpr'
#if MIN_VERSION_ghc(9,10,0)
#  if MIN_VERSION_ghc(9,12,0)
    mkMatch r = Match noExtField context
                    (wrapXRec @GhcPs $ map builtPat $ map parenthesize $ rawMatchPats r)
#  else
    mkMatch r = Match noAnn context
                    (map builtPat $ map parenthesize $ rawMatchPats r)
#  endif
#else
    mkMatch r = withEpAnnNotUsed Match context
                    (map builtPat $ map parenthesize $ rawMatchPats r)
#endif
                    (mkGRHSs $ rawMatchGRHSs r)

mkGRHSs :: RawGRHSs -> GRHSs' LHsExpr'
mkGRHSs g = withEmptyEpAnnComments GRHSs
--mkGRHSs g = GRHSs emptyComments
#if MIN_VERSION_ghc(9,14,0)
                (NonEmpty.fromList $ map mkLocated $ rawGRHSs g)
#elif MIN_VERSION_ghc(9,4,0)
                (map mkLocated $ rawGRHSs g)
#else
                (map builtLoc $ rawGRHSs g)
#endif
                (fromLocalBinds $ valBinds $ rawGRHSWhere g)
  where
#if MIN_VERSION_ghc(9,2,0)
    fromLocalBinds = 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 = noExt SigD
    bindB = noExt ValD

instance HasValBind RawValBind where
    sigB = SigV
    bindB = BindV