Add a type class for showing values at elaboration time

src/Libraries/Base1/SShow.bs

@@ -0,0 +1,145 @@
+package SShow where
+
+import ListN
+import Vector
+
+{-
+ - Show values at elaboration time as strings, using generics.
+ - Uses classic (Haskell) syntax, like CShow.
+ -}
+
+--@ XXX THIS PACKAGE IS NOT YET DOCUMENTED
+
+class SShow a where
+  -- Show a top-level value with classic syntax
+  sshow :: a -> String
+
+  -- Unambigously show a value with parentheses, if required
+  sshowP :: a -> String
+  sshowP = sshow
+
+-- Explicit instances for various primitive types
+instance SShow (Bit n) where
+  sshow = bitToString
+
+instance SShow (UInt a) where
+  sshow = compose integerToString toStaticIndex
+
+instance SShow (Int a) where
+  sshow = compose integerToString toStaticIndex
+
+instance SShow Integer where
+  sshow = integerToString
+
+instance SShow Real where
+  sshow = realToString
+
+instance SShow Char where
+  sshow x = "'" +++ charToString x +++ "'"
+
+instance SShow String where
+  sshow = doubleQuote  -- XXX should escape special chars
+
+-- SShow for lists and arrays uses [] mirroring Haskell, even though we don't
+-- actually support that syntax for constructing values.
+instance (SShow a) => SShow (List a) where
+  sshow l =
+    let contents =
+          if List.null l then ""
+          else List.foldr1 (\ a b -> a +++ ", " +++ b) $ List.map sshow l
+    in "[" +++ contents +++ "]"
+
+instance (SShow a) => SShow (Array a) where
+  sshow l =
+    let contents =
+          if arrayLength l == 0 then ""
+          else Array.foldr1 (\ a b -> a +++ ", " +++ b) $ Array.map sshow l
+    in "[" +++ contents +++ "]"
+
+-- Show tuple types with tuple syntax rather than PrimPair {...}
+instance SShow () where
+  sshow () = "()"
+
+instance (SShowTuple (a, b)) => SShow (a, b) where
+  sshow x = "("  +++ sshowTuple x +++ ")"
+
+class SShowTuple a where
+  sshowTuple :: a -> String
+
+instance (SShow a, SShowTuple b) => SShowTuple (a, b) where
+  sshowTuple (x, y) = sshow x +++ ", " +++ sshowTuple y
+
+instance (SShow a) => SShowTuple a where
+  sshowTuple = sshow
+
+-- Default generic instance uses the SShow' type class over generic representations
+instance (Generic a r, SShow' r) => SShow a where
+  sshow x = sshow' $ from x
+  sshowP x = sshowP' $ from x
+
+class SShow' a where
+  sshow' :: a -> String
+  sshowP' :: a -> String
+  sshowP' = sshow'
+
+-- Note that there is no instance for SShow' ConcPrim - all showable primitive
+-- types should eventually have SShow instances.  This is because there is no
+-- generic way to show any primitive type.
+
+instance (SShow a) => SShow' (Conc a) where
+  sshow' (Conc x) = sshow x
+  sshowP' (Conc x) = sshowP x
+
+instance SShow' (ConcPoly a) where
+  sshow' (ConcPoly _) = "<polymorphic value>"
+
+-- Note that below there are more specific instances for
+-- SShow' (Meta (MetaConsNamed ...)) and SShow' (Meta (MetaConsAnon ...))
+instance (SShow' a) => SShow' (Meta m a) where
+  sshow' (Meta x) = sshow' x
+  sshowP' (Meta x) = sshowP' x
+
+instance (SShow' a, SShow' b) => SShow' (Either a b) where
+  sshow' (Left x) = sshow' x
+  sshow' (Right x) = sshow' x
+  sshowP' (Left x) = sshowP' x
+  sshowP' (Right x) = sshowP' x
+
+instance (SShowSummand a) => SShow' (Meta (MetaConsNamed name idx nfields) a) where
+  sshow' (Meta x) = stringOf name +++ " {" +++ sshowSummandNamed x +++ "}"
+  sshowP' x = "(" +++ sshow' x +++ ")"
+
+instance (SShowSummand a) => SShow' (Meta (MetaConsAnon name idx nfields) a) where
+  sshow' (Meta x) = stringOf name +++ sshowSummandAnon x
+  sshowP' x = if (valueOf nfields) > 0 then "(" +++ sshow' x +++ ")" else sshow' x
+
+-- Defines the classic-syntax show operation for the representation type of a
+-- single summand's constructor.
+-- We only know whether a constructor is named or anonymous at the top of the
+-- constructor's representation type, so we propagate that information by calling
+-- the appropriate function of this type class.
+class SShowSummand a where
+  sshowSummandNamed :: a -> String
+  sshowSummandAnon  :: a -> String
+
+instance (SShowSummand a, SShowSummand b) => SShowSummand (a, b) where
+  sshowSummandNamed (x, y) = sshowSummandNamed x +++ sshowSummandNamed y
+  sshowSummandAnon  (x, y) = sshowSummandAnon x +++ sshowSummandAnon y
+
+instance SShowSummand () where
+  sshowSummandNamed () = ""
+  sshowSummandAnon  () = ""
+
+instance (SShow' a) => SShowSummand (Meta (MetaField name idx) a) where
+  sshowSummandNamed (Meta x) = (if valueOf idx > 0 then "; " else "") +++ stringOf name +++ "=" +++ sshow' x
+  sshowSummandAnon  (Meta x) = " " +++ sshowP' x
+
+-- SShow for fixed-size collection types uses [] mirroring Haskell, even though we don't
+-- actually support that syntax for constructing values.
+instance (SShow' a) => SShow' (Vector n a) where
+  sshow' v =
+    let contents =
+          if valueOf n > 0
+          then List.foldr1 (\ a b -> a +++ ", " +++ b) $ List.map sshow' $ Vector.toList v
+          else ""
+    in "[" +++ contents +++ "]"

src/Libraries/Base1/depends.mk

@@ -1,5 +1,5 @@
 ## Automatically generated by bluetcl -exec makedepend -- Do NOT EDIT
-## Date: Tue 08 Dec 2020 09:49:58 PM UTC
+## Date: Tue Jul 23 10:01:18 AM PDT 2024
 ## Command: bluetcl -exec makedepend -bdir $(BUILDDIR) *.bs*
 
 $(BUILDDIR)/ActionSeq.bo:	ActionSeq.bs $(BUILDDIR)/List.bo $(BUILDDIR)/Vector.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo
@@ -35,4 +35,5 @@ $(BUILDDIR)/Real.bo:	Real.bs $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo
 $(BUILDDIR)/RegFile.bo:	RegFile.bs $(BUILDDIR)/ConfigReg.bo $(BUILDDIR)/List.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo
 $(BUILDDIR)/Reserved.bo:	Reserved.bs $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo
 $(BUILDDIR)/RevertingVirtualReg.bo:	RevertingVirtualReg.bs $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo
+$(BUILDDIR)/SShow.bo:	SShow.bs $(BUILDDIR)/ListN.bo $(BUILDDIR)/Vector.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo
 $(BUILDDIR)/Vector.bo:	Vector.bs $(BUILDDIR)/List.bo $(BUILDDIR)/Array.bo $(BUILDDIR)/Prelude.bo $(BUILDDIR)/PreludeBSV.bo

testsuite/bsc.lib/SShow/Makefile

@@ -0,0 +1,5 @@
+# for "make clean" to work everywhere
+
+CONFDIR = $(realpath ../..)
+
+include $(CONFDIR)/clean.mk

testsuite/bsc.lib/SShow/SShow.exp

@@ -0,0 +1,6 @@
+
+# tests for elaboration-time classic-syntax show library
+
+compile_verilog_pass TestSShow.bs sysTestSShow
+
+compare_file sysTestSShow.out

testsuite/bsc.lib/SShow/TestSShow.bs

@@ -0,0 +1,47 @@
+package TestSShow where
+
+import SShow
+import ListN
+import Vector
+import BuildVector
+import BuildList
+
+data Foo = A (UInt 8) Bool Bar
+         | B (Int 16)
+         | C
+         | D {a :: (Bit 8); b :: Foo}
+  deriving (FShow)
+
+struct Bar =
+  foo :: Foo
+  x :: (UInt 8)
+ deriving (FShow)
+
+data Baz a = Baz a a
+  deriving (FShow)
+
+struct Qux =
+  x :: a -> a -- Higher rank
+  y :: Int 8
+
+sysTestSShow :: Module Empty
+sysTestSShow = module
+  out <- openFile "sysTestSShow.out" WriteMode
+
+  hPutStrLn out (sshow (42 :: UInt 8))
+  hPutStrLn out (sshow (321 :: Integer))
+  hPutStrLn out (sshow (3.14 :: Real))
+  hPutStrLn out (sshow '*')
+  hPutStrLn out (sshow "Hello")
+  hPutStrLn out (sshow ())
+  hPutStrLn out (sshow (Bar {x=42; foo=C}))
+  hPutStrLn out (sshow (A 12 True (Bar {foo=D {a=34; b=C}; x=42})))
+  hPutStrLn out (sshow (Baz C (A 12 True (Bar {foo=D {a=34; b=C}; x=42}))))
+  hPutStrLn out (sshow ((vec (Bar {x=42; foo=C}) (Bar {x=3; foo=B 2323})) :: Vector 2 Bar))
+  hPutStrLn out (sshow $ vectorToArray ((vec (Bar {x=42; foo=C}) (Bar {x=3; foo=B 2323})) :: Vector 2 Bar))
+  hPutStrLn out (sshow ((lst (Bar {x=42; foo=C}) (Bar {x=3; foo=B 2323})) :: List Bar))
+  hPutStrLn out (sshow ((Bar {x=42; foo=C}) :> (Bar {x=3; foo=B 2323}) :> ListN.nil))
+  hPutStrLn out (sshow ("x", ((Left 123) :: Either (UInt 8) Bar, False)))
+  hPutStrLn out (sshow $ Qux {x = id; y = 42;})
+
+  hClose out

testsuite/bsc.lib/SShow/sysTestSShow.out.expected

@@ -0,0 +1,15 @@
+42
+321
+3.14
+'*'
+"Hello"
+()
+Bar {foo=C; x=42}
+A 12 True (Bar {foo=D {a=34; b=C}; x=42})
+Baz C (A 12 True (Bar {foo=D {a=34; b=C}; x=42}))
+[Bar {foo=C; x=42}, Bar {foo=B 2323; x=3}]
+[Bar {foo=C; x=42}, Bar {foo=B 2323; x=3}]
+[Bar {foo=C; x=42}, Bar {foo=B 2323; x=3}]
+[Bar {foo=C; x=42}, Bar {foo=B 2323; x=3}]
+("x", Left 123, False)
+Qux {x=<polymorphic value>; y=42}