From 3fd8d35cca2a23c137934a170c67e8ce310edf13 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Tue, 29 Apr 2025 15:54:12 +0200
Subject: Complete monoidal accumulator rewrite

---
 src/Interpreter/Rep.hs | 40 ++++++++++++++++++++++++++++++++++------
 1 file changed, 34 insertions(+), 6 deletions(-)

(limited to 'src/Interpreter/Rep.hs')

diff --git a/src/Interpreter/Rep.hs b/src/Interpreter/Rep.hs
index 1226b0c..070ba4c 100644
--- a/src/Interpreter/Rep.hs
+++ b/src/Interpreter/Rep.hs
@@ -1,11 +1,16 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Interpreter.Rep where
 
+import Control.DeepSeq
+import Data.Coerce (coerce)
 import Data.List (intersperse, intercalate)
 import Data.Foldable (toList)
 import Data.IORef
+import GHC.Exts (withDict)
 
 import Array
 import AST
@@ -58,12 +63,12 @@ showValue d (STArr _ t) arr = showParen (d > 10) $
   . showString " ["
   . foldr (.) id (intersperse (showString ",") $ map (showValue 0 t) (toList arr))
   . showString "]"
-showValue _ (STScal sty) x = case sty of
-  STF32 -> shows x
-  STF64 -> shows x
-  STI32 -> shows x
-  STI64 -> shows x
-  STBool -> shows x
+showValue d (STScal sty) x = case sty of
+  STF32 -> showsPrec d x
+  STF64 -> showsPrec d x
+  STI32 -> showsPrec d x
+  STI64 -> showsPrec d x
+  STBool -> showsPrec d x
 showValue _ (STAccum t) _ = showString $ "<accumulator for " ++ ppSMTy 0 t ++ ">"
 showValue _ (STLEither _ _) Nothing = showString "LNil"
 showValue d (STLEither a _) (Just (Left x)) = showParen (d > 10) $ showString "LInl " . showValue 11 a x
@@ -75,3 +80,26 @@ showEnv = \env vals -> "[" ++ intercalate ", " (showEntries env vals) ++ "]"
     showEntries :: SList STy env -> SList Value env -> [String]
     showEntries SNil SNil = []
     showEntries (t `SCons` env) (Value x `SCons` xs) = showValue 0 t x "" : showEntries env xs
+
+rnfRep :: STy t -> Rep t -> ()
+rnfRep STNil () = ()
+rnfRep (STPair a b) (x, y) = rnfRep a x `seq` rnfRep b y
+rnfRep (STEither a _) (Left x) = rnfRep a x
+rnfRep (STEither _ b) (Right y) = rnfRep b y
+rnfRep (STMaybe _) Nothing = ()
+rnfRep (STMaybe t) (Just x) = rnfRep t x
+rnfRep (STArr (_ :: SNat n) (t :: STy t2)) arr =
+  withDict @(KnownTy t2) t $ rnf (coerce @(Array n (Rep t2)) @(Array n (Value t2)) arr)
+rnfRep (STScal t) x = case t of
+  STI32 -> rnf x
+  STI64 -> rnf x
+  STF32 -> rnf x
+  STF64 -> rnf x
+  STBool -> rnf x
+rnfRep STAccum{} _ = error "Cannot rnf accumulators"
+rnfRep (STLEither _ _) Nothing = ()
+rnfRep (STLEither a _) (Just (Left x)) = rnfRep a x
+rnfRep (STLEither _ b) (Just (Right y)) = rnfRep b y
+
+instance KnownTy t => NFData (Value t) where
+  rnf (Value x) = rnfRep (knownTy @t) x
-- 
cgit v1.2.3-70-g09d2