Merge pull request #16 from garyb/comparisons

Fix `Ord` / `Ord1` by restoring original `Ord1` instance

Author: garyb

src/Data/Json/Extended.purs

@@ -146,10 +146,10 @@ array ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ Array t → t
 array = embed <<< Sig.Array
 
 map ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ Map.Map t t → t
-map = embed <<< Sig.Map <<< A.fromFoldable <<< Map.toList
+map = embed <<< Sig.Map <<< Sig.EJsonMap <<< A.fromFoldable <<< Map.toList
 
 map' ∷ ∀ t. Corecursive t Sig.EJsonF ⇒ SM.StrMap t → t
-map' = embed <<< Sig.Map <<< F.map go <<< A.fromFoldable <<< SM.toList
+map' = embed <<< Sig.Map <<< Sig.EJsonMap <<< F.map go <<< A.fromFoldable <<< SM.toList
   where
     go (T.Tuple a b) = T.Tuple (string a) b
 
@@ -213,10 +213,10 @@ _Array = prism' array $ project >>> case _ of
 
 _Map ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF, Ord t) ⇒ Prism' t (Map.Map t t)
 _Map = prism' map $ project >>> case _ of
-  Sig.Map kvs → M.Just $ Map.fromFoldable kvs
+  Sig.Map (Sig.EJsonMap kvs) → M.Just $ Map.fromFoldable kvs
   _ → M.Nothing
 
 _Map' ∷ ∀ t. (Corecursive t Sig.EJsonF, Recursive t Sig.EJsonF) ⇒ Prism' t (SM.StrMap t)
 _Map' = prism' map' $ project >>> case _ of
-  Sig.Map kvs → SM.fromFoldable <$> for kvs (bitraverse (preview _String) pure)
+  Sig.Map (Sig.EJsonMap kvs) → SM.fromFoldable <$> for kvs (bitraverse (preview _String) pure)
   _ → M.Nothing

src/Data/Json/Extended/Cursor.purs

@@ -105,7 +105,7 @@ set cur x v = case lmap project <$> peel cur of
 -- | ```
 getKey ∷ EJ.EJson → EJ.EJson → Maybe EJ.EJson
 getKey k v = case project v of
-  EJ.Map fields → lookup k fields
+  EJ.Map (EJ.EJsonMap fields) → lookup k fields
   _ → Nothing
 
 -- | For a given key, attempts to set a new value for it in an EJson Map. If the
@@ -120,8 +120,8 @@ getKey k v = case project v of
 -- | ```
 setKey ∷ EJ.EJson → EJ.EJson → EJ.EJson → EJ.EJson
 setKey k x v = case project v of
