From 92a7b4ca93f32494492c23adc9b64e86a96ce7f3 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 13 Mar 2018 18:13:38 -0400 Subject: [PATCH 1/4] Add Evaluatable instance for Rational and unify numerical interface. This one's kind of a doozy. We pull in a GADT that wraps an `Integer`, `Rational`, or `String`, and change the interpreted value types to hold instances of this GADT (`Number`). We also provide a rank-2 wrapper that hides the type parameter when necessary. The upshot of this patch is that we get support for rational numbers and a cleaner interface in MonadValue, without sacrificing a mote of type safety: interpreted `Integer` values are guaranteed to contain a Haskell `Integer`. On the other hand, it's kind of a monstrosity. Please let me know if you spot any places where I can simplify these constructs or document the code more fully. To test in Ruby, evaluate `3r ** 4r`. --- src/Control/Abstract/Value.hs | 60 +++++++++++++----------- src/Data/Abstract/Type.hs | 1 + src/Data/Abstract/Value.hs | 88 ++++++++++++++++++++++++++++++++--- src/Data/Syntax/Expression.hs | 13 +++--- src/Data/Syntax/Literal.hs | 6 ++- 5 files changed, 129 insertions(+), 39 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 2db0a067a..8df79c220 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -7,7 +7,7 @@ import Data.Abstract.Environment import Data.Abstract.FreeVariables import Data.Abstract.Type as Type import Data.Abstract.Value as Value -import Data.Scientific (Scientific, fromFloatDigits, toRealFloat) +import Data.Scientific (Scientific) import Prelude hiding (fail) import Prologue @@ -40,8 +40,7 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where -- You usually pass the same operator as both arguments, except in the cases where -- Haskell provides different functions for integral and fractional operations, such -- as division, exponentiation, and modulus. - liftNumeric2 :: (forall a . (Real a, Floating a) => a -> a -> a) - -> (forall b . Integral b => b -> b -> b) + liftNumeric2 :: (forall a b. Number a -> Number b -> SomeNumber) -> (value -> value -> m value) -- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values. @@ -56,6 +55,9 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where -- | Construct a floating-point value. float :: Scientific -> m value + -- | Construct a rational value. + rational :: Prelude.Rational -> m value + -- | Construct an N-ary tuple of multiple (possibly-disjoint) values multiple :: [value] -> m value @@ -115,10 +117,11 @@ instance ( MonadAddressable location (Value location term) m => MonadValue term (Value location term) m where unit = pure . injValue $ Value.Unit - integer = pure . injValue . Integer + integer = pure . injValue . Integer . Whole boolean = pure . injValue . Boolean string = pure . injValue . Value.String - float = pure . injValue . Value.Float + float = pure . injValue . Value.Float . Decim + rational = pure . injValue . Value.Rational . Ratio multiple vals = pure . injValue $ Value.Tuple vals @@ -129,33 +132,37 @@ instance ( MonadAddressable location (Value location term) m | otherwise = fail ("not defined for non-boolean conditions: " <> show cond) liftNumeric f arg - | Just (Integer i) <- prjValue arg = pure . injValue . Integer $ f i - | Just (Value.Float i) <- prjValue arg = pure . injValue . Value.Float $ f i + | Just (Integer (Whole i)) <- prjValue arg = integer $ f i + | Just (Value.Float (Decim d)) <- prjValue arg = float $ f d | otherwise = fail ("Invalid operand to liftNumeric: " <> show arg) - liftNumeric2 f g left right - | Just (Integer i, Integer j) <- prjPair pair = pure . injValue . Integer $ g i j - | Just (Integer i, Value.Float j) <- prjPair pair = pure . injValue . float $ f (fromIntegral i) (munge j) - | Just (Value.Float i, Value.Float j) <- prjPair pair = pure . injValue . float $ f (munge i) (munge j) - | Just (Value.Float i, Integer j) <- prjPair pair = pure . injValue . float $ f (munge i) (fromIntegral j) + liftNumeric2 f left right + | Just (Integer i, Integer j) <- prjPair pair = f i j & specialize + | Just (Integer i, Value.Rational j) <- prjPair pair = f i j & specialize + | Just (Integer i, Value.Float j) <- prjPair pair = f i j & specialize + | Just (Value.Rational i, Integer j) <- prjPair pair = f i j & specialize + | Just (Value.Rational i, Value.Rational j) <- prjPair pair = f i j & specialize + | Just (Value.Rational i, Value.Float j) <- prjPair pair = f i j & specialize + | Just (Value.Float i, Integer j) <- prjPair pair = f i j & specialize + | Just (Value.Float i, Value.Rational j) <- prjPair pair = f i j & specialize + | Just (Value.Float i, Value.Float j) <- prjPair pair = f i j & specialize | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair) where - -- Yucky hack to work around the lack of a Floating instance for Scientific. - -- This may possibly lose precision, but there's little we can do about that. - munge :: Scientific -> Double - munge = toRealFloat - float :: Double -> Value.Float a - float = Value.Float . fromFloatDigits + -- Dispatch whatever's contained inside a 'SomeNumber' to its appropriate 'MonadValue' ctor + specialize :: MonadValue term value m => SomeNumber -> m value + specialize (SomeNumber (Whole i)) = integer i + specialize (SomeNumber (Ratio r)) = rational r + specialize (SomeNumber (Decim d)) = float d pair = (left, right) liftComparison comparator left right - | 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 + | Just (Integer (Whole i), Integer (Whole j)) <- prjPair pair = go i j + | Just (Integer (Whole i), Value.Float (Decim j)) <- prjPair pair = go (fromIntegral i) j + | Just (Value.Float (Decim i), Integer (Whole j)) <- prjPair pair = go i (fromIntegral j) + | Just (Value.Float (Decim i), Value.Float (Decim 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 @@ -203,6 +210,7 @@ instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue boolean _ = pure Bool string _ = pure Type.String float _ = pure Type.Float + rational _ = pure Type.Rational multiple = pure . Type.Product -- TODO interface = undefined @@ -213,7 +221,7 @@ instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue liftNumeric _ Int = pure Int liftNumeric _ _ = fail "Invalid type in unary numeric operation" - liftNumeric2 _ _ left right = case (left, right) of + liftNumeric2 _ left right = case (left, right) of (Type.Float, Int) -> pure Type.Float (Int, Type.Float) -> pure Type.Float _ -> unify left right diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 423f23ebe..217bb48d1 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -14,6 +14,7 @@ data Type | String -- ^ Primitive string type. | Unit -- ^ The unit type. | Float -- ^ Floating-point type. + | Rational -- ^ Rational type. | Type :-> Type -- ^ Binary function types. | Var TName -- ^ A type variable. | Product [Type] -- ^ N-ary products. diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 621c9820b..9b65b2736 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-} +{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-} module Data.Abstract.Value where import Data.Abstract.Address @@ -8,9 +8,9 @@ import Data.Abstract.FreeVariables import Data.Abstract.Live import qualified Data.Abstract.Type as Type import qualified Data.Set as Set -import Data.Scientific (Scientific) +import Data.Scientific (Scientific, toRealFloat, fromFloatDigits) import Prologue -import Prelude hiding (Float, Integer, String, fail) +import Prelude hiding (Float, Integer, String, Rational, fail) import qualified Prelude type ValueConstructors location term @@ -21,6 +21,7 @@ type ValueConstructors location term , Float , Integer , String + , Rational , Tuple ] @@ -43,8 +44,75 @@ prjPair :: ( f :< ValueConstructors loc term1 , g :< ValueConstructors loc term2 -> Maybe (f (Value loc term1), g (Value loc term2)) prjPair = bitraverse prjValue prjValue +-- | A generalized number type that unifies all interpretable numeric types. +-- This is a GADT, so you can specialize the 'a' parameter and be confident +-- that, say, a @Number Scientific@ contains a 'Scientific' and not an integer +-- in disguise. +data Number a where + Whole :: Prelude.Integer -> Number Prelude.Integer + Ratio :: Prelude.Rational -> Number Prelude.Rational + Decim :: Scientific -> Number Scientific --- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. +deriving instance Eq a => Eq (Number a) + +instance Show (Number a) where + show (Whole i) = show i + show (Ratio r) = show r + show (Decim d) = show d + +-- | Every 'Number' can be coerced to a 'Scientific'. Used in the 'Ord' instance. +collapse :: Number a -> Scientific +collapse (Whole i) = fromInteger i +collapse (Ratio r) = fromRational r +collapse (Decim s) = s + +instance Eq a => Ord (Number a) where compare = compare `on` collapse + +-- | A box that hides the @a@ parameter to a given 'Number'. Pattern-match +-- on it to extract the information contained. +data SomeNumber = forall a . SomeNumber (Number a) + +-- | Smart constructors for 'SomeNumber'. +whole :: Prelude.Integer -> SomeNumber +whole = SomeNumber . Whole + +ratio :: Prelude.Rational -> SomeNumber +ratio = SomeNumber . Ratio + +decim :: Scientific -> SomeNumber +decim = SomeNumber . Decim + +-- | Promote a function on 'Real' values into one operating on 'Number's. +-- You pass things like @+@ and @-@ here. +liftSimple :: (forall n . Real n => n -> n -> n) + -> (Number a -> Number b -> SomeNumber) +liftSimple f = liftThorny f f + +-- | Promote two functions, one on 'Integral' and one on 'Fractional' and 'Real' values, +-- to operate on 'Numbers'. Examples of this: 'mod' and 'mod'', 'div' and '/'. +liftThorny :: (forall n . Integral n => n -> n -> n) + -> (forall f . (Fractional f, Real f) => f -> f -> f) + -> (Number a -> Number b -> SomeNumber) +liftThorny f _ (Whole i) (Whole j) = whole (f i j) +liftThorny _ g (Whole i) (Ratio j) = ratio (g (toRational i) j) +liftThorny _ g (Whole i) (Decim j) = decim (g (fromIntegral i) j) +liftThorny _ g (Ratio i) (Ratio j) = ratio (g i j) +liftThorny _ g (Ratio i) (Whole j) = ratio (g i (fromIntegral j)) +liftThorny _ g (Ratio i) (Decim j) = decim (g (fromRational i) j) +liftThorny _ g (Decim i) (Whole j) = decim (g i (fromIntegral j)) +liftThorny _ g (Decim i) (Ratio j) = decim (g i (fromRational j)) +liftThorny _ g (Decim i) (Decim j) = decim (g i j) + +-- | Exponential behavior is too hard to generalize, so here's a manually implemented version. +-- TODO: Given a 'Ratio' raised to some 'Whole', we could check to see if it's an integer +-- and round it before the exponentiation, giving back a 'Whole'. +safeExp :: Number a -> Number b -> SomeNumber +safeExp (Whole i) (Whole j) = whole (i ^ j) +safeExp (Ratio i) (Whole j) = ratio (i ^^ j) +safeExp i j = decim (fromFloatDigits ((munge i) ** (munge j))) + where munge = (toRealFloat . collapse) :: Number a -> Double + +-- TODO: Parameerize Value by the set of constructors s.t. each language can have a distinct value union. -- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body. data Closure location term value = Closure [Name] term (Environment location value) @@ -79,13 +147,21 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec -- | Arbitrary-width integral values. -newtype Integer value = Integer Prelude.Integer +newtype Integer value = Integer (Number Prelude.Integer) deriving (Eq, Generic1, Ord, Show) instance Eq1 Integer where liftEq = genericLiftEq instance Ord1 Integer where liftCompare = genericLiftCompare instance Show1 Integer where liftShowsPrec = genericLiftShowsPrec +-- | Arbitrary-width rational values values. +newtype Rational value = Rational (Number Prelude.Rational) + deriving (Eq, Generic1, Ord, Show) + +instance Eq1 Rational where liftEq = genericLiftEq +instance Ord1 Rational where liftCompare = genericLiftCompare +instance Show1 Rational where liftShowsPrec = genericLiftShowsPrec + -- | String values. newtype String value = String ByteString deriving (Eq, Generic1, Ord, Show) @@ -95,7 +171,7 @@ instance Ord1 String where liftCompare = genericLiftCompare instance Show1 String where liftShowsPrec = genericLiftShowsPrec -- | Float values. -newtype Float value = Float Scientific +newtype Float value = Float (Number Scientific) deriving (Eq, Generic1, Ord, Show) instance Eq1 Float where liftEq = genericLiftEq diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 6779bed53..bc32e83f4 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -6,6 +6,7 @@ import Data.Fixed import Diffing.Algorithm import Prelude hiding (fail) import Prologue hiding (apply) +import Data.Abstract.Value (liftThorny, liftSimple, safeExp) -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell. data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a } @@ -61,12 +62,12 @@ instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Arithmetic instance Evaluatable Arithmetic where eval = traverse subtermValue >=> go where - go (Plus a b) = liftNumeric2 (+) (+) a b - go (Minus a b) = liftNumeric2 (-) (-) a b - go (Times a b) = liftNumeric2 (*) (*) a b - go (DividedBy a b) = liftNumeric2 (/) div a b - go (Modulo a b) = liftNumeric2 mod' mod a b - go (Power a b) = liftNumeric2 (**) (^) a b + go (Plus a b) = liftNumeric2 add a b where add = liftSimple (+) + go (Minus a b) = liftNumeric2 sub a b where sub = liftSimple (-) + go (Times a b) = liftNumeric2 mul a b where mul = liftSimple (*) + go (DividedBy a b) = liftNumeric2 div' a b where div' = liftThorny div (/) + go (Modulo a b) = liftNumeric2 mod'' a b where mod'' = liftThorny mod mod' + go (Power a b) = liftNumeric2 safeExp a b go (Negate a) = liftNumeric negate a -- | Boolean operators. diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 310d13396..1fb5a7bca 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -106,7 +106,11 @@ instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompar instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Rational -instance Evaluatable Data.Syntax.Literal.Rational +instance Evaluatable Data.Syntax.Literal.Rational where + eval (Rational r) = let trimmed = B.takeWhile (/= 'r') r in + case readMaybe @Prelude.Integer (unpack trimmed) of + Just i -> rational (toRational i) + Nothing -> fail ("Bug: invalid rational " <> show r) -- Complex literals e.g. `3 + 2i` From ca96b02869b33da9a5b707756360585f226be445 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 13 Mar 2018 19:03:00 -0400 Subject: [PATCH 2/4] strictness annotations. will this do anything? only time will tell --- src/Data/Abstract/Value.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 48c521c6e..7af5c9ec2 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -49,9 +49,9 @@ prjPair = bitraverse prjValue prjValue -- that, say, a @Number Scientific@ contains a 'Scientific' and not an integer -- in disguise. data Number a where - Whole :: Prelude.Integer -> Number Prelude.Integer - Ratio :: Prelude.Rational -> Number Prelude.Rational - Decim :: Scientific -> Number Scientific + Whole :: !Prelude.Integer -> Number Prelude.Integer + Ratio :: !Prelude.Rational -> Number Prelude.Rational + Decim :: !Scientific -> Number Scientific deriving instance Eq a => Eq (Number a) From 0d248e2aab6e2dcf857ba3432e4e067d547eccf3 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 13 Mar 2018 20:55:46 -0400 Subject: [PATCH 3/4] Make sure we match Rationals in liftNumeric. --- src/Control/Abstract/Value.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 1792d1aa1..f12e59b06 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -140,8 +140,9 @@ instance ( MonadAddressable location (Value location term) m | otherwise = fail ("not defined for non-boolean conditions: " <> show cond) liftNumeric f arg - | Just (Integer (Whole i)) <- prjValue arg = integer $ f i - | Just (Value.Float (Decim d)) <- prjValue arg = float $ f d + | Just (Integer (Whole i)) <- prjValue arg = integer $ f i + | Just (Value.Float (Decim d)) <- prjValue arg = float $ f d + | Just (Value.Rational (Ratio r)) <- prjValue arg = rational $ f r | otherwise = fail ("Invalid operand to liftNumeric: " <> show arg) liftNumeric2 f left right From 81aab6572e998805674d8ece5e17c86271736641 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 14 Mar 2018 10:36:56 -0400 Subject: [PATCH 4/4] Address Rob's changes. --- semantic.cabal | 1 + src/Control/Abstract/Value.hs | 51 +++++++++--------- src/Data/Abstract/Number.hs | 98 +++++++++++++++++++++++++++++++++++ src/Data/Abstract/Value.hs | 75 ++------------------------- src/Data/Syntax/Expression.hs | 14 ++--- src/Data/Syntax/Literal.hs | 1 - 6 files changed, 136 insertions(+), 104 deletions(-) create mode 100644 src/Data/Abstract/Number.hs diff --git a/semantic.cabal b/semantic.cabal index 4d91706a5..1617b1351 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -49,6 +49,7 @@ library , Data.Abstract.FreeVariables , Data.Abstract.Live , Data.Abstract.ModuleTable + , Data.Abstract.Number , Data.Abstract.Store , Data.Abstract.Type , Data.Abstract.Value diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index f12e59b06..30f7dc8bf 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -5,6 +5,7 @@ import Control.Abstract.Addressable import Control.Abstract.Analysis import Data.Abstract.Environment import Data.Abstract.FreeVariables +import Data.Abstract.Number as Number import Data.Abstract.Type as Type import Data.Abstract.Value as Value import qualified Data.Map as Map @@ -117,14 +118,14 @@ instance ( MonadAddressable location (Value location term) m ) => MonadValue term (Value location term) m where - unit = pure . injValue $ Value.Unit - integer = pure . injValue . Integer . Whole - boolean = pure . injValue . Boolean - string = pure . injValue . Value.String - float = pure . injValue . Value.Float . Decim + unit = pure . injValue $ Value.Unit + integer = pure . injValue . Value.Integer . Number.Integer + boolean = pure . injValue . Boolean + string = pure . injValue . Value.String + float = pure . injValue . Value.Float . Decimal rational = pure . injValue . Value.Rational . Ratio - multiple vals = - pure . injValue $ Value.Tuple vals + + multiple = pure . injValue . Value.Tuple interface v = do -- TODO: If the set of exports is empty because no exports have been @@ -140,38 +141,38 @@ instance ( MonadAddressable location (Value location term) m | otherwise = fail ("not defined for non-boolean conditions: " <> show cond) liftNumeric f arg - | Just (Integer (Whole i)) <- prjValue arg = integer $ f i - | Just (Value.Float (Decim d)) <- prjValue arg = float $ f d - | Just (Value.Rational (Ratio r)) <- prjValue arg = rational $ f r + | Just (Value.Integer (Number.Integer i)) <- prjValue arg = integer $ f i + | Just (Value.Float (Decimal d)) <- prjValue arg = float $ f d + | Just (Value.Rational (Ratio r)) <- prjValue arg = rational $ f r | otherwise = fail ("Invalid operand to liftNumeric: " <> show arg) liftNumeric2 f left right - | Just (Integer i, Integer j) <- prjPair pair = f i j & specialize - | Just (Integer i, Value.Rational j) <- prjPair pair = f i j & specialize - | Just (Integer i, Value.Float j) <- prjPair pair = f i j & specialize - | Just (Value.Rational i, Integer j) <- prjPair pair = f i j & specialize + | Just (Value.Integer i, Value.Integer j) <- prjPair pair = f i j & specialize + | Just (Value.Integer i, Value.Rational j) <- prjPair pair = f i j & specialize + | Just (Value.Integer i, Value.Float j) <- prjPair pair = f i j & specialize + | Just (Value.Rational i, Value.Integer j) <- prjPair pair = f i j & specialize | Just (Value.Rational i, Value.Rational j) <- prjPair pair = f i j & specialize | Just (Value.Rational i, Value.Float j) <- prjPair pair = f i j & specialize - | Just (Value.Float i, Integer j) <- prjPair pair = f i j & specialize + | Just (Value.Float i, Value.Integer j) <- prjPair pair = f i j & specialize | Just (Value.Float i, Value.Rational j) <- prjPair pair = f i j & specialize | Just (Value.Float i, Value.Float j) <- prjPair pair = f i j & specialize | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair) where -- Dispatch whatever's contained inside a 'SomeNumber' to its appropriate 'MonadValue' ctor specialize :: MonadValue term value m => SomeNumber -> m value - specialize (SomeNumber (Whole i)) = integer i - specialize (SomeNumber (Ratio r)) = rational r - specialize (SomeNumber (Decim d)) = float d + specialize (SomeNumber (Number.Integer i)) = integer i + specialize (SomeNumber (Ratio r)) = rational r + specialize (SomeNumber (Decimal d)) = float d pair = (left, right) liftComparison comparator left right - | Just (Integer (Whole i), Integer (Whole j)) <- prjPair pair = go i j - | Just (Integer (Whole i), Value.Float (Decim j)) <- prjPair pair = go (fromIntegral i) j - | Just (Value.Float (Decim i), Integer (Whole j)) <- prjPair pair = go i (fromIntegral j) - | Just (Value.Float (Decim i), Value.Float (Decim 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 + | Just (Value.Integer (Number.Integer i), Value.Integer (Number.Integer j)) <- prjPair pair = go i j + | Just (Value.Integer (Number.Integer i), Value.Float (Decimal j)) <- prjPair pair = go (fromIntegral i) j + | Just (Value.Float (Decimal i), Value.Integer (Number.Integer j)) <- prjPair pair = go i (fromIntegral j) + | Just (Value.Float (Decimal i), Value.Float (Decimal 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 diff --git a/src/Data/Abstract/Number.hs b/src/Data/Abstract/Number.hs new file mode 100644 index 000000000..9470aa99f --- /dev/null +++ b/src/Data/Abstract/Number.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE GADTs, StandaloneDeriving, Rank2Types #-} + +module Data.Abstract.Number + ( Number (..) + , SomeNumber (..) + , liftReal + , liftIntegralFrac + , liftedExponent + ) where + +import Data.Scientific +import qualified Prelude +import Prelude hiding (Integer) +import Prologue + +-- | A generalized number type that unifies all interpretable numeric types. +-- This is a GADT, so you can specialize the 'a' parameter and be confident +-- that, say, a @Number Scientific@ contains a 'Scientific' and not an integer +-- in disguise. This unified type is used to provide mathematical operations +-- that can change their representation based on an operation's operands—e.g. +-- raising a rational number to a ratio may not produce another rational number. +-- This also neatly encapsulates the "coalescing" behavior of adding numbers +-- of different type in dynamic languages: operating on a whole and a rational +-- produces a rational, operating on a rational and a decimal produces a decimal, +-- and so on and so forth. When we add complex numbers, they will in turn subsume +-- the other numeric types. +data Number a where + Integer :: !Prelude.Integer -> Number Prelude.Integer + Ratio :: !Prelude.Rational -> Number Prelude.Rational + Decimal :: !Scientific -> Number Scientific + +deriving instance Eq a => Eq (Number a) + +instance Show (Number a) where + show (Integer i) = show i + show (Ratio r) = show r + show (Decimal d) = show d + +-- | Every 'Number' can be coerced to a 'Scientific'. Used in the 'Ord' instance. +toScientific :: Number a -> Scientific +toScientific (Integer i) = fromInteger i +toScientific (Ratio r) = fromRational r +toScientific (Decimal s) = s + +instance Eq a => Ord (Number a) where compare = compare `on` toScientific + +-- | A box that hides the @a@ parameter to a given 'Number'. Pattern-match +-- on it to extract the information contained; because there are only three +-- possible constructors, pattern-matching all three cases is possible. +data SomeNumber = forall a . SomeNumber (Number a) + +-- | Smart constructors for 'SomeNumber'. +whole :: Prelude.Integer -> SomeNumber +whole = SomeNumber . Integer + +ratio :: Prelude.Rational -> SomeNumber +ratio = SomeNumber . Ratio + +decim :: Scientific -> SomeNumber +decim = SomeNumber . Decimal + +-- | In order to provide truly generic math operations, where functions like +-- exponentiation handle the fact that they are not closed over the rational +-- numbers, we must promote standard Haskell math functions from operations +-- on 'Real', 'Integral', and 'Fractional' numbers into functions that operate +-- on two 'Number' values and return a temporarily-indeterminate 'SomeNumber' +-- value. At the callsite, we can then unwrap the 'SomeNumber' and handle the +-- specific cases. +-- +-- Promote a function on 'Real' values into one operating on 'Number's. +-- You pass things like @+@ and @-@ here. +liftReal :: (forall n . Real n => n -> n -> n) + -> (Number a -> Number b -> SomeNumber) +liftReal f = liftIntegralFrac f f + +-- | Promote two functions, one on 'Integral' and one on 'Fractional' and 'Real' values, +-- to operate on 'Numbers'. Examples of this: 'mod' and 'mod'', 'div' and '/'. +liftIntegralFrac :: (forall n . Integral n => n -> n -> n) + -> (forall f . (Fractional f, Real f) => f -> f -> f) + -> (Number a -> Number b -> SomeNumber) +liftIntegralFrac f _ (Integer i) (Integer j) = whole (f i j) +liftIntegralFrac _ g (Integer i) (Ratio j) = ratio (g (toRational i) j) +liftIntegralFrac _ g (Integer i) (Decimal j) = decim (g (fromIntegral i) j) +liftIntegralFrac _ g (Ratio i) (Ratio j) = ratio (g i j) +liftIntegralFrac _ g (Ratio i) (Integer j) = ratio (g i (fromIntegral j)) +liftIntegralFrac _ g (Ratio i) (Decimal j) = decim (g (fromRational i) j) +liftIntegralFrac _ g (Decimal i) (Integer j) = decim (g i (fromIntegral j)) +liftIntegralFrac _ g (Decimal i) (Ratio j) = decim (g i (fromRational j)) +liftIntegralFrac _ g (Decimal i) (Decimal j) = decim (g i j) + +-- | Exponential behavior is too hard to generalize, so here's a manually implemented version. +-- TODO: Given a 'Ratio' raised to some 'Integer', we could check to see if it's an integer +-- and round it before the exponentiation, giving back a 'Integer'. +liftedExponent :: Number a -> Number b -> SomeNumber +liftedExponent (Integer i) (Integer j) = whole (i ^ j) +liftedExponent (Ratio i) (Integer j) = ratio (i ^^ j) +liftedExponent i j = decim (fromFloatDigits ((munge i) ** (munge j))) + where munge = (toRealFloat . toScientific) :: Number a -> Double diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 7af5c9ec2..90868824e 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators #-} +{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-} module Data.Abstract.Value where import Data.Abstract.Address @@ -6,9 +6,10 @@ import Data.Abstract.Environment import Data.Abstract.Store import Data.Abstract.FreeVariables import Data.Abstract.Live +import Data.Abstract.Number import qualified Data.Abstract.Type as Type import qualified Data.Set as Set -import Data.Scientific (Scientific, toRealFloat, fromFloatDigits) +import Data.Scientific (Scientific) import Prologue import Prelude hiding (Float, Integer, String, Rational, fail) import qualified Prelude @@ -44,75 +45,7 @@ prjPair :: ( f :< ValueConstructors loc term1 , g :< ValueConstructors loc term2 -> Maybe (f (Value loc term1), g (Value loc term2)) prjPair = bitraverse prjValue prjValue --- | A generalized number type that unifies all interpretable numeric types. --- This is a GADT, so you can specialize the 'a' parameter and be confident --- that, say, a @Number Scientific@ contains a 'Scientific' and not an integer --- in disguise. -data Number a where - Whole :: !Prelude.Integer -> Number Prelude.Integer - Ratio :: !Prelude.Rational -> Number Prelude.Rational - Decim :: !Scientific -> Number Scientific - -deriving instance Eq a => Eq (Number a) - -instance Show (Number a) where - show (Whole i) = show i - show (Ratio r) = show r - show (Decim d) = show d - --- | Every 'Number' can be coerced to a 'Scientific'. Used in the 'Ord' instance. -collapse :: Number a -> Scientific -collapse (Whole i) = fromInteger i -collapse (Ratio r) = fromRational r -collapse (Decim s) = s - -instance Eq a => Ord (Number a) where compare = compare `on` collapse - --- | A box that hides the @a@ parameter to a given 'Number'. Pattern-match --- on it to extract the information contained. -data SomeNumber = forall a . SomeNumber (Number a) - --- | Smart constructors for 'SomeNumber'. -whole :: Prelude.Integer -> SomeNumber -whole = SomeNumber . Whole - -ratio :: Prelude.Rational -> SomeNumber -ratio = SomeNumber . Ratio - -decim :: Scientific -> SomeNumber -decim = SomeNumber . Decim - --- | Promote a function on 'Real' values into one operating on 'Number's. --- You pass things like @+@ and @-@ here. -liftSimple :: (forall n . Real n => n -> n -> n) - -> (Number a -> Number b -> SomeNumber) -liftSimple f = liftThorny f f - --- | Promote two functions, one on 'Integral' and one on 'Fractional' and 'Real' values, --- to operate on 'Numbers'. Examples of this: 'mod' and 'mod'', 'div' and '/'. -liftThorny :: (forall n . Integral n => n -> n -> n) - -> (forall f . (Fractional f, Real f) => f -> f -> f) - -> (Number a -> Number b -> SomeNumber) -liftThorny f _ (Whole i) (Whole j) = whole (f i j) -liftThorny _ g (Whole i) (Ratio j) = ratio (g (toRational i) j) -liftThorny _ g (Whole i) (Decim j) = decim (g (fromIntegral i) j) -liftThorny _ g (Ratio i) (Ratio j) = ratio (g i j) -liftThorny _ g (Ratio i) (Whole j) = ratio (g i (fromIntegral j)) -liftThorny _ g (Ratio i) (Decim j) = decim (g (fromRational i) j) -liftThorny _ g (Decim i) (Whole j) = decim (g i (fromIntegral j)) -liftThorny _ g (Decim i) (Ratio j) = decim (g i (fromRational j)) -liftThorny _ g (Decim i) (Decim j) = decim (g i j) - --- | Exponential behavior is too hard to generalize, so here's a manually implemented version. --- TODO: Given a 'Ratio' raised to some 'Whole', we could check to see if it's an integer --- and round it before the exponentiation, giving back a 'Whole'. -safeExp :: Number a -> Number b -> SomeNumber -safeExp (Whole i) (Whole j) = whole (i ^ j) -safeExp (Ratio i) (Whole j) = ratio (i ^^ j) -safeExp i j = decim (fromFloatDigits ((munge i) ** (munge j))) - where munge = (toRealFloat . collapse) :: Number a -> Double - --- TODO: Parameerize Value by the set of constructors s.t. each language can have a distinct value union. +-- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. -- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body. data Closure location term value = Closure [Name] term (Environment location value) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index bc32e83f4..9ec8d333a 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -2,11 +2,11 @@ module Data.Syntax.Expression where import Data.Abstract.Evaluatable +import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent) import Data.Fixed import Diffing.Algorithm import Prelude hiding (fail) import Prologue hiding (apply) -import Data.Abstract.Value (liftThorny, liftSimple, safeExp) -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell. data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a } @@ -62,12 +62,12 @@ instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Arithmetic instance Evaluatable Arithmetic where eval = traverse subtermValue >=> go where - go (Plus a b) = liftNumeric2 add a b where add = liftSimple (+) - go (Minus a b) = liftNumeric2 sub a b where sub = liftSimple (-) - go (Times a b) = liftNumeric2 mul a b where mul = liftSimple (*) - go (DividedBy a b) = liftNumeric2 div' a b where div' = liftThorny div (/) - go (Modulo a b) = liftNumeric2 mod'' a b where mod'' = liftThorny mod mod' - go (Power a b) = liftNumeric2 safeExp a b + go (Plus a b) = liftNumeric2 add a b where add = liftReal (+) + go (Minus a b) = liftNumeric2 sub a b where sub = liftReal (-) + go (Times a b) = liftNumeric2 mul a b where mul = liftReal (*) + go (DividedBy a b) = liftNumeric2 div' a b where div' = liftIntegralFrac div (/) + go (Modulo a b) = liftNumeric2 mod'' a b where mod'' = liftIntegralFrac mod mod' + go (Power a b) = liftNumeric2 liftedExponent a b go (Negate a) = liftNumeric negate a -- | Boolean operators. diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 1fb5a7bca..96328a7d0 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -105,7 +105,6 @@ instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompare instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Rational instance Evaluatable Data.Syntax.Literal.Rational where eval (Rational r) = let trimmed = B.takeWhile (/= 'r') r in case readMaybe @Prelude.Integer (unpack trimmed) of