Reuse expensive computation for day 4 extra tests

Ideally we'd similarly add the ability for later tests to use the results of earlier ones. But this would probably require much heavier type family usage.

haskell/Main.hs

@@ -2,7 +2,6 @@ module Main (main) where
 
 import Pre
 
-import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Puzzles.Day1 qualified as Day1
 import Puzzles.Day10 qualified as Day10
@@ -40,7 +39,7 @@ main =
                  in
                     describe pt do
                         input <- liftIO $ parseFile $ "../inputs/" <> t <> "/" <> pt
-                        sequence_ $ flip mapWithIndexOutputParameterisedFunctionList parts \(show . succ -> n) pp ->
+                        let (os, rs) = applyPuzzleParts input parts
-                            it n . pureGoldenTextFile ("../outputs/" <> t <> "/" <> pt <> "/" <> n) $
+                        for_ (zip [1 :: Int ..] rs) $ uncurry $ \(show -> n) ->
-                                T.show (pp input) <> "\n"
+                            it n . pureGoldenTextFile ("../outputs/" <> t <> "/" <> pt <> "/" <> n) . (<> "\n")
-                        describe "extra" $ extraTests isRealData ("../outputs/" <> t <> "/" <> pt <> "/extra/") input
+                        describe "extra" $ extraTests isRealData ("../outputs/" <> t <> "/" <> pt <> "/extra/") input os