-  EJ.Map fields →
-    embed <<< EJ.Map $ map
+  EJ.Map (EJ.EJsonMap fields) →
+    embed <<< EJ.Map <<< EJ.EJsonMap $ map
       (\(kv@(Tuple k' v)) → if k == k' then Tuple k x else kv) fields
   _ → v
 

src/Data/Json/Extended/Signature/Core.purs

@@ -1,23 +1,25 @@
 module Data.Json.Extended.Signature.Core
   ( EJsonF(..)
+  , EJsonMap(..)
   , getType
   ) where
 
 import Prelude
 
 import Data.Bifunctor as BF
 import Data.DateTime as DT
-import Data.Eq (class Eq1, eq1)
+import Data.Eq (class Eq1)
 import Data.Foldable as F
 import Data.HugeNum as HN
-import Data.Int as Int
 import Data.Json.Extended.Type as JT
 import Data.List as L
+import Data.Map as M
 import Data.Monoid (mempty)
+import Data.Newtype (class Newtype)
 import Data.Ord (class Ord1)
+import Data.TacitString (TacitString)
 import Data.Traversable as T
 import Data.Tuple (Tuple(..))
-import Data.TacitString (TacitString)
 
 -- | The signature endofunctor for the EJson theory.
 data EJsonF a
@@ -32,42 +34,34 @@ data EJsonF a
   | Interval String
   | ObjectId String
   | Array (Array a)
-  | Map (Array (Tuple a a))
-
-instance functorEJsonF ∷ Functor EJsonF where
-  map f x =
-    case x of
-      Null → Null
-      String str → String str
-      Boolean b → Boolean b
-      Integer i → Integer i
-      Decimal a → Decimal a
-      Timestamp ts → Timestamp ts
-      Date d → Date d
-      Time t → Time t
-      Interval i → Interval i
-      ObjectId oid → ObjectId oid
-      Array xs → Array $ f <$> xs
-      Map xs → Map $ BF.bimap f f <$> xs
+  | Map (EJsonMap a)
+
+derive instance functorEJsonF ∷ Functor EJsonF
+
+derive instance eqEJsonF ∷ Eq a ⇒ Eq (EJsonF a)
+instance eq1EJsonF ∷ Eq1 EJsonF where eq1 = eq
+
+derive instance ordEJsonF ∷ Ord a ⇒ Ord (EJsonF a)
+instance ord1EJsonF ∷ Ord1 EJsonF where compare1 = compare
 
 instance foldableEJsonF ∷ F.Foldable EJsonF where
   foldMap f = case _ of
     Array xs → F.foldMap f xs
-    Map xs → F.foldMap (\(Tuple k v) → f k <> f v) xs
+    Map xs → F.foldMap f xs
     _ → mempty
   foldl f a = case _ of
     Array xs → F.foldl f a xs
-    Map xs → F.foldl (\acc (Tuple k v) → f (f acc k) v) a xs
+    Map xs → F.foldl f a xs
     _ → a
   foldr f a = case _ of
     Array xs → F.foldr f a xs
-    Map xs → F.foldr (\(Tuple k v) acc → f k $ f v acc) a xs
+    Map xs → F.foldr f a xs
     _ → a
 
 instance traversableEJsonF ∷ T.Traversable EJsonF where
   traverse f = case _ of
-    Array xs → map Array $ T.traverse f xs
-    Map xs → map Map $ T.traverse (\(Tuple k v) → Tuple <$> f k <*> f v) xs
+    Array xs → Array <$> T.traverse f xs
+    Map xs → Map <$> T.traverse f xs
     Null → pure Null
     String str → pure $ String str
     Boolean b → pure $ Boolean b
@@ -80,57 +74,6 @@ instance traversableEJsonF ∷ T.Traversable EJsonF where
     ObjectId oid → pure $ ObjectId oid
   sequence = T.sequenceDefault
 
-instance eq1EJsonF ∷ Eq1 EJsonF where
-  eq1 Null Null = true
-  eq1 (Boolean b1) (Boolean b2) = b1 == b2
-  eq1 (Integer i) (Integer j) = i == j
-  eq1 (Decimal a) (Decimal b) = a == b
-  eq1 (Integer i) (Decimal b) = intToHugeNum i == b
-  eq1 (Decimal a) (Integer j) = a == intToHugeNum j
-  eq1 (String a) (String b) = a == b
-  eq1 (Timestamp a) (Timestamp b) = a == b
-  eq1 (Date a) (Date b) = a == b
-  eq1 (Time a) (Time b) = a == b
-  eq1 (Interval a) (Interval b) = a == b
-  eq1 (ObjectId a) (ObjectId b) = a == b
-  eq1 (Array xs) (Array ys) = xs == ys
-  eq1 (Map xs) (Map ys) =
-    let
-      xs' = L.fromFoldable xs
-      ys' = L.fromFoldable ys
-    in
-      isSubobject xs' ys'
-        && isSubobject ys' xs'
-  eq1 _ _ = false
-
-instance eqEJsonF ∷ Eq a ⇒ Eq (EJsonF a) where
-  eq = eq1
-
--- | Very badly performing, but we don't have access to Ord here,
--- | so the performant version is not implementable.
-isSubobject
-  ∷ ∀ a b
-  . (Eq a, Eq b)
-  ⇒ L.List (Tuple a b)
-  → L.List (Tuple a b)
-  → Boolean
-isSubobject xs ys =
-  F.foldl
-    (\acc x → acc && F.elem x ys)
-    true
-    xs
-
-intToHugeNum
-  ∷ Int
-  → HN.HugeNum
-intToHugeNum =
-  HN.fromNumber
-    <<< Int.toNumber
-
-derive instance ordEJsonF ∷ Ord a ⇒ Ord (EJsonF a)
-instance ord1EJsonF ∷ Ord1 EJsonF where
-  compare1 = compare
-
 instance showEJsonF ∷ Show (EJsonF TacitString) where
   show = case _ of
     Null → "Null"
@@ -160,3 +103,41 @@ getType = case _ of
   ObjectId _ → JT.ObjectId
   Array _ → JT.Array
   Map _ → JT.Map
+
+newtype EJsonMap a = EJsonMap (Array (Tuple a a))
+
+derive instance newtypeEJsonMap ∷ Newtype (EJsonMap a) _
+
+instance functorEJsonMap ∷ Functor EJsonMap where
+  map f (EJsonMap xs) = EJsonMap (BF.bimap f f <$> xs)
+
+instance eqEJsonMap ∷ Eq a ⇒ Eq (EJsonMap a) where
+  eq (EJsonMap xs) (EJsonMap ys) =
+    let
+      xs' = L.fromFoldable xs
+      ys' = L.fromFoldable ys
+    in
+      isSubobject xs' ys'
+        && isSubobject ys' xs'
+
+-- | Very badly performing, but we don't have access to Ord here,
+-- | so the performant version is not implementable.
+isSubobject ∷ ∀ a. Eq a ⇒ L.List (Tuple a a) → L.List (Tuple a a) → Boolean
+isSubobject xs ys = F.foldl (\acc x → acc && F.elem x ys) true xs
+
+instance ordEJsonMap ∷ Ord a ⇒ Ord (EJsonMap a) where
+  compare (EJsonMap xs) (EJsonMap ys) =
+    compare (M.fromFoldable xs) (M.fromFoldable ys)
+
+instance showEJsonMap ∷ Show (EJsonMap TacitString) where
+  show (EJsonMap xs) = "(EJsonMap " <> show xs <> ")"
+
+instance foldableEJsonMap ∷ F.Foldable EJsonMap where
+  foldMap f (EJsonMap xs) = F.foldMap (\(Tuple k v) → f k <> f v) xs
+  foldl f a (EJsonMap xs) = F.foldl (\acc (Tuple k v) → f (f acc k) v) a xs
+  foldr f a (EJsonMap xs) = F.foldr (\(Tuple k v) acc → f k $ f v acc) a xs
+
+instance traversableEJsonMap ∷ T.Traversable EJsonMap where
+  traverse f (EJsonMap xs) =
+    EJsonMap <$> T.traverse (\(Tuple k v) → Tuple <$> f k <*> f v) xs
+  sequence = T.sequenceDefault

src/Data/Json/Extended/Signature/Gen.purs

@@ -10,7 +10,7 @@ import Data.Array as A
 import Data.DateTime as DT
 import Data.Enum (toEnum)
 import Data.HugeNum as HN
-import Data.Json.Extended.Signature.Core (EJsonF(..))
+import Data.Json.Extended.Signature.Core (EJsonF(..), EJsonMap(..))
 import Data.Maybe (fromMaybe)
 import Data.Tuple as T
 
@@ -42,7 +42,7 @@ arbitraryEJsonFWithKeyGen keyGen rec =
   Gen.oneOf (pure Null)
     [ arbitraryBaseEJsonF
     , Array <$> Gen.arrayOf rec
-    , Map <$> do
+    , Map <<< EJsonMap <$> do
         keys ← distinctArrayOf keyGen
         vals ← Gen.vectorOf (A.length keys) rec
         pure $ A.zip keys vals

src/Data/Json/Extended/Signature/Json.purs

@@ -13,7 +13,7 @@ import Data.DateTime as DT
 import Data.Either as E
 import Data.HugeNum as HN
 import Data.Int as Int
-import Data.Json.Extended.Signature.Core (EJsonF(..))
+import Data.Json.Extended.Signature.Core (EJsonF(..), EJsonMap(..))
 import Data.Json.Extended.Signature.Parse (parseDate, parseTime, parseTimestamp)
 import Data.Json.Extended.Signature.Render (renderDate, renderTime, renderTimestamp)
 import Data.Maybe as M
@@ -37,7 +37,7 @@ encodeJsonEJsonF = case _ of
   Interval str → JS.jsonSingletonObject "$interval" $ encodeJson str
   ObjectId str → JS.jsonSingletonObject "$oid" $ encodeJson str
   Array xs → encodeJson xs
-  Map xs → JS.jsonSingletonObject "$obj" $ encodeJson $ asStrMap xs
+  Map (EJsonMap xs) → JS.jsonSingletonObject "$obj" $ encodeJson $ asStrMap xs
   where
   tuple
     ∷ T.Tuple JS.Json JS.Json
@@ -89,6 +89,7 @@ decodeJsonEJsonF =
     → EJsonF JS.Json
   strMapObject =
     Map
+    <<< EJsonMap
     <<< A.fromFoldable
     <<< map (lmap encodeJson)
     <<< SM.toList