JSON Zipper

gistfile1.hs

import Text.JSON
import Data.Maybe

data JSZipper = JSZipper {
    parent :: Maybe JSZipper,
    lefts :: [JSValue],
    hole :: JSValue,
    rights :: [JSValue]
    }

toZipper :: JSValue -> JSZipper
toZipper j = JSZipper Nothing [] j []

fromZipper :: JSZipper -> JSValue    
fromZipper (JSZipper Nothing _ j _) = j 
fromZipper x = fromZipper $ fromJust $ up x


up :: JSZipper -> Maybe JSZipper
up (JSZipper Nothing _ j _) = Nothing
up (JSZipper (Just p) ls j rs) = 
    Just p{hole =(replaceChildren (hole p) children)}
       where children = reverse ls ++ j : rs

replaceChildren :: JSValue -> [JSValue] -> JSValue
replaceChildren (JSArray _) children = JSArray children
replaceChildren (JSObject x) children = 
  JSObject (toJSObject $ zip keys children)
  where keys = map fst $ fromJSObject x

replaceChildren x [] = x
replaceChildren x _ = error "OMG!! Those are probably not my children :)"


left :: JSZipper -> Maybe JSZipper
left (JSZipper p as x bs) = case as of
    [] -> Nothing
    a:as -> Just $ JSZipper p as a (x:bs)

right :: JSZipper -> Maybe JSZipper
right (JSZipper p as x bs) = case bs of
    [] -> Nothing
    b:bs -> Just $ JSZipper p (x:as) b bs

down :: JSZipper -> Maybe JSZipper
down z@(JSZipper p ls v rs) = do
  (c:cs) <- getChildren v
  return $ JSZipper (Just z) [] c cs


getChildren :: JSValue -> [JSValue]
getChildren (JSArray cs) = cs
getChildren (JSObject obj) = map snd $ fromJSObject obj
getChildren _ = []


field ::String -> JSZipper -> Maybe JSZipper
field n z = do
    JSObject obj <- return $ hole z
    i            <- findIndex ((== n) . fst) (fromJSObject obj)
    firstChild   <- down z
    applyM right i firstChild

    -- foldr (\_ next jsv -> right jsv >>= next) return [0..i-1]
    

applyM _ 0 z = return z
applyM f n z = do next <- f z ; applyM (n-1) next

applyM :: (a -> m a) -> Int -> a -> m a
applyM f 0 x = return x
applyM f i x = applyM f (i-1) =<< f x

setHole x (JSZipper p as _ bs) = JSZipper p as x bs


update f jsz = setHole (f (hole jsz)) jsz



http://tinyurl.com/hoodlums10march


link test:
http://json.org/

toZipper jsonThing >>= down >>= right >>= right >>= field "foo" >>= update (const $ showJSON "blah") >>= fromZipper