From 83e4489e1ff736689d17a7b307d761754d057a59 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Tue, 6 Jan 2026 17:14:03 +0000 Subject: [PATCH] Add timing information to tests Most of this is concerned with propagating `NFData` constraints. --- haskell/Main.hs | 4 +-- haskell/Pre.hs | 64 ++++++++++++++++++++++++++++++---------- haskell/Puzzles/Day1.hs | 8 ++--- haskell/Puzzles/Day10.hs | 4 ++- haskell/Puzzles/Day2.hs | 2 +- haskell/Puzzles/Day3.hs | 4 +-- haskell/Puzzles/Day4.hs | 12 ++++++-- haskell/Puzzles/Day5.hs | 2 +- haskell/Puzzles/Day6.hs | 2 +- haskell/aoc.cabal | 1 + 10 files changed, 72 insertions(+), 31 deletions(-) diff --git a/haskell/Main.hs b/haskell/Main.hs index a87eeb3..075ad0f 100644 --- a/haskell/Main.hs +++ b/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) $ - mapHListF (\(Fanout (f, Op o)) -> (o &&& id) $ f input) parts + (lookupHList (fst . getCompose) &&& foldHListF ((\(Constrained x) -> HConsC x) . snd . getCompose) HNilC) $ + mapHListF (\(Compose (Fanout (f, Op o))) -> Compose $ (o &&& id) $ f input) parts in pure (input, rs, os) ) $ ( finites <&> \(n@(show . succ @Int . fromIntegral -> nt)) -> diff --git a/haskell/Pre.hs b/haskell/Pre.hs index af235f2..774d31f 100644 --- a/haskell/Pre.hs +++ b/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) -(/\\) (f, o) = HConsF $ Fanout (f, Op o) +(/\\) :: (NFData output) => (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs) +(/\\) (f, o) = HConsF $ Compose $ Fanout (Constrained . f, Op $ o . (.unwrap)) infixr 9 /\ -(/\) :: (Show output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs) -(/\) f = HConsF $ Fanout (f, Op T.show) +(/\) :: (Show output, NFData output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs) +(/\) 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 x (TestTree name f ts) = - Control.Monad.Catch.try (f x) >>= \case +runTests :: (MonadIO m, MonadCatch m) => a -> TestTree m a -> m TestResult +runTests r0 (TestTree name f ts) = + Control.Monad.Catch.try (timed $ f r0) >>= \case Left e -> pure $ Fail name $ SomeExceptionLegalShow e - Right r -> - Pass name <$> for ts (runTests r) + Right (r, dt) -> + 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) diff --git a/haskell/Puzzles/Day1.hs b/haskell/Puzzles/Day1.hs index 2dc3120..f30ad47 100644 --- a/haskell/Puzzles/Day1.hs +++ b/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 diff --git a/haskell/Puzzles/Day10.hs b/haskell/Puzzles/Day10.hs index 510dee8..58c8383 100644 --- a/haskell/Puzzles/Day10.hs +++ b/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 diff --git a/haskell/Puzzles/Day2.hs b/haskell/Puzzles/Day2.hs index cb3e44b..481b81f 100644 --- a/haskell/Puzzles/Day2.hs +++ b/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 diff --git a/haskell/Puzzles/Day3.hs b/haskell/Puzzles/Day3.hs index cf80c5b..33b586d 100644 --- a/haskell/Puzzles/Day3.hs +++ b/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) diff --git a/haskell/Puzzles/Day4.hs b/haskell/Puzzles/Day4.hs index 7a60c4a..403448c 100644 --- a/haskell/Puzzles/Day4.hs +++ b/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 = () diff --git a/haskell/Puzzles/Day5.hs b/haskell/Puzzles/Day5.hs index 729b4ee..6232b7d 100644 --- a/haskell/Puzzles/Day5.hs +++ b/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 diff --git a/haskell/Puzzles/Day6.hs b/haskell/Puzzles/Day6.hs index 7d75a52..6b1c3b9 100644 --- a/haskell/Puzzles/Day6.hs +++ b/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 -> (+) diff --git a/haskell/aoc.cabal b/haskell/aoc.cabal index 8d24503..bbc9022 100644 --- a/haskell/aoc.cabal +++ b/haskell/aoc.cabal @@ -23,6 +23,7 @@ executable aoc default-language: GHC2024 default-extensions: BlockArguments + DeriveAnyClass DuplicateRecordFields ImpredicativeTypes LexicalNegation