Generate fixity declarations for "fully saturated" defunctionalizatio…

…n symbols

We were not generating these previously due to an oversight.

CHANGES.md

@@ -24,6 +24,8 @@ next
     classes and class methods correctly.
   * `singletons` will no longer erroneously try to single fixity declarations
     for type synonym or type family names.
+  * A bug that caused fixity declarations for certain defunctionalization
+    symbols not to be generated has been fixed.
 
 2.6
 ---

src/Data/Singletons/Promote/Defun.hs

@@ -287,21 +287,20 @@ defunctionalize name m_fixity m_arg_tvbs' m_res_kind' = do
                                                                     mkTupleDExp []])]]
 
             mk_rhs'     = foldTypeTvbs (DConT data_name)
-
             -- See Note [Fixity declarations for defunctionalization symbols]
-            mk_fix_decl f = DLetDec $ DInfixD f data_name
-            fixity_decl   = maybeToList $ fmap mk_fix_decl m_fixity
+            fixity_decl = maybeToList $ fmap (mk_fix_decl data_name) m_fixity
 
         decls <- go (n - 1) m_args m_tyfun mk_rhs'
         return $ suppress : data_decl : app_decl : fixity_decl ++ decls
 
-  let num_args = length m_arg_tvbs
-      sat_name = promoteTySym name num_args
-      mk_rhs   = foldTypeTvbs (DConT name)
-      sat_dec  = DTySynD sat_name m_arg_tvbs (mk_rhs m_arg_tvbs)
+  let num_args       = length m_arg_tvbs
+      sat_name       = promoteTySym name num_args
+      mk_rhs         = foldTypeTvbs (DConT name)
+      sat_dec        = DTySynD sat_name m_arg_tvbs (mk_rhs m_arg_tvbs)
+      sat_fixity_dec = maybeToList $ fmap (mk_fix_decl sat_name) m_fixity
 
   other_decs <- go (num_args - 1) (reverse m_arg_tvbs) m_res_kind mk_rhs
-  return $ sat_dec : other_decs
+  return $ sat_dec : sat_fixity_dec ++ other_decs
   where
     eta_expand :: [DTyVarBndr] -> Maybe DKind -> PrM ([DTyVarBndr], Maybe DKind)
     eta_expand m_arg_tvbs Nothing = pure (m_arg_tvbs, Nothing)
@@ -321,6 +320,9 @@ defunctionalize name m_fixity m_arg_tvbs' m_res_kind' = do
     map_tvb_kind _ tvb@DPlainTV{}  = tvb
     map_tvb_kind f (DKindedTV n k) = DKindedTV n (f k)
 
