{-# LANGUAGE CPP #-}
-- 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

-- | This module provides combinators for constructing Haskell types.
module GHC.SourceGen.Type
    ( HsType'
    , tyPromotedVar
    , stringTy
    , numTy
    , listTy
    , listPromotedTy
    , tuplePromotedTy
    , (-->)
    , forall'
    , HsTyVarBndr'
    , (==>)
    , kindedVar
    ) where

import Data.String (fromString)
#if MIN_VERSION_ghc(9,0,0)
import GHC.Hs.Type
import GHC.Parser.Annotation
#else
import GHC.Hs.Type
#endif

#if MIN_VERSION_ghc(9,4,0)
import Language.Haskell.Syntax.Extension
#endif

import GHC.SourceGen.Syntax.Internal
import GHC.SourceGen.Lit.Internal (noSourceText)
import GHC.SourceGen.Name.Internal
import GHC.SourceGen.Type.Internal

-- | A promoted name, for example from the @DataKinds@ extension.
tyPromotedVar :: RdrNameStr -> HsType'
tyPromotedVar :: RdrNameStr -> HsType'
tyPromotedVar = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar PromotionFlag
promoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrNameStr -> LocatedN RdrName
typeRdrName

stringTy :: String -> HsType'
stringTy :: String -> HsType'
stringTy = forall a. (NoExtField -> a) -> a
noExt forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (SourceText -> a) -> a
noSourceText SourceText -> FastString -> HsTyLit
HsStrTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

numTy :: Integer -> HsType'
numTy :: Integer -> HsType'
numTy = forall a. (NoExtField -> a) -> a
noExt forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (SourceText -> a) -> a
noSourceText SourceText -> Integer -> HsTyLit
HsNumTy

listTy :: HsType' -> HsType'
listTy :: HsType' -> HsType'
listTy = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated

listPromotedTy :: [HsType'] -> HsType'
-- Lists of two or more elements don't need the explicit tick (`'`).
-- But for consistency, just always add it.
listPromotedTy :: [HsType'] -> HsType'
listPromotedTy = forall a. a -> a
withPlaceHolder (forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy PromotionFlag
promoted) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated

tuplePromotedTy :: [HsType'] -> HsType'
tuplePromotedTy :: [HsType'] -> HsType'
tuplePromotedTy = forall a. a -> a
withPlaceHolders (forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated

-- | A function type.
--
-- > a -> b
-- > =====
-- > var "a" --> var "b"
(-->) :: HsType' -> HsType' -> HsType'
HsType'
a --> :: HsType' -> HsType' -> HsType'
--> HsType'
b = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy
#if MIN_VERSION_ghc(9,4,0)
         (HsUnrestrictedArrow mkUniToken)
#elif MIN_VERSION_ghc(9,0,0)
         (forall pass. IsUnicodeSyntax -> HsArrow pass
HsUnrestrictedArrow IsUnicodeSyntax
NormalSyntax)
#endif
         (LHsType GhcPs -> LHsType GhcPs
parenthesizeTypeForFun forall a b. (a -> b) -> a -> b
$ forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated HsType'
a) (forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated HsType'
b)

infixr 0 -->

-- | A type variable binding.
--
-- > forall a . T a
-- > =====
-- > forall' [bvar "a"] $ var "T" @@ var "a"
forall' :: [HsTyVarBndrS'] -> HsType' -> HsType'
forall' :: [HsTyVarBndrS'] -> HsType' -> HsType'
forall' [HsTyVarBndrS']
ts = forall a. (NoExtField -> a) -> a
noExt forall {p :: Pass}.
NoExtField
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass p))]
-> GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> HsType (GhcPass p)
hsForAllTy (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated [HsTyVarBndrS']
ts) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated
  where
#if MIN_VERSION_ghc(9,2,0)
    hsForAllTy :: NoExtField
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass p))]
-> GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> HsType (GhcPass p)
hsForAllTy NoExtField
x = forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy NoExtField
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele
#elif MIN_VERSION_ghc(9,0,0)
    hsForAllTy x = HsForAllTy x . mkHsForAllInvisTele
#elif MIN_VERSION_ghc(8,10,0)
    fvf = ForallInvis -- "Invisible" forall, i.e., with a dot
    hsForAllTy x = HsForAllTy x fvf
#else
    hsForAllTy = HsForAllTy
#endif

-- | Qualify a type with constraints.
--
-- > (F x, G x) => x
-- > =====
-- > [var "F" @@ var "x", var "G" @@ var "x"] ==> var "x"
(==>) :: [HsType'] -> HsType' -> HsType'
==> :: [HsType'] -> HsType' -> HsType'
(==>) [HsType']
cs = XRec GhcPs [LHsType GhcPs] -> LHsType GhcPs -> HsType'
hsQualTy (forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated (forall a b. (a -> b) -> [a] -> [b]
map forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated [HsType']
cs)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated
  where
#if MIN_VERSION_ghc(9,4,0)
    hsQualTy = noExt HsQualTy 
#elif MIN_VERSION_ghc(9,2,0)
    hsQualTy :: XRec GhcPs [LHsType GhcPs] -> LHsType GhcPs -> HsType'
hsQualTy = forall a. (NoExtField -> a) -> a
noExt forall pass.
XQualTy pass
-> Maybe (LHsContext pass) -> LHsType pass -> HsType pass
HsQualTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
#else
    hsQualTy = noExt HsQualTy
#endif

infixr 0 ==>

-- | A type variable with a kind signature.
--
-- > x :: A
-- > =====
-- > kindedVar "x" (var "A")
kindedVar :: OccNameStr -> HsType' -> HsTyVarBndr'
kindedVar :: OccNameStr -> HsType' -> HsTyVarBndr'
kindedVar OccNameStr
v HsType'
t = forall ann a. (EpAnn ann -> a) -> a
withEpAnnNotUsed forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar
#if MIN_VERSION_ghc(9,0,0)
                ()
#endif
                (RdrNameStr -> LocatedN RdrName
typeRdrName forall a b. (a -> b) -> a -> b
$ OccNameStr -> RdrNameStr
UnqualStr OccNameStr
v) (forall a ann. a -> GenLocated (SrcSpanAnn ann) a
mkLocated HsType'
t)