diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 1f34a6d8f..7b84cce5f 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -12,13 +12,6 @@ import Data.Scientific (Scientific, fromFloatDigits, toRealFloat) import Prelude hiding (fail) import Prologue --- TODO: move this useful projection function elsewhere -au :: ( f :< ValueConstructors loc term1 - , g :< ValueConstructors loc term2) - => (Value loc term1, Value loc term2) - -> Maybe (f (Value loc term1), g (Value loc term2)) -au = bitraverse prjValue prjValue - -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP -- have built-in generalized-comparison ("spaceship") operators. If you want to -- encapsulate a traditional, boolean-returning operator, wrap it in 'Concrete'; @@ -141,23 +134,25 @@ instance ( MonadAddressable location (Value location term) m pair = (left, right) liftComparison comparator left right - | Just (Integer i, Integer j) <- au pair = go i j - | Just (Integer i, Value.Float j) <- au pair = go (fromIntegral i) j - | Just (Value.Float i, Integer j) <- au pair = go i (fromIntegral j) - | Just (Value.Float i, Value.Float j) <- au pair = go i j - | Just (Value.String i, Value.String j) <- au pair = go i j - | Just (Boolean i, Boolean j) <- au pair = go i j - | Just (Value.Unit, Value.Unit) <- au pair = boolean True + | Just (Integer i, Integer j) <- prjPair pair = go i j + | Just (Integer i, Value.Float j) <- prjPair pair = go (fromIntegral i) j + | Just (Value.Float i, Integer j) <- prjPair pair = go i (fromIntegral j) + | Just (Value.Float i, Value.Float j) <- prjPair pair = go i j + | Just (Value.String i, Value.String j) <- prjPair pair = go i j + | Just (Boolean i, Boolean j) <- prjPair pair = go i j + | Just (Value.Unit, Value.Unit) <- prjPair pair = boolean True | otherwise = fail ("Type error: invalid arguments to liftComparison: " <> show pair) where + -- Explicit type signature is necessary here because we're passing all sorts of things + -- to these comparison functions. go :: (Ord a, MonadValue term value m) => a -> a -> m value go l r = case comparator of Concrete f -> boolean (f l r) - Generalized -> integer (munge (compare l r)) + Generalized -> integer (orderingToInt (compare l r)) - munge LT = negate 1 - munge EQ = 0 - munge GT = 1 + -- Map from [LT, EQ, GT] to [-1, 0, 1] + orderingToInt :: Ordering -> Prelude.Integer + orderingToInt = toInteger . pred . fromEnum pair = (left, right)