+    mk_fix_decl :: Name -> Fixity -> DDec
+    mk_fix_decl n f = DLetDec $ DInfixD f n
+
 {-
 Note [Defunctionalization and dependent quantification]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

tests/compile-and-dump/Singletons/Classes.golden

@@ -134,6 +134,7 @@ Singletons/Classes.hs:(0,0)-(0,0): Splicing declarations
     type instance Apply MycompareSym0 arg0123456789876543210 = MycompareSym1 arg0123456789876543210
     type (<=>@#@$$$) (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: a0123456789876543210) =
         (<=>) arg0123456789876543210 arg0123456789876543210
+    infix 4 <=>@#@$$$
     instance SuppressUnusedWarnings ((<=>@#@$$) arg0123456789876543210) where
       suppressUnusedWarnings = snd (((,) (:<=>@#@$$###)) ())
     data (<=>@#@$$) (arg0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 Ordering

tests/compile-and-dump/Singletons/Fixity.golden

@@ -18,6 +18,7 @@ Singletons/Fixity.hs:(0,0)-(0,0): Splicing declarations
     infix 4 ====
     type (====@#@$$$) (a0123456789876543210 :: a0123456789876543210) (a0123456789876543210 :: a0123456789876543210) =
         (====) a0123456789876543210 a0123456789876543210
+    infix 4 ====@#@$$$
     instance SuppressUnusedWarnings ((====@#@$$) a0123456789876543210) where
       suppressUnusedWarnings = snd (((,) (:====@#@$$###)) ())
     data (====@#@$$) (a0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 a0123456789876543210
@@ -42,6 +43,7 @@ Singletons/Fixity.hs:(0,0)-(0,0): Splicing declarations
       (====) a _ = a
     type (<=>@#@$$$) (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: a0123456789876543210) =
         (<=>) arg0123456789876543210 arg0123456789876543210
+    infix 4 <=>@#@$$$
     instance SuppressUnusedWarnings ((<=>@#@$$) arg0123456789876543210) where
       suppressUnusedWarnings = snd (((,) (:<=>@#@$$###)) ())
     data (<=>@#@$$) (arg0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 Ordering

tests/compile-and-dump/Singletons/ShowDeriving.golden

@@ -71,6 +71,7 @@ Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations
     type instance Apply MkFoo2aSym0 t0123456789876543210 = MkFoo2aSym1 t0123456789876543210
     type MkFoo2bSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: a0123456789876543210) =
         MkFoo2b t0123456789876543210 t0123456789876543210
+    infixl 5 `MkFoo2bSym2`
     instance SuppressUnusedWarnings (MkFoo2bSym1 t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) MkFoo2bSym1KindInference) ())
     data MkFoo2bSym1 (t0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 (Foo2 a0123456789876543210)
@@ -93,6 +94,7 @@ Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations
     infixl 5 `MkFoo2bSym0`
     type (:*:@#@$$$) (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: a0123456789876543210) =
         (:*:) t0123456789876543210 t0123456789876543210
+    infixl 5 :*:@#@$$$
     instance SuppressUnusedWarnings ((:*:@#@$$) t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) (::*:@#@$$###)) ())
     data (:*:@#@$$) (t0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 (Foo2 a0123456789876543210)
@@ -115,6 +117,7 @@ Singletons/ShowDeriving.hs:(0,0)-(0,0): Splicing declarations
     infixl 5 :*:@#@$
     type (:&:@#@$$$) (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: a0123456789876543210) =
         (:&:) t0123456789876543210 t0123456789876543210
+    infixl 5 :&:@#@$$$
     instance SuppressUnusedWarnings ((:&:@#@$$) t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) (::&:@#@$$###)) ())
     data (:&:@#@$$) (t0123456789876543210 :: a0123456789876543210) :: (~>) a0123456789876543210 (Foo2 a0123456789876543210)

tests/compile-and-dump/Singletons/StandaloneDeriving.golden

@@ -27,6 +27,7 @@ Singletons/StandaloneDeriving.hs:(0,0)-(0,0): Splicing declarations
     deriving instance Enum S
     type (:*:@#@$$$) (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) =
         (:*:) t0123456789876543210 t0123456789876543210
+    infixl 6 :*:@#@$$$
     instance SuppressUnusedWarnings ((:*:@#@$$) t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) (::*:@#@$$###)) ())
     data (:*:@#@$$) (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210.

tests/compile-and-dump/Singletons/T159.golden

@@ -45,6 +45,7 @@ Singletons/T159.hs:0:0:: Splicing declarations
     type N1Sym0 = 'N1
     type C1Sym2 (t0123456789876543210 :: T0) (t0123456789876543210 :: T1) =
         'C1 t0123456789876543210 t0123456789876543210
+    infixr 5 `C1Sym2`
     instance SuppressUnusedWarnings (C1Sym1 t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) C1Sym1KindInference) ())
     data C1Sym1 (t0123456789876543210 :: T0) :: (~>) T1 T1
@@ -66,6 +67,7 @@ Singletons/T159.hs:0:0:: Splicing declarations
     infixr 5 `C1Sym0`
     type (:&&@#@$$$) (t0123456789876543210 :: T0) (t0123456789876543210 :: T1) =
         '(:&&) t0123456789876543210 t0123456789876543210
+    infixr 5 :&&@#@$$$
     instance SuppressUnusedWarnings ((:&&@#@$$) t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) (::&&@#@$$###)) ())
     data (:&&@#@$$) (t0123456789876543210 :: T0) :: (~>) T1 T1
@@ -141,6 +143,7 @@ Singletons/T159.hs:(0,0)-(0,0): Splicing declarations
     type N2Sym0 = N2
     type C2Sym2 (t0123456789876543210 :: T0) (t0123456789876543210 :: T2) =
         C2 t0123456789876543210 t0123456789876543210
+    infixr 5 `C2Sym2`
     instance SuppressUnusedWarnings (C2Sym1 t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) C2Sym1KindInference) ())
     data C2Sym1 (t0123456789876543210 :: T0) :: (~>) T2 T2
@@ -162,6 +165,7 @@ Singletons/T159.hs:(0,0)-(0,0): Splicing declarations
     infixr 5 `C2Sym0`
     type (:||@#@$$$) (t0123456789876543210 :: T0) (t0123456789876543210 :: T2) =
         (:||) t0123456789876543210 t0123456789876543210
+    infixr 5 :||@#@$$$
     instance SuppressUnusedWarnings ((:||@#@$$) t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) (::||@#@$$###)) ())
     data (:||@#@$$) (t0123456789876543210 :: T0) :: (~>) T2 T2

tests/compile-and-dump/Singletons/T197.golden

@@ -10,6 +10,7 @@ Singletons/T197.hs:(0,0)-(0,0): Splicing declarations
     ($$:) _ _ = False
     type ($$:@#@$$$) (a0123456789876543210 :: Bool) (a0123456789876543210 :: Bool) =
         ($$:) a0123456789876543210 a0123456789876543210
+    infixl 5 $$:@#@$$$
     instance SuppressUnusedWarnings (($$:@#@$$) a0123456789876543210) where
       suppressUnusedWarnings = snd (((,) (:$$:@#@$$###)) ())
     data ($$:@#@$$) (a0123456789876543210 :: Bool) :: (~>) Bool Bool

tests/compile-and-dump/Singletons/T197b.golden

@@ -32,6 +32,7 @@ Singletons/T197b.hs:(0,0)-(0,0): Splicing declarations
     type instance Apply (:*:@#@$) t0123456789876543210 = (:*:@#@$$) t0123456789876543210
     type MkPairSym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) =
         MkPair t0123456789876543210 t0123456789876543210
+    infixr 9 `MkPairSym2`
     instance SuppressUnusedWarnings (MkPairSym1 t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) MkPairSym1KindInference) ())
     data MkPairSym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210.

tests/compile-and-dump/Singletons/T322.golden

@@ -10,6 +10,7 @@ Singletons/T322.hs:(0,0)-(0,0): Splicing declarations
     infixr 2 !
     type (!@#@$$$) (a0123456789876543210 :: Bool) (a0123456789876543210 :: Bool) =
         (!) a0123456789876543210 a0123456789876543210
+    infixr 2 !@#@$$$
     instance SuppressUnusedWarnings ((!@#@$$) a0123456789876543210) where
       suppressUnusedWarnings = snd (((,) (:!@#@$$###)) ())
     data (!@#@$$) (a0123456789876543210 :: Bool) :: (~>) Bool Bool

tests/compile-and-dump/Singletons/T412.golden

@@ -27,6 +27,7 @@ Singletons/T412.hs:(0,0)-(0,0): Splicing declarations
     data D1 a b = MkD1 a b
     type T1aSym2 a0123456789876543210 b0123456789876543210 =
         T1a a0123456789876543210 b0123456789876543210
+    infixl 5 `T1aSym2`
     instance SuppressUnusedWarnings (T1aSym1 a0123456789876543210) where
       suppressUnusedWarnings = snd (((,) T1aSym1KindInference) ())
     data T1aSym1 a0123456789876543210 b0123456789876543210
@@ -48,6 +49,7 @@ Singletons/T412.hs:(0,0)-(0,0): Splicing declarations
     infixl 5 `T1aSym0`
     type T1bSym2 a0123456789876543210 b0123456789876543210 =
         T1b a0123456789876543210 b0123456789876543210
+    infixl 5 `T1bSym2`
     instance SuppressUnusedWarnings (T1bSym1 a0123456789876543210) where
       suppressUnusedWarnings = snd (((,) T1bSym1KindInference) ())
     data T1bSym1 a0123456789876543210 b0123456789876543210
@@ -69,6 +71,7 @@ Singletons/T412.hs:(0,0)-(0,0): Splicing declarations
     infixl 5 `T1bSym0`
     type MkD1Sym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) =
         MkD1 t0123456789876543210 t0123456789876543210
+    infixr 5 `MkD1Sym2`
     instance SuppressUnusedWarnings (MkD1Sym1 t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) MkD1Sym1KindInference) ())
     data MkD1Sym1 (t0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210.
@@ -94,6 +97,7 @@ Singletons/T412.hs:(0,0)-(0,0): Splicing declarations
     infix 5 `PC1`
     type M1Sym2 (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: b0123456789876543210) =
         M1 arg0123456789876543210 arg0123456789876543210
+    infix 6 `M1Sym2`
     instance SuppressUnusedWarnings (M1Sym1 arg0123456789876543210) where
       suppressUnusedWarnings = snd (((,) M1Sym1KindInference) ())
     data M1Sym1 (arg0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210.
@@ -152,6 +156,7 @@ Singletons/T412.hs:0:0:: Splicing declarations
   ======>
     type M2Sym2 (arg0123456789876543210 :: a0123456789876543210) (arg0123456789876543210 :: b0123456789876543210) =
         M2 arg0123456789876543210 arg0123456789876543210
+    infix 6 `M2Sym2`
     instance SuppressUnusedWarnings (M2Sym1 arg0123456789876543210) where
       suppressUnusedWarnings = snd (((,) M2Sym1KindInference) ())
     data M2Sym1 (arg0123456789876543210 :: a0123456789876543210) :: forall b0123456789876543210.
@@ -190,6 +195,7 @@ Singletons/T412.hs:0:0:: Splicing declarations
       sing = (singFun1 @(M2Sym1 (d :: a))) (sM2 (sing @d))
     type T2aSym2 (a0123456789876543210 :: GHC.Types.Type) (b0123456789876543210 :: GHC.Types.Type) =
         T2a a0123456789876543210 b0123456789876543210
+    infixl 5 `T2aSym2`
     instance SuppressUnusedWarnings (T2aSym1 a0123456789876543210) where
       suppressUnusedWarnings = snd (((,) T2aSym1KindInference) ())
     data T2aSym1 (a0123456789876543210 :: GHC.Types.Type) b0123456789876543210
@@ -211,6 +217,7 @@ Singletons/T412.hs:0:0:: Splicing declarations
     infixl 5 `T2aSym0`
     type T2bSym2 (a0123456789876543210 :: GHC.Types.Type) (b0123456789876543210 :: GHC.Types.Type) =
         T2b a0123456789876543210 b0123456789876543210
+    infixl 5 `T2bSym2`
     instance SuppressUnusedWarnings (T2bSym1 a0123456789876543210) where
       suppressUnusedWarnings = snd (((,) T2bSym1KindInference) ())
     data T2bSym1 (a0123456789876543210 :: GHC.Types.Type) :: (~>) GHC.Types.Type GHC.Types.Type
@@ -232,6 +239,7 @@ Singletons/T412.hs:0:0:: Splicing declarations
     infixl 5 `T2bSym0`
     type MkD2Sym2 (t0123456789876543210 :: a0123456789876543210) (t0123456789876543210 :: b0123456789876543210) =
         'MkD2 t0123456789876543210 t0123456789876543210
+    infixr 5 `MkD2Sym2`
     instance SuppressUnusedWarnings (MkD2Sym1 t0123456789876543210) where
       suppressUnusedWarnings = snd (((,) MkD2Sym1KindInference) ())
     data MkD2Sym1 (t0123456789876543210 :: a0123456789876543210 :: GHC.Types.Type) :: forall (b0123456789876543210 :: GHC.Types.Type).