JSON Zipper

zipper.hs

module Zipper where

import Data.List
import Text.JSON
import Data.Maybe
import Control.Monad

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 -> Maybe [JSValue]
getChildren (JSArray cs) = Just cs
getChildren (JSObject obj) = Just (map snd $ fromJSObject obj)
getChildren _ = Nothing


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 f i = foldr (>=>) return (replicate i f)

--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
--toZipper jsonThing >>= down >>= right >>= right >>= field "foo" >>= update (const $ showJSON "blah") >>= fromZipper