diff --git a/haskell/Main.hs b/haskell/Main.hs index c61db06..5ccdcb2 100644 --- a/haskell/Main.hs +++ b/haskell/Main.hs @@ -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 - 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 + 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 + 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/") + ] diff --git a/haskell/Pre.hs b/haskell/Pre.hs index f087d17..60935c6 100644 --- a/haskell/Pre.hs +++ b/haskell/Pre.hs @@ -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" diff --git a/haskell/Puzzles/Day4.hs b/haskell/Puzzles/Day4.hs index d5503e6..2f4e9c9 100644 --- a/haskell/Puzzles/Day4.hs +++ b/haskell/Puzzles/Day4.hs @@ -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 - 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 + , extraTests = \isRealData path -> + [ TestTree + "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 + "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) $ - 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) - Just g <- pure $ Seq.lookup nFrames frames - (g `shouldSatisfyNamed` "accessible tile found") noneAccessible + in map + ( \n -> + TestTree + (mkTestName $ show n) + ( \frames -> + golden (path <> "frames/" <> show n) $ + maybe "frame list too short!" drawGrid (Seq.lookup n frames) + ) + [] + ) + [0 .. nFrames] + <> [ TestTree + "end" + ( \frames -> do + assertEqual (nFrames + 1) (Seq.length frames) + Just g <- pure $ Seq.lookup nFrames frames + assert "accessible tile found" $ noneAccessible g + ) + [] + ] + ] } newtype Grid a = Grid (Seq (Seq (V2 Int, a))) diff --git a/haskell/aoc.cabal b/haskell/aoc.cabal index c9d5f67..cb4f6e0 100644 --- a/haskell/aoc.cabal +++ b/haskell/aoc.cabal @@ -63,7 +63,6 @@ executable aoc mtl, pretty-simple, safe, - sydtest, stm, streams, text,