From e856792d482ec9f3a349873b2e0a348cec6108d3 Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Fri, 29 Aug 2025 00:23:04 +0200 Subject: [PATCH] Fix output for non-Unicode locales --- src/Test/StrictCheck.hs | 89 +++++++++++++++++++++----- src/Test/StrictCheck/Examples/Lists.hs | 6 ++ tests/Specs.hs | 13 +++- 3 files changed, 90 insertions(+), 18 deletions(-) diff --git a/src/Test/StrictCheck.hs b/src/Test/StrictCheck.hs index eb65d12..de8f822 100644 --- a/src/Test/StrictCheck.hs +++ b/src/Test/StrictCheck.hs @@ -78,9 +78,13 @@ import Generics.SOP hiding (Shape) import Test.QuickCheck as Exported hiding (Args, Result, function) import qualified Test.QuickCheck as QC +import Data.Char (ord) +import Data.Function (on) import Data.List import Data.Maybe import Data.IORef +import GHC.IO.Encoding (textEncodingName) +import qualified System.IO as IO import Type.Reflection -- | The default comparison of demands: exact equality @@ -295,8 +299,16 @@ strictCheckSpecExact spec function = (putStrLn . head . lines) (output result) case maybeExample of Nothing -> return () - Just example -> - putStrLn (Prelude.uncurry displayCounterSpec example) + Just example -> do + unicode <- doesStdoutAcceptUnicode + putStrLn (Prelude.uncurry (displayCounterSpec unicode) example) + +doesStdoutAcceptUnicode :: IO Bool +doesStdoutAcceptUnicode = do + encoding <- IO.hGetEncoding IO.stdout + case encoding of + Nothing -> pure False + Just enc -> pure (any (((==) `on` textEncodingName) enc) [IO.utf8, IO.utf8_bom, IO.utf16, IO.utf16le, IO.utf16be, IO.utf32, IO.utf32le, IO.utf32be]) ------------------------------------------------------------ -- An Evaluation is what we generate when StrictCheck-ing -- @@ -400,53 +412,94 @@ shrinkEvalWith T -> Nothing E pos -> Just pos +-- | If 'False' (unicode output is disabled), replace all non-ASCII characters with '?'. +sanitize :: Bool -> String -> String +sanitize True = id +sanitize False = fmap (\c -> if ord c < 128 then c else '?') -- | Render a counter-example to a specification (that is, an 'Evaluation' --- paired with some expected input demands it doesn't match) as a Unicode --- box-drawing sketch +-- paired with some expected input demands it doesn't match) as a +-- box-drawing sketch (in Unicode or ASCII depending on whether the +-- first argument is 'True' or 'False') displayCounterSpec :: forall args result. (Shaped result, All Shaped args) - => Evaluation args result + => Bool -- ^ 'True' to enable prettier Unicode output + -> Evaluation args result -> NP Demand args -> String -displayCounterSpec (Evaluation inputs inputsD resultD) predictedInputsD = - beside inputBox (" " : "───" : repeat " ") resultBox +displayCounterSpec unicode (Evaluation inputs inputsD resultD) predictedInputsD = + sanitize unicode $ + beside inputBox (" " : threeDashes : repeat " ") resultBox ++ (flip replicate ' ' $ (2 `max` (subtract 2 $ (lineMax [inputString] `div` 2)))) - ++ "🡓 🡓 🡓\n" + ++ threeArrows ++ beside actualBox - (" " : " " : " ═╱═ " : repeat " ") + (" " : " " : notEqual : repeat " ") predictedBox where - inputBox = + threeDashes | unicode = "───" + | otherwise = "---" + threeArrows | unicode = "🡓 🡓 🡓\n" + | otherwise = "v v v\n" + notEqual | unicode = " ═╱═ " + | otherwise = " =/= " + inputBox + | unicode = box "┌" '─' "┐" "│" inputHeader "├" "├" '─' "┤" "│" inputString "│" "└" '─' "┘" - - resultBox = + | otherwise = + box "+" '-' "+" + "|" inputHeader "+" + "+" '-' "+" + "|" inputString "|" + "+" '-' "+" + + resultBox + | unicode = box "┌" '─' "┐" "┤" resultHeader "│" "├" '─' "┤" "│" resultString "│" "└" '─' "┘" - - actualBox = + | otherwise = + box "+" '-' "+" + "+" resultHeader "|" + "+" '-' "+" + "|" resultString "|" + "+" '-' "+" + + actualBox + | unicode = box "┌" '─' "┐" "│" actualHeader "│" "├" '─' "┤" "│" actualDemandString "│" "└" '─' "┘" - - predictedBox = + | otherwise = + box "+" '-' "+" + "|" actualHeader "|" + "+" '-' "+" + "|" actualDemandString "|" + "+" '-' "+" + + predictedBox + | unicode = box "┌" '─' "┐" "│" predictedHeader "│" "├" '─' "┤" "│" predictedDemandString "│" "└" '─' "┘" + | otherwise = + box "+" '-' "+" + "|" predictedHeader "|" + "+" '-' "+" + "|" predictedDemandString "|" + "+" '-' "+" inputHeader = " Input" ++ plural resultHeader = " Demand on result" @@ -511,4 +564,6 @@ displayCounterSpec (Evaluation inputs inputsD resultD) predictedInputsD = showNPWith' :: forall ys. All c ys => NP g ys -> String showNPWith' Nil = "" showNPWith' (y :* ys) = - " • " ++ display y ++ "\n" ++ showNPWith' ys + bullet ++ display y ++ "\n" ++ showNPWith' ys + bullet | unicode = " • " + | otherwise = " * " diff --git a/src/Test/StrictCheck/Examples/Lists.hs b/src/Test/StrictCheck/Examples/Lists.hs index 9e7ee04..a5609a1 100644 --- a/src/Test/StrictCheck/Examples/Lists.hs +++ b/src/Test/StrictCheck/Examples/Lists.hs @@ -20,6 +20,12 @@ length_spec = Spec $ \predict _ xs -> predict (xs $> thunk) +-- | An incorrect specification for 'length' (to test the pretty printer) +bad_length_spec :: Spec '[[a]] Int +bad_length_spec = + Spec $ \predict _ xs -> + predict (take 1 xs $> thunk) + -- | A naive specification for 'take', which is wrong take_spec_too_easy :: Spec '[Int, [a]] [a] take_spec_too_easy = diff --git a/tests/Specs.hs b/tests/Specs.hs index 017daa9..cde6671 100644 --- a/tests/Specs.hs +++ b/tests/Specs.hs @@ -6,6 +6,10 @@ import Test.StrictCheck import Test.StrictCheck.Examples.Lists import Test.StrictCheck.Examples.Map +import Control.Monad (when) +import GHC.IO.Encoding (textEncodingName) +import System.IO + runSpecs :: IO () runSpecs = do putStrLn "Checking length_spec..." @@ -35,4 +39,11 @@ runSpecs = do iterSolution_spec iterSolutionWithKey >>= print - return () + putStrLn "Checking bad_length_spec (failure is expected!)..." + strictCheckSpecExact bad_length_spec (length :: [Int] -> Int) + + enc <- hGetEncoding stdout + when (fmap textEncodingName enc == Just "UTF-8") $ do + hSetEncoding stdout latin1 + putStrLn "Checking bad_length_spec without Unicode output (failure is expected!)..." + strictCheckSpecExact bad_length_spec (length :: [Int] -> Int)