Commit f1e5b134 authored by Alex D's avatar Alex D 🍄

Template Haskell: make unary tuples legal (#16881)

parent d584e3f0
Pipeline #11301 passed with stages
in 345 minutes and 48 seconds
...@@ -1368,12 +1368,7 @@ cvtTypeKind ty_str ty ...@@ -1368,12 +1368,7 @@ cvtTypeKind ty_str ty
TupleT n TupleT n
| Just normals <- m_normals | Just normals <- m_normals
, normals `lengthIs` n -- Saturated , normals `lengthIs` n -- Saturated
-> if n==1 then return (head normals) -- Singleton tuples treated -> returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals)
-- like nothing (ie just parens)
else returnL (HsTupleTy noExtField
HsBoxedOrConstraintTuple normals)
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
| otherwise | otherwise
-> mk_apps -> mk_apps
(HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n)))) (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))
...@@ -1491,8 +1486,6 @@ cvtTypeKind ty_str ty ...@@ -1491,8 +1486,6 @@ cvtTypeKind ty_str ty
-- Promoted data constructor; hence cName -- Promoted data constructor; hence cName
PromotedTupleT n PromotedTupleT n
| n == 1
-> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
| Just normals <- m_normals | Just normals <- m_normals
, normals `lengthIs` n -- Saturated , normals `lengthIs` n -- Saturated
-> returnL (HsExplicitTupleTy noExtField normals) -> returnL (HsExplicitTupleTy noExtField normals)
......
...@@ -171,6 +171,10 @@ Template Haskell ...@@ -171,6 +171,10 @@ Template Haskell
:extension:`DeriveLift` has been simplified to take advantage of expression :extension:`DeriveLift` has been simplified to take advantage of expression
quotations. quotations.
- Explicit boxed 1-tuples from `HsSyn` are now treated as actual 1-tuples,
without flattening. In most of the cases these will be obtained using
Template Haskell since it is uncommon to deal with 1-tuples in the source.
``ghc-prim`` library ``ghc-prim`` library
~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~
......
...@@ -1534,20 +1534,8 @@ tupleDataName :: Int -> Name ...@@ -1534,20 +1534,8 @@ tupleDataName :: Int -> Name
-- | Tuple type constructor -- | Tuple type constructor
tupleTypeName :: Int -> Name tupleTypeName :: Int -> Name
tupleDataName 0 = mk_tup_name 0 DataName tupleDataName n = mk_tup_name n DataName True
tupleDataName 1 = error "tupleDataName 1" tupleTypeName n = mk_tup_name n TcClsName True
tupleDataName n = mk_tup_name (n-1) DataName
tupleTypeName 0 = mk_tup_name 0 TcClsName
tupleTypeName 1 = error "tupleTypeName 1"
tupleTypeName n = mk_tup_name (n-1) TcClsName
mk_tup_name :: Int -> NameSpace -> Name
mk_tup_name n_commas space
= Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)
where
occ = mkOccName ('(' : replicate n_commas ',' ++ ")")
tup_mod = mkModName "GHC.Tuple"
-- Unboxed tuple data and type constructors -- Unboxed tuple data and type constructors
-- | Unboxed tuple data constructor -- | Unboxed tuple data constructor
...@@ -1555,15 +1543,18 @@ unboxedTupleDataName :: Int -> Name ...@@ -1555,15 +1543,18 @@ unboxedTupleDataName :: Int -> Name
-- | Unboxed tuple type constructor -- | Unboxed tuple type constructor
unboxedTupleTypeName :: Int -> Name unboxedTupleTypeName :: Int -> Name
unboxedTupleDataName n = mk_unboxed_tup_name n DataName unboxedTupleDataName n = mk_tup_name n DataName False
unboxedTupleTypeName n = mk_unboxed_tup_name n TcClsName unboxedTupleTypeName n = mk_tup_name n TcClsName False
mk_unboxed_tup_name :: Int -> NameSpace -> Name mk_tup_name :: Int -> NameSpace -> Bool -> Name
mk_unboxed_tup_name n space mk_tup_name n space boxed
= Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-prim") tup_mod) = Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-prim") tup_mod)
where where
tup_occ | n == 1 = "Unit#" -- See Note [One-tuples] in TysWiredIn withParens thing
| otherwise = "(#" ++ replicate n_commas ',' ++ "#)" | boxed = "(" ++ thing ++ ")"
| otherwise = "(#" ++ thing ++ "#)"
tup_occ | n == 1 = if boxed then "Unit" else "Unit#"
| otherwise = withParens (replicate n_commas ',')
n_commas = n - 1 n_commas = n - 1
tup_mod = mkModName "GHC.Tuple" tup_mod = mkModName "GHC.Tuple"
......
TH_1tuple.hs:11:7: TH_1tuple.hs:11:7: error:
Illegal 1-tuple type constructor • Expecting one more argument to ‘Unit’
When splicing a TH expression: 1 :: () Expected a type, but ‘Unit’ has kind ‘* -> *’
In the untyped splice: $(sigE [| 1 |] (tupleT 1)) • In an expression type signature: Unit
In the expression: (1 :: Unit)
In an equation for ‘y’: y = (1 :: Unit)
TH_Promoted1Tuple.hs:7:3: TH_Promoted1Tuple.hs:7:3: error:
Illegal promoted 1-tuple type Illegal type: ‘'(Int)’ Perhaps you intended to use DataKinds
When splicing a TH declaration: type F = '(GHC.Types.Int)
{-# LANGUAGE TemplateHaskell #-} module Main where
-- Test the use of tupleDataName, tupleTypeName
module ShouldCompile where
import Language.Haskell.TH import Language.Haskell.TH
import TH_tuple1a
foo = $( sigE (appsE [conE (tupleDataName 2), main :: IO ()
litE (integerL 1), main = do
litE (integerL 2)]) let pprQ = \a -> print a >> (putStrLn $ pprint a)
(appT (appT (conT (tupleTypeName 2)) mapM_ (\q -> runQ q >>= pprQ) [tp2, tp1, tp2u, tp1u]
(conT ''Integer))
(conT ''Integer))
)
SigE (AppE (AppE (ConE GHC.Tuple.(,)) (LitE (IntegerL 1))) (LitE (IntegerL 2))) (AppT (AppT (ConT GHC.Tuple.(,)) (ConT GHC.Integer.Type.Integer)) (ConT GHC.Integer.Type.Integer))
GHC.Tuple.(,) 1 2 :: GHC.Tuple.(,) GHC.Integer.Type.Integer
GHC.Integer.Type.Integer
SigE (AppE (ConE GHC.Tuple.Unit) (LitE (IntegerL 1))) (AppT (ConT GHC.Tuple.Unit) (ConT GHC.Integer.Type.Integer))
GHC.Tuple.Unit 1 :: GHC.Tuple.Unit GHC.Integer.Type.Integer
SigE (AppE (AppE (ConE GHC.Tuple.(#,#)) (LitE (IntegerL 1))) (LitE (IntegerL 2))) (AppT (AppT (ConT GHC.Tuple.(#,#)) (ConT GHC.Integer.Type.Integer)) (ConT GHC.Integer.Type.Integer))
GHC.Tuple.(#,#) 1 2 :: GHC.Tuple.(#,#) GHC.Integer.Type.Integer
GHC.Integer.Type.Integer
SigE (AppE (ConE GHC.Tuple.Unit#) (LitE (IntegerL 1))) (AppT (ConT GHC.Tuple.Unit#) (ConT GHC.Integer.Type.Integer))
GHC.Tuple.Unit# 1 :: GHC.Tuple.Unit# GHC.Integer.Type.Integer
{-# LANGUAGE TemplateHaskell #-}
-- Test the use of tupleDataName, tupleTypeName
module TH_tuple1a where
import Language.Haskell.TH
tp2 = sigE (appsE [conE (tupleDataName 2),
litE (integerL 1),
litE (integerL 2)])
(appT (appT (conT (tupleTypeName 2))
(conT ''Integer))
(conT ''Integer))
tp1 = sigE (appsE [conE (tupleDataName 1),
litE (integerL 1)])
(appT (conT (tupleTypeName 1))
(conT ''Integer))
tp2u = sigE (appsE [conE (unboxedTupleDataName 2),
litE (integerL 1),
litE (integerL 2)])
(appT (appT (conT (unboxedTupleTypeName 2))
(conT ''Integer))
(conT ''Integer))
tp1u = sigE (appsE [conE (unboxedTupleDataName 1),
litE (integerL 1)])
(appT (conT (unboxedTupleTypeName 1))
(conT ''Integer))
...@@ -102,7 +102,8 @@ test('TH_spliceE3', normal, compile, ['-v0']) ...@@ -102,7 +102,8 @@ test('TH_spliceE3', normal, compile, ['-v0'])
test('TH_spliceE4', normal, compile_and_run, ['']) test('TH_spliceE4', normal, compile_and_run, [''])
test('TH_class1', normal, compile, ['-v0']) test('TH_class1', normal, compile, ['-v0'])
test('TH_tuple1', normal, compile, ['-v0']) test('TH_tuple1', [], multimod_compile_and_run,
['TH_tuple1', '-v0 ' + config.ghc_th_way_flags])
test('TH_genEx', [], multimod_compile, test('TH_genEx', [], multimod_compile,
['TH_genEx', '-v0 ' + config.ghc_th_way_flags]) ['TH_genEx', '-v0 ' + config.ghc_th_way_flags])
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment