bundles/org.simantics.scl.runtime/scl/Json2.scl

   1 import "Prelude"
   2 import "StringBuilder" as StringBuilder
   3 import "Coercion"
   4
   5 class JSON a where
   6     toJSON :: a -> String
   7     buildJSON :: StringBuilder.T -> a -> <Proc> StringBuilder.T
   8     buildJSONList :: StringBuilder.T -> [a] -> <Proc> StringBuilder.T
   9
  10     toJSON v = runProc (StringBuilder.toString (buildJSON StringBuilder.new v))
  11     buildJSONList sb v = printList buildJSON (sb << "[") v << "]"
  12
  13 // Basic types
  14
  15 instance JSON Integer where
  16     buildJSON = (<+)
  17 instance JSON Long where
  18     buildJSON = (<+)
  19 instance JSON Float where
  20     buildJSON = (<+)
  21 instance JSON Double where
  22     buildJSON = (<+)
  23 instance JSON String where
  24     buildJSON = (<+)
  25 instance JSON Boolean where
  26     buildJSON sb v = if v then sb << "true" else sb << "false"
  27
  28 // Compound types
  29
  30 @private
  31 @inline
  32 printList :: (StringBuilder.T -> a -> <Proc> StringBuilder.T) -> StringBuilder.T -> [a] -> <Proc> StringBuilder.T
  33 printList f sb l = loop 0
  34   where
  35     len = length l
  36     loop i = if i >= len then sb
  37              else do
  38                  f (if i==0 then sb else sb << ",") (l!i)
  39                  loop (i+1)
  40
  41 instance (JSON a) => JSON [a] where
  42     buildJSON = buildJSONList
  43 instance JSON () where
  44     buildJSON sb _ = sb << "[]"
  45 instance (JSON a,JSON b) => JSON (a,b) where
  46     buildJSON sb (a,b) = buildJSON (buildJSON (sb << "[") a << ",") b << "]"
  47 instance (JSON a,JSON b,JSON c) => JSON (a,b,c) where
  48     buildJSON sb (a,b,c) = buildJSON (buildJSON (buildJSON (sb << "[") a << ",") b << ",") c << "]"
  49 instance (JSON a,JSON b,JSON c,JSON d) => JSON (a,b,c,d) where
  50     buildJSON sb (a,b,c,d) = buildJSON (buildJSON (buildJSON (buildJSON (sb << "[") a << ",") b << ",") c << ",") d << "]"
  51 instance (JSON a) => JSON (Maybe a) where
  52     buildJSON sb (Just a) = buildJSON sb a
  53     buildJSON sb Nothing  = sb << "null"
  54
  55 // Building custom objects
  56
  57 data JSEntry = JSEntry String (StringBuilder.T -> <Proc> StringBuilder.T)
  58
  59 (:::) :: JSON a => String -> a -> JSEntry
  60 key ::: value = JSEntry key (\sb -> buildJSON sb value)
  61
  62 instance JSON JSEntry where
  63     buildJSON _ _ = fail "JSEntry cannot be directly serialized to JSON."
  64     buildJSONList sb v = printList printJSEntry (sb << "{") v << "}"
  65       where
  66         printJSEntry sb (JSEntry key value) = value (sb <+ key << ":")
  67
  68 //
  69
  70 data JSObject = JSObject (StringBuilder.T -> <Proc> StringBuilder.T)
  71
  72 toJSONList :: JSON a => [a] -> [JSObject]
  73 toJSONList = map (\v -> JSObject (\sb -> buildJSON sb v))
  74
  75 instance JSON JSObject where
  76     buildJSON sb (JSObject f) = f sb