fix: adjust runner to not display Strings in quotes

IndecisionTree · IndecisionTree · commit 62df075ecaf6 · 2022-12-05T09:35:40.000-05:00
diff --git a/aoc/AOC.hs b/aoc/AOC.hs
@@ -1,7 +1,19 @@
+{-# language ScopedTypeVariables, GADTs #-}
+
 module AOC (
   module AOC.Types,
-  mkAocClient
+  mkAocClient,
+  showSolution,
 ) where
 
 import AOC.Types
 import AOC.API
+import Type.Reflection
+
+-- TODO find a better way to avoid 'show'ing Stringlike things in
+-- quotes ("") without resorting to end-users having to wrap Solutions
+-- with something like data StringOr = StringLike a | NotStringLike b
+showSolution :: forall a. (Typeable a, Show a) => a -> String
+showSolution a = case eqTypeRep (typeRep @a) (typeRep @String) of
+  Just HRefl -> a
+  Nothing -> show a
diff --git a/aoc/AOC/Types.hs b/aoc/AOC/Types.hs
@@ -7,9 +7,11 @@ module AOC.Types (
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Web.Internal.FormUrlEncoded (ToForm)
+import Type.Reflection
 
 data Solution where
-  Solution :: Show b => (Text -> a) -> (a -> b) -> (a -> b) -> Solution
+  Solution :: (Typeable b, Show b) =>
+    (Text -> a) -> (a -> b) -> (a -> b) -> Solution
 
 data Submission = Submission {
   part :: Int,
diff --git a/runner/Main.hs b/runner/Main.hs
@@ -1,6 +1,6 @@
 module Main where
 
-import AOC (Solution (..), mkAocClient)
+import AOC (Solution (..), mkAocClient, showSolution)
 import Configuration.Dotenv (defaultConfig, loadFile)
 import Control.Exception (IOException, catch)
 import Control.Monad (when)
@@ -71,8 +71,8 @@ run (Solution pInput part1 part2) part input =
     Just n -> printf "Part %d: %s\n" n $ if n == 1 then part1' else part2'
   where
     parsed = pInput input
-    part1' = show $ part1 parsed
-    part2' = show $ part2 parsed
+    part1' = showSolution $ part1 parsed
+    part2' = showSolution $ part2 parsed
 
 -- | CLI parser
 opts :: ParserInfo Options
diff --git a/runner/Tests.hs b/runner/Tests.hs
@@ -2,7 +2,7 @@
 
 module Tests (test) where
 
-import AOC (Solution (..))
+import AOC (Solution (..), showSolution)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Data.Void (Void)
@@ -14,6 +14,7 @@ import Test.Tasty.Ingredients.Basic (consoleTestReporter)
 import Text.Megaparsec
 import Text.Megaparsec.Char (newline, space)
 import Text.Megaparsec.Char.Lexer qualified as L
+import Type.Reflection
 
 data TestInput = TestInput
   { _testName :: T.Text,
@@ -55,13 +56,15 @@ test (Solution pInput part1 part2) day part = do
 
 -- | Given an input parser, part1 or part2 function, and a test input,
 -- generate an HUnit test.
-mkTest :: Show b => (T.Text -> a) -> (a -> b) -> TestInput -> TestTree
+-- TODO this feels like a leaky abstraction of Solution
+mkTest :: (Typeable b, Show b) => (T.Text -> a) -> (a -> b) -> TestInput -> TestTree
 mkTest pInput part TestInput {..} =
   testCase (T.unpack _testName) $ T.unpack _testExpected @=? result
   where
-    result = show . part $ pInput _testInput
+    result = showSolution . part $ pInput _testInput
 
 -- | Parse test files into TestInput's
+-- TODO more robust parsing and better, user-friendly custom errors
 pTests :: Parser [TestInput]
 pTests = many pTest <* eof
   where
@@ -71,8 +74,5 @@ pTests = many pTest <* eof
     pInput = T.pack <$> someTill anySingle (symbol "==") <?> "Input Lines"
     pExpected = T.pack <$> many (anySingleBut '\n') <* newline <?> "Expected Output"
 
-lexeme :: Parser a -> Parser a
-lexeme = L.lexeme space
-
 symbol :: T.Text -> Parser T.Text
 symbol = L.symbol space
