Add Eq, Ord and Semigroup constraints for Record

This commit is to be followed by several others, slowly building up the
set of record instances in the prelude by way of RowToList.

Author: Tom Harding

src/Data/Eq.purs

@@ -1,10 +1,19 @@
 module Data.Eq
   ( class Eq, eq, (==), notEq, (/=)
   , class Eq1, eq1, notEq1
+
+  , class EqRecord
+  , eqRecordImpl
   ) where
 
+import Data.HeytingAlgebra ((&&))
+import Data.Internal.Record (unsafeGet)
+import Data.RowList (RLProxy(..))
+import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
 import Data.Unit (Unit)
 import Data.Void (Void)
+import Prim.Row as Row
+import Prim.RowList as RL
 
 -- | The `Eq` type class represents types which support decidable equality.
 -- |
@@ -66,3 +75,29 @@ instance eq1Array :: Eq1 Array where
 
 notEq1 :: forall f a. Eq1 f => Eq a => f a -> f a -> Boolean
 notEq1 x y = (x `eq1` y) == false
+
+class EqRecord rowlist row focus | rowlist -> focus where
+  eqRecordImpl :: RLProxy rowlist -> Record row -> Record row -> Boolean
+
+instance eqRecordNil :: EqRecord RL.Nil row focus where
+  eqRecordImpl _ _ _ = true
+
+instance eqRecordCons
+    :: ( EqRecord rowlistTail row subfocus
+       , Row.Cons key focus rowTail row
+       , IsSymbol key
+       , Eq focus
+       )
+    => EqRecord (RL.Cons key a rowlistTail) row a where
+  eqRecordImpl _ ra rb
+    = unsafeGet' key ra == unsafeGet key rb
+        && eqRecordImpl (RLProxy :: RLProxy rowlistTail) ra rb
+    where key = reflectSymbol (SProxy :: SProxy key)
+          unsafeGet' = unsafeGet :: String -> Record row -> focus
+
+instance eqRecord
+    :: ( RL.RowToList row list
+       , EqRecord list row focus
+       )
+    => Eq (Record row) where
+  eq = eqRecordImpl (RLProxy :: RLProxy list)

src/Data/Internal/Record.js

@@ -0,0 +1,14 @@
+exports.unsafeGet = function (key) {
+  return function (xs) {
+    return xs[key];
+  };
+};
+
+exports.unsafeInsert = function (key) {
+  return function (value) {
+    return function (xs) {
+      xs[key] = value;
+      return xs;
+    };
+  };
+};

src/Data/Internal/Record.purs

@@ -0,0 +1,14 @@
+module Data.Internal.Record where
+
+-- | *Really* unsafely get a value from a record. You really shouldn't be using
+-- | this function unless you know what you're doing.
+foreign import unsafeGet :: forall a rs. String -> Record rs -> a
+
+-- | *Really* unsafely insert a value into a record. Again, you really
+-- | shouldn't use this function.
+foreign import unsafeInsert
+  :: forall a ra rb
+   . String
+  -> a
+  -> Record ra
+  -> Record rb

src/Data/Ord.purs

@@ -14,12 +14,17 @@ module Data.Ord
   , module Data.Ordering
   ) where
 
-import Data.Eq (class Eq, class Eq1)
+import Data.Eq (class Eq, class Eq1, class EqRecord, (/=))
+import Data.Internal.Record (unsafeGet)
 import Data.Ord.Unsafe (unsafeCompare)
 import Data.Ordering (Ordering(..))
 import Data.Ring (class Ring, zero, one, negate)
+import Data.RowList (RLProxy(..))
+import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
 import Data.Unit (Unit)
 import Data.Void (Void)
+import Prim.Row as Row
+import Prim.RowList as RL
 
 -- | The `Ord` type class represents types which support comparisons with a
 -- | _total order_.
@@ -168,3 +173,32 @@ class Eq1 f <= Ord1 f where
 
 instance ord1Array :: Ord1 Array where
   compare1 = compare
+
+class EqRecord rowlist row focus <= OrdRecord rowlist row focus | rowlist -> focus where
+  compareImpl :: RLProxy rowlist -> Record row -> Record row -> Ordering
+
+instance ordRecordNil :: OrdRecord RL.Nil row focus where
+  compareImpl _ _ _ = EQ
+
+instance ordRecordCons
+    :: ( OrdRecord rowlistTail row subfocus
+       , Row.Cons key focus rowTail row
+       , IsSymbol key
+       , Ord focus
+       )
+    => OrdRecord (RL.Cons key focus rowlistTail) row focus where
+  compareImpl _ ra rb
+    = if left /= EQ
+        then left
+        else compareImpl (RLProxy :: RLProxy rowlistTail) ra rb
+    where
+      key = reflectSymbol (SProxy :: SProxy key)
+      unsafeGet' = unsafeGet :: String -> Record row -> focus
+      left = unsafeGet' key ra `compare` unsafeGet' key rb
+
+instance ordRecord
+    :: ( RL.RowToList row list
+       , OrdRecord list row focus
+       )
+    => Ord (Record row) where
+  compare = compareImpl (RLProxy :: RLProxy list)

src/Data/RowList.purs

@@ -0,0 +1,7 @@
+module Data.RowList where
+
+import Prim.RowList (kind RowList)
+
+-- | A proxy to carry information about a rowlist.
+data RLProxy (rowlist :: RowList)
+  = RLProxy

src/Data/Semigroup.purs

@@ -1,7 +1,12 @@
 module Data.Semigroup (class Semigroup, append, (<>)) where
 
+import Data.Internal.Record (unsafeGet, unsafeInsert)
+import Data.RowList (RLProxy(..))
+import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
 import Data.Unit (Unit, unit)
 import Data.Void (Void, absurd)
+import Prim.Row as Row
+import Prim.RowList as RL
 
 -- | The `Semigroup` type class identifies an associative operation on a type.
 -- |
@@ -33,3 +38,30 @@ instance semigroupArray :: Semigroup (Array a) where
 
 foreign import concatString :: String -> String -> String
 foreign import concatArray :: forall a. Array a -> Array a -> Array a
+
+class SemigroupRecord rowlist row subrow focus | rowlist -> subrow focus where
+  semigroupRecordImpl :: RLProxy rowlist -> Record row -> Record row -> Record subrow
+
+instance semigroupRecordNil :: SemigroupRecord RL.Nil row () focus where
+  semigroupRecordImpl _ _ _ = {}
+
+instance semigroupRecordCons
+    :: ( IsSymbol key
+       , Row.Cons key focus subrowTail subrow
+       , SemigroupRecord rowlistTail row subrowTail subfocus
+       , Semigroup focus
+       )
+    => SemigroupRecord (RL.Cons key focus rowlistTail) row subrow focus where
+  semigroupRecordImpl _ ra rb
+    = unsafeInsert key
+        (unsafeGet' key ra <> unsafeGet' key rb)
+        (semigroupRecordImpl (RLProxy :: RLProxy rowlistTail) ra rb)
+    where key = reflectSymbol (SProxy :: SProxy key)
+          unsafeGet' = unsafeGet :: String -> Record row -> focus
+
+instance semigroupRecord
+    :: ( RL.RowToList row list
+       , SemigroupRecord list row row focus
+       )
+    => Semigroup (Record row) where
+  append = semigroupRecordImpl (RLProxy :: RLProxy list)