Move to custom test library
This commit is contained in:
George Thomas
parent
ab0a926e24
commit
c3e69cde09
@ -3,6 +3,7 @@ module Main (main) where
|
||||
import Pre
|
||||
|
||||
import Data.Functor.Contravariant
|
||||
import Data.List ((!!))
|
||||
import Data.Text.IO qualified as T
|
||||
import Puzzles.Day1 qualified as Day1
|
||||
import Puzzles.Day10 qualified as Day10
|
||||
@ -14,11 +15,13 @@ import Puzzles.Day6 qualified as Day6
|
||||
import Puzzles.Day7 qualified as Day7
|
||||
import Puzzles.Day8 qualified as Day8
|
||||
import Puzzles.Day9 qualified as Day9
|
||||
import Text.Pretty.Simple (pPrintForceColor)
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
sydTest $ doNotRandomiseExecutionOrder $ for_ enumerate \isRealData@(bool "examples" "real" -> t) ->
|
||||
describe t $ for_
|
||||
(pPrintForceColor =<<) $ runTests () $ TestTree "tests" pure $ flip map enumerate \isRealData@(bool "examples" "real" -> t) ->
|
||||
TestTree (mkTestName t) (\() -> pure ()) $ flip
|
||||
map
|
||||
[ Day1.puzzle
|
||||
, Day2.puzzle
|
||||
, Day3.puzzle
|
||||
@ -38,11 +41,26 @@ main =
|
||||
. runParser (parser isRealData <* eof) fp
|
||||
=<< T.readFile fp
|
||||
in
|
||||
describe pt do
|
||||
TestTree
|
||||
(mkTestName pt)
|
||||
( \() -> do
|
||||
input <- liftIO $ parseFile $ "../inputs/" <> t <> "/" <> pt
|
||||
let (rs, os) =
|
||||
(foldHListF0 ((:) . fst) [] &&& foldHListF (HCons . snd) HNil) $
|
||||
mapHListF (\(Fanout (f, Op o)) -> (o &&& id) $ f input) parts
|
||||
for_ (zip [1 :: Int ..] rs) $ uncurry $ \(show -> n) ->
|
||||
it n . pureGoldenTextFile ("../outputs/" <> t <> "/" <> pt <> "/" <> n) . (<> "\n")
|
||||
describe "extra" $ extraTests isRealData ("../outputs/" <> t <> "/" <> pt <> "/extra/") input os
|
||||
pure (input, rs, os)
|
||||
)
|
||||
$ ( flip map ([0 :: Int .. hlistfLength parts - 1]) $
|
||||
\n@(show . succ -> nt) ->
|
||||
TestTree
|
||||
(mkTestName nt)
|
||||
( \(_, rs, _) -> do
|
||||
golden ("../outputs/" <> t <> "/" <> pt <> "/" <> nt) $ (rs !! n) <> "\n"
|
||||
)
|
||||
[]
|
||||
)
|
||||
<> [ TestTree
|
||||
"extra"
|
||||
(\(input, _, os) -> pure (input, os))
|
||||
$ extraTests isRealData ("../outputs/" <> t <> "/" <> pt <> "/extra/")
|
||||
]
|
||||
|
||||
@ -1,6 +1,5 @@
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Pre (
|
||||
module BasePrelude,
|
||||
@ -30,7 +29,6 @@ module Pre (
|
||||
module Data.Word,
|
||||
module Linear,
|
||||
module Safe,
|
||||
module Test.Syd,
|
||||
module Text.Megaparsec,
|
||||
module Text.Megaparsec.Char,
|
||||
module Text.Megaparsec.Char.Lexer,
|
||||
@ -41,14 +39,25 @@ module Pre (
|
||||
allUnorderedPairs,
|
||||
adjacentPairs,
|
||||
sortPair,
|
||||
HList (..),
|
||||
hlistLength,
|
||||
HListF (..),
|
||||
foldHListF,
|
||||
foldHListF0,
|
||||
mapHListF,
|
||||
hlistfLength,
|
||||
(/\),
|
||||
(/\\),
|
||||
nil,
|
||||
Fanout (..),
|
||||
TestTree (..),
|
||||
TestName,
|
||||
mkTestName,
|
||||
getTestTree,
|
||||
runTests,
|
||||
assertEqual,
|
||||
assert,
|
||||
golden,
|
||||
)
|
||||
where
|
||||
|
||||
@ -66,7 +75,9 @@ import "base" Prelude as BasePrelude hiding (
|
||||
)
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception (SomeException)
|
||||
import Control.Monad
|
||||
import Control.Monad.Catch (MonadCatch, try)
|
||||
import Control.Monad.Loops
|
||||
import Control.Monad.State
|
||||
import Data.Bifunctor
|
||||
@ -85,16 +96,18 @@ import Data.Maybe
|
||||
import Data.Ord
|
||||
import Data.Sequence (Seq)
|
||||
import Data.Stream.Infinite (Stream ((:>)))
|
||||
import Data.String (IsString)
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Text.IO qualified as T
|
||||
import Data.Traversable
|
||||
import Data.Tree
|
||||
import Data.Tuple.Extra ((&&&))
|
||||
import Data.Void
|
||||
import Data.Word
|
||||
import Linear (V2 (..))
|
||||
import Safe
|
||||
import Test.Syd
|
||||
import Text.Megaparsec hiding (Pos, State, Stream, many, some)
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Char.Lexer (decimal)
|
||||
@ -103,7 +116,7 @@ data Puzzle = forall input outputs. Puzzle
|
||||
{ number :: Word
|
||||
, parser :: Bool -> Parsec Void Text input
|
||||
, parts :: PuzzleParts input outputs
|
||||
, extraTests :: Bool -> FilePath -> input -> HList outputs -> Spec
|
||||
, extraTests :: Bool -> FilePath -> [TestTree IO (input, HList outputs)]
|
||||
}
|
||||
|
||||
digit :: (Token s ~ Char, Num b, MonadParsec e s f) => f b
|
||||
@ -141,6 +154,17 @@ infixr 9 /\
|
||||
nil :: PuzzleParts input '[]
|
||||
nil = HNilF
|
||||
|
||||
data HList (as :: List Type) :: Type where
|
||||
HNil :: HList '[]
|
||||
HCons ::
|
||||
a ->
|
||||
HList as ->
|
||||
HList (a ': as)
|
||||
hlistLength :: HList r -> Int
|
||||
hlistLength = \case
|
||||
HNil -> 0
|
||||
HCons _ l -> 1 + hlistLength l
|
||||
|
||||
data HListF (f :: Type -> Type) (as :: List Type) :: Type where
|
||||
HNilF :: HListF f '[]
|
||||
HConsF ::
|
||||
@ -157,10 +181,47 @@ foldHListF0 f e = \case
|
||||
HConsF x xs -> f x $ foldHListF0 f e xs
|
||||
mapHListF :: (forall a. f a -> g a) -> HListF f as -> HListF g as
|
||||
mapHListF t = foldHListF (\x r -> HConsF (t x) $ r) HNilF
|
||||
|
||||
instance Semigroup (TestDefM a b ()) where
|
||||
(<>) = (>>)
|
||||
instance Monoid (TestDefM a b ()) where
|
||||
mempty = pure ()
|
||||
hlistfLength :: HListF f r -> Int
|
||||
hlistfLength = \case
|
||||
HNilF -> 0
|
||||
HConsF _ l -> 1 + hlistfLength l
|
||||
|
||||
newtype Fanout f g a = Fanout (f a, g a)
|
||||
|
||||
data TestTree m input where
|
||||
TestTree :: TestName -> (input -> m output) -> [TestTree m output] -> TestTree m input
|
||||
|
||||
data TestResult
|
||||
= Pass TestName [TestResult]
|
||||
| Fail TestName SomeExceptionLegalShow
|
||||
deriving (Show)
|
||||
|
||||
newtype TestName = TestName String
|
||||
deriving newtype (IsString, Show)
|
||||
|
||||
mkTestName :: String -> TestName
|
||||
mkTestName = TestName
|
||||
|
||||
newtype SomeExceptionLegalShow = SomeExceptionLegalShow SomeException
|
||||
instance Show SomeExceptionLegalShow where
|
||||
show (SomeExceptionLegalShow e) = show $ show e
|
||||
|
||||
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
|
||||
Left e ->
|
||||
pure $ Fail name $ SomeExceptionLegalShow e
|
||||
Right r ->
|
||||
Pass name <$> for ts (runTests r)
|
||||
|
||||
assertEqual :: (Eq p, MonadFail f) => p -> p -> f ()
|
||||
assertEqual expected actual = assert "not equal" (expected == actual)
|
||||
assert :: (MonadFail f) => String -> Bool -> f ()
|
||||
assert s b = if b then pure () else fail s
|
||||
golden :: FilePath -> Text -> IO ()
|
||||
golden p x = do
|
||||
expected <- T.readFile p
|
||||
if expected == x then pure () else fail "golden test failure"
|
||||
|
||||
@ -21,22 +21,41 @@ puzzle =
|
||||
T.show $ countRolls g - countRolls (fst $ S.head $ S.filter (noneAccessible . snd) fs)
|
||||
)
|
||||
/\\ nil
|
||||
, extraTests = \isRealData path input (HCons _ (HCons (_, fmap snd -> frameStream) HNil)) -> do
|
||||
it "round trip" do
|
||||
, extraTests = \isRealData path ->
|
||||
[ TestTree
|
||||
"round trip"
|
||||
( \(input, _) -> 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 frameStream
|
||||
assertEqual t $ drawGrid (mkGrid input <&> \case InEmpty -> OutEmpty; InRoll -> OutRoll)
|
||||
)
|
||||
[]
|
||||
, TestTree
|
||||
"frames"
|
||||
( \(_, (HCons _ (HCons (_, fmap snd -> frameStream) HNil))) ->
|
||||
pure $ Seq.fromList $ takeUntil noneAccessible frameStream
|
||||
)
|
||||
let nFrames = if isRealData then 58 else 9
|
||||
for_ [0 .. nFrames] \n ->
|
||||
it (show n) . pureGoldenTextFile (path <> "frames/" <> show n) $
|
||||
in map
|
||||
( \n ->
|
||||
TestTree
|
||||
(mkTestName $ show n)
|
||||
( \frames ->
|
||||
golden (path <> "frames/" <> show n) $
|
||||
maybe "frame list too short!" drawGrid (Seq.lookup n frames)
|
||||
it "end" do
|
||||
-- we can't actually define `nFrames` this way as it would messing up reporting,
|
||||
-- due to forcing the expensive evaluation during test tree construction
|
||||
Seq.length frames `shouldBe` (nFrames + 1)
|
||||
)
|
||||
[]
|
||||
)
|
||||
[0 .. nFrames]
|
||||
<> [ TestTree
|
||||
"end"
|
||||
( \frames -> do
|
||||
assertEqual (nFrames + 1) (Seq.length frames)
|
||||
Just g <- pure $ Seq.lookup nFrames frames
|
||||
(g `shouldSatisfyNamed` "accessible tile found") noneAccessible
|
||||
assert "accessible tile found" $ noneAccessible g
|
||||
)
|
||||
[]
|
||||
]
|
||||
]
|
||||
}
|
||||
|
||||
newtype Grid a = Grid (Seq (Seq (V2 Int, a)))
|
||||
|
||||
@ -63,7 +63,6 @@ executable aoc
|
||||
mtl,
|
||||
pretty-simple,
|
||||
safe,
|
||||
sydtest,
|
||||
stm,
|
||||
streams,
|
||||
text,
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user