Update th-desugar submodule

This commit looks large, but most of the changes are due to:

* Mechanically changing `Pred` to `Type`, now that the former is a synonym
  for the latter
* Mechanically changing `-Pa` to `-P`, now that `DPat` uses the latter suffix
  instead of the former

Along the way, I was able to delete a couple of extraneous functions (e.g.,
`substPred`). On the flip side, I had to add a couple of failure cases for
`DArrowT`/`DLitT` in functions that only accept `DPred`. Oh well.

cabal.project

@@ -4,4 +4,4 @@ packages: .
 source-repository-package
   type: git
   location: https://github.com/goldfirere/th-desugar
-  tag: 567145eddeb5f6692a75e74d4a2dc575b1ad6f29
+  tag: 8495349a53f4bc3bde30378f2d85a07aae53bdbd

src/Data/Singletons/CustomStar.hs

@@ -76,7 +76,7 @@ singletonStar names = do
   kinds <- mapM getKind names
   ctors <- zipWithM (mkCtor True) names kinds
   let repDecl = DDataD Data [] repName [] (Just (DConT typeKindName)) ctors
-                         [DDerivClause Nothing (map DConPr [''Eq, ''Ord, ''Read, ''Show])]
+                         [DDerivClause Nothing (map DConT [''Eq, ''Ord, ''Read, ''Show])]
   fakeCtors <- zipWithM (mkCtor False) names kinds
   let dataDecl = DataDecl repName [] fakeCtors
   -- Why do we need withLocalDeclarations here? It's because we end up
@@ -86,7 +86,7 @@ singletonStar names = do
   withLocalDeclarations (decToTH repDecl) $ do
     -- We opt to infer the constraints for the Eq instance here so that when it's
     -- promoted, Rep will be promoted to Type.
-    dataDeclEqCxt <- inferConstraints (DConPr ''Eq) (DConT repName) fakeCtors
+    dataDeclEqCxt <- inferConstraints (DConT ''Eq) (DConT repName) fakeCtors
     let dataDeclEqInst = DerivedDecl (Just dataDeclEqCxt) (DConT repName) dataDecl
     ordInst  <- mkOrdInstance Nothing (DConT repName) dataDecl
     showInst <- mkShowInstance Nothing (DConT repName) dataDecl

src/Data/Singletons/Deriving/Bounded.hs

@@ -50,7 +50,7 @@ mkBoundedInstance mb_ctxt ty (DataDecl _ _ cons) = do
           in (minEqnRHS, maxEqnRHS)
 
       mk_rhs rhs = UFunction [DClause [] rhs]
-  constraints <- inferConstraintsDef mb_ctxt (DConPr boundedName) ty cons
+  constraints <- inferConstraintsDef mb_ctxt (DConT boundedName) ty cons
   return $ InstDecl { id_cxt = constraints
                     , id_name = boundedName
                     , id_arg_tys = [ty]

src/Data/Singletons/Deriving/Enum.hs

@@ -33,15 +33,15 @@ mkEnumInstance mb_ctxt ty (DataDecl data_name tvbs cons) = do
               non_vanilla || not (null $ tysOfConFields f)) cons) $
     fail ("Can't derive Enum instance for " ++ pprint (typeToTH ty) ++ ".")
   n <- qNewName "n"
-  let to_enum = UFunction [DClause [DVarPa n] (to_enum_rhs cons [0..])]
+  let to_enum = UFunction [DClause [DVarP n] (to_enum_rhs cons [0..])]
       to_enum_rhs [] _ = DVarE errorName `DAppE` DLitE (StringL "toEnum: bad argument")
       to_enum_rhs (DCon _ _ name _ _ : rest) (num:nums) =
         DCaseE (DVarE equalsName `DAppE` DVarE n `DAppE` DLitE (IntegerL num))
-          [ DMatch (DConPa trueName []) (DConE name)
-          , DMatch (DConPa falseName []) (to_enum_rhs rest nums) ]
+          [ DMatch (DConP trueName []) (DConE name)
+          , DMatch (DConP falseName []) (to_enum_rhs rest nums) ]
       to_enum_rhs _ _ = error "Internal error: exhausted infinite list in to_enum_rhs"
 
