Add JSON functionality to Trace.HPC.Utils

src/Trace/Hpc/Utils.hs

+{-# LANGUAGE GADTSyntax #-}
+
 -- |
 -- Module             : Trace.Hpc.Utils
 -- Description        : Utility functions for hpc-bin
 -- License            : BSD-3-Clause
 module Trace.Hpc.Utils where
 
+import Data.Char (isControl)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Numeric (showHex)
 import System.FilePath
 import Trace.Hpc.Flags
 import Trace.Hpc.Tix
@@ -80,3 +84,89 @@ mergeTix modComb f (Tix t1) (Tix t2) =
 
     fm1 = Map.fromList [(tixModuleName tix, tix) | tix <- t1]
     fm2 = Map.fromList [(tixModuleName tix, tix) | tix <- t2]
+
+-- | Simple data type to represent JSON documents.
+-- Copied from: https://hackage.haskell.org/package/ghc-9.4.4/docs/GHC-Utils-Json.html
+data JsonDoc where
+  JSNull :: JsonDoc
+  JSBool :: Bool -> JsonDoc
+  JSInt :: Int -> JsonDoc
+  JSString ::
+    String ->
+    -- | The 'String' is unescaped
+    JsonDoc
+  JSArray :: [JsonDoc] -> JsonDoc
+  JSObject :: [(String, JsonDoc)] -> JsonDoc
+
+-- | Class for types which can be converted to JSON
+class ToJson a where
+  json :: a -> JsonDoc
+
+-- | returns the JSON-data as a single line
+jsonToString :: JsonDoc -> String
+jsonToString d = case d of
+  JSNull -> "null"
+  JSBool b -> if b then "true" else "false"
+  JSInt n -> show n
+  JSString s -> doubleQuotes $ escapeJsonString s
+  JSArray as -> arrayToString as
+  JSObject o -> objectToString o
+  where
+    brackets :: String -> String
+    brackets s = "[" ++ s ++ "]"
+
+    braces :: String -> String
+    braces s = "{" ++ s ++ "}"
+
+    doubleQuotes :: String -> String
+    doubleQuotes s = "\"" ++ s ++ "\""
+
+    arrayToString :: [JsonDoc] -> String
+    arrayToString lst = brackets $ go lst
+      where
+        go [] = ""
+        go [x] = jsonToString x
+        go (x : xs) = jsonToString x ++ "," ++ go xs
+
+    objectToString :: [(String, JsonDoc)] -> String
+    objectToString lst = braces $ go lst
+      where
+        go [] = []
+        go [(s, x)] = doubleQuotes s ++ ":" ++ jsonToString x
+        go ((s, x) : os) =
+          doubleQuotes s
+            ++ ":"
+            ++ jsonToString x
+            ++ ","
+            ++ go os
+
+    escapeJsonString :: String -> String
+    escapeJsonString = concatMap escapeChar
+      where
+        escapeChar '\b' = "\\b"
+        escapeChar '\f' = "\\f"
+        escapeChar '\n' = "\\n"
+        escapeChar '\r' = "\\r"
+        escapeChar '\t' = "\\t"
+        escapeChar '"' = "\\\\\\\""
+        escapeChar '\'' = "\\\'"
+        escapeChar '\\' = "\\\\\\\\"
+        escapeChar c | isControl c || fromEnum c >= 0x7f = uni_esc c
+        escapeChar c = [c]
+
+        uni_esc c = "\\u" ++ pad 4 (showHex (fromEnum c) "")
+
+        pad n cs
+          | len < n = replicate (n - len) '0' ++ cs
+          | otherwise = cs
+          where
+            len = length cs
+
+-- | Writes JSON data to file
+writeJSON ::
+  -- | Filepath to file
+  FilePath ->
+  -- | JSON data
+  JsonDoc ->
+  IO ()
+writeJSON fp js = writeFileUtf8 fp $ jsonToString js