{-# 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)
import GHC.Hs.Types

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 = (NoExtField -> PromotionFlag -> Located RdrName -> HsType')
-> PromotionFlag -> Located RdrName -> HsType'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> PromotionFlag -> Located RdrName -> HsType'
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar PromotionFlag
promoted (Located RdrName -> HsType')
-> (RdrNameStr -> Located RdrName) -> RdrNameStr -> HsType'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrNameStr -> Located RdrName
typeRdrName

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

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

listTy :: HsType' -> HsType'
listTy :: HsType' -> HsType'
listTy = (NoExtField -> LHsType GhcPs -> HsType')
-> LHsType GhcPs -> HsType'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> LHsType GhcPs -> HsType'
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy (LHsType GhcPs -> HsType')
-> (HsType' -> LHsType GhcPs) -> HsType' -> HsType'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType' -> LHsType GhcPs
forall e. e -> Located e
builtLoc

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 = ([LHsType GhcPs] -> HsType') -> [LHsType GhcPs] -> HsType'
forall a. a -> a
withPlaceHolder ((NoExtField -> PromotionFlag -> [LHsType GhcPs] -> HsType')
-> PromotionFlag -> [LHsType GhcPs] -> HsType'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> PromotionFlag -> [LHsType GhcPs] -> HsType'
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy PromotionFlag
promoted) ([LHsType GhcPs] -> HsType')
-> ([HsType'] -> [LHsType GhcPs]) -> [HsType'] -> HsType'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType' -> LHsType GhcPs) -> [HsType'] -> [LHsType GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map HsType' -> LHsType GhcPs
forall e. e -> Located e
builtLoc

tuplePromotedTy :: [HsType'] -> HsType'
tuplePromotedTy :: [HsType'] -> HsType'
tuplePromotedTy = ([LHsType GhcPs] -> HsType') -> [LHsType GhcPs] -> HsType'
forall a. a -> a
withPlaceHolders ((NoExtField -> [LHsType GhcPs] -> HsType')
-> [LHsType GhcPs] -> HsType'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> [LHsType GhcPs] -> HsType'
forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy) ([LHsType GhcPs] -> HsType')
-> ([HsType'] -> [LHsType GhcPs]) -> [HsType'] -> HsType'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType' -> LHsType GhcPs) -> [HsType'] -> [LHsType GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map HsType' -> LHsType GhcPs
forall e. e -> Located e
builtLoc

-- | A function type.
--
-- > a -> b
-- > =====
-- > var "a" --> var "b"
(-->) :: HsType' -> HsType' -> HsType'
HsType'
a --> :: HsType' -> HsType' -> HsType'
--> HsType'
b = (NoExtField -> LHsType GhcPs -> LHsType GhcPs -> HsType')
-> LHsType GhcPs -> LHsType GhcPs -> HsType'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> LHsType GhcPs -> LHsType GhcPs -> HsType'
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy (LHsType GhcPs -> LHsType GhcPs
parenthesizeTypeForFun (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ HsType' -> LHsType GhcPs
forall e. e -> Located e
builtLoc HsType'
a) (HsType' -> LHsType GhcPs
forall e. e -> Located e
builtLoc HsType'
b)

infixr 0 -->

-- | A type variable binding.
--
-- > forall a . T a
-- > =====
-- > forall' [bvar "a"] $ var "T" @@ var "a"
forall' :: [HsTyVarBndr'] -> HsType' -> HsType'
forall' :: [HsTyVarBndr'] -> HsType' -> HsType'
forall' [HsTyVarBndr']
ts = (NoExtField
 -> ForallVisFlag
 -> [LHsTyVarBndr GhcPs]
 -> LHsType GhcPs
 -> HsType')
-> ForallVisFlag
-> [LHsTyVarBndr GhcPs]
-> LHsType GhcPs
-> HsType'
forall a. (NoExtField -> a) -> a
noExt NoExtField
-> ForallVisFlag
-> [LHsTyVarBndr GhcPs]
-> LHsType GhcPs
-> HsType'
forall pass.
XForAllTy pass
-> ForallVisFlag
-> [LHsTyVarBndr pass]
-> LHsType pass
-> HsType pass
HsForAllTy
#if MIN_VERSION_ghc(8,10,0)
        ForallVisFlag
ForallInvis  -- "Invisible" forall, i.e., with a dot
#endif
        ((HsTyVarBndr' -> LHsTyVarBndr GhcPs)
-> [HsTyVarBndr'] -> [LHsTyVarBndr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map HsTyVarBndr' -> LHsTyVarBndr GhcPs
forall e. e -> Located e
builtLoc [HsTyVarBndr']
ts) (LHsType GhcPs -> HsType')
-> (HsType' -> LHsType GhcPs) -> HsType' -> HsType'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType' -> LHsType GhcPs
forall e. e -> Located e
builtLoc

-- | 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 = (NoExtField -> LHsContext GhcPs -> LHsType GhcPs -> HsType')
-> LHsContext GhcPs -> LHsType GhcPs -> HsType'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> LHsContext GhcPs -> LHsType GhcPs -> HsType'
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy ([LHsType GhcPs] -> LHsContext GhcPs
forall e. e -> Located e
builtLoc ((HsType' -> LHsType GhcPs) -> [HsType'] -> [LHsType GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map HsType' -> LHsType GhcPs
forall e. e -> Located e
builtLoc [HsType']
cs)) (LHsType GhcPs -> HsType')
-> (HsType' -> LHsType GhcPs) -> HsType' -> HsType'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType' -> LHsType GhcPs
forall e. e -> Located e
builtLoc

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 = (NoExtField -> Located RdrName -> LHsType GhcPs -> HsTyVarBndr')
-> Located RdrName -> LHsType GhcPs -> HsTyVarBndr'
forall a. (NoExtField -> a) -> a
noExt NoExtField -> Located RdrName -> LHsType GhcPs -> HsTyVarBndr'
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar (RdrNameStr -> Located RdrName
typeRdrName (RdrNameStr -> Located RdrName) -> RdrNameStr -> Located RdrName
forall a b. (a -> b) -> a -> b
$  OccNameStr -> RdrNameStr
UnqualStr OccNameStr
v)
                        (HsType' -> LHsType GhcPs
forall e. e -> Located e
builtLoc HsType'
t)