Refactor comparison using cases

src/swarm-engine/Swarm/Game/Step/Arithmetic.hs

@@ -43,53 +43,55 @@ evalCmp c v1 v2 = decideCmp c $ compareValues v1 v2
 -- | Compare two values, returning an 'Ordering' if they can be
 --   compared, or @Nothing@ if they cannot.
 compareValues :: Has (Throw Exn) sig m => Value -> Value -> m Ordering
-compareValues v1 = case v1 of
-  VUnit -> \case VUnit -> return EQ; v2 -> incompatCmp VUnit v2
-  VInt n1 -> \case VInt n2 -> return (compare n1 n2); v2 -> incompatCmp v1 v2
-  VText t1 -> \case VText t2 -> return (compare t1 t2); v2 -> incompatCmp v1 v2
-  VDir d1 -> \case VDir d2 -> return (compare d1 d2); v2 -> incompatCmp v1 v2
-  VBool b1 -> \case VBool b2 -> return (compare b1 b2); v2 -> incompatCmp v1 v2
-  VRobot r1 -> \case VRobot r2 -> return (compare r1 r2); v2 -> incompatCmp v1 v2
-  VInj s1 v1' -> \case
-    VInj s2 v2' ->
-      case compare s1 s2 of
-        EQ -> compareValues v1' v2'
-        o -> return o
-    v2 -> incompatCmp v1 v2
-  VPair v11 v12 -> \case
-    VPair v21 v22 ->
-      (<>) <$> compareValues v11 v21 <*> compareValues v12 v22
-    v2 -> incompatCmp v1 v2
-  VRcd m1 -> \case
-    VRcd m2 -> mconcat <$> (zipWithM compareValues `on` M.elems) m1 m2
-    v2 -> incompatCmp v1 v2
-  VKey kc1 -> \case
-    VKey kc2 -> return (compare kc1 kc2)
-    v2 -> incompatCmp v1 v2
-  VClo {} -> incomparable v1
-  VCApp {} -> incomparable v1
-  VBind {} -> incomparable v1
-  VDelay {} -> incomparable v1
-  VRef {} -> incomparable v1
-  VIndir {} -> incomparable v1
-  VRequirements {} -> incomparable v1
-  VSuspend {} -> incomparable v1
-  VExc {} -> incomparable v1
-  VBlackhole {} -> incomparable v1
-  VType {} -> incomparable v1
+compareValues = \cases
+  VUnit VUnit -> return EQ
+  (VInt n1) (VInt n2) -> return (compare n1 n2)
+  (VText t1) (VText t2) -> return (compare t1 t2)
+  (VDir d1) (VDir d2) -> return (compare d1 d2)
+  (VBool b1) (VBool b2) -> return (compare b1 b2)
+  (VRobot r1) (VRobot r2) -> return (compare r1 r2)
+  (VKey kc1) (VKey kc2) -> return (compare kc1 kc2)
+  (VInj s1 v1') (VInj s2 v2') ->
+    case compare s1 s2 of
+      EQ -> compareValues v1' v2'
+      o -> return o
+  (VPair v11 v12) (VPair v21 v22) ->
+    (<>) <$> compareValues v11 v21 <*> compareValues v12 v22
+  (VRcd m1) (VRcd m2) ->
+    mconcat <$> (zipWithM compareValues `on` M.elems) m1 m2
+  v1 v2 ->
+    if incomparable v1 || incomparable v2
+      then incomparableErr v1 v2
+      else incompatCmpErr v1 v2
+
+-- | Check if comparing types which cannot be compared (e.g. functions, etc.)
+incomparable :: Value -> Bool
+incomparable = \case
+  VClo {} -> True
+  VCApp {} -> True
+  VBind {} -> True
+  VDelay {} -> True
+  VRef {} -> True
+  VIndir {} -> True
+  VRequirements {} -> True
+  VSuspend {} -> True
+  VExc {} -> True
+  VBlackhole {} -> True
+  VType {} -> True
+  _ -> False
 
 -- | Values with different types were compared; this should not be
 --   possible since the type system should catch it.
-incompatCmp :: Has (Throw Exn) sig m => Value -> Value -> m a
-incompatCmp v1 v2 =
+incompatCmpErr :: Has (Throw Exn) sig m => Value -> Value -> m a
+incompatCmpErr v1 v2 =
   throwError $
     Fatal $
       T.unwords ["Incompatible comparison of ", prettyValue v1, "and", prettyValue v2]
 
 -- | Values were compared of a type which cannot be compared
 --   (e.g. functions, etc.).
-incomparable :: Has (Throw Exn) sig m => Value -> Value -> m a
-incomparable v1 v2 =
+incomparableErr :: Has (Throw Exn) sig m => Value -> Value -> m a
+incomparableErr v1 v2 =
   throwError $
     cmdExn
       Lt