Merge pull request #12 from garyb/cursor

Add a cursor for EJson

src/Data/Json/Extended/Cursor.purs

@@ -0,0 +1,151 @@
+module Data.Json.Extended.Cursor where
+
+import Prelude
+
+import Data.Array as A
+import Data.Bifunctor (lmap)
+import Data.Eq (class Eq1)
+import Data.Functor.Mu (Mu, roll, unroll)
+import Data.Json.Extended (EJson)
+import Data.Json.Extended as EJ
+import Data.Maybe (Maybe(..), maybe)
+import Data.Ord (class Ord1)
+import Data.Tuple (Tuple(..), lookup)
+
+import Matryoshka (Algebra, cata)
+
+-- | A cursor to a location in an EJson value.
+-- |
+-- | The functions operating on cursor are "depth first", that is to say:
+-- | ``` purescript
+-- | atKey (EJ.string "foo") $ atIndex 0 $ atKey (EJ.string "bar") all
+-- | ```
+-- | Is the path:
+-- | ```
+-- | <value>.bar[0].foo
+-- | ```
+type Cursor = Mu CursorF
+
+all ∷ Cursor
+all = roll All
+
+atKey ∷ EJ.EJson → Cursor → Cursor
+atKey k = roll <<< AtKey k
+
+atIndex ∷ Int → Cursor → Cursor
+atIndex i = roll <<< AtIndex i
+
+-- | The possible steps in a cursor.
+data CursorF a
+  = All
+  | AtKey EJson a
+  | AtIndex Int a
+
+derive instance functorCursorF ∷ Functor CursorF
+derive instance eqCursor ∷ Eq a ⇒ Eq (CursorF a)
+derive instance ordCursor ∷ Ord a ⇒ Ord (CursorF a)
+
+instance eq1CursorF ∷ Eq1 CursorF where
+  eq1 = eq
+
+instance ord1CursorF ∷ Ord1 CursorF where
+  compare1 = compare
+
+instance showCursorF ∷ Show a => Show (CursorF a) where
+  show = case _ of
+    All → "All"
+    AtKey k a → "(AtKey " <> show k <> " " <> show a <> ")"
+    AtIndex i a → "(AtIndex " <> show i <> " " <> show a <> ")"
+
+-- | Peels off one layer of a cursor, if possible. The resulting tuple contains
+-- | the current step (made relative), and the remainder of the cursor.
+-- |
+-- | ``` purescript
+-- | peel (atKey (EJ.string "foo") $ atIndex 0 all) == Just (Tuple (atKey (EJ.string "foo") all) (atIndex 0 all))
+-- | peel (atIndex 0 all) == Just (Tuple (atIndex 0 all) all)
+-- | peel all == Nothing
+-- | ```
+peel ∷ Cursor → Maybe (Tuple Cursor Cursor)
+peel c = case unroll c of
+  All → Nothing
+  AtKey k rest → Just $ Tuple (atKey k all) rest
+  AtIndex i rest → Just $ Tuple (atIndex i all) rest
+
+-- | Takes a cursor and attempts to read from an EJson value, producing the
+-- | value the cursor points to, if it exists.
+get ∷ Cursor → EJson → Maybe EJson
+get = cata go
+  where
+  go :: Algebra CursorF (EJson -> Maybe EJson)
+  go = case _ of
+    All → Just
+    AtKey k prior → getKey k <=< prior
+    AtIndex i prior → getIndex i <=< prior
+
+-- | Takes a cursor and attempts to set an EJson value within a larger EJson
+-- | value if the value the cursor points at exists.
+set ∷ Cursor → EJson → EJson → EJson
+set cur x v = case lmap unroll <$> peel cur of
+  Nothing → x
+  Just (Tuple All _) → x
+  Just (Tuple (AtKey k _) path) → maybe v (setKey k x) $ get path v
+  Just (Tuple (AtIndex i _) path) → maybe v (setIndex i x) $ get path v
+
+-- | Attempts to lookup a key in an EJson Map, returning the associated value
+-- | if the key exists and the value is a Map.
+-- |
+-- | ``` purescript
+-- | getKey (EJ.string "foo") (EJ.map' $ EJ.string <$> SM.fromFoldable [Tuple "foo" "bar"]) == Just (EJ.string "bar")
+-- | getKey (EJ.string "foo") (EJ.map' $ EJ.string <$> SM.fromFoldable [Tuple "key" "value"]) == Nothing
+-- | getKey (EJ.string "foo") (EJ.boolean false) == Nothing
+-- | ```
+getKey ∷ EJ.EJson → EJ.EJson → Maybe EJ.EJson
+getKey k v = case EJ.head v of
+  EJ.Map fields → EJ.EJson <$> lookup (EJ.getEJson k) fields
+  _ → Nothing
+
+-- | For a given key, attempts to set a new value for it in an EJson Map. If the
+-- | value is not a Map, or the key does not already exist, the original value
+-- | is returned.
+-- |
+-- | ``` purescript
+-- | let map = EJ.map' $ EJ.string <$> SM.fromFoldable [Tuple "foo" "bar"]
+-- | setKey (EJ.string "foo") (EJ.boolean true) map == EJ.map' (SM.fromFoldable [Tuple "foo" (EJ.boolean true)])
+-- | setKey (EJ.string "bar") (EJ.boolean true) map == map
+-- | setKey (EJ.string "foo") (EJ.boolean true) (EJ.string "not-a-map") == EJ.string "not-a-map"
+-- | ```
+setKey ∷ EJ.EJson → EJ.EJson → EJ.EJson → EJ.EJson
+setKey (EJ.EJson k) (EJ.EJson x) v = case EJ.head v of
+  EJ.Map fields →
+    EJ.EJson <<< roll <<< EJ.Map $ map
+      (\(kv@(Tuple k' v)) → if k == k' then Tuple k x else kv) fields
+  _ → v
+
+-- | Attempts to lookup an index in an EJson Array, returning the associated
+-- | value if there is an item at that index, and the value is an Array.
+-- |
+-- | ``` purescript
+-- | getIndex 0 (EJ.array $ EJ.string <$> ["foo"]) == Just (EJ.string "foo")
+-- | getIndex 1 (EJ.array $ EJ.string <$> ["foo"]) == Nothing
+-- | getIndex 0 (EJ.boolean false) == Nothing
+-- | ```
+getIndex ∷ Int → EJ.EJson → Maybe EJ.EJson
+getIndex i v = case EJ.head v of
+  EJ.Array items → EJ.EJson <$> A.index items i
+  _ → Nothing
+
+-- | For a given index, attempts to set a new value for it in an EJson Array. If
+-- | the value is not a Array, or the index does not already exist, the original
+-- | value is returned.
+-- |
+-- | ``` purescript
+-- | let array = EJ.array $ EJ.string <$> ["foo"]
+-- | setIndex 0 (EJ.boolean true) array == EJ.array [EJ.boolean true]
+-- | setIndex 1 (EJ.boolean true) array == array
+-- | setIndex 0 (EJ.boolean true) (EJ.string "not-an-array") == EJ.string "not-an-array"
+-- | ```
+setIndex ∷ Int → EJ.EJson → EJ.EJson → EJ.EJson
+setIndex i (EJ.EJson x) v = case EJ.head v of
+  EJ.Array items →
+    maybe v (EJ.EJson <<< roll <<< EJ.Array) $ A.updateAt i x items
+  _ → v

test/Main.purs

@@ -9,7 +9,12 @@ import Control.Monad.Eff.Console (CONSOLE)
 import Data.Argonaut.Decode (decodeJson)
 import Data.Argonaut.Encode (encodeJson)
 import Data.Either as E
+import Data.Maybe
+import Data.StrMap as SM
+import Data.Tuple
 import Data.Json.Extended (EJson, arbitraryJsonEncodableEJsonOfSize, arbitraryEJsonOfSize, renderEJson, parseEJson)
+import Data.Json.Extended as EJ
+import Data.Json.Extended.Cursor as EJC
 
 import Text.Parsing.Parser as P
 
@@ -45,7 +50,61 @@ testRenderParse =
       E.Right y → x == y SC.<?> "Mismatch:\n" <> show x <> "\n" <> show y
       E.Left err → SC.Failed $ "Parse error: " <> show err <> " when parsing:\n\n " <> renderEJson x <> "\n\n"
 
+testCursorExamples ∷ Eff TestEffects Unit
+testCursorExamples = do
+  assertEq
+    (EJC.peel (EJC.atKey (EJ.string "foo") $ EJC.atIndex 0 EJC.all))
+    (Just (Tuple (EJC.atKey (EJ.string "foo") EJC.all) (EJC.atIndex 0 EJC.all)))
+  assertEq
+    (EJC.peel (EJC.atIndex 0 EJC.all))
+    (Just (Tuple (EJC.atIndex 0 EJC.all) EJC.all))
+  assertEq
+    (EJC.peel EJC.all)
+    Nothing
+  assertEq
+    (EJC.getKey (EJ.string "foo") (EJ.map' $ EJ.string <$> SM.fromFoldable [Tuple "foo" "bar"]))
+    (Just (EJ.string "bar"))
+  assertEq
+    (EJC.getKey (EJ.string "foo") (EJ.map' $ EJ.string <$> SM.fromFoldable [Tuple "key" "value"]))
+    Nothing
+  assertEq
+    (EJC.getKey (EJ.string "foo") (EJ.boolean false))
+    Nothing
+  assertEq
+    (EJC.getIndex 0 (EJ.array $ EJ.string <$> ["foo"]))
+    (Just (EJ.string "foo"))
+  assertEq
+    (EJC.getIndex 1 (EJ.array $ EJ.string <$> ["foo"]))
+    Nothing
+  assertEq
+    (EJC.getIndex 0 (EJ.boolean false))
+    Nothing
+  let map = EJ.map' $ EJ.string <$> SM.fromFoldable [Tuple "foo" "bar"]
+  assertEq
+    (EJC.setKey (EJ.string "foo") (EJ.boolean true) map)
+    (EJ.map' (SM.fromFoldable [Tuple "foo" (EJ.boolean true)]))
+  assertEq
+    (EJC.setKey (EJ.string "bar") (EJ.boolean true) map)
+    map
+  assertEq
+    (EJC.setKey (EJ.string "foo") (EJ.boolean true) (EJ.string "not-a-map"))
+    (EJ.string "not-a-map")
+  let array = EJ.array $ EJ.string <$> ["foo"]
+  assertEq
+    (EJC.setIndex 0 (EJ.boolean true) array)
+    (EJ.array [EJ.boolean true])
+  assertEq
+    (EJC.setIndex 1 (EJ.boolean true) array)
+    array
+  assertEq
+    (EJC.setIndex 0 (EJ.boolean true) (EJ.string "not-an-array"))
+    (EJ.string "not-an-array")
+  where
+  assertEq ∷ ∀ a. (Show a, Eq a) ⇒ a → a → Eff TestEffects Unit
+  assertEq x y = SC.assert $ SC.assertEq x y
+
 main :: Eff TestEffects Unit
 main = do
   testJsonSerialization
   testRenderParse
+  testCursorExamples