Overloaded.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 overloads some combinators so they can be used in
-- different contexts: for expressions, types and/or patterns.
module GHC.SourceGen.Overloaded
    ( Par(..)
    , App(..)
    , HasTuple(..)
    , tuple
    , unboxedTuple
    , HasList(..)
    , Var(..)
    , BVar(..)
    ) where

import GHC.Hs.Type
    ( HsType(..)
    , HsTyVarBndr(..)
#if MIN_VERSION_ghc(9,12,0)
    , HsBndrVar(HsBndrVar)
    , HsBndrKind(HsBndrNoKind)
#endif
#if MIN_VERSION_ghc(9,8,0)
    , HsBndrVis (HsBndrRequired)
    , mkHsOpTy
#endif
    )
import GHC.Hs (IE(..), IEWrappedName(..))
#if !MIN_VERSION_ghc(8,6,0)
import PlaceHolder(PlaceHolder(..))
#endif

import GHC.Hs
    ( HsExpr(..)
    , Pat(..)
    , HsTupArg(..)
    , HsTupleSort(..)
#if MIN_VERSION_ghc(9,10,0)
    , EpToken (..)
    , noSpanAnchor
#endif
    )
#if MIN_VERSION_ghc(9,10,0)
import GHC.Parser.Annotation (AnnList (..), noAnn)
#endif
#if MIN_VERSION_ghc(9,0,0)
import GHC.Types.Basic (Boxity(..))
import GHC.Core.DataCon (dataConName)
import GHC.Types.Name.Reader (nameRdrName)
import GHC.Builtin.Types (consDataCon_RDR, nilDataCon, unitDataCon)
import GHC.Types.Var (Specificity(..))
#else
import BasicTypes (Boxity(..))
import DataCon (dataConName)
import RdrName (nameRdrName)
import TysWiredIn (consDataCon_RDR, nilDataCon, unitDataCon)
#endif

import GHC.SourceGen.Expr.Internal
import GHC.SourceGen.Name.Internal
import GHC.SourceGen.Syntax.Internal
import GHC.SourceGen.Type.Internal

-- | A class for wrapping terms in parentheses.
class Par e where
    par :: e -> e

#if MIN_VERSION_ghc(9,10,0)
mkParToken :: (EpToken "(", EpToken ")")
mkParToken = (EpTok noSpanAnchor, EpTok noSpanAnchor)
#endif

instance Par HsExpr' where
#if MIN_VERSION_ghc(9,10,0)
    par p = HsPar mkParToken (mkLocated p)
#elif MIN_VERSION_ghc(9,4,0)
    par p = withEpAnnNotUsed HsPar mkToken (mkLocated p) mkToken
#else
    par = withEpAnnNotUsed HsPar . mkLocated
#endif

instance Par Pat' where
#if MIN_VERSION_ghc(9,10,0)
    par p = ParPat mkParToken (builtPat p)
#elif MIN_VERSION_ghc(9,4,0)
    par p = withEpAnnNotUsed ParPat mkToken (builtPat p) mkToken
#else
    par = withEpAnnNotUsed ParPat . builtPat
#endif

instance Par HsType' where
#if MIN_VERSION_ghc(9,10,0)
    par = HsParTy noAnn . mkLocated
#else
    par = withEpAnnNotUsed HsParTy . mkLocated
#endif

-- | A class for term application.
--
-- These functions may add additional parentheses to the AST.
-- GHC's pretty-printing functions expect those parentheses
-- to already be present, because GHC preserves parentheses when it
-- parses the AST from a source file.
class App e where
    -- | Prefix-apply a term:
    --
    -- > f x
    -- > =====
    -- > var "f" @@ var "x"
    --
    -- > (+) x
    -- > =====
    -- > var "+" @@ var "x"
    --
    -- Also parenthesizes the right-hand side in order to preserve its
    -- semantics when pretty-printed, but tries to do so only when
    -- necessary:
    --
    -- > f x y
    -- > =====
    -- > var "f" @@ var "x" @@ var "y"
    -- > -- equivalently:
    -- > (var "f" @@ var "x") @@ var "y"
    --
    -- > f (g x)
    -- > =====
    -- > var "f" @@ (var "g" @@ var "x")
    --
    -- > f (g x)
    -- > =====
    -- > var "f" @@ par (var "g" @@ par (var "x"))
    (@@) :: e -> e -> e

    -- | Infix-apply an operator or function.
    --
    -- For example:
    --
    -- > x + y
    -- > =====
    -- > op (var "x") "+" (var "y")
    --
    -- Also parenthesizes the right-hand side in order to preserve its
    -- semantics when pretty-printed, but tries to do so only when necessary:
    --
    -- > f x + g y
    -- > =====
    -- > op (var "f" @@ var "x") "+" (var "g" @@ var "y")
    --
    -- > x + (y + z)
    -- > =====
    -- > op (var "x") "+" (op (var "y") "+" (var "z"))
    --
    -- > f x `plus` g y
    -- > =====
    -- > op (var "f" @@ var "x") "plus" (var "g" @@ var "y")
    op :: e -> RdrNameStr -> e -> e
