diff --git a/semantic.cabal b/semantic.cabal index 3e315868d..e23f53a33 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -48,6 +48,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 4d6552887..287b46cff 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -5,9 +5,11 @@ 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 Data.Scientific (Scientific, fromFloatDigits, toRealFloat) +import qualified Data.Map as Map +import Data.Scientific (Scientific) import Prelude hiding (fail) import Prologue @@ -40,8 +42,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. @@ -60,6 +61,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 @@ -112,47 +116,53 @@ instance ( MonadAddressable location (Value location term) m ) => MonadValue term (Value location term) m where - unit = pure . injValue $ Value.Unit - integer = pure . injValue . Integer - boolean = pure . injValue . Boolean - string = pure . injValue . Value.String - float = pure . injValue . Value.Float - symbol = pure . injValue . Value.Symbol - multiple vals = - pure . injValue $ Value.Tuple vals + 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 + symbol = pure . injValue . Value.Symbol + rational = pure . injValue . Value.Rational . Ratio + + multiple = pure . injValue . Value.Tuple ifthenelse cond if' else' | Just (Boolean b) <- prjValue cond = if b then if' else else' | 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 (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 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 (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, 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 - -- 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 (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 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 (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 @@ -191,13 +201,14 @@ instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue ret <- localEnv (mappend env) body pure (Product tvars :-> ret) - unit = pure Type.Unit - integer _ = pure Int - boolean _ = pure Bool - string _ = pure Type.String - float _ = pure Type.Float - symbol _ = pure Type.Symbol - multiple = pure . Type.Product + unit = pure Type.Unit + integer _ = pure Int + boolean _ = pure Bool + string _ = pure Type.String + float _ = pure Type.Float + symbol _ = pure Type.Symbol + rational _ = pure Type.Rational + multiple = pure . Type.Product ifthenelse cond if' else' = unify cond Bool *> (if' <|> else') @@ -205,7 +216,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/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/Type.hs b/src/Data/Abstract/Type.hs index 3c8db9fdb..2ab376de3 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -15,6 +15,7 @@ data Type | Symbol -- ^ Type of unique symbols. | 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 909af9097..ee99a4b79 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -6,11 +6,12 @@ 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) import Prologue -import Prelude hiding (Float, Integer, String) +import Prelude hiding (Float, Integer, String, Rational, fail) import qualified Prelude type ValueConstructors location term @@ -20,6 +21,7 @@ type ValueConstructors location term , Float , Integer , String + , Rational , Symbol , Tuple ] @@ -43,7 +45,6 @@ prjPair :: ( f :< ValueConstructors loc term1 , g :< ValueConstructors loc term2 -> Maybe (f (Value loc term1), g (Value loc term2)) prjPair = bitraverse prjValue prjValue - -- 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. @@ -71,13 +72,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) @@ -96,7 +105,7 @@ instance Ord1 Symbol where liftCompare = genericLiftCompare instance Show1 Symbol 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..9ec8d333a 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -2,6 +2,7 @@ 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) @@ -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 = 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 8e6b0cc34..c449a36c1 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -105,8 +105,11 @@ 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 +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`