diff --git a/haskell/Main.hs b/haskell/Main.hs index 092304d..417a40a 100644 --- a/haskell/Main.hs +++ b/haskell/Main.hs @@ -2,9 +2,8 @@ module Main (main) where import Pre +import Data.Text qualified as T import Data.Text.IO qualified as T -import Data.Text.Lazy qualified as TL -import Data.Text.Lazy.Encoding qualified as TL import Puzzles.Day1 qualified as Day1 import Puzzles.Day10 qualified as Day10 import Puzzles.Day2 qualified as Day2 @@ -15,38 +14,33 @@ 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 Test.Tasty.Ingredients.ConsoleReporter main :: IO () main = - defaultMain - . localOption (Always :: UseColor) - . testGroup "tests" - $ enumerate <&> \isRealData@(bool "examples" "real" -> t) -> - testGroup t $ - [ Day1.puzzle - , Day2.puzzle - , Day3.puzzle - , Day4.puzzle - , Day5.puzzle - , Day6.puzzle - , Day7.puzzle - , Day8.puzzle - , Day9.puzzle - , Day10.puzzle - ] - <&> \Puzzle{number, parser, parts, extraTests} -> - let - pt = show number - parseFile fp = - either (fail . ("parse failure: " <>) . errorBundlePretty) pure - . runParser (parser isRealData <* eof) fp - =<< T.readFile fp - in - withResource (parseFile $ "../inputs/" <> t <> "/" <> pt) mempty \input -> - testGroup pt $ - ( flip mapWithIndexOutputParameterisedFunctionList parts \(show . succ -> n) pp -> - goldenVsStringDiff n diffCommand ("../outputs/" <> t <> "/" <> pt <> "/" <> n) $ - TL.encodeUtf8 . (<> "\n") . TL.show . pp <$> input - ) - <> [testGroup "extra" $ extraTests isRealData ("../outputs/" <> t <> "/" <> pt <> "/extra/") input] + sydTest $ doNotRandomiseExecutionOrder $ for_ enumerate \isRealData@(bool "examples" "real" -> t) -> + describe t $ for_ + [ Day1.puzzle + , Day2.puzzle + , Day3.puzzle + , Day4.puzzle + , Day5.puzzle + , Day6.puzzle + , Day7.puzzle + , Day8.puzzle + , Day9.puzzle + , Day10.puzzle + ] + \Puzzle{number, parser, parts, extraTests} -> + let + pt = show number + parseFile fp = + either (fail . ("parse failure: " <>) . errorBundlePretty) pure + . runParser (parser isRealData <* eof) fp + =<< T.readFile fp + in + describe pt do + input <- liftIO $ parseFile $ "../inputs/" <> t <> "/" <> pt + sequence_ $ flip mapWithIndexOutputParameterisedFunctionList parts \(show . succ -> n) pp -> + it n . pureGoldenTextFile ("../outputs/" <> t <> "/" <> pt <> "/" <> n) $ + T.show (pp input) <> "\n" + describe "extra" $ extraTests isRealData ("../outputs/" <> t <> "/" <> pt <> "/extra/") input diff --git a/haskell/Pre.hs b/haskell/Pre.hs index badace2..4414c51 100644 --- a/haskell/Pre.hs +++ b/haskell/Pre.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Pre ( module BasePrelude, @@ -28,9 +29,7 @@ module Pre ( module Data.Word, module Linear, module Safe, - module Test.Tasty, - module Test.Tasty.Golden, - module Test.Tasty.HUnit, + module Test.Syd, module Text.Megaparsec, module Text.Megaparsec.Char, module Text.Megaparsec.Char.Lexer, @@ -41,7 +40,6 @@ module Pre ( allUnorderedPairs, adjacentPairs, sortPair, - diffCommand, OutputParameterisedFunctionList, mapOutputParameterisedFunctionList, mapWithIndexOutputParameterisedFunctionList, @@ -90,9 +88,7 @@ import Data.Void import Data.Word import Linear (V2 (..)) import Safe -import Test.Tasty -import Test.Tasty.Golden hiding (Always) -import Test.Tasty.HUnit +import Test.Syd import Text.Megaparsec hiding (Pos, State, Stream, many, some) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer (decimal) @@ -101,7 +97,7 @@ data Puzzle = forall input outputs. Puzzle { number :: Word , parser :: Bool -> Parsec Void Text input , parts :: OutputParameterisedFunctionList Show input outputs - , extraTests :: Bool -> FilePath -> IO input -> [TestTree] + , extraTests :: Bool -> FilePath -> input -> Spec } digit :: (Token s ~ Char, Num b, MonadParsec e s f) => f b @@ -129,9 +125,6 @@ adjacentPairs = \case sortPair :: (Ord a) => (a, a) -> (a, a) sortPair (a, b) = if a <= b then (a, b) else (b, a) -diffCommand :: FilePath -> FilePath -> [String] -diffCommand a b = ["diff", "--color=always", a, b] - infixr 9 /\ (/\) :: (c output) => (input -> output) -> OutputParameterisedFunctionList c input outputs -> OutputParameterisedFunctionList c input (output : outputs) (/\) = OutputParameterisedFunctionListCons @@ -163,3 +156,8 @@ mapWithIndexOutputParameterisedFunctionList f = go 0 go i = \case OutputParameterisedFunctionListNil -> [] OutputParameterisedFunctionListCons x xs -> f i x : go (i + 1) xs + +instance Semigroup (TestDefM '[] () ()) where + (<>) = (>>) +instance Monoid (TestDefM '[] () ()) where + mempty = pure () diff --git a/haskell/Puzzles/Day4.hs b/haskell/Puzzles/Day4.hs index 104cbca..f6e1e24 100644 --- a/haskell/Puzzles/Day4.hs +++ b/haskell/Puzzles/Day4.hs @@ -4,9 +4,8 @@ import Pre import Data.Sequence qualified as Seq import Data.Stream.Infinite qualified as S -import Data.Text.Lazy qualified as TL -import Data.Text.Lazy.Encoding qualified as TL -import Data.Text.Lazy.IO qualified as TL +import Data.Text qualified as T +import Data.Text.IO qualified as T puzzle :: Puzzle puzzle = @@ -21,31 +20,23 @@ puzzle = . mkGrid ) /\ nil - , extraTests = \isRealData path input -> - [ testCase "round trip" do - t <- TL.readFile if isRealData then "../inputs/real/4" else "../inputs/examples/4" - input' <- input - t @=? drawGrid (mkGrid input' <&> \case InEmpty -> OutEmpty; InRoll -> OutRoll) - , withResource - (Seq.fromList . takeUntil noneAccessible . fmap snd . generateFrames . mkGrid <$> input) - mempty - \frames -> - testGroup - "frames" - let nFrames = if isRealData then 58 else 9 - in ( [0 .. nFrames] <&> \n -> - goldenVsStringDiff (show n) diffCommand (path <> "frames/" <> show n) $ - TL.encodeUtf8 . maybe "frame list too short!" drawGrid . Seq.lookup n <$> frames - ) - <> [ testCase "end" do - Just g <- Seq.lookup nFrames <$> frames - assertBool "accessible tile found" $ noneAccessible g - ] - ] + , extraTests = \isRealData path input -> 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 nFrames = Seq.length frames - 1 + for_ [0 .. nFrames] \n -> + it (show n) . pureGoldenTextFile (path <> "frames/" <> show n) $ + maybe "frame list too short!" drawGrid (Seq.lookup n frames) + it "end" do + Just g <- pure $ Seq.lookup nFrames frames + (g `shouldSatisfyNamed` "accessible tile found") noneAccessible } newtype Grid a = Grid (Seq (Seq (V2 Int, a))) - deriving (Functor) + deriving (Functor, Show) data InTile = InEmpty @@ -67,8 +58,8 @@ outToChar = \case OutRoll -> inToChar InRoll OutAccessible -> 'x' -drawGrid :: Grid OutTile -> TL.Text -drawGrid (Grid g) = TL.unlines . toList . fmap (TL.pack . toList . fmap outToChar) $ snd <<$>> g +drawGrid :: Grid OutTile -> T.Text +drawGrid (Grid g) = T.unlines . toList . fmap (T.pack . toList . fmap outToChar) $ snd <<$>> g mkGrid :: [[a]] -> Grid a mkGrid = Grid . Seq.fromList . map Seq.fromList . zipWith (map . first . V2) [0 ..] . map (zip [0 ..]) diff --git a/haskell/aoc.cabal b/haskell/aoc.cabal index 8975c94..c9d5f67 100644 --- a/haskell/aoc.cabal +++ b/haskell/aoc.cabal @@ -39,6 +39,9 @@ executable aoc ghc-options: -Wall -fdefer-type-errors + -threaded + -rtsopts + -with-rtsopts=-N build-depends: base >= 4.14, async, @@ -60,11 +63,9 @@ executable aoc mtl, pretty-simple, safe, + sydtest, stm, streams, - tasty-golden, - tasty-hunit, - tasty, text, time, transformers,