infixl 2 @@

instance App HsExpr' where
#if MIN_VERSION_ghc(9,10,0)
#  if MIN_VERSION_ghc(9,12,0)
    op x o y = noExt OpApp
#  else
    op x o y = OpApp []
#  endif
            (parenthesizeExprForOp $ mkLocated x)
            (mkLocated $ var o)
            (parenthesizeExprForOp $ mkLocated y)
#else
    op x o y
        = withEpAnnNotUsed OpApp
            (parenthesizeExprForOp $ mkLocated x)
            (mkLocated $ var o)
#if !MIN_VERSION_ghc(8,6,0)
            PlaceHolder
#endif
            (parenthesizeExprForOp $ mkLocated y)
#endif
#if MIN_VERSION_ghc(9,10,0)
    x @@ y = noExt HsApp (parenthesizeExprForOp $ mkLocated x)
                (parenthesizeExprForApp $ mkLocated y)
#else
    x @@ y = withEpAnnNotUsed HsApp (parenthesizeExprForOp $ mkLocated x)
                (parenthesizeExprForApp $ mkLocated y)
#endif

instance App HsType' where
    op x o y
#if MIN_VERSION_ghc(9,10,0)
        = mkHsOpTy notPromoted (parenthesizeTypeForOp $ mkLocated x)
                (typeRdrName o)
                (parenthesizeTypeForOp $ mkLocated y)
#elif MIN_VERSION_ghc(9,4,0)
        = withEpAnnNotUsed HsOpTy notPromoted (parenthesizeTypeForOp $ mkLocated x)
                (typeRdrName o)
                (parenthesizeTypeForOp $ mkLocated y)
#else
        = noExt HsOpTy (parenthesizeTypeForOp $ mkLocated x)
                (typeRdrName o)
                (parenthesizeTypeForOp $ mkLocated y)
#endif
    x @@ y = noExt HsAppTy
                (parenthesizeTypeForOp $ mkLocated x)
                (parenthesizeTypeForApp $ mkLocated y)

class HasTuple e where
    unit :: e
    tupleOf :: Boxity -> [e] -> e

tuple, unboxedTuple :: HasTuple e => [e] -> e
tuple = tupleOf Boxed
unboxedTuple = tupleOf Unboxed

instance HasTuple HsExpr' where

#if MIN_VERSION_ghc(9,10,0)
    tupleOf b ts =
        ExplicitTuple noAnn (map (noExt Present . mkLocated) ts) b
#else
    tupleOf b ts =
        explicitTuple
            (map (withEpAnnNotUsed Present . mkLocated) ts)
            b
      where
#if MIN_VERSION_ghc(9,2,0)
        explicitTuple = withEpAnnNotUsed ExplicitTuple
#else
        explicitTuple = noExt ExplicitTuple . map builtLoc
#endif
#endif
    unit = noExt HsVar unitDataConName

unitDataConName :: LIdP
unitDataConName = mkLocated $ nameRdrName $ dataConName $ unitDataCon

instance HasTuple HsType' where
#if MIN_VERSION_ghc(9,10,0)
    tupleOf b = HsTupleTy noAnn b' . map mkLocated
#else
    tupleOf b = withEpAnnNotUsed HsTupleTy b' . map mkLocated
#endif
        where
            b' = case b of
                    Unboxed -> HsUnboxedTuple
                    -- See the note [Unit tuples] in HsType.hs for why
                    -- this isn't just HsBoxed.
                    Boxed -> HsBoxedOrConstraintTuple
    unit = tupleOf Boxed []

instance HasTuple Pat' where
    tupleOf b ps =
#if MIN_VERSION_ghc(9,10,0)
        TuplePat noAnn (map builtPat ps) b
#elif MIN_VERSION_ghc(8,6,0)
        withEpAnnNotUsed TuplePat (map builtPat ps) b
#else
        withEpAnnNotUsed TuplePat (map builtPat ps) b []
#endif
    unit = noExt VarPat unitDataConName

-- | An explicit list of terms.
--
-- > [x, y]
-- > =====
-- > list [var "x", var "y"]
--
-- NOTE: for types, use either @listTy@ or @promotedListTy@.
class HasList e where
    list :: [e] -> e
    -- | The empty list @[]@.
    nil :: e

    -- | The list cons constructor @(:)@.
    cons :: e

