Avoid forcing puzzle parts outputs

Note that:
- This allows us to remove some very temporary hacky code from day 4.
- This includes a refactoring to hide `TestTree`, which could in theory have been made separate.
- This reverts a lot of 1163889.

haskell/Main.hs

@@ -19,8 +19,8 @@ import Text.Pretty.Simple (pPrintForceColor)
 
 main :: IO ()
 main =
-    (pPrintForceColor =<<) $ runTests () $ TestTree "tests" pure $ flip map enumerate \isRealData@(bool "examples" "real" -> t) ->
+    (pPrintForceColor =<<) $ runTests () $ test "tests" pure $ flip map enumerate \isRealData@(bool "examples" "real" -> t) ->
-        TestTree (mkTestName t) pure $ flip
+        test (mkTestName t) pure $ flip
             map
             [ Day1.puzzle
             , Day2.puzzle
@@ -34,7 +34,7 @@ main =
             , Day10.puzzle
             ]
             \Puzzle{number = show -> pt, parser, parts, extraTests} ->
-                TestTree
+                testLazy
                     (mkTestName pt)
                     ( \() -> do
                         let fp = "../inputs/" <> t <> "/" <> pt
@@ -43,12 +43,12 @@ main =
                                 . runParser (parser isRealData <* eof) fp
                                 =<< T.readFile fp
                         let (rs, os) =
-                                (lookupHList (fst . getCompose) &&& foldHListF (withConstrained HConsC . snd . getCompose) HNilC) $
+                                (lookupHList fst &&& foldHListF (HCons . snd) HNil) $
-                                    mapHListF (\(Compose (Fanout (f, Op o))) -> Compose $ (o &&& id) $ f input) parts
+                                    mapHListF (\((Fanout (f, Op o))) -> (o &&& id) $ f input) parts
                          in pure (input, rs, os)
                     )
                     $ ( finites <&> \(n@(show . succ @Int . fromIntegral -> nt)) ->
-                            TestTree
+                            test
                                 (mkTestName nt)
                                 (\(_, rs, _) -> golden ("../outputs/" <> t <> "/" <> pt <> "/" <> nt) $ rs n <> "\n")
                                 []
@@ -56,4 +56,4 @@ main =
                         <> let ts = extraTests isRealData ("../outputs/" <> t <> "/" <> pt <> "/extra/")
                             in if null ts
                                 then []
-                                else [TestTree "extra" (\(input, _, os) -> pure (input, os)) ts]
+                                else [testLazy "extra" (\(input, _, os) -> pure (input, os)) ts]

haskell/Pre.hs

@@ -57,7 +57,9 @@ module Pre (
     withConstrained,
     Fanout (..),
     Length,
-    TestTree (..),
+    TestTree,
+    test,
+    testLazy,
     TestName,
     mkTestName,
     getTestTree,
@@ -130,7 +132,7 @@ data Puzzle = forall input outputs. (KnownNat (Length outputs), NFData input) =>
     { number :: Word
     , parser :: Bool -> Parsec Void Text input
     , parts :: PuzzleParts input outputs
-    , extraTests :: Bool -> FilePath -> [TestTree IO (input, HListC NFData outputs)]
+    , extraTests :: Bool -> FilePath -> [TestTree IO (input, HList outputs)]
     }
 
 digit :: (Token s ~ Char, Num b, MonadParsec e s f) => f b
@@ -158,13 +160,13 @@ adjacentPairs = \case
 sortPair :: (Ord a) => (a, a) -> (a, a)
 sortPair (a, b) = if a <= b then (a, b) else (b, a)
 
-type PuzzleParts input = HListF (Compose (Fanout ((->) input) (Op Text)) (Constrained NFData))
+type PuzzleParts input = HListF ((Fanout ((->) input) (Op Text)))
 infixr 9 /\\
-(/\\) :: (NFData output) => (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
+(/\\) :: (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
-(/\\) (f, o) = HConsF $ Compose $ Fanout (Constrained . f, Op $ withConstrained o)
+(/\\) (f, o) = HConsF $ Fanout (f, Op o)
 infixr 9 /\
-(/\) :: (Show output, NFData output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
+(/\) :: (Show output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
-(/\) f = HConsF $ Compose $ Fanout (Constrained . f, Op $ withConstrained T.show)
+(/\) f = HConsF $ Fanout (f, Op T.show)
 nil :: PuzzleParts input '[]
 nil = HNilF
 
@@ -221,7 +223,21 @@ type family Length as :: Nat where
     Length (x ': xs) = Length xs + 1
 
 data TestTree m input where
-    TestTree :: (NFData output) => TestName -> (input -> m output) -> [TestTree m output] -> TestTree m input
+    TestTree :: TestName -> TestCase m input output -> [TestTree m output] -> TestTree m input
+
+data TestCase m input output where
+    TestCase :: (NFData output) => (input -> m output) -> TestCase m input output
+    TestCaseLazy :: (input -> m output) -> TestCase m input output
+
+-- | See `testLazy` for avoiding the `NFData` constraint.
+test :: (NFData output) => TestName -> (input -> m output) -> [TestTree m output] -> TestTree m input
+test n f = TestTree n $ TestCase f
+
+{- | This is `test` without the `NFData` constraint.
+It doesn't force the output before completion, which means that reported timings may be less accurate.
+-}
+testLazy :: TestName -> (input -> m output) -> [TestTree m output] -> TestTree m input
+testLazy n f = TestTree n $ TestCaseLazy f
 
 data TestResult
     = Pass TestName NominalDiffTime [TestResult]
@@ -242,17 +258,20 @@ getTestTree :: TestTree m r -> Tree TestName
 getTestTree (TestTree name _ ts) = Node name $ map getTestTree ts
 
 runTests :: (MonadIO m, MonadCatch m) => a -> TestTree m a -> m TestResult
-runTests r0 (TestTree name f ts) =
+runTests r0 (TestTree name tc ts) =
-    Control.Monad.Catch.try (timed $ f r0) >>= \case
+    Control.Monad.Catch.try (runTest tc) >>= \case
         Left e ->
             pure $ Fail name $ SomeExceptionLegalShow e
         Right (r, dt) ->
             Pass name dt <$> for ts (runTests r)
   where
-    timed x = do
+    runTest = \case
+        TestCase f -> timed (liftIO . evaluate . DeepSeq.force) $ f r0
+        TestCaseLazy f -> timed pure $ f r0
+    timed f x = do
         t0 <- liftIO getCurrentTime
         r <- x
-        rf <- liftIO $ evaluate $ DeepSeq.force r
+        rf <- f r
         t1 <- liftIO getCurrentTime
         pure (rf, diffUTCTime t1 t0)
 

haskell/Puzzles/Day4.hs

@@ -6,7 +6,6 @@ import Data.Sequence qualified as Seq
 import Data.Stream.Infinite qualified as S
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
-import Control.DeepSeq (rnf)
 
 puzzle :: Puzzle
 puzzle =
@@ -23,16 +22,16 @@ puzzle =
                    )
                 /\\ nil
         , extraTests = \isRealData path ->
-            [ TestTree
+            [ test
                 "round trip"
                 ( \(input, _) -> do
                     t <- T.readFile if isRealData then "../inputs/real/4" else "../inputs/examples/4"
                     assertEqual t $ drawGrid (mkGrid input <&> \case InEmpty -> OutEmpty; InRoll -> OutRoll)
                 )
                 []
-            , TestTree
+            , test
                 "frames"
-                ( \(_, (HConsC _ (HConsC (_, fmap snd -> frameStream) HNilC))) ->
+                ( \(_, (HCons _ (HCons (_, fmap snd -> frameStream) HNil))) ->
                     pure $ Seq.fromList $ takeUntil noneAccessible frameStream
                 )
                 let nFrames = if isRealData then 58 else 9
@@ -41,7 +40,7 @@ puzzle =
                             Seq.lookup n frames
                  in map
                         ( \n ->
-                            TestTree
+                            test
                                 (mkTestName $ show n)
                                 ( \frames -> do
                                     g <- lookupFrame n frames
@@ -50,7 +49,7 @@ puzzle =
                                 []
                         )
                         [0 .. nFrames]
-                        <> [ TestTree
+                        <> [ test
                                 "end"
                                 ( \frames -> do
                                     assertEqual (nFrames + 1) (Seq.length frames)
@@ -134,7 +133,3 @@ takeUntil p = foldr (\x xs -> x : if p x then [] else xs) []
 
 unfoldMutual :: (a -> b) -> (b -> a) -> a -> Stream (a, b)
 unfoldMutual f g a = let b = f a in (a, b) :> unfoldMutual f g (g b)
-
--- TODO this is a junk instance which sort-of works because we never truly care about forcing this
-instance NFData (Stream a) where
-    rnf a = ()