git.iko.soy/jrec
on master help sign in
Merge pull request #20 from kamoii/ord-instance
41fb875Artyom Kazak
src/JRec/Internal.hs+28
compare with master
unifiedsplit
@@ -114,6 +114,10 @@ instance RecEq lts lts => Eq (Rec lts) where
114 (==) (a :: Rec lts) (b :: Rec lts) = recEq a b (Proxy :: Proxy lts)
114 (==) (a :: Rec lts) (b :: Rec lts) = recEq a b (Proxy :: Proxy lts)
115 {-# INLINE (==) #-}
115 {-# INLINE (==) #-}
116
116
117+instance RecOrd lts lts => Ord (Rec lts) where
118+ compare (a :: Rec lts) (b :: Rec lts) = recOrd a b (Proxy :: Proxy lts)
119+ {-# INLINE compare #-}
120+
117#ifdef WITH_AESON
121#ifdef WITH_AESON
118instance
122instance
119 ( RecApply lts lts EncodeField
123 ( RecApply lts lts EncodeField
@@ -633,6 +637,30 @@ instance
633 pNext = Proxy
637 pNext = Proxy
634 in res && recEq r1 r2 pNext
638 in res && recEq r1 r2 pNext
635
639
640+-- | Machinery to implement order
641+class RecEq rts lts => RecOrd (rts :: [*]) (lts :: [*]) where
642+ recOrd :: Rec rts -> Rec rts -> Proxy lts -> Ordering
643+
644+instance RecOrd rts '[] where
645+ recOrd _ _ _ = EQ
646+
647+instance
648+ ( RecOrd rts (RemoveAccessTo l lts),
649+ Has l rts v,
650+ Ord v
651+ ) =>
652+ RecOrd rts (l := t ': lts)
653+ where
654+ recOrd r1 r2 (_ :: Proxy (l := t ': lts)) =
655+ let lbl :: FldProxy l
656+ lbl = FldProxy
657+ val1 = get lbl r1
658+ val2 = get lbl r2
659+ ord = compare val1 val2
660+ pNext :: Proxy (RemoveAccessTo l (l := t ': lts))
661+ pNext = Proxy
662+ in if ord == EQ then recOrd r1 r2 pNext else ord
663+
636-- TODO: this probably slows typechecking in euler-ps, and should not be needed
664-- TODO: this probably slows typechecking in euler-ps, and should not be needed
637type family RemoveAccessTo (l :: Symbol) (lts :: [*]) :: [*] where
665type family RemoveAccessTo (l :: Symbol) (lts :: [*]) :: [*] where
638 RemoveAccessTo l (l := t ': lts) = RemoveAccessTo l lts
666 RemoveAccessTo l (l := t ': lts) = RemoveAccessTo l lts
test/JRecSpec.hs+12
@@ -25,6 +25,18 @@ spec = do
25 Rec (#a := 1, #a := 2) `shouldNotBe` Rec (#a := 0, #a := 2)
25 Rec (#a := 1, #a := 2) `shouldNotBe` Rec (#a := 0, #a := 2)
26 it "succeeds if first matching field compares" $ do
26 it "succeeds if first matching field compares" $ do
27 Rec (#a := 1, #a := 2) `shouldBe` Rec (#a := 1, #a := 0)
27 Rec (#a := 1, #a := 2) `shouldBe` Rec (#a := 1, #a := 0)
28+ it "ord" $ do
29+ -- Same as eq when there is duplicated keys.
30+ -- Only the first occurence of that key is considered.
31+ compare (Rec (#a := 1, #a := 2)) (Rec (#a := 1, #a := 2)) `shouldBe` EQ
32+ compare (Rec (#a := 1, #a := 2)) (Rec (#a := 1, #a := 3)) `shouldBe` EQ
33+ compare (Rec (#a := 1, #a := 2)) (Rec (#a := 2, #a := 1)) `shouldBe` LT
34+ compare (Rec (#a := 1, #a := 2)) (Rec (#a := 0, #a := 3)) `shouldBe` GT
35+ compare (Rec (#a := 1, #b := 2)) (Rec (#a := 1, #b := 2)) `shouldBe` EQ
36+ compare (Rec (#a := 1, #b := 2)) (Rec (#a := 1, #b := 3)) `shouldBe` LT
37+ compare (Rec (#a := 1, #b := 2)) (Rec (#a := 2, #b := 1)) `shouldBe` LT
38+ compare (Rec (#a := 1, #b := 2)) (Rec (#a := 0, #b := 3)) `shouldBe` GT
39+ compare (Rec (#a := 1, #a := 2, #b := 3)) (Rec (#a := 1, #a := 3, #b := 2)) `shouldBe` GT
28 it "show" $ do
40 it "show" $ do
29 show (Rec ()) `shouldBe` "{}"
41 show (Rec ()) `shouldBe` "{}"
30 show (Rec (#foo := True)) `shouldBe` "{foo = True}"
42 show (Rec (#foo := True)) `shouldBe` "{foo = True}"