less-quick-and-dirty JSON

0-json.hs

{-# LANGUAGE QuasiQuotes #-}

import Atomo.Environment
import Atomo.Haskell
import Atomo.Method
import Atomo.Valuable

import Text.JSON as JSON

load :: VM ()
load = do
    eval [$e|JSON = Object clone|]

    [$p|JSON parse: (s: String)|] =: do
        s <- here "s" >>= findString
        case decode (fromString s) :: Result JSValue of
            Ok js -> toValue js
            JSON.Error s -> raise ["json-parse-failed"] [string s]

    [$p|o as: JSON|] =::: [$e|JSON clone do: { delegates-to: o }|]

    [$p|(j: JSON) as: String|] =: do
        o <- here "j"
        js <- fromValue o :: VM JSValue
        return (string (encode js))

instance Valuable JSValue where
    toValue JSNull = return (particle "null")
    toValue (JSBool b) = bool b
    toValue (JSRational _ r) = return (Double (fromRational r))
    toValue (JSString s) = return (string . fromJSString $ s)
    toValue (JSArray vs) = mapM toValue vs >>= list
    toValue (JSObject o) = do
        ms <- forM (fromJSObject o) $ \(n, j) -> do
            v <- toValue j
            return (psingle n PThis, v)

        json <- here "JSON"
        o <- newObject $ \o -> o
            { oDelegates = [json]
            , oMethods = (toMethods ms, emptyMap)
            }

        return o
      where
        as = fromJSObject o

    fromValue (Particle (PMSingle "null")) = return JSNull
    fromValue (Integer i) = return (JSRational True (toRational i))
    fromValue (Double d) = return (JSRational True (toRational d))
    fromValue s@(String _) = return (JSString (toJSString (fromString s)))
    fromValue l@(List _) = do
        js <- toList l >>= mapM fromValue
        return (JSArray js)

    fromValue v = do
        [t, f] <- mapM bool [True, False]

        true <- dispatch (keyword ["is-a?"] [v, t])
        if true == t
            then return (JSBool True)
            else do

        false <- dispatch (keyword ["is-a?"] [v, f])
        if false == t
            then return (JSBool False)
            else do

        ifVM (dispatch (keyword ["delegates-to?"] [v, particle "null"]))
            (return JSNull) $ do

        ifVM (here "Integer" >>= isA v >>= bool)
            (findInteger v >>= fromValue) $ do

        ifVM (here "Double" >>= isA v >>= bool)
            (findDouble v >>= fromValue) $ do

        ifVM (here "String" >>= isA v >>= bool)
            (findString v >>= fromValue) $ do

        ifVM (here "List" >>= isA v >>= bool)
            (findList v >>= fromValue) $ do

        json <- here "JSON"
        dispatch (keyword ["as"] [v, json])

        [$p|o|] =:: v
        ms <- eval [$e|o methods singles (map: { (m . _) | [m pattern name, m value] })|] >>= toList >>= mapM toList

        js <- forM ms $ \[n, v] -> do
            j <- fromValue v
            return (fromString n, j)

        return (JSObject $ toJSObject js)

1-usage.js

> obj = JSON clone (do: { a = 1; b = [2, @null, "four"]; c = JSON clone do: { x = "y" } })
<object (delegates to 1 object)>
  a := 1
  b := [2, @null, "four"]
  c := <object>
> obj print
{"a":1,"b":[2,null,"four"],"c":{"x":"y"}}
<object (delegates to 1 object)>
  a := 1
  b := [2, @null, "four"]
  c := <object>
> JSON parse: (obj as: String)
<object (delegates to 1 object)>
  a := 1.0
  b := [2.0, @null, "four"]
  c := <object>
>