Template Haskell support for unboxed sums

This adds new constructors `UnboxedSumE`, `UnboxedSumT`, and
`UnboxedSumP` to represent unboxed sums in Template Haskell.

One thing you can't currently do is, e.g., `reify ''(#||#)`, since I
don't believe unboxed sum type/data constructors can be written in
prefix form.  I will look at fixing that as part of #12514.

Fixes #12478.

Test Plan: make test TEST=T12478_{1,2,3}

Reviewers: osa1, goldfire, austin, bgamari

Reviewed By: goldfire, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2448

GHC Trac Issues: #12478

8 files changed, 67 insertions, 0 deletions

diff --git a/testsuite/tests/th/T12478_1.hs b/testsuite/tests/th/T12478_1.hs
new file mode 100644
index 0000000000..3d2ab1062b
--- /dev/null
+++ b/testsuite/tests/th/T12478_1.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+module Main where
+
+import Language.Haskell.TH
+
+data T = T (# Int | Char #)
+
+$(return [])
+
+main :: IO ()
+main = putStrLn $(reify ''T >>= stringE . show)
diff --git a/testsuite/tests/th/T12478_1.stdout b/testsuite/tests/th/T12478_1.stdout
new file mode 100644
index 0000000000..8437f925d5
--- /dev/null
+++ b/testsuite/tests/th/T12478_1.stdout
@@ -0,0 +1 @@
+TyConI (DataD [] Main.T [] Nothing [NormalC Main.T [(Bang NoSourceUnpackedness NoSourceStrictness,AppT (AppT (UnboxedSumT 2) (ConT GHC.Types.Int)) (ConT GHC.Types.Char))]] [])
diff --git a/testsuite/tests/th/T12478_2.hs b/testsuite/tests/th/T12478_2.hs
new file mode 100644
index 0000000000..bb0a73ba0f
--- /dev/null
+++ b/testsuite/tests/th/T12478_2.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+-- Essentially the same as TH_repUnboxedTuples, but for unboxed sums
+module Main where
+
+import Language.Haskell.TH
+
+main :: IO ()
+main = case bar () of
+       (# a |   #) -> print a
+       (#   | b #) -> print b
+
+bar :: () -> (# String | Int #)
+bar () = $( do e <- [| case (# 'b' | #) of
+                        (# 'a' |   #) -> (# "One"   |   #)
+                        (# 'b' |   #) -> (#         | 2 #)
+                        (# _   |   #) -> (# "Three" |   #)
+                        (#     | _ #) -> (#         | 4 #)
+                     |]
+               return e )
diff --git a/testsuite/tests/th/T12478_2.stdout b/testsuite/tests/th/T12478_2.stdout
new file mode 100644
index 0000000000..0cfbf08886
--- /dev/null
+++ b/testsuite/tests/th/T12478_2.stdout
@@ -0,0 +1 @@
+2
diff --git a/testsuite/tests/th/T12478_3.hs b/testsuite/tests/th/T12478_3.hs
new file mode 100644
index 0000000000..7c84eee50f
--- /dev/null
+++ b/testsuite/tests/th/T12478_3.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+module T12478_3 where
+
+import Language.Haskell.TH
+
+$(do let ubxSum = unboxedSumT 2 `appT` conT ''Int `appT` conT ''Int
+     x <- newName "x"
+     y <- newName "y"
+
+     [d| swap :: $(ubxSum) -> $(ubxSum)
+         swap $(unboxedSumP (varP x) 1 2) = $(unboxedSumE (varE x) 2 2)
+         swap $(unboxedSumP (varP y) 2 2) = $(unboxedSumE (varE y) 1 2)
+      |])
diff --git a/testsuite/tests/th/T12478_4.hs b/testsuite/tests/th/T12478_4.hs
new file mode 100644
index 0000000000..9017f32bd1
--- /dev/null
+++ b/testsuite/tests/th/T12478_4.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedSums #-}
+module T12478_4 where
+
+import Language.Haskell.TH
+
+f :: $(unboxedSumT 1 `appT` conT ''()) -> Int
+f _ = 42
diff --git a/testsuite/tests/th/T12478_4.stderr b/testsuite/tests/th/T12478_4.stderr
new file mode 100644
index 0000000000..6a68b3d15a
--- /dev/null
+++ b/testsuite/tests/th/T12478_4.stderr
@@ -0,0 +1,6 @@
+
+T12478_4.hs:7:8: error:
+    • Illegal sum arity: 1
+        Sums must have an arity of at least 2
+      When splicing a TH type: (#  #) GHC.Tuple.()
+    • In the untyped splice: $(unboxedSumT 1 `appT` conT ''())
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index b05d601670..592e133e7d 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -421,4 +421,9 @@ test('T12130', extra_clean(['T12130a.hi','T12130a.o']),
 test('T12403', omit_ways(['ghci']),
               compile_and_run, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T12407', omit_ways(['ghci']), compile, ['-v0'])
+test('T12478_1', omit_ways(['ghci']), compile_and_run,
+     ['-v0 -dsuppress-uniques'])
+test('T12478_2', omit_ways(['ghci']), compile_and_run, ['-v0'])
+test('T12478_3', omit_ways(['ghci']), compile, ['-v0'])
+test('T12478_4', omit_ways(['ghci']), compile_fail, ['-v0'])
 test('T12513', omit_ways(['ghci']), compile_fail, ['-v0'])