From 4772247d32d278325fe9ca3bf8283f0a13d4e01b Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Thu, 10 Jan 2019 09:19:50 -0500
Subject: [PATCH] Fix #376 by inserting an apostrophe (#377)

---
 CHANGES.md                                    |  2 +
 src/Data/Singletons/Promote.hs                |  2 +-
 tests/SingletonsTestSuite.hs                  |  1 +
 .../Singletons/T376.ghc86.template            | 40 +++++++++++++++++++
 tests/compile-and-dump/Singletons/T376.hs     |  8 ++++
 5 files changed, 52 insertions(+), 1 deletion(-)
 create mode 100644 tests/compile-and-dump/Singletons/T376.ghc86.template
 create mode 100644 tests/compile-and-dump/Singletons/T376.hs

diff --git a/CHANGES.md b/CHANGES.md
index ad618a13..6e1f9f1d 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -12,6 +12,8 @@ Changelog for singletons project
   One benefit of this change is that one no longer needs defunctionalization
   symbols in order to partially apply `Σ`. As a result, `ΣSym0`, `ΣSym1`,
   and `ΣSym2` have been removed.
+* Fix a bug where expressions with explicit signatures involving function types
+  would fail to single.
 
 2.5.1
 -----
diff --git a/src/Data/Singletons/Promote.hs b/src/Data/Singletons/Promote.hs
index c8d800c8..29ac8fa2 100644
--- a/src/Data/Singletons/Promote.hs
+++ b/src/Data/Singletons/Promote.hs
@@ -806,7 +806,7 @@ promoteExp (DLetE decs exp) = do
 promoteExp (DSigE exp ty) = do
   (exp', ann_exp) <- promoteExp exp
   ty' <- promoteType ty
-  return (DSigT exp' ty', ADSigE exp' ann_exp ty)
+  return (DSigT exp' ty', ADSigE exp' ann_exp ty')
 promoteExp e@(DStaticE _) = fail ("Static expressions cannot be promoted: " ++ show e)
 
 promoteLitExp :: Quasi q => Lit -> q DType
diff --git a/tests/SingletonsTestSuite.hs b/tests/SingletonsTestSuite.hs
index d662a39f..69994a38 100644
--- a/tests/SingletonsTestSuite.hs
+++ b/tests/SingletonsTestSuite.hs
@@ -115,6 +115,7 @@ tests =
     , compileAndDumpStdTest "T353"
     , compileAndDumpStdTest "T358"
     , compileAndDumpStdTest "T371"
+    , compileAndDumpStdTest "T376"
     ],
     testCompileAndDumpGroup "Promote"
     [ compileAndDumpStdTest "Constructors"
diff --git a/tests/compile-and-dump/Singletons/T376.ghc86.template b/tests/compile-and-dump/Singletons/T376.ghc86.template
new file mode 100644
index 00000000..2ffbf25c
--- /dev/null
+++ b/tests/compile-and-dump/Singletons/T376.ghc86.template
@@ -0,0 +1,40 @@
+Singletons/T376.hs:(0,0)-(0,0): Splicing declarations
+    singletons
+      [d| f :: (() -> ()) -> (() -> ())
+          f g = g :: () -> () |]
+  ======>
+    f :: (() -> ()) -> () -> ()
+    f g = g :: () -> ()
+    type FSym2 (a0123456789876543210 :: (~>) () ()) (a0123456789876543210 :: ()) =
+        F a0123456789876543210 a0123456789876543210
+    instance SuppressUnusedWarnings (FSym1 a0123456789876543210) where
+      suppressUnusedWarnings = snd (((,) FSym1KindInference) ())
+    data FSym1 (a0123456789876543210 :: (~>) () ()) :: (~>) () ()
+      where
+        FSym1KindInference :: forall a0123456789876543210
+                                     a0123456789876543210
+                                     arg. SameKind (Apply (FSym1 a0123456789876543210) arg) (FSym2 a0123456789876543210 arg) =>
+                              FSym1 a0123456789876543210 a0123456789876543210
+    type instance Apply (FSym1 a0123456789876543210) a0123456789876543210 = F a0123456789876543210 a0123456789876543210
+    instance SuppressUnusedWarnings FSym0 where
+      suppressUnusedWarnings = snd (((,) FSym0KindInference) ())
+    data FSym0 :: (~>) ((~>) () ()) ((~>) () ())
+      where
+        FSym0KindInference :: forall a0123456789876543210
+                                     arg. SameKind (Apply FSym0 arg) (FSym1 arg) =>
+                              FSym0 a0123456789876543210
+    type instance Apply FSym0 a0123456789876543210 = FSym1 a0123456789876543210
+    type family F (a :: (~>) () ()) (a :: ()) :: () where
+      F g a_0123456789876543210 = Apply (g :: (~>) () ()) a_0123456789876543210
+    sF ::
+      forall (t :: (~>) () ()) (t :: ()).
+      Sing t -> Sing t -> Sing (Apply (Apply FSym0 t) t :: ())
+    sF
+      (sG :: Sing g)
+      (sA_0123456789876543210 :: Sing a_0123456789876543210)
+      = (applySing (sG :: Sing (g :: (~>) () ()))) sA_0123456789876543210
+    instance SingI (FSym0 :: (~>) ((~>) () ()) ((~>) () ())) where
+      sing = (singFun2 @FSym0) sF
+    instance SingI d =>
+             SingI (FSym1 (d :: (~>) () ()) :: (~>) () ()) where
+      sing = (singFun1 @(FSym1 (d :: (~>) () ()))) (sF (sing @d))
diff --git a/tests/compile-and-dump/Singletons/T376.hs b/tests/compile-and-dump/Singletons/T376.hs
new file mode 100644
index 00000000..e93f4d16
--- /dev/null
+++ b/tests/compile-and-dump/Singletons/T376.hs
@@ -0,0 +1,8 @@
+module T376 where
+
+import Data.Singletons.TH
+
+$(singletons [d|
+  f :: (() -> ()) -> (() -> ())
+  f g = g :: () -> ()
+  |])