From 81aab6572e998805674d8ece5e17c86271736641 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 14 Mar 2018 10:36:56 -0400 Subject: [PATCH] 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