From 4dcefed8d744bfd6d0870872070740d6db1d6c57 Mon Sep 17 00:00:00 2001
From: Liam Goodacre <goodacre.liam@gmail.com>
Date: Mon, 16 Jul 2018 22:11:32 +0100
Subject: [PATCH] Add/finish Ord instance for Records

---
 src/Data/Ord.purs   | 70 +++++++++++++++++++++++----------------------
 test/Test/Main.purs |  6 ++++
 2 files changed, 42 insertions(+), 34 deletions(-)

diff --git a/src/Data/Ord.purs b/src/Data/Ord.purs
index 66609d4b..aa839206 100644
--- a/src/Data/Ord.purs
+++ b/src/Data/Ord.purs
@@ -12,14 +12,20 @@ module Data.Ord
   , abs
   , signum
   , module Data.Ordering
+  , class OrdRecord, compareRecord
   ) where
 
-import Data.Eq (class Eq, class Eq1)
+import Data.Eq (class Eq, class Eq1, class EqRecord, (/=))
+import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
 import Data.Ord.Unsafe (unsafeCompare)
 import Data.Ordering (Ordering(..))
 import Data.Ring (class Ring, zero, one, negate)
 import Data.Unit (Unit)
 import Data.Void (Void)
+import Prim.Row as Row
+import Prim.RowList as RL
+import Record.Unsafe (unsafeGet)
+import Type.Data.RowList (RLProxy(..))
 
 -- | The `Ord` type class represents types which support comparisons with a
 -- | _total order_.
@@ -169,36 +175,32 @@ class Eq1 f <= Ord1 f where
 instance ord1Array :: Ord1 Array where
   compare1 = compare
 
--- Ordering for records is currently unimplemented as there are outstanding
--- questions around whether this implementation be useful. This is because it
--- prioritises the keys alphabetically, and this behaviour isn't overridable.
--- For now, we leave this unavailable, but the implementation is as follows:
-
--- 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)
+class EqRecord rowlist row <= OrdRecord rowlist row where
+  compareRecord :: RLProxy rowlist -> Record row -> Record row -> Ordering
+
+instance ordRecordNil :: OrdRecord RL.Nil row where
+  compareRecord _ _ _ = EQ
+
+instance ordRecordCons
+    :: ( OrdRecord rowlistTail row
+       , Row.Cons key focus rowTail row
+       , IsSymbol key
+       , Ord focus
+       )
+    => OrdRecord (RL.Cons key focus rowlistTail) row where
+  compareRecord _ ra rb
+    = if left /= EQ
+        then left
+        else compareRecord (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
+       )
+    => Ord (Record row) where
+  compare = compareRecord (RLProxy :: RLProxy list)
+
diff --git a/test/Test/Main.purs b/test/Test/Main.purs
index 9e01851e..2a7a896b 100644
--- a/test/Test/Main.purs
+++ b/test/Test/Main.purs
@@ -144,3 +144,9 @@ testRecordInstances = do
     { a: true, b: false, c: true, d: false }
     { a: true, b: true, c: false, d: false }
     == { a: true, b: true, c: false, d: true }
+  testOrd { a: 0, b: "hello" } { a: 42, b: "hello" } LT
+  testOrd { a: 42, b: "hello" } { a: 0, b: "hello" } GT
+  testOrd { a: 42, b: "hello" } { a: 42, b: "hello" } EQ
+  testOrd { a: 42, b: "hell" } { a: 42, b: "hello" } LT
+  testOrd { a: 42, b: "hello" } { a: 42, b: "hell" } GT
+