Add timing information to tests

Most of this is concerned with propagating `NFData` constraints.

haskell/Main.hs

@@ -43,8 +43,8 @@ main =
                                 . runParser (parser isRealData <* eof) fp
                                 =<< T.readFile fp
                         let (rs, os) =
-                                (lookupHList fst &&& foldHListF (HCons . snd) HNil) $
+                                (lookupHList (fst . getCompose) &&& foldHListF ((\(Constrained x) -> HConsC x) . snd . getCompose) HNilC) $
-                                    mapHListF (\(Fanout (f, Op o)) -> (o &&& id) $ f input) parts
+                                    mapHListF (\(Compose (Fanout (f, Op o))) -> Compose $ (o &&& id) $ f input) parts
                          in pure (input, rs, os)
                     )
                     $ ( finites <&> \(n@(show . succ @Int . fromIntegral -> nt)) ->

haskell/Pre.hs

@@ -5,6 +5,7 @@
 module Pre (
     module BasePrelude,
     module Control.Applicative,
+    module Control.DeepSeq,
     module Control.Monad,
     module Control.Monad.Loops,
     module Control.Monad.State,
@@ -15,6 +16,7 @@ module Pre (
     module Data.Foldable1,
     module Data.Function,
     module Data.Functor,
+    module Data.Functor.Compose,
     module Data.List,
     module Data.List.Extra,
     module Data.List.NonEmpty,
@@ -28,6 +30,7 @@ module Pre (
     module Data.Tuple.Extra,
     module Data.Void,
     module Data.Word,
+    module GHC.Generics,
     module Linear,
     module Safe,
     module Text.Megaparsec,
@@ -41,6 +44,7 @@ module Pre (
     adjacentPairs,
     sortPair,
     HList (..),
+    HListC (..),
     HListF (..),
     foldHListF,
     foldHListF0,
@@ -49,6 +53,7 @@ module Pre (
     (/\),
     (/\\),
     nil,
+    Constrained (..),
     Fanout (..),
     Length,
     TestTree (..),
@@ -76,7 +81,9 @@ import "base" Prelude as BasePrelude hiding (
  )
 
 import Control.Applicative
-import Control.Exception (SomeException)
+import Control.DeepSeq (NFData, deepseq)
+import Control.DeepSeq qualified as DeepSeq
+import Control.Exception (SomeException, evaluate)
 import Control.Monad
 import Control.Monad.Catch (MonadCatch, try)
 import Control.Monad.Loops
@@ -89,8 +96,9 @@ import Data.Foldable hiding (foldl1, foldr1, maximum, maximumBy, minimum, minimu
 import Data.Foldable1
 import Data.Function
 import Data.Functor
+import Data.Functor.Compose (Compose (Compose), getCompose)
 import Data.Functor.Contravariant
-import Data.Kind (Type)
+import Data.Kind (Constraint, 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)
@@ -103,11 +111,13 @@ import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Text.IO qualified as T
+import Data.Time
 import Data.Traversable
 import Data.Tree
 import Data.Tuple.Extra ((&&&))
 import Data.Void
 import Data.Word
+import GHC.Generics (Generic)
 import GHC.TypeNats (KnownNat, Nat, type (+))
 import Linear (V2 (..))
 import Safe
@@ -115,11 +125,11 @@ import Text.Megaparsec hiding (Pos, State, Stream, many, some)
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer (decimal)
 
-data Puzzle = forall input outputs. (KnownNat (Length outputs)) => Puzzle
+data Puzzle = forall input outputs. (KnownNat (Length outputs), NFData input) => Puzzle
     { number :: Word
     , parser :: Bool -> Parsec Void Text input
     , parts :: PuzzleParts input outputs
-    , extraTests :: Bool -> FilePath -> [TestTree IO (input, HList outputs)]
+    , extraTests :: Bool -> FilePath -> [TestTree IO (input, HListC NFData outputs)]
     }
 
 digit :: (Token s ~ Char, Num b, MonadParsec e s f) => f b
@@ -147,13 +157,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 (Fanout ((->) input) (Op Text))
+type PuzzleParts input = HListF (Compose (Fanout ((->) input) (Op Text)) (Constrained NFData))
 infixr 9 /\\
-(/\\) :: (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
+(/\\) :: (NFData output) => (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
-(/\\) (f, o) = HConsF $ Fanout (f, Op o)
+(/\\) (f, o) = HConsF $ Compose $ Fanout (Constrained . f, Op $ o . (.unwrap))
 infixr 9 /\
-(/\) :: (Show output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
+(/\) :: (Show output, NFData output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
-(/\) f = HConsF $ Fanout (f, Op T.show)
+(/\) f = HConsF $ Compose $ Fanout (Constrained . f, Op $ T.show . (.unwrap))
 nil :: PuzzleParts input '[]
 nil = HNilF
 
@@ -164,6 +174,18 @@ data HList (as :: List Type) :: Type where
         HList as ->
         HList (a ': as)
 
+data HListC (c :: Type -> Constraint) (as :: List Type) :: Type where
+    HNilC :: HListC c '[]
+    HConsC ::
+        (c a) =>
+        a ->
+        HListC c as ->
+        HListC c (a ': as)
+instance NFData (HListC NFData outputs) where
+    rnf = \case
+        HNilC -> ()
+        HConsC x xs -> deepseq x $ DeepSeq.rnf xs
+
 data HListF (f :: Type -> Type) (as :: List Type) :: Type where
     HNilF :: HListF f '[]
     HConsF ::
@@ -186,6 +208,9 @@ lookupHList f = \case
     HNilF -> absurd . separateZero
     HConsF x xs -> maybe (f x) (lookupHList f xs) . unshift
 
+data Constrained c a where
+    Constrained :: (c a) => {unwrap :: a} -> Constrained c a
+
 newtype Fanout f g a = Fanout (f a, g a)
 
 type family Length as :: Nat where
@@ -193,10 +218,10 @@ type family Length as :: Nat where
     Length (x ': xs) = Length xs + 1
 
 data TestTree m input where
-    TestTree :: TestName -> (input -> m output) -> [TestTree m output] -> TestTree m input
+    TestTree :: (NFData output) => TestName -> (input -> m output) -> [TestTree m output] -> TestTree m input
 
 data TestResult
-    = Pass TestName [TestResult]
+    = Pass TestName NominalDiffTime [TestResult]
     | Fail TestName SomeExceptionLegalShow
     deriving (Show)
 
@@ -213,13 +238,20 @@ instance Show SomeExceptionLegalShow where
 getTestTree :: TestTree m r -> Tree TestName
 getTestTree (TestTree name _ ts) = Node name $ map getTestTree ts
 
-runTests :: (MonadCatch m) => a -> TestTree m a -> m TestResult
+runTests :: (MonadIO m, MonadCatch m) => a -> TestTree m a -> m TestResult
-runTests x (TestTree name f ts) =
+runTests r0 (TestTree name f ts) =
-    Control.Monad.Catch.try (f x) >>= \case
+    Control.Monad.Catch.try (timed $ f r0) >>= \case
         Left e ->
             pure $ Fail name $ SomeExceptionLegalShow e
-        Right r ->
+        Right (r, dt) ->
-            Pass name <$> for ts (runTests r)
+            Pass name dt <$> for ts (runTests r)
+  where
+    timed x = do
+        t0 <- liftIO getCurrentTime
+        r <- x
+        rf <- liftIO $ evaluate $ DeepSeq.force r
+        t1 <- liftIO getCurrentTime
+        pure (rf, diffUTCTime t1 t0)
 
 assertEqual :: (Eq p, MonadFail f) => p -> p -> f ()
 assertEqual expected actual = assert "not equal" (expected == actual)

haskell/Puzzles/Day1.hs

@@ -35,16 +35,16 @@ puzzle =
         }
 
 data Direction = L | R
-    deriving (Eq, Ord, Show)
+    deriving (Eq, Ord, Show, Generic, NFData)
 
 newtype Pos = Pos Int
-    deriving newtype (Eq, Ord, Show, Num)
+    deriving newtype (Eq, Ord, Show, Num, NFData)
 
 newtype Inc = Inc Int
-    deriving newtype (Eq, Ord, Show, Num)
+    deriving newtype (Eq, Ord, Show, Num, NFData)
 
 newtype Count = Count Int
-    deriving newtype (Eq, Ord, Show, Num)
+    deriving newtype (Eq, Ord, Show, Num, NFData)
 
 step :: Inc -> Direction -> Pos -> (Count, Pos)
 step (Inc i) d (Pos p) = bimap Count Pos case d of

haskell/Puzzles/Day10.hs

@@ -34,7 +34,7 @@ puzzle =
         }
 
 data Light = On | Off
-    deriving (Eq, Ord, Show)
+    deriving (Eq, Ord, Show, Generic, NFData)
 flipLight :: Light -> Light
 flipLight = \case
     On -> Off
@@ -42,10 +42,12 @@ flipLight = \case
 
 newtype Lights = Lights (IM.IntMap Light)
     deriving (Eq, Ord, Show)
+    deriving newtype (NFData)
 allOff :: Lights -> Bool
 allOff (Lights ls) = all (== Off) $ map snd $ IM.toList ls
 
 newtype Switch = Switch [Int]
     deriving (Eq, Ord, Show)
+    deriving newtype (NFData)
 applySwitch :: Switch -> Lights -> Lights
 applySwitch (Switch ss) (Lights ls) = Lights $ foldl' (flip $ IM.adjust flipLight) ls ss

haskell/Puzzles/Day2.hs

@@ -23,7 +23,7 @@ puzzle =
         }
 
 newtype ID = ID Int
-    deriving newtype (Eq, Ord, Show, Num, Enum)
+    deriving newtype (Eq, Ord, Show, Num, Enum, NFData)
 
 isRepetition2 :: ID -> Bool
 isRepetition2 (T.show -> n) = case T.length n `divMod` 2 of

haskell/Puzzles/Day3.hs

@@ -21,10 +21,10 @@ puzzle =
         }
 
 newtype Bank = Bank (NonEmpty Battery)
-    deriving newtype (Eq, Ord, Show)
+    deriving newtype (Eq, Ord, Show, NFData)
 
 newtype Battery = Battery Word8
-    deriving newtype (Eq, Ord, Show, Num, Enum, Real, Integral)
+    deriving newtype (Eq, Ord, Show, Num, Enum, Real, Integral, NFData)
 
 -- maximal n-digit subsequence
 -- returns `Nothing` if list isn't long enough (>= n)

haskell/Puzzles/Day4.hs

@@ -6,6 +6,7 @@ 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 =
@@ -31,7 +32,7 @@ puzzle =
                 []
             , TestTree
                 "frames"
-                ( \(_, (HCons _ (HCons (_, fmap snd -> frameStream) HNil))) ->
+                ( \(_, (HConsC _ (HConsC (_, fmap snd -> frameStream) HNilC))) ->
                     pure $ Seq.fromList $ takeUntil noneAccessible frameStream
                 )
                 let nFrames = if isRealData then 58 else 9
@@ -63,11 +64,12 @@ puzzle =
 
 newtype Grid a = Grid (Seq (Seq (V2 Int, a)))
     deriving (Functor, Show)
+    deriving newtype (NFData)
 
 data InTile
     = InEmpty
     | InRoll
-    deriving (Eq, Ord, Show, Enum, Bounded)
+    deriving (Eq, Ord, Show, Enum, Bounded, Generic, NFData)
 inToChar :: InTile -> Char
 inToChar = \case
     InEmpty -> '.'
@@ -77,7 +79,7 @@ data OutTile
     = OutEmpty
     | OutRoll
     | OutAccessible
-    deriving (Eq, Ord, Show, Enum, Bounded)
+    deriving (Eq, Ord, Show, Enum, Bounded, Generic, NFData)
 outToChar :: OutTile -> Char
 outToChar = \case
     OutEmpty -> inToChar InEmpty
@@ -132,3 +134,7 @@ 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 = ()

haskell/Puzzles/Day5.hs

@@ -31,7 +31,7 @@ data Range = Range
     { lower :: Int
     , upper :: Int
     }
-    deriving (Eq, Ord, Show)
+    deriving (Eq, Ord, Show, Generic, NFData)
 
 rangeLength :: Range -> Int
 rangeLength r = r.upper - r.lower + 1

haskell/Puzzles/Day6.hs

@@ -30,7 +30,7 @@ puzzle =
         }
 
 data Op = Add | Multiply
-    deriving (Eq, Ord, Show, Enum, Bounded)
+    deriving (Eq, Ord, Show, Enum, Bounded, Generic, NFData)
 apply :: Op -> Int -> Int -> Int
 apply = \case
     Add -> (+)

haskell/aoc.cabal

@@ -23,6 +23,7 @@ executable aoc
     default-language: GHC2024
     default-extensions:
         BlockArguments
+        DeriveAnyClass
         DuplicateRecordFields
         ImpredicativeTypes
         LexicalNegation