diff --git a/src/Trace/Hpc/Utils.hs b/src/Trace/Hpc/Utils.hs index e851aa1bc1dc4780191b45761ad38ed24c2e1127..5407bc93b815b0028ca2c6c624916b0c27d2b61f 100644 --- a/src/Trace/Hpc/Utils.hs +++ b/src/Trace/Hpc/Utils.hs @@ -1,11 +1,15 @@ +{-# 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