-      from_enum = UFunction (zipWith (\i con -> DClause [DConPa (extractName con) []]
+      from_enum = UFunction (zipWith (\i con -> DClause [DConP (extractName con) []]
                                                         (DLitE (IntegerL i)))
                                      [0..] cons)
   return (InstDecl { id_cxt     = fromMaybe [] mb_ctxt

src/Data/Singletons/Deriving/Foldable.hs

@@ -69,17 +69,17 @@ mkFoldableInstance mb_ctxt ty dd@(DataDecl _ _ cons) = do
       mk_foldMap_clause :: DCon -> q DClause
       mk_foldMap_clause con = do
         parts <- foldDataConArgs ft_foldMap con
-        clause_for_foldMap [DVarPa f] con =<< sequence parts
+        clause_for_foldMap [DVarP f] con =<< sequence parts
 
       mk_foldr_clause :: DCon -> q DClause
       mk_foldr_clause con = do
         parts <- foldDataConArgs ft_foldr con
-        clause_for_foldr [DVarPa f, DVarPa z] con =<< sequence parts
+        clause_for_foldr [DVarP f, DVarP z] con =<< sequence parts
 
       mk_foldMap :: q [DClause]
       mk_foldMap =
         case cons of
-          [] -> pure [DClause [DWildPa, DWildPa] (DVarE memptyName)]
+          [] -> pure [DClause [DWildP, DWildP] (DVarE memptyName)]
           _  -> traverse mk_foldMap_clause cons
 
       mk_foldr :: q [DClause]
@@ -91,7 +91,7 @@ mkFoldableInstance mb_ctxt ty dd@(DataDecl _ _ cons) = do
               : case cons of
                   [] -> []
                   _  -> [(foldrName, UFunction foldr_clauses)]
-  constraints <- inferConstraintsDef mb_ctxt (DConPr foldableName) ty cons
+  constraints <- inferConstraintsDef mb_ctxt (DConT foldableName) ty cons
   return $ InstDecl { id_cxt = constraints
                     , id_name = foldableName
                     , id_arg_tys = [ty]

src/Data/Singletons/Deriving/Functor.hs

@@ -61,28 +61,28 @@ mkFunctorInstance mb_ctxt ty dd@(DataDecl _ _ cons) = do
       mk_fmap_clause :: DCon -> q DClause
       mk_fmap_clause con = do
         parts <- foldDataConArgs ft_fmap con
-        clause_for_con [DVarPa f] con =<< sequence parts
+        clause_for_con [DVarP f] con =<< sequence parts
 
       mk_replace_clause :: DCon -> q DClause
       mk_replace_clause con = do
         parts <- foldDataConArgs ft_replace con
-        clause_for_con [DVarPa z] con =<< traverse (fmap replace) parts
+        clause_for_con [DVarP z] con =<< traverse (fmap replace) parts
 
       mk_fmap :: q [DClause]
       mk_fmap = case cons of
                   [] -> do v <- newUniqueName "v"
-                           pure [DClause [DWildPa, DVarPa v] (DCaseE (DVarE v) [])]
+                           pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])]
                   _  -> traverse mk_fmap_clause cons
 
       mk_replace :: q [DClause]
       mk_replace = case cons of
                      [] -> do v <- newUniqueName "v"
-                              pure [DClause [DWildPa, DVarPa v] (DCaseE (DVarE v) [])]
+                              pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])]
                      _  -> traverse mk_replace_clause cons
 
   fmap_clauses    <- mk_fmap
   replace_clauses <- mk_replace
