Fix output for non-Unicode locales

Author: Lysxia

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 = " * "

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 =

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)