From c0665bd5a68912fa90e5ad632bab4a0baab0e123 Mon Sep 17 00:00:00 2001
From: dalpd <denizalpd@ogr.iu.edu.tr>
Date: Wed, 21 Jul 2021 18:41:55 +0300
Subject: [PATCH] [#14] Add type family to display list of types separated by
 commas

---
 src/Type/Errors/Helpers.hs | 46 +++++++++++++++++++++++++++++++++
 src/Type/Errors/Pretty.hs  | 52 +++++++++++++++++++++++++++++++-------
 2 files changed, 89 insertions(+), 9 deletions(-)
 create mode 100644 src/Type/Errors/Helpers.hs

diff --git a/src/Type/Errors/Helpers.hs b/src/Type/Errors/Helpers.hs
new file mode 100644
index 0000000..a0dd41b
--- /dev/null
+++ b/src/Type/Errors/Helpers.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeInType           #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UnicodeSyntax        #-}
+{-# LANGUAGE UndecidableInstances #-}
+{- |
+Copyright:  (c) 2019-2020 Dmitrii Kovanikov
+            (c) 2020-2021 Kowainik
+SPDX-License-Identifier: MPL-2.0
+Maintainer: Dmitrii Kovanikov <kovanikov@gmail.com>
+            Kowainik <xrom.xkov@gmail.com>
+
+This module provides type-level helpers for operations on type-level lists.
+-}
+module Type.Errors.Helpers
+       ( -- * Helper type families
+         Intercalate,
+       ) where
+
+import GHC.TypeLits
+
+-- | Internal type family to prepend all the elements of a list, used to
+-- construct `Intersperse`.
+type family PrependToAll (sep :: a) (xs :: [a]) :: [a] where
+  PrependToAll _ '[] = '[]
+  PrependToAll sep (x ': xs) = sep ': x ': PrependToAll sep xs
+
+-- | Internal type family to intersperse a list with a given seperator,
+-- type-level version of `Data.List.intersperse`.
+type family Intersperse (sep :: a) (xs :: [a]) :: [a] where
+  Intersperse _ '[] = '[]
+  Intersperse sep (x ': xs) = x ': PrependToAll sep xs
+
+-- | Internal type family to concatenate all the type-level symbols in a list.
+type family Concat (xs :: [Symbol]) :: Symbol where
+  Concat '[] = ""
+  Concat (x:xs) = AppendSymbol x (Concat xs)
+
+{- | Type family to insert a symbol in between a given list of symbols and concatenate.
+
+>>> :kind! Intercalate ", " '["Int", "String", "Bool"]
+Intercalate ", " '["Int", "String", "Bool"] :: Symbol
+= "Int, String, Bool"
+-}
+type family Intercalate (x :: Symbol) (xs :: [Symbol]) :: Symbol where
+  Intercalate x xs = Concat (Intersperse x xs)
diff --git a/src/Type/Errors/Pretty.hs b/src/Type/Errors/Pretty.hs
index 53b14ba..ef619fc 100644
--- a/src/Type/Errors/Pretty.hs
+++ b/src/Type/Errors/Pretty.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE TypeFamilies  #-}
-{-# LANGUAGE TypeInType    #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UnicodeSyntax #-}
-
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeInType           #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UnicodeSyntax        #-}
+{-# LANGUAGE UndecidableInstances #-}
 {- |
 Copyright:  (c) 2019-2020 Dmitrii Kovanikov
-            (c) 2020 Kowainik
+            (c) 2020-2021 Kowainik
 SPDX-License-Identifier: MPL-2.0
 Maintainer: Dmitrii Kovanikov <kovanikov@gmail.com>
             Kowainik <xrom.xkov@gmail.com>
@@ -69,12 +69,15 @@ module Type.Errors.Pretty
          -- * Reexports from "GHC.TypeLits"
        , TypeError
 
-         -- * Helper internal type families
+         -- * Helper type families
        , ToErrorMessage
+       , CommaSeparated
        ) where
 
-import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError)
-
+import Data.Kind
+import GHC.TypeLits (AppendSymbol, ErrorMessage (..), Symbol, TypeError)
+import GHC.Generics
+import Type.Errors.Helpers (Intercalate)
 
 {- | Append two types automatically converting them to corresponding
 'ErrorMessage' constructors.
@@ -114,3 +117,34 @@ type family ToErrorMessage (t :: k) :: ErrorMessage where
     ToErrorMessage (t :: Symbol) = 'Text t
     ToErrorMessage (t :: ErrorMessage) = t
     ToErrorMessage t = 'ShowType t
+
+-- | Internal type family to go from a `Type` to a `Symbol` representation.
+-- The names for types without `Generic` instances have to be defined
+-- manually, and we do so for a handful of common types.
+type family TypeName (a :: Type) :: Symbol where
+  TypeName Char = "Char"
+  TypeName String = "String"
+  TypeName Int  = "Int"
+  TypeName (Maybe a) = AppendSymbol "Maybe " (TypeName a)
+  TypeName [a] = AppendSymbol "[" (AppendSymbol (TypeName a) "]")
+  TypeName (D1 ('MetaData name _ _ _) _ _) = name
+  TypeName a = TypeName (Rep a ())
+
+-- | Internal type family to map over a list of `Type`s while applying
+-- `TypeName` to each, returning a list of `Symbol`s.
+type family CommaSeparated' (ts :: [Type]) :: [Symbol] where
+  CommaSeparated' '[] = '[]
+  CommaSeparated' (t ': ts) = TypeName t ': CommaSeparated' ts
+
+{- | Type family to display a list of types separated by commas.
+
+@
+__data__ UserDefinedTypeDerivingGeneric = C1 | C2 __deriving__ Generic
+@
+>>> :kind! CommaSeparated '[Int, String, Maybe Int, [[[Char]]], UserDefinedTypeDerivingGeneric]
+CommaSeparated '[Int, String, Maybe Int, [[[Char]]], UserDefinedTypeDerivingGeneric] :: Symbol
+= "Int, String, Maybe Int, [[String]], UserDefinedTypeDerivingGeneric"
+
+-}
+type family CommaSeparated (ts :: [Type]) :: Symbol where
+  CommaSeparated ts = Intercalate ", " (CommaSeparated' ts)