char class stuff

tests/Tests/CharExtra.idr

@@ -0,0 +1,56 @@
+module Tests.CharExtra
+
+import Quox.NatExtra
+import Quox.CharExtra
+import Data.List
+import Data.String
+import Data.Maybe
+import TAP
+
+
+escape : Char -> Maybe String
+escape '\'' = Nothing
+escape c =
+  if ord c > 0xFF then Nothing else
+  case unpack $ show c of
+       '\'' :: '\\' :: cs => pack . ('\\' ::) <$> init' cs
+       _                  => Nothing
+
+display : Char -> String
+display c =
+  let ord = cast c {to = Nat} in
+  let c'  = fromMaybe (singleton c) $ escape c in
+  if 0x20 <= ord && ord <= 0xFF then
+    "｢\{c'}｣"
+  else
+    let codepoint = padLeft 4 '0' $ showHex ord in
+    "｢\{c'}｣ (U+\{codepoint})"
+
+testOne : (Char -> Bool) -> Char -> Test
+testOne pred c = test (display c) $ unless (pred c) $ Left ()
+
+testAll : String -> (Char -> Bool) -> List Char -> Test
+testAll label pred chars = label :- map (testOne pred) chars
+
+
+tests = "char extras" :- [
+  testAll "id starts" isIdStart
+    ['a', 'á', '𝕕', '개', 'ʨ', '𒁙', '𝟙'],
+  testAll "not id starts" (not . isIdStart)
+    ['0', '_', '-', '‿', ' ', '[', ',', '.', '\1'],
+  testAll "id continuations" isIdCont
+    ['a', 'á', '𝕕', '개', 'ʨ', '𒁙', '0', '\''],
+  testAll "not id continuations" (not . isIdCont)
+    ['_', '‿', ' ', '[', ',', '.', '\1'],
+  testAll "id connectors" isIdConnector
+    ['_', '‿'],
+  testAll "not id connectors" (not . isIdConnector)
+    ['a', ' ', ',', '-'],
+  testAll "white space" isWhitespace
+    [' ', '\t', '\r', '\n',
+     '\x2028', -- line separator
+     '\x2029'  -- paragraph separator
+    ],
+  testAll "not white space" (not . isWhitespace)
+    ['a', '-', '_', '\1']
+]