-- TODO: allow something like "consOp" which applies (:) as an operator, but using
-- the built-in RdrName.

nilDataConName :: LIdP
nilDataConName = mkLocated $ nameRdrName $ dataConName $ nilDataCon

instance HasList HsExpr' where
    list = withPlaceHolder (withEpAnnNotUsed explicitList) . map mkLocated
      where
#if MIN_VERSION_ghc(9,10,0)
        explicitList = ExplicitList noAnn
#elif MIN_VERSION_ghc(9,2,0)
        explicitList = ExplicitList
#else
        explicitList x = ExplicitList x Nothing
#endif
    nil = noExt HsVar nilDataConName
    cons = noExt HsVar $ mkLocated consDataCon_RDR

instance HasList Pat' where
#if MIN_VERSION_ghc(9,10,0)
    list = ListPat noAnn . map builtPat
#elif MIN_VERSION_ghc(8,6,0)
    list = withEpAnnNotUsed ListPat . map builtPat
#else
    list ps = ListPat (map builtPat ps) PlaceHolder Nothing
#endif
    nil = noExt VarPat nilDataConName
    cons = noExt VarPat $ mkLocated $ consDataCon_RDR

-- | Terms that can contain references to locally-bound variables.
--
-- Depending on the context, @'bvar' \"a\"@ could refer to either a
-- pattern variable or a type variable.
class BVar a where
    bvar :: OccNameStr -> a

-- | Terms that can contain references to named things.  They may be actual variables,
-- functions, or constructors.  For example, @'var' \"a\"@ and @'var' \"A\"@
-- are equally valid.
-- Depending on the context, the former could refer to either a function,
-- value, type variable, or pattern; and the latter could refer to either a type
-- constructor or a  data constructor,
class BVar a => Var a where
    var :: RdrNameStr -> a

instance BVar Pat' where
    bvar = noExt VarPat . valueRdrName . UnqualStr

instance Var HsExpr' where
    var = noExt HsVar . valueRdrName

instance BVar HsExpr' where
    bvar = var . UnqualStr

instance Var HsType' where
#if MIN_VERSION_ghc(9,10,0)
    var = HsTyVar noAnn notPromoted . typeRdrName
#else
    var = withEpAnnNotUsed HsTyVar notPromoted . typeRdrName
#endif

instance BVar HsType' where
    bvar = var . UnqualStr

#if MIN_VERSION_ghc(9,12,0)
instance BVar HsTyVarBndr' where
    bvar n = HsTvb noAnn (noExt HsBndrRequired) (noExt HsBndrVar $ typeRdrName $ UnqualStr n) (noExt HsBndrNoKind)
instance BVar HsTyVarBndrS' where
    bvar n = HsTvb noAnn SpecifiedSpec (noExt HsBndrVar $ typeRdrName $ UnqualStr n) (noExt HsBndrNoKind)
#elif MIN_VERSION_ghc(9,10,0)
instance BVar HsTyVarBndr' where
    bvar = UserTyVar noAnn (noExt HsBndrRequired) . typeRdrName . UnqualStr
instance BVar HsTyVarBndrS' where
    bvar = UserTyVar noAnn SpecifiedSpec . typeRdrName . UnqualStr
#elif MIN_VERSION_ghc(9,8,0)
instance BVar HsTyVarBndr' where
    bvar = withEpAnnNotUsed UserTyVar HsBndrRequired . typeRdrName . UnqualStr
instance BVar HsTyVarBndrS' where
    bvar = withEpAnnNotUsed UserTyVar SpecifiedSpec . typeRdrName . UnqualStr
#elif MIN_VERSION_ghc(9,0,0)
instance BVar HsTyVarBndr' where
  bvar = withEpAnnNotUsed UserTyVar () . typeRdrName . UnqualStr
instance BVar HsTyVarBndrS' where
    bvar = withEpAnnNotUsed UserTyVar SpecifiedSpec . typeRdrName . UnqualStr
#else
instance BVar HsTyVarBndr' where
    bvar = withEpAnnNotUsed UserTyVar . typeRdrName . UnqualStr
#endif

instance Var IE' where
    var n = ie_var $ mkLocated $ ie_name $ exportRdrName n
      where
#if MIN_VERSION_ghc(9,10,0)
        ie_var x =
          IEVar Nothing x Nothing
#elif MIN_VERSION_ghc(9,8,0)
        ie_var =
          IEVar Nothing
#else
        ie_var =
          noExt IEVar
#endif

        ie_name =
#if MIN_VERSION_ghc(9,6,0)
          noExt IEName
#else
          IEName
#endif

instance BVar IE' where
    bvar = var . UnqualStr