Skip to content
Snippets Groups Projects

Add JSON functionality to Utils

Merged Leonard Zieger requested to merge LeoZieger/hpc-bin:implement-json into master
+ 90
0
{-# 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
Loading