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
TupleT n
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
-> if n==1 then return (head normals) -- Singleton tuples treated
-- like nothing (ie just parens)
else returnL (HsTupleTy noExtField
HsBoxedOrConstraintTuple normals)
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
-> returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals)
| otherwise
-> mk_apps
(HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))
......@@ -1491,8 +1486,6 @@ cvtTypeKind ty_str ty
-- Promoted data constructor; hence cName
PromotedTupleT n
| n == 1
-> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
-> returnL (HsExplicitTupleTy noExtField normals)
......
......@@ -171,6 +171,10 @@ Template Haskell
:extension:`DeriveLift` has been simplified to take advantage of expression
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
~~~~~~~~~~~~~~~~~~~~
......
......@@ -1534,20 +1534,8 @@ tupleDataName :: Int -> Name
-- | Tuple type constructor
tupleTypeName :: Int -> Name
tupleDataName 0 = mk_tup_name 0 DataName
tupleDataName 1 = error "tupleDataName 1"
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"
tupleDataName n = mk_tup_name n DataName True
tupleTypeName n = mk_tup_name n TcClsName True
-- Unboxed tuple data and type constructors
-- | Unboxed tuple data constructor
......@@ -1555,15 +1543,18 @@ unboxedTupleDataName :: Int -> Name
-- | Unboxed tuple type constructor
unboxedTupleTypeName :: Int -> Name
unboxedTupleDataName n = mk_unboxed_tup_name n DataName
unboxedTupleTypeName n = mk_unboxed_tup_name n TcClsName
unboxedTupleDataName n = mk_tup_name n DataName False
unboxedTupleTypeName n = mk_tup_name n TcClsName False
mk_unboxed_tup_name :: Int -> NameSpace -> Name
mk_unboxed_tup_name n space
mk_tup_name :: Int -> NameSpace -> Bool -> Name
mk_tup_name n space boxed
= Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-prim") tup_mod)
where
tup_occ | n == 1 = "Unit#" -- See Note [One-tuples] in TysWiredIn
| otherwise = "(#" ++ replicate n_commas ',' ++ "#)"
withParens thing
| boxed = "(" ++ thing ++ ")"
| otherwise = "(#" ++ thing ++ "#)"
tup_occ | n == 1 = if boxed then "Unit" else "Unit#"
| otherwise = withParens (replicate n_commas ',')
n_commas = n - 1
tup_mod = mkModName "GHC.Tuple"
......
TH_1tuple.hs:11:7:
Illegal 1-tuple type constructor
When splicing a TH expression: 1 :: ()
In the untyped splice: $(sigE [| 1 |] (tupleT 1))
TH_1tuple.hs:11:7: error:
• Expecting one more argument to ‘Unit’
Expected a type, but ‘Unit’ has kind ‘* -> *’
• In an expression type signature: Unit
In the expression: (1 :: Unit)
In an equation for ‘y’: y = (1 :: Unit)
TH_Promoted1Tuple.hs:7:3:
Illegal promoted 1-tuple type
When splicing a TH declaration: type F = '(GHC.Types.Int)
TH_Promoted1Tuple.hs:7:3: error:
Illegal type: ‘'(Int)’ Perhaps you intended to use DataKinds
{-# LANGUAGE TemplateHaskell #-}
-- Test the use of tupleDataName, tupleTypeName
module ShouldCompile where
module Main where
import Language.Haskell.TH
import TH_tuple1a
foo = $( sigE (appsE [conE (tupleDataName 2),
litE (integerL 1),
litE (integerL 2)])
(appT (appT (conT (tupleTypeName 2))
(conT ''Integer))
(conT ''Integer))
)
main :: IO ()
main = do
let pprQ = \a -> print a >> (putStrLn $ pprint a)
mapM_ (\q -> runQ q >>= pprQ) [tp2, tp1, tp2u, tp1u]
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'])
test('TH_spliceE4', normal, compile_and_run, [''])
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,
['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