Move to custom test library

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) ->
+    (pPrintForceColor =<<) $ runTests () $ TestTree "tests" pure $ flip map enumerate \isRealData@(bool "examples" "real" -> t) ->
-        describe t $ for_
+        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) ->
+                            pure (input, rs, os)
-                            it n . pureGoldenTextFile ("../outputs/" <> t <> "/" <> pt <> "/" <> n) . (<> "\n")
+                        )
-                        describe "extra" $ extraTests isRealData ("../outputs/" <> t <> "/" <> pt <> "/extra/") input 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/")
+                               ]

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
-
+hlistfLength :: HListF f r -> Int
-instance Semigroup (TestDefM a b ()) where
+hlistfLength = \case
-    (<>) = (>>)
+    HNilF -> 0
-instance Monoid (TestDefM a b ()) where
+    HConsF _ l -> 1 + hlistfLength l
-    mempty = pure ()
 
 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"

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
+        , extraTests = \isRealData path ->
-            it "round trip" do
+            [ 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
+                    assertEqual t $ drawGrid (mkGrid input <&> \case InEmpty -> OutEmpty; InRoll -> OutRoll)
-            describe "frames" do
+                )
-                let frames = Seq.fromList $ takeUntil noneAccessible frameStream
+                []
+            , 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 ->
+                 in map
-                    it (show n) . pureGoldenTextFile (path <> "frames/" <> show n) $
+                        ( \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)))

haskell/aoc.cabal

@@ -63,7 +63,6 @@ executable aoc
         mtl,
         pretty-simple,
         safe,
-        sydtest,
         stm,
         streams,
         text,