API.hs

-- | This module re-exports a bunch of the GHC API.

{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE BangPatterns #-}

module Language.Haskell.Liquid.GHC.API (
    module Ghc

#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
  , VarBndr
  , AnonArgFlag(..)
  , pattern Bndr
  , pattern FunTy
  , pattern AnonTCB
  , pattern LitString
  , pattern LitFloat
  , pattern LitDouble
  , pattern LitChar
  , ft_af, ft_arg, ft_res
  , bytesFS
  , mkFunTy
  , isEvVarType
  , isEqPrimPred
#endif
#endif

  , tyConRealArity
  , dataConExTyVars

  ) where

import Avail          as Ghc
import GHC            as Ghc hiding (Warning)
import ConLike        as Ghc
import Var            as Ghc
import Module         as Ghc
import DataCon        as Ghc
import TysWiredIn     as Ghc
import BasicTypes     as Ghc
import CoreSyn        as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase)
import NameSet        as Ghc
import InstEnv        as Ghc
import Literal        as Ghc
import TcType         as Ghc (isClassPred)
import Class          as Ghc
import Unique         as Ghc
import RdrName        as Ghc
import SrcLoc         as Ghc
import Name           as Ghc hiding (varName)
import TysPrim        as Ghc
import HscTypes       as Ghc
import HscMain        as Ghc
import Id             as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported)
import ErrUtils       as Ghc
import DynFlags       as Ghc

--
-- Compatibility layer for different GHC versions.
--

--
-- Specific imports for GHC 8.6.5
--
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)

import                   Binary
import                   Data.ByteString (ByteString)
import                   Data.Data (Data)
import                   Outputable
import Kind              as Ghc (classifiesTypeWithValues)
import FastString        as Ghc hiding (bytesFS, LitString)
import TyCoRep           as Ghc hiding (Type (FunTy), mkFunTy)
import TyCon             as Ghc hiding (TyConBndrVis(AnonTCB))
import Type              as Ghc hiding (typeKind, mkFunTy)
import qualified Type    as Ghc
import qualified TyCoRep as Ty
import qualified Literal as Lit
import qualified TyCon   as Ty
import qualified Var     as Var
import qualified GHC.Real

#endif
#endif

--
-- Specific imports for GHC 8.10
--
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
import Type           as Ghc hiding (typeKind , isPredTy)
import TyCon          as Ghc
import TyCoRep        as Ghc
import FastString     as Ghc
import Predicate      as Ghc (isEqPred, getClassPredTys_maybe, isEvVarType, isEqPrimPred)
import Data.Foldable  (asum)
#endif
#endif

--
-- GHC-specific functions and pattern synonyms
--
#ifdef MIN_VERSION_GLASGOW_HASKELL
#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)

-- | The non-dependent version of 'ArgFlag'.

-- Appears here partly so that it's together with its friend ArgFlag,
-- but also because it is used in IfaceType, rather early in the
-- compilation chain
-- See Note [AnonArgFlag vs. ForallVisFlag]
data AnonArgFlag
  = VisArg    -- ^ Used for @(->)@: an ordinary non-dependent arrow.
              --   The argument is visible in source code.
  | InvisArg  -- ^ Used for @(=>)@: a non-dependent predicate arrow.
              --   The argument is invisible in source code.
  deriving (Eq, Ord, Data)

instance Outputable AnonArgFlag where
  ppr VisArg   = text "[vis]"
  ppr InvisArg = text "[invis]"

instance Binary AnonArgFlag where
  put_ bh VisArg   = putByte bh 0
  put_ bh InvisArg = putByte bh 1

  get bh = do
    h <- getByte bh
    case h of
      0 -> return VisArg
      _ -> return InvisArg

bytesFS :: FastString -> ByteString
bytesFS = fastStringToByteString

mkFunTy :: AnonArgFlag -> Type -> Type -> Type
mkFunTy _ = Ty.FunTy

pattern Bndr :: var -> argf -> Var.TyVarBndr var argf
pattern Bndr var argf <- TvBndr var argf where
    Bndr var argf = TvBndr var argf

type VarBndr = TyVarBndr

pattern FunTy :: AnonArgFlag -> Type -> Type -> Type
pattern FunTy { ft_af, ft_arg, ft_res } <- ((VisArg,) -> (ft_af, Ty.FunTy ft_arg ft_res)) where
    FunTy _ft_af ft_arg ft_res = Ty.FunTy ft_arg ft_res

pattern AnonTCB :: AnonArgFlag -> Ty.TyConBndrVis
pattern AnonTCB af <- ((VisArg,) -> (af, Ty.AnonTCB)) where
    AnonTCB _af = Ty.AnonTCB

pattern LitString :: ByteString -> Lit.Literal
pattern LitString bs <- Lit.MachStr bs where
    LitString bs = Lit.MachStr bs

pattern LitFloat :: GHC.Real.Ratio Integer -> Lit.Literal
pattern LitFloat f <- Lit.MachFloat f where
    LitFloat f = Lit.MachFloat f

pattern LitDouble :: GHC.Real.Ratio Integer -> Lit.Literal
pattern LitDouble d <- Lit.MachDouble d where
    LitDouble d = Lit.MachDouble d

pattern LitChar :: Char -> Lit.Literal
pattern LitChar c <- Lit.MachChar c where
    LitChar c = Lit.MachChar c

-- See NOTE [tyConRealArity].
tyConRealArity :: TyCon -> Int
tyConRealArity = tyConArity

-- See NOTE [isEvVarType].
isEvVarType :: Type -> Bool
isEvVarType = Ghc.isPredTy

isEqPrimPred :: Type -> Bool
isEqPrimPred = Ghc.isPredTy

#endif

{- | [NOTE:tyConRealArity]

The semantics of 'tyConArity' changed between GHC 8.6.5 and GHC 8.10, mostly due to the
Visible Dependent Quantification (VDQ). As a result, given the following:

data family EntityField record :: * -> *

Calling `tyConArity` on this would yield @2@ for 8.6.5 but @1@ an 8.10, so we try to backport
the old behaviour in 8.10 by \"looking\" at the 'Kind' of the input 'TyCon' and trying to recursively
split the type apart with either 'splitFunTy_maybe' or 'splitForAllTy_maybe'.

-}

{- | [NOTE:isEvVarType]

For GHC < 8.10.1 'isPredTy' is effectively the same as the new 'isEvVarType', which covers the cases
for coercion types and \"normal\" type coercions. The 8.6.5 version of 'isPredTy' had a special case to
handle a 'TyConApp' in the case of type equality (i.e. ~ ) which was removed in the implementation
for 8.10.1, which essentially calls 'tcIsConstraintKind' straight away.
-}

--
-- Support for GHC >= 8.10.0
--

#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)

-- See NOTE [tyConRealArity].
tyConRealArity :: TyCon -> Int
tyConRealArity tc = go 0 (tyConKind tc)
  where
    go :: Int -> Kind -> Int
    go !acc k =
      case asum [fmap snd (splitFunTy_maybe k), fmap snd (splitForAllTy_maybe k)] of
        Nothing -> acc
        Just ks -> go (acc + 1) ks

dataConExTyVars :: DataCon -> [TyVar]
dataConExTyVars = dataConExTyCoVars

#endif

--
-- End of compatibility shim.
--
#endif