public
Created

JSON Zipper

  • Download Gist
gistfile1.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.