summaryrefslogtreecommitdiff
path: root/libraries
diff options
context:
space:
mode:
Diffstat (limited to 'libraries')
-rw-r--r--libraries/base/Data/Kind.hs3
-rw-r--r--libraries/base/Data/Typeable/Internal.hs57
-rwxr-xr-xlibraries/base/GHC/Exts.hs1
-rw-r--r--libraries/base/GHC/Ptr.hs4
-rw-r--r--libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs1
-rw-r--r--libraries/ghc-prim/GHC/CString.hs2
-rw-r--r--libraries/ghc-prim/GHC/Types.hs47
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib.hs1
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs3
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Ppr.hs7
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs4
11 files changed, 92 insertions, 38 deletions
diff --git a/libraries/base/Data/Kind.hs b/libraries/base/Data/Kind.hs
index 9ee7b7ab07..094bc4efae 100644
--- a/libraries/base/Data/Kind.hs
+++ b/libraries/base/Data/Kind.hs
@@ -14,6 +14,7 @@
-- @since 4.9.0.0
-----------------------------------------------------------------------------
-module Data.Kind ( Type, Constraint ) where
+module Data.Kind ( Type, Constraint, FUN ) where
+import GHC.Prim
import GHC.Types
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index 274efb8ade..7ac590a829 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -19,6 +19,7 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE LinearTypes #-}
-----------------------------------------------------------------------------
-- |
@@ -81,9 +82,10 @@ module Data.Typeable.Internal (
typeSymbolTypeRep, typeNatTypeRep,
) where
+import GHC.Prim ( FUN )
import GHC.Base
import qualified GHC.Arr as A
-import GHC.Types ( TYPE )
+import GHC.Types ( TYPE, Multiplicity (Many) )
import Data.Type.Equality
import GHC.List ( splitAt, foldl', elem )
import GHC.Word
@@ -209,18 +211,19 @@ data TypeRep a where
, trAppKind :: !(TypeRep k2) } -- See Note [Kind caching]
-> TypeRep (a b)
- -- | @TrFun fpr a b@ represents a function type @a -> b@. We use this for
+ -- | @TrFun fpr m a b@ represents a function type @a # m -> b@. We use this for
-- the sake of efficiency as functions are quite ubiquitous.
- TrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
+ TrFun :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(a :: TYPE r1) (b :: TYPE r2).
{ -- See Note [TypeRep fingerprints]
trFunFingerprint :: {-# UNPACK #-} !Fingerprint
-- The TypeRep represents a function from trFunArg to
-- trFunRes.
+ , trFunMul :: !(TypeRep m)
, trFunArg :: !(TypeRep a)
, trFunRes :: !(TypeRep b) }
- -> TypeRep (a -> b)
+ -> TypeRep (FUN m a b)
{- Note [TypeRep fingerprints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -308,7 +311,7 @@ instance Ord (TypeRep a) where
-- | A non-indexed type representation.
data SomeTypeRep where
- SomeTypeRep :: forall k (a :: k). !(TypeRep a) -> SomeTypeRep
+ SomeTypeRep :: forall k (a :: k). !(TypeRep a) #-> SomeTypeRep
instance Eq SomeTypeRep where
SomeTypeRep a == SomeTypeRep b =
@@ -335,8 +338,8 @@ pattern Fun :: forall k (fun :: k). ()
=> TypeRep arg
-> TypeRep res
-> TypeRep fun
-pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res}
- where Fun arg res = mkTrFun arg res
+pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res, trFunMul = (eqTypeRep trMany -> Just HRefl)}
+ where Fun arg res = mkTrFun trMany arg res
-- | Observe the 'Fingerprint' of a type representation
--
@@ -383,6 +386,9 @@ trTYPE = typeRep
trLiftedRep :: TypeRep 'LiftedRep
trLiftedRep = typeRep
+trMany :: TypeRep 'Many
+trMany = typeRep
+
-- | Construct a representation for a type application that is
-- NOT a saturated arrow type. This is not checked!
@@ -426,7 +432,7 @@ mkTrAppChecked rep@(TrApp {trAppFun = p, trAppArg = x :: TypeRep x})
, Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y)
, Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry
$ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep
- = mkTrFun x y
+ = mkTrFun trMany x y
mkTrAppChecked a b = mkTrApp a b
-- | A type application.
@@ -455,9 +461,9 @@ pattern App f x <- (splitApp -> IsApp f x)
data AppOrCon (a :: k) where
IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()
- => TypeRep f -> TypeRep x -> AppOrCon (f x)
+ => TypeRep f #-> TypeRep x #-> AppOrCon (f x)
-- See Note [Con evidence]
- IsCon :: IsApplication a ~ "" => TyCon -> [SomeTypeRep] -> AppOrCon a
+ IsCon :: IsApplication a ~ "" => TyCon #-> [SomeTypeRep] #-> AppOrCon a
type family IsApplication (x :: k) :: Symbol where
IsApplication (_ _) = "An error message about this unifying with \"\" "
@@ -616,7 +622,7 @@ instantiateKindRep vars = go
go (KindRepApp f a)
= SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)
go (KindRepFun a b)
- = SomeTypeRep $ mkTrFun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)
+ = SomeTypeRep $ mkTrFun trMany (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)
go (KindRepTYPE LiftedRep) = SomeTypeRep TrType
go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r
go (KindRepTypeLitS sort s)
@@ -634,7 +640,7 @@ unkindedTypeRep (SomeKindedTypeRep x) = SomeTypeRep x
data SomeKindedTypeRep k where
SomeKindedTypeRep :: forall k (a :: k). TypeRep a
- -> SomeKindedTypeRep k
+ #-> SomeKindedTypeRep k
kApp :: SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k
@@ -712,19 +718,19 @@ vecElemTypeRep e =
rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep = kindedTypeRep @VecElem @a
-bareArrow :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
+bareArrow :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(a :: TYPE r1) (b :: TYPE r2). ()
- => TypeRep (a -> b)
- -> TypeRep ((->) :: TYPE r1 -> TYPE r2 -> Type)
-bareArrow (TrFun _ a b) =
- mkTrCon funTyCon [SomeTypeRep rep1, SomeTypeRep rep2]
+ => TypeRep (FUN m a b)
+ -> TypeRep (FUN m :: TYPE r1 -> TYPE r2 -> Type)
+bareArrow (TrFun _ m a b) =
+ mkTrCon funTyCon [SomeTypeRep m, SomeTypeRep rep1, SomeTypeRep rep2]
where
rep1 = getRuntimeRep $ typeRepKind a :: TypeRep r1
rep2 = getRuntimeRep $ typeRepKind b :: TypeRep r2
bareArrow _ = error "Data.Typeable.Internal.bareArrow: impossible"
data IsTYPE (a :: Type) where
- IsTYPE :: forall (r :: RuntimeRep). TypeRep r -> IsTYPE (TYPE r)
+ IsTYPE :: forall (r :: RuntimeRep). TypeRep r #-> IsTYPE (TYPE r)
-- | Is a type of the form @TYPE rep@?
isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a)
@@ -816,8 +822,9 @@ splitApps = go []
= (tc, xs)
go xs (TrApp {trAppFun = f, trAppArg = x})
= go (SomeTypeRep x : xs) f
- go [] (TrFun {trFunArg = a, trFunRes = b})
- = (funTyCon, [SomeTypeRep a, SomeTypeRep b])
+ go [] (TrFun {trFunArg = a, trFunRes = b, trFunMul = mul})
+ | Just HRefl <- eqTypeRep trMany mul = (funTyCon, [SomeTypeRep a, SomeTypeRep b])
+ | otherwise = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Only unrestricted functions are supported"
go _ (TrFun {})
= errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 1"
go [] TrType = (tyConTYPE, [SomeTypeRep trLiftedRep])
@@ -997,14 +1004,16 @@ typeLitTypeRep :: forall k (a :: k). (Typeable k) =>
typeLitTypeRep nm kind_tycon = mkTrCon (mkTypeLitTyCon nm kind_tycon) []
-- | For compiler use.
-mkTrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
+mkTrFun :: forall (m :: Multiplicity) (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(a :: TYPE r1) (b :: TYPE r2).
- TypeRep a -> TypeRep b -> TypeRep ((a -> b) :: Type)
-mkTrFun arg res = TrFun
+ TypeRep m -> TypeRep a -> TypeRep b -> TypeRep ((FUN m a b) :: Type)
+mkTrFun mul arg res = TrFun
{ trFunFingerprint = fpr
+ , trFunMul = mul
, trFunArg = arg
, trFunRes = res }
- where fpr = fingerprintFingerprints [ typeRepFingerprint arg
+ where fpr = fingerprintFingerprints [ typeRepFingerprint mul
+ , typeRepFingerprint arg
, typeRepFingerprint res]
{- $kind_instantiation
diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs
index de66508fcb..f6d7c43ca9 100755
--- a/libraries/base/GHC/Exts.hs
+++ b/libraries/base/GHC/Exts.hs
@@ -30,6 +30,7 @@ module GHC.Exts
maxTupleSize,
-- * Primitive operations
+ FUN, -- See https://gitlab.haskell.org/ghc/ghc/issues/18302
module GHC.Prim,
module GHC.Prim.Ext,
shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#,
diff --git a/libraries/base/GHC/Ptr.hs b/libraries/base/GHC/Ptr.hs
index 1bc4cac1ea..e4021ee115 100644
--- a/libraries/base/GHC/Ptr.hs
+++ b/libraries/base/GHC/Ptr.hs
@@ -93,9 +93,7 @@ minusPtr (Ptr a1) (Ptr a2) = I# (minusAddr# a1 a2)
------------------------------------------------------------------------
-- Function pointers for the default calling convention.
--- 'FunPtr' has a phantom role for similar reasons to 'Ptr'. Note
--- that 'FunPtr's role cannot become nominal without changes elsewhere
--- in GHC. See Note [FFI type roles] in GHC.Tc.Gen.Foreign.
+-- 'FunPtr' has a phantom role for similar reasons to 'Ptr'.
type role FunPtr phantom
data FunPtr a = FunPtr Addr# deriving (Eq, Ord)
-- ^ A value of type @'FunPtr' a@ is a pointer to a function callable
diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
index 33573f62b7..b7c3ba3a1a 100644
--- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
+++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
@@ -73,6 +73,7 @@ data Extension
| DataKinds -- Datatype promotion
| InstanceSigs
| ApplicativeDo
+ | LinearTypes
| StandaloneDeriving
| DeriveDataTypeable
diff --git a/libraries/ghc-prim/GHC/CString.hs b/libraries/ghc-prim/GHC/CString.hs
index ad89a5d3e3..1edeecbbfa 100644
--- a/libraries/ghc-prim/GHC/CString.hs
+++ b/libraries/ghc-prim/GHC/CString.hs
@@ -27,7 +27,7 @@ module GHC.CString (
unpackNBytes#,
) where
-import GHC.Types
+import GHC.Types hiding (One)
import GHC.Prim
{-
diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs
index 0a32454149..ea36868e2d 100644
--- a/libraries/ghc-prim/GHC/Types.hs
+++ b/libraries/ghc-prim/GHC/Types.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples,
MultiParamTypeClasses, RoleAnnotations, CPP, TypeOperators,
- PolyKinds #-}
+ PolyKinds, NegativeLiterals, DataKinds #-}
+-- NegativeLiterals: see Note [Fixity of (->)]
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Types
@@ -40,13 +41,40 @@ module GHC.Types (
-- * Runtime type representation
Module(..), TrName(..), TyCon(..), TypeLitSort(..),
- KindRep(..), KindBndr
+ KindRep(..), KindBndr,
+
+ -- * Multiplicity Types
+ Multiplicity(..), MultMul
) where
import GHC.Prim
infixr 5 :
+
+{- *********************************************************************
+* *
+ Functions
+* *
+********************************************************************* -}
+
+infixr -1 ->
+{-
+Note [Fixity of (->)]
+~~~~~~~~~~~~~~~~~~~~~
+This declaration is important for :info (->) command (issue #10145)
+1) The parser parses -> as if it had lower fixity than 0,
+ so we conventionally use -1 (issue #15235).
+2) Fixities outside the 0-9 range are exceptionally allowed
+ for (->) (see checkPrecP in RdrHsSyn)
+3) The negative fixity -1 must be parsed as a single token,
+ hence this module requires NegativeLiterals.
+-}
+
+-- | The regular function type
+type (->) = FUN 'Many
+-- See Note [Linear Types] in Multiplicity
+
{- *********************************************************************
* *
Kinds
@@ -59,6 +87,14 @@ data Constraint
-- | The kind of types with lifted values. For example @Int :: Type@.
type Type = TYPE 'LiftedRep
+data Multiplicity = Many | One
+
+type family MultMul (a :: Multiplicity) (b :: Multiplicity) :: Multiplicity where
+ MultMul 'One x = x
+ MultMul x 'One = x
+ MultMul 'Many x = 'Many
+ MultMul x 'Many = 'Many
+
{- *********************************************************************
* *
Nat and Symbol
@@ -185,13 +221,6 @@ or the 'Prelude.>>' and 'Prelude.>>=' operations from the 'Prelude.Monad'
class.
-}
newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
-type role IO representational
-
-{- The 'type role' role annotation for IO is redundant but is included
-because this role is significant in the normalisation of FFI
-types. Specifically, if this role were to become nominal (which would
-be very strange, indeed!), changes elsewhere in GHC would be
-necessary. See [FFI type roles] in GHC.Tc.Gen.Foreign. -}
{- *********************************************************************
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 4df23cd3c5..4c4eaf5dbe 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -56,6 +56,7 @@ module Language.Haskell.TH.Lib (
-- *** Types
forallT, forallVisT, varT, conT, appT, appKindT, arrowT, infixT,
+ mulArrowT,
uInfixT, parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT,
sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT,
promotedConsT, implicitParamT,
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index e5899dacb8..ff020ee62d 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -694,6 +694,9 @@ appKindT ty ki = do
arrowT :: Quote m => m Type
arrowT = pure ArrowT
+mulArrowT :: Quote m => m Type
+mulArrowT = pure MulArrowT
+
listT :: Quote m => m Type
listT = pure ListT
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 6dd90e364b..fcaaa40c3e 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -756,6 +756,7 @@ pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
pprParendType ArrowT = parens (text "->")
+pprParendType MulArrowT = text "FUN"
pprParendType ListT = text "[]"
pprParendType (LitT l) = pprTyLit l
pprParendType (PromotedT c) = text "'" <> pprName' Applied c
@@ -812,6 +813,11 @@ parens around it. E.g. the parens are required here:
So we always print a SigT with parens (see #10050). -}
pprTyApp :: (Type, [TypeArg]) -> Doc
+pprTyApp (MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2])
+ | c == oneName = sep [pprFunArgType arg1 <+> text "#->", ppr arg2]
+ | c == manyName = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
+pprTyApp (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) =
+ sep [pprFunArgType arg1 <+> text "#" <+> ppr argm <+> text "->", ppr arg2]
pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) =
sep [pprFunArgType arg1 <+> text "~", ppr arg2]
@@ -834,6 +840,7 @@ pprFunArgType :: Type -> Doc -- Should really use a precedence argument
-- Everything except forall and (->) binds more tightly than (->)
pprFunArgType ty@(ForallT {}) = parens (ppr ty)
pprFunArgType ty@(ForallVisT {}) = parens (ppr ty)
+pprFunArgType ty@(((MulArrowT `AppT` _) `AppT` _) `AppT` _) = parens (ppr ty)
pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)
pprFunArgType ty@(SigT _ _) = parens (ppr ty)
pprFunArgType ty = ppr ty
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index b1b40c7951..955f430d33 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1095,6 +1095,9 @@ rightName = mkNameG DataName "base" "Data.Either" "Right"
nonemptyName :: Name
nonemptyName = mkNameG DataName "base" "GHC.Base" ":|"
+oneName, manyName :: Name
+oneName = mkNameG DataName "ghc-prim" "GHC.Types" "One"
+manyName = mkNameG DataName "ghc-prim" "GHC.Types" "Many"
-----------------------------------------------------
--
-- Generic Lift implementations
@@ -2465,6 +2468,7 @@ data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ct
| UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@
| UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@
| ArrowT -- ^ @->@
+ | MulArrowT -- ^ @FUN@
| EqualityT -- ^ @~@
| ListT -- ^ @[]@
| PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@
View Lorry Controller Status