-  constraints <- inferConstraintsDef mb_ctxt (DConPr functorName) ty cons
+  constraints <- inferConstraintsDef mb_ctxt (DConT functorName) ty cons
   return $ InstDecl { id_cxt = constraints
                     , id_name = functorName
                     , id_arg_tys = [ty]

src/Data/Singletons/Deriving/Infer.hs

@@ -128,7 +128,7 @@ inferConstraints pr inst_ty = fmap (nubBy geq) . concatMapM infer_ct
                       Just subst -> traverse (substTy subst) field_tys
       if is_functor_like
          then mk_functor_like_constraints field_tys' res_ty'
-         else pure $ map (pr `DAppPr`) field_tys'
+         else pure $ map (pr `DAppT`) field_tys'
 
     -- If we derive a Functor-like class, e.g.,
     --
@@ -146,11 +146,11 @@ inferConstraints pr inst_ty = fmap (nubBy geq) . concatMapM infer_ct
           (_, last_res_ty_arg) = snocView res_ty_args
           Just last_tv         = getDVarTName_maybe last_res_ty_arg
       deep_subtypes <- concatMapM (deepSubtypesContaining last_tv) fields
-      pure $ map (pr `DAppPr`) deep_subtypes
+      pure $ map (pr `DAppT`) deep_subtypes
 
     is_functor_like :: Bool
     is_functor_like
-      | DConT pr_class_name :| _ <- unfoldType (predToType pr)
+      | DConT pr_class_name :| _ <- unfoldType pr
       = isFunctorLikeClassName pr_class_name
       | otherwise
       = False

src/Data/Singletons/Deriving/Ord.hs

@@ -24,7 +24,7 @@ import Data.Singletons.Syntax
 -- | Make a *non-singleton* Ord instance
 mkOrdInstance :: DsMonad q => DerivDesc q
 mkOrdInstance mb_ctxt ty (DataDecl _ _ cons) = do
-  constraints <- inferConstraintsDef mb_ctxt (DConPr ordName) ty cons
+  constraints <- inferConstraintsDef mb_ctxt (DConT ordName) ty cons
   compare_eq_clauses <- mapM mk_equal_clause cons
   let compare_noneq_clauses = map (uncurry mk_nonequal_clause)
                                   [ (con1, con2)
@@ -45,8 +45,8 @@ mk_equal_clause (DCon _tvbs _cxt name fields _rty) = do
   let tys = tysOfConFields fields
   a_names <- mapM (const $ newUniqueName "a") tys
   b_names <- mapM (const $ newUniqueName "b") tys
-  let pat1 = DConPa name (map DVarPa a_names)
-      pat2 = DConPa name (map DVarPa b_names)
+  let pat1 = DConP name (map DVarP a_names)
+      pat2 = DConP name (map DVarP b_names)
   return $ DClause [pat1, pat2] (DVarE foldlName `DAppE`
                                  DVarE thenCmpName `DAppE`
                                  DConE cmpEQName `DAppE`
@@ -63,9 +63,9 @@ mk_nonequal_clause (DCon _tvbs1 _cxt1 name1 fields1 _rty1, n1)
                           EQ -> DConE cmpEQName
                           GT -> DConE cmpGTName)
   where
-    pat1 = DConPa name1 (map (const DWildPa) (tysOfConFields fields1))
-    pat2 = DConPa name2 (map (const DWildPa) (tysOfConFields fields2))
+    pat1 = DConP name1 (map (const DWildP) (tysOfConFields fields1))
+    pat2 = DConP name2 (map (const DWildP) (tysOfConFields fields2))
 
 -- A variant of mk_equal_clause tailored to empty datatypes
 mk_empty_clause :: DClause
-mk_empty_clause = DClause [DWildPa, DWildPa] (DConE cmpEQName)
+mk_empty_clause = DClause [DWildP, DWildP] (DConE cmpEQName)

src/Data/Singletons/Deriving/Show.hs

@@ -30,7 +30,7 @@ import GHC.Show (appPrec, appPrec1)
 mkShowInstance :: DsMonad q => DerivDesc q
 mkShowInstance mb_ctxt ty (DataDecl _ _ cons) = do
   clauses <- mk_showsPrec cons
-  constraints <- inferConstraintsDef mb_ctxt (DConPr showName) ty cons
+  constraints <- inferConstraintsDef mb_ctxt (DConT showName) ty cons
   return $ InstDecl { id_cxt = constraints
                     , id_name = showName
                     , id_arg_tys = [ty]
@@ -42,7 +42,7 @@ mk_showsPrec cons = do
     p <- newUniqueName "p" -- The precedence argument (not always used)
     if null cons
        then do v <- newUniqueName "v"
-               pure [DClause [DWildPa, DVarPa v] (DCaseE (DVarE v) [])]
+               pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])]
        else mapM (mk_showsPrec_clause p) cons
 
 mk_showsPrec_clause :: forall q. DsMonad q
@@ -54,7 +54,7 @@ mk_showsPrec_clause p (DCon _ _ con_name con_fields _) = go con_fields
 
     -- No fields: print just the constructor name, with no parentheses
     go (DNormalC _ []) = return $
-      DClause [DWildPa, DConPa con_name []] $
+      DClause [DWildP, DConP con_name []] $
         DVarE showStringName `DAppE` dStringE (parenInfixConName con_name "")
 
     -- Infix constructors have special Show treatment.
@@ -70,7 +70,7 @@ mk_showsPrec_clause p (DCon _ _ con_name con_fields _) = go con_fields
                           -- Make sure to handle infix data constructors
                           -- like (Int `Foo` Int)
                           else " `" ++ op_name ++ "` "
-      return $ DClause [DVarPa p, DConPa con_name [DVarPa argL, DVarPa argR]] $
+      return $ DClause [DVarP p, DConP con_name [DVarP argL, DVarP argR]] $
         (DVarE showParenName `DAppE` (DVarE gtName `DAppE` DVarE p
                                                    `DAppE` dIntegerE con_prec))
           `DAppE` (DVarE composeName
@@ -91,7 +91,7 @@ mk_showsPrec_clause p (DCon _ _ con_name con_fields _) = go con_fields
                          `DAppE` (DVarE showStringName
                                    `DAppE` dStringE (parenInfixConName con_name " "))
                          `DAppE` composed_args
-      return $ DClause [DVarPa p, DConPa con_name $ map DVarPa args] $
+      return $ DClause [DVarP p, DConP con_name $ map DVarP args] $
         DVarE showParenName
           `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
           `DAppE` named_args
@@ -121,7 +121,7 @@ mk_showsPrec_clause p (DCon _ _ con_name con_fields _) = go con_fields
                          `DAppE` (DVarE showStringName
                                    `DAppE` dStringE (parenInfixConName con_name " "))
                          `DAppE` composed_args
-      return $ DClause [DVarPa p, DConPa con_name $ map DVarPa args] $
+      return $ DClause [DVarP p, DConP con_name $ map DVarP args] $
         DVarE showParenName
           `DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
           `DAppE` named_args
@@ -156,7 +156,7 @@ mkShowSingContext :: DCxt -> DCxt
 mkShowSingContext = map show_to_SingShow
   where
     show_to_SingShow :: DPred -> DPred
-    show_to_SingShow = modifyConNameDPred $ \n ->
+    show_to_SingShow = modifyConNameDType $ \n ->
                          if n == showName
                             then showSingName
                             else n

src/Data/Singletons/Deriving/Traversable.hs

@@ -51,17 +51,17 @@ mkTraversableInstance mb_ctxt ty dd@(DataDecl _ _ cons) = do
       mk_trav_clause :: DCon -> q DClause
       mk_trav_clause con = do
         parts <- foldDataConArgs ft_trav con
-        clause_for_con [DVarPa f] con =<< sequence parts
+        clause_for_con [DVarP f] con =<< sequence parts
 
       mk_trav :: q [DClause]
       mk_trav = case cons of
                   [] -> do v <- newUniqueName "v"
-                           pure [DClause [DWildPa, DVarPa v]
+                           pure [DClause [DWildP, DVarP v]
                                          (DVarE pureName `DAppE` DCaseE (DVarE v) [])]
                   _  -> traverse mk_trav_clause cons
 
   trav_clauses <- mk_trav
-  constraints <- inferConstraintsDef mb_ctxt (DConPr traversableName) ty cons
+  constraints <- inferConstraintsDef mb_ctxt (DConT traversableName) ty cons
   return $ InstDecl { id_cxt = constraints
                     , id_name = traversableName
                     , id_arg_tys = [ty]

src/Data/Singletons/Deriving/Util.hs

@@ -208,7 +208,7 @@ functorLikeValidityChecks allowConstrainedLastTyVar (DataDecl n data_tvbs cons)
       = do ex_tvbs <- conExistentialTvbs (foldTypeTvbs (DConT n) data_tvbs) con
            let univ_tvb_names = map extractTvbName con_tvbs \\ map extractTvbName ex_tvbs
            if last_tv `elem` univ_tvb_names
-                && last_tv `Set.notMember` foldMap fvDPred con_theta
+                && last_tv `Set.notMember` foldMap fvDType con_theta
               then pure ()
               else fail $ badCon con_name existential
       | otherwise
@@ -297,7 +297,7 @@ mkSimpleConClause :: Quasi q
                   -> q DClause
 mkSimpleConClause fold extra_pats (DCon _ _ con_name _ _) insides = do
   vars_needed <- replicateM (length insides) $ newUniqueName "a"
-  let pat = DConPa con_name (map DVarPa vars_needed)
+  let pat = DConP con_name (map DVarP vars_needed)
       rhs = fold con_name (zipWith (\i v -> i `DAppE` DVarE v) insides vars_needed)
   pure $ DClause (extra_pats ++ [pat]) rhs
 

src/Data/Singletons/Names.hs

@@ -285,7 +285,7 @@ singFamily :: DType
 singFamily = DConT singFamilyName
 
 singKindConstraint :: DKind -> DPred
-singKindConstraint = DAppPr (DConPr singKindClassName)
+singKindConstraint = DAppT (DConT singKindClassName)
 
 demote :: DType
 demote = DConT demoteName
@@ -302,9 +302,9 @@ mkListE =
 foldApply :: DType -> [DType] -> DType
 foldApply = foldl apply
 
--- make and equality predicate
+-- make an equality predicate
 mkEqPred :: DType -> DType -> DPred
-mkEqPred ty1 ty2 = foldPred (DConPr equalityName) [ty1, ty2]
+mkEqPred ty1 ty2 = foldType (DConT equalityName) [ty1, ty2]
 
 -- | If a 'String' begins with one or more underscores, return
 -- @'Just' (us, rest)@, where @us@ contain all of the underscores at the
@@ -315,16 +315,18 @@ splitUnderscores s = case span (== '_') s of
                        ([], _) -> Nothing
                        res     -> Just res
 
--- Walk a DPred, applying a function to all occurrences of constructor names.
-modifyConNameDPred :: (Name -> Name) -> DPred -> DPred
-modifyConNameDPred mod_con_name = go
+-- Walk a DType, applying a function to all occurrences of constructor names.
+modifyConNameDType :: (Name -> Name) -> DType -> DType
+modifyConNameDType mod_con_name = go
   where
-    go (DForallPr tvbs cxt p) = DForallPr tvbs (map go cxt) (go p)
-    go (DAppPr p t)           = DAppPr (go p) t
-    go (DSigPr p k)           = DSigPr (go p) k
-    go p@(DVarPr _)           = p
-    go (DConPr n)             = DConPr (mod_con_name n)
-    go p@DWildCardPr          = p
+    go (DForallT tvbs cxt p) = DForallT tvbs (map go cxt) (go p)
+    go (DAppT p t)           = DAppT (go p) t
+    go (DSigT p k)           = DSigT (go p) k
+    go p@(DVarT _)           = p
+    go (DConT n)             = DConT (mod_con_name n)
+    go p@DWildCardT          = p
+    go p@(DLitT {})          = p
+    go p@DArrowT             = p
 
 {-
 Note [Defunctionalization symbol suffixes]

src/Data/Singletons/Partition.hs

@@ -89,9 +89,9 @@ partitionDec (DDataD _nd _cxt name tvbs mk cons derivings) = do
       $ concatMap flatten_clause derivings
   return $ mconcat $ derived_dec : derived_decs
   where
-    flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DType)]
+    flatten_clause :: DDerivClause -> [(Maybe DDerivStrategy, DPred)]
     flatten_clause (DDerivClause strat preds) =
-      map (\p -> (strat, predToType p)) preds
+      map (\p -> (strat, p)) preds
 
 partitionDec (DClassD cxt name tvbs fds decs) = do
   (lde, otfs) <- concatMapM partitionClassDec decs
@@ -155,7 +155,7 @@ partitionDec dec =
 partitionClassDec :: Monad m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])
 partitionClassDec (DLetDec (DSigD name ty)) =
   pure (typeBinding name ty, mempty)
-partitionClassDec (DLetDec (DValD (DVarPa name) exp)) =
+partitionClassDec (DLetDec (DValD (DVarP name) exp)) =
   pure (valueBinding name (UValue exp), mempty)
 partitionClassDec (DLetDec (DFunD name clauses)) =
   pure (valueBinding name (UFunction clauses), mempty)
@@ -177,7 +177,7 @@ partitionInstanceDec :: Monad m => DDec
                      -> m ( Maybe (Name, ULetDecRHS) -- right-hand sides of methods
                           , Map Name DType           -- method type signatures
                           )
-partitionInstanceDec (DLetDec (DValD (DVarPa name) exp)) =
+partitionInstanceDec (DLetDec (DValD (DVarP name) exp)) =
   pure (Just (name, UValue exp), mempty)
 partitionInstanceDec (DLetDec (DFunD name clauses)) =
   pure (Just (name, UFunction clauses), mempty)
@@ -196,7 +196,7 @@ partitionDeriving
   :: forall m. DsMonad m
   => Maybe DDerivStrategy
                 -- ^ The deriving strategy, if present.
-  -> DType      -- ^ The class being derived (e.g., 'Eq'), possibly applied to
+  -> DPred      -- ^ The class being derived (e.g., 'Eq'), possibly applied to
                 --   some number of arguments (e.g., @C Int Bool@).
   -> Maybe DCxt -- ^ @'Just' ctx@ if @ctx@ was provided via @StandaloneDeriving@.
                 --   'Nothing' if using a @deriving@ clause.