Render type-level lists as [a, b, c] not (: a (: b []))

renderArg now special-cases GHC's promoted cons (`:`) / nil (`[]`)
TyCons and the unapplied list TyCon, unfolding nested cons chains
into Haskell list syntax. Demo gets a Bagful + BagList exhibit so
the path is exercised.

Co-Authored-By: Claude Opus 4.7 (1M context) <[email protected]>

diff --git a/data/viewer.js b/data/viewer.js
index f9329812ccbec7d78ea0490570e27309fa83ec2c..044a0aa78c71da14f6195a61acf184c961ac4e5c 100644 (file)
--- a/data/viewer.js
+++ b/data/viewer.js
@@ -1190,6 +1190,11 @@
     }
     if (a.tag === 'TyConApp' || a.tag === 'FamilyApp') {
       const [q, args] = a.contents;
+      // Promoted-list literal: render `(: x (: y []))` as `[x, y]`.
+      const list = unfoldPromotedList(a);
+      if (list) {
+        return '[' + list.map(x => renderArg(x, boundTvs)).join(', ') + ']';
+      }
       // Infix render for equality/coercibility-like binary operators that
       // appear as TyCons in argument position. Without this they would
       // print as e.g. "(~ a b)".
@@ -1247,6 +1252,52 @@
     return null;
   }
 
+  // Recognise GHC's promoted-list constructors. The dumps use the
+  // unprimed forms (`:`, `[]`) for the type-level cons / nil — GHC's
+  // pretty-printer drops the leading apostrophe when round-tripping
+  // through `splitTyConApp_maybe`. We accept both spellings just in
+  // case future GHCs reintroduce the prime.
+  function isConsTycon(name) {
+    return name === ':' || name === "':" || name === "'(:)";
+  }
+  function isNilTycon(name) {
+    return name === '[]' || name === "'[]";
+  }
+
+  // Try to unfold a TypeArg as either:
+  //   * a promoted-list literal (`(: x (: y []))` → `[x, y]`)
+  //   * the plain list type constructor applied to one arg (`[] a` → `[a]`)
+  //   * the bare list TyCon (`[]` → `[]`)
+  // Returns the element list, or `null` when @a@ isn't a list shape.
+  // Empirically the dumped cons args are `[head, tail]` (kind argument
+  // is stripped by GHC's Type representation); we still support the
+  // 3-arg fallback in case that changes.
+  function unfoldPromotedList(a) {
+    if (!a || a.tag !== 'TyConApp') return null;
+    const [q, args] = a.contents;
+    if (isNilTycon(q.qnName)) {
+      if (!args || args.length === 0) return [];
+      if (args.length === 1) return [args[0]];
+      return null;
+    }
+    if (!isConsTycon(q.qnName)) return null;
+    const items = [];
+    let cur = a;
+    while (cur && cur.tag === 'TyConApp') {
+      const [qq, ag] = cur.contents;
+      if (isNilTycon(qq.qnName)) return items;
+      if (!isConsTycon(qq.qnName)) return null;
+      let head, tail;
+      if (ag && ag.length === 2)      { [head, tail] = ag; }
+      else if (ag && ag.length === 3) { head = ag[1]; tail = ag[2]; }
+      else return null;
+      items.push(head);
+      cur = tail;
+    }
+    return null; // ran off into a TyVar/lit tail — bail and let the
+                 // default renderer handle it.
+  }
+
   // ---------------------------------------------------------------------------
   // Side panel
 

diff --git a/examples/demo/src/Demo/MoreFamilies.hs b/examples/demo/src/Demo/MoreFamilies.hs
index e253755eb93c35b3cb2f3d33ceb76054c8fd0a23..f9d627533258a5ecdaf864d0387264475ad3a331 100644 (file)
--- a/examples/demo/src/Demo/MoreFamilies.hs
+++ b/examples/demo/src/Demo/MoreFamilies.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -10,12 +11,18 @@
 -- row underneath.
 module Demo.MoreFamilies where
 
+import Data.Kind (Type)
+import Data.Proxy (Proxy (..))
 import Demo.Basic (Pretty (..))
 
 -- An open type family whose instances live a few lines below this
 -- declaration. The viewer's family view should list both rows.
 type family Bag a
 
+-- Same as 'Bag' but parameterised by a /promoted-list/ kind, used in
+-- the list-rendering demo below.
+type family BagList (xs :: [Type])
+
 class Boxable a where
   box :: a -> Bag a
 
@@ -46,3 +53,20 @@ data family Crate a
 data instance Crate Int  = CrateInt  Int
 data instance Crate Bool = CrateBool Bool
 data instance Crate [a]  = CrateList [a]
+
+-- A class parameterised by a /promoted-list/ kind. Demonstrates that
+-- the viewer renders `'[Int, Bool]` as `[Int, Bool]`, not the
+-- nested-cons `(: Int (: Bool []))` shape.
+class Bagful (xs :: [Type]) where
+  bagSize :: proxy xs -> Int
+
+instance Bagful '[]                        where bagSize _ = 0
+instance Bagful xs => Bagful (x ': xs)     where bagSize _ = 1 + bagSize (Proxy :: Proxy xs)
+
+type instance BagList '[Int, Bool]    = String
+type instance BagList '[ShelleyEra]   = Int
+type instance BagList '[]             = ()
+
+-- A stand-in for a real Shelley-flavored block type, just to give the
+-- list-of-types demo something with type parameters in it.
+data ShelleyEra