haskell/Pre.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Pre (
@@ -40,10 +41,10 @@ module Pre (
     allUnorderedPairs,
     adjacentPairs,
     sortPair,
-    OutputParameterisedFunctionList,
+    PuzzleParts,
-    mapOutputParameterisedFunctionList,
+    applyPuzzleParts,
-    mapWithIndexOutputParameterisedFunctionList,
     (/\),
+    (/\\),
     nil,
 )
 where
@@ -72,7 +73,7 @@ import Data.Foldable hiding (foldl1, foldr1, maximum, maximumBy, minimum, minimu
 import Data.Foldable1
 import Data.Function
 import Data.Functor
-import Data.Kind (Constraint, Type)
+import Data.Kind (Type)
 import Data.List (List, sortOn, transpose)
 import Data.List.Extra (dropEnd, enumerate, firstJust, notNull, splitOn)
 import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, some1, tail, tails)
@@ -81,6 +82,7 @@ import Data.Ord
 import Data.Sequence (Seq)
 import Data.Stream.Infinite (Stream ((:>)))
 import Data.Text (Text)
+import Data.Text qualified as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Traversable
 import Data.Tuple.Extra ((&&&))
@@ -96,8 +98,8 @@ import Text.Megaparsec.Char.Lexer (decimal)
 data Puzzle = forall input outputs. Puzzle
     { number :: Word
     , parser :: Bool -> Parsec Void Text input
-    , parts :: OutputParameterisedFunctionList Show input outputs
+    , parts :: PuzzleParts input outputs
-    , extraTests :: Bool -> FilePath -> input -> Spec
+    , extraTests :: Bool -> FilePath -> input -> HList outputs -> Spec
     }
 
 digit :: (Token s ~ Char, Num b, MonadParsec e s f) => f b
@@ -125,37 +127,30 @@ adjacentPairs = \case
 sortPair :: (Ord a) => (a, a) -> (a, a)
 sortPair (a, b) = if a <= b then (a, b) else (b, a)
 
+infixr 9 /\\
+(/\\) :: (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
+(/\\) = uncurry PuzzlePartsCons
 infixr 9 /\
-(/\) :: (c output) => (input -> output) -> OutputParameterisedFunctionList c input outputs -> OutputParameterisedFunctionList c input (output : outputs)
+(/\) :: (Show output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
-(/\) = OutputParameterisedFunctionListCons
+(/\) = flip PuzzlePartsCons T.show
-nil :: OutputParameterisedFunctionList c input '[]
+nil :: PuzzleParts input '[]
-nil = OutputParameterisedFunctionListNil
+nil = PuzzlePartsNil
 
-data OutputParameterisedFunctionList (c :: Type -> Constraint) (input :: Type) (outputs :: List Type) :: Type where
+data PuzzleParts (input :: Type) (outputs :: List Type) :: Type where
-    OutputParameterisedFunctionListNil :: OutputParameterisedFunctionList c input '[]
+    PuzzlePartsNil :: PuzzleParts input '[]
-    OutputParameterisedFunctionListCons ::
+    PuzzlePartsCons ::
-        (c output) =>
         (input -> output) ->
-        OutputParameterisedFunctionList c input outputs ->
+        (output -> Text) ->
-        OutputParameterisedFunctionList c input (output ': outputs)
+        PuzzleParts input outputs ->
-mapOutputParameterisedFunctionList ::
+        PuzzleParts input (output ': outputs)
-    (forall output. (c output) => (input -> output) -> a) ->
+applyPuzzleParts ::
-    OutputParameterisedFunctionList c input outputs ->
+    forall input outputs.
-    [a]
+    input ->
-mapOutputParameterisedFunctionList f = \case
+    PuzzleParts input outputs ->
-    OutputParameterisedFunctionListNil -> []
+    (HList outputs, [Text])
-    OutputParameterisedFunctionListCons x xs -> f x : mapOutputParameterisedFunctionList f xs
+applyPuzzleParts e = \case
-mapWithIndexOutputParameterisedFunctionList ::
+    PuzzlePartsNil -> (HNil, [])
-    forall c input outputs a.
+    PuzzlePartsCons f o ps -> let r = f e in bimap (HCons r) (o r :) $ applyPuzzleParts e ps
-    (forall output. (c output) => Int -> (input -> output) -> a) ->
-    OutputParameterisedFunctionList c input outputs ->
-    [a]
-mapWithIndexOutputParameterisedFunctionList f = go 0
-  where
-    go :: Int -> OutputParameterisedFunctionList c input outputs' -> [a]
-    go i = \case
-        OutputParameterisedFunctionListNil -> []
-        OutputParameterisedFunctionListCons x xs -> f i x : go (i + 1) xs
 
 instance Semigroup (TestDefM '[] () ()) where
     (<>) = (>>)

haskell/Puzzles/Day4.hs

@@ -16,17 +16,20 @@ puzzle =
             ( (\g -> countRolls g - countRolls (removeAccessibleRolls $ findAccessible g))
                 . mkGrid
             )
-                /\ ( (\g -> countRolls g - countRolls (fst $ S.head $ S.filter (noneAccessible . snd) $ generateFrames g))
+                /\ ( (id &&& generateFrames) . mkGrid
-                        . mkGrid
+                   , \(g, fs) ->
+                        T.show $ countRolls g - countRolls (fst $ S.head $ S.filter (noneAccessible . snd) fs)
                    )
-                /\ nil
+                /\\ nil
-        , extraTests = \isRealData path input -> do
+        , extraTests = \isRealData path input (HCons _ (HCons (_, fmap snd -> frameStream) HNil)) -> do
             it "round trip" do
                 t <- T.readFile if isRealData then "../inputs/real/4" else "../inputs/examples/4"
                 drawGrid (mkGrid input <&> \case InEmpty -> OutEmpty; InRoll -> OutRoll) `shouldBe` t
             describe "frames" do
-                let frames = Seq.fromList . takeUntil noneAccessible . fmap snd . generateFrames $ mkGrid input
+                let frames = Seq.fromList $ takeUntil noneAccessible frameStream
-                let nFrames = Seq.length frames - 1
+                -- note that `nFrames = Seq.length frames - 1`, but we don't define it as such
+                -- since that would force the expensive evaluation during test tree construction, messing up reporting
+                let nFrames = if isRealData then 58 else 9
                 for_ [0 .. nFrames] \n ->
                     it (show n) . pureGoldenTextFile (path <> "frames/" <> show n) $
                         maybe "frame list too short!" drawGrid (Seq.lookup n frames)