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.
This commit is contained in:
George Thomas
parent
f213cdb6c3
commit
db41a65453
@ -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) ->
|
||||
TestTree (mkTestName t) pure $ flip
|
||||
(pPrintForceColor =<<) $ runTests () $ test "tests" pure $ flip map enumerate \isRealData@(bool "examples" "real" -> t) ->
|
||||
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) $
|
||||
mapHListF (\(Compose (Fanout (f, Op o))) -> Compose $ (o &&& id) $ f input) parts
|
||||
(lookupHList fst &&& foldHListF (HCons . snd) HNil) $
|
||||
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]
|
||||
|
||||
@ -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)
|
||||
(/\\) (f, o) = HConsF $ Compose $ Fanout (Constrained . f, Op $ withConstrained o)
|
||||
(/\\) :: (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
|
||||
(/\\) (f, o) = HConsF $ Fanout (f, Op o)
|
||||
infixr 9 /\
|
||||
(/\) :: (Show output, NFData output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
|
||||
(/\) f = HConsF $ Compose $ Fanout (Constrained . f, Op $ withConstrained T.show)
|
||||
(/\) :: (Show output) => (input -> output) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)
|
||||
(/\) 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) =
|
||||
Control.Monad.Catch.try (timed $ f r0) >>= \case
|
||||
runTests r0 (TestTree name tc ts) =
|
||||
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)
|
||||
|
||||
|
||||
@ -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 = ()
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user