Allow output types to vary for different parts of same day

For now this applies to Haskell only, and it may turn out to be tricky for the Rust implementation.

In practice, the limitation hasn't turned out to be important, and we could even go the other way and use `Integer` everywhere. This does however at least help with debugging, as well as just being conceptually right.

The `nil` and `(/\)` functions are intended to be overloaded to work for other list-like things in a later commit, and from there we will investigate using `OverloadedLists` and `RebindableSyntax` to recover standard list syntax, although there are probably limitations due to `(:)` being special.

haskell/Main.hs

@@ -45,7 +45,7 @@ main =
                          in
                             withResource (parseFile $ "../inputs/" <> t <> "/" <> pt) mempty \input ->
                                 testGroup pt $
-                                    ( zip (map show [1 :: Int ..]) parts <&> \(n, pp) ->
+                                    ( flip mapWithIndexOutputParameterisedFunctionList parts \(show . succ -> n) pp ->
                                         goldenVsStringDiff n diffCommand ("../outputs/" <> t <> "/" <> pt <> "/" <> n) $
                                             TL.encodeUtf8 . (<> "\n") . TL.show . pp <$> input
                                     )

haskell/Pre.hs

@@ -42,6 +42,11 @@ module Pre (
     adjacentPairs,
     sortPair,
     diffCommand,
+    OutputParameterisedFunctionList,
+    mapOutputParameterisedFunctionList,
+    mapWithIndexOutputParameterisedFunctionList,
+    (/\),
+    nil,
 )
 where
 
@@ -69,7 +74,8 @@ import Data.Foldable hiding (foldl1, foldr1, maximum, maximumBy, minimum, minimu
 import Data.Foldable1
 import Data.Function
 import Data.Functor
-import Data.List (sortOn, transpose)
+import Data.Kind (Constraint, Type)
+import Data.List (List, sortOn, transpose)
 import Data.List.Extra (dropEnd, enumerate, firstJust, notNull, splitOn)
 import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, some1, tail, tails)
 import Data.Maybe
@@ -91,10 +97,10 @@ import Text.Megaparsec hiding (Pos, State, Stream, many, some)
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer (decimal)
 
-data Puzzle = forall input output. (Show output) => Puzzle
+data Puzzle = forall input outputs. Puzzle
     { number :: Word
     , parser :: Bool -> Parsec Void Text input
-    , parts :: [input -> output]
+    , parts :: OutputParameterisedFunctionList Show input outputs
     , extraTests :: Bool -> FilePath -> IO input -> [TestTree]
     }
 
@@ -125,3 +131,35 @@ 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
+nil :: OutputParameterisedFunctionList c input '[]
+nil = OutputParameterisedFunctionListNil
+
+data OutputParameterisedFunctionList (c :: Type -> Constraint) (input :: Type) (outputs :: List Type) :: Type where
+    OutputParameterisedFunctionListNil :: OutputParameterisedFunctionList c input '[]
+    OutputParameterisedFunctionListCons ::
+        (c output) =>
+        (input -> output) ->
+        OutputParameterisedFunctionList c input outputs ->
+        OutputParameterisedFunctionList c input (output ': outputs)
+mapOutputParameterisedFunctionList ::
+    (forall output. (c output) => (input -> output) -> a) ->
+    OutputParameterisedFunctionList c input outputs ->
+    [a]
+mapOutputParameterisedFunctionList f = \case
+    OutputParameterisedFunctionListNil -> []
+    OutputParameterisedFunctionListCons x xs -> f x : mapOutputParameterisedFunctionList f xs
+mapWithIndexOutputParameterisedFunctionList ::
+    forall c input outputs a.
+    (forall output. (c output) => Int -> (input -> output) -> a) ->
+    OutputParameterisedFunctionList c input outputs ->
+    [a]
+mapWithIndexOutputParameterisedFunctionList f = go 0
+  where
+    go :: Int -> OutputParameterisedFunctionList c input outputs' -> [a]
+    go i = \case
+        OutputParameterisedFunctionListNil -> []
+        OutputParameterisedFunctionListCons x xs -> f i x : go (i + 1) xs

haskell/Puzzles/Day1.hs

@@ -8,13 +8,15 @@ puzzle =
         { number = 1
         , parser = const $ ((,) <$> ((char 'L' $> L) <|> (char 'R' $> R)) <*> (Inc <$> decimal)) `sepEndBy` newline
         , parts =
-            [ sum
+            ( sum
-                . flip evalState 50
+                . ( flip evalState 50
                         . traverse \(d, i) -> do
                             modify $ snd . step i d
                             p' <- get
                             pure $ Count if p' == 0 then 1 else 0
-            , sum
+                  )
+            )
+                /\ ( sum
                         . flip evalState 50
                         . traverse \(d, i) -> do
                             p <- get
@@ -27,7 +29,8 @@ puzzle =
                                         | p == 0 -> abs c - 1
                                         | p' == 0 -> abs c + 1
                                         | otherwise -> abs c
-            ]
+                   )
+                /\ nil
         , extraTests = mempty
         }
 

haskell/Puzzles/Day10.hs

@@ -23,12 +23,13 @@ puzzle =
             void $ single '}'
             pure (Lights $ IM.fromList $ zip [0 ..] lights, switches)
         , parts =
-            [ sum . map \(lights, switches) ->
+            ( sum . map \(lights, switches) ->
                 maybe (error "no solution") length
                     . firstJust (firstJust (\(s, ls) -> guard (allOff ls) $> s))
                     $ flip iterate [([], lights)] \ls ->
                         concatMap (\s -> map (\(ss, l) -> (s : ss, applySwitch s l)) ls) switches
-            ]
+            )
+                /\ nil
         , extraTests = mempty
         }
 

haskell/Puzzles/Day2.hs

@@ -10,13 +10,15 @@ puzzle =
         { number = 2
         , parser = const $ (<* newline) $ ((,) <$> (decimal <* char '-') <*> decimal) `sepBy` (char ',')
         , parts =
-            [ sum
+            ( sum
                 . concatMap
                     (mapMaybe (\n -> guard (isRepetition2 n) $> n) . uncurry enumFromTo)
-            , sum
+            )
+                /\ ( sum
                         . concatMap
                             (mapMaybe (\n -> guard (isRepetitionN n) $> n) . uncurry enumFromTo)
-            ]
+                   )
+                /\ nil
         , extraTests = mempty
         }
 

haskell/Puzzles/Day3.hs

@@ -10,11 +10,13 @@ puzzle =
         { number = 3
         , parser = const $ (Bank <$> some1 digit) `sepEndBy` newline
         , parts =
-            [ sum
+            ( sum
                 . map (digitsToInt . fromMaybe (error "battery list too short") . maxBatteries 2)
-            , sum
+            )
+                /\ ( sum
                         . map (digitsToInt . fromMaybe (error "battery list too short") . maxBatteries 12)
-            ]
+                   )
+                /\ nil
         , extraTests = mempty
         }
 

haskell/Puzzles/Day4.hs

@@ -14,11 +14,13 @@ puzzle =
         { number = 4
         , parser = const $ (some $ asum $ enumerate <&> \t -> char (inToChar t) $> t) `sepEndBy` newline
         , parts =
-            [ (\g -> countRolls g - countRolls (removeAccessibleRolls $ findAccessible g))
+            ( (\g -> countRolls g - countRolls (removeAccessibleRolls $ findAccessible g))
                 . mkGrid
-            , (\g -> countRolls g - countRolls (fst $ S.head $ S.filter (noneAccessible . snd) $ generateFrames g))
+            )
+                /\ ( (\g -> countRolls g - countRolls (fst $ S.head $ S.filter (noneAccessible . snd) $ generateFrames g))
                         . mkGrid
-            ]
+                   )
+                /\ nil
         , extraTests = \isRealData path input ->
             [ testCase "round trip" do
                 t <- TL.readFile if isRealData then "../inputs/real/4" else "../inputs/examples/4"

haskell/Puzzles/Day5.hs

@@ -12,16 +12,18 @@ puzzle =
             vals <- decimal `sepEndBy` newline
             pure (ranges, vals)
         , parts =
-            [ \(ranges, vals) ->
+            ( \(ranges, vals) ->
                 length
                     . filter (flip any ranges . isInRange)
                     $ vals
-            , sum
+            )
+                /\ ( sum
                         . map rangeLength
                         . foldr addInterval []
                         . sortOn (Down . (.lower))
                         . fst
-            ]
+                   )
+                /\ nil
         , extraTests = mempty
         }
 

haskell/Puzzles/Day6.hs

@@ -12,10 +12,11 @@ puzzle =
             void newline
             pure (ops, ints)
         , parts =
-            [ sum
+            ( sum
                 . uncurry (zipWith applyToList)
                 . second (transpose . map (map (digitsToInt @Int . catMaybes) . filter notNull . splitOn [Nothing]))
-            , sum
+            )
+                /\ ( sum
                         . uncurry (zipWith applyToList)
                         . second
                             ( map catMaybes
@@ -23,7 +24,8 @@ puzzle =
                                 . map (\l -> if all isNothing l then Nothing else Just $ digitsToInt @Int $ catMaybes l)
                                 . transpose
                             )
-            ]
+                   )
+                /\ nil
         , extraTests = mempty
         }
 

haskell/Puzzles/Day7.hs

@@ -17,7 +17,7 @@ puzzle =
             let splitters = map (IS.fromList . map fst . filter snd . zip [0 ..]) rows
             pure (start, splitters)
         , parts =
-            [ uncurry \start ->
+            ( uncurry \start ->
                 flip execState (0 :: Int)
                     . foldlM
                         ( \beams splitters ->
@@ -27,7 +27,8 @@ puzzle =
                                 pure if hit then [x - 1, x + 1] else [x]
                         )
                         (IS.singleton start)
-            , uncurry \start ->
+            )
+                /\ ( uncurry \start ->
                         sum
                             . map snd
                             . IM.toList
@@ -38,6 +39,7 @@ puzzle =
                                         zip (if hit then [x - 1, x + 1] else [x]) (repeat n)
                                 )
                                 (IM.singleton start (1 :: Int))
-            ]
+                   )
+                /\ nil
         , extraTests = mempty
         }

haskell/Puzzles/Day8.hs

@@ -15,7 +15,7 @@ puzzle =
             (if isRealData then 1000 else 10,)
                 <$> (V3 <$> decimal <* single ',' <*> decimal <* single ',' <*> decimal) `sepEndBy` newline
         , parts =
-            [ uncurry \n ->
+            ( uncurry \n ->
                 product
                     . take 3
                     . sortOn Down
@@ -24,13 +24,15 @@ puzzle =
                     . maybe (error "not enough boxes") snd
                     . listIndex n
                     . connectBoxes
-            , uncurry . const $
+            )
+                /\ ( uncurry . const $
                         uncurry ((*) `on` view _x)
                             . maybe (error "sets never unified") fst
                             . lastMay
                             . takeWhile ((> 1) . DS.sets . snd)
                             . connectBoxes
-            ]
+                   )
+                /\ nil
         , extraTests = mempty
         }
 

haskell/Puzzles/Day9.hs

@@ -8,12 +8,13 @@ puzzle =
         { number = 9
         , parser = const $ (V2 <$> decimal <* single ',' <*> decimal) `sepEndBy1` newline
         , parts =
-            [ maximum
+            ( maximum
                 . fmap (squareSize . uncurry Rectangle)
                 . fromMaybe (error "input too small")
                 . nonEmpty
                 . allUnorderedPairs False
-            , \points ->
+            )
+                /\ ( \points ->
                         let path =
                                 fromMaybe (error "malformed line")
                                     . traverse mkLine
@@ -26,7 +27,8 @@ puzzle =
                                 . sortOn (Down . snd)
                                 . fmap ((id &&& squareSize) . uncurry Rectangle)
                                 $ allUnorderedPairs False points
-            ]
+                   )
+                /\ nil
         , extraTests = mempty
         }
 

haskell/aoc.cabal

@@ -24,6 +24,7 @@ executable aoc
     default-extensions:
         BlockArguments
         DuplicateRecordFields
+        ImpredicativeTypes
         LexicalNegation
         MultiWayIf
         NamedFieldPuns