Merge branch 'master' into fix-fix

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

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.
@@ -53,9 +54,16 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
   -- | Construct an abstract string value.
   string :: ByteString -> m value
 
+  -- | Construct a self-evaluating symbol value.
+  --   TODO: Should these be interned in some table to provide stronger uniqueness guarantees?
+  symbol :: ByteString -> m value
+
   -- | 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
 
@@ -126,46 +134,53 @@ instance ( FreeVariables term
          )
          => 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
-  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
@@ -206,12 +221,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
-  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')
 
@@ -219,7 +236,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

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

src/Data/Abstract/Type.hs

@@ -12,8 +12,10 @@ data Type
   = Int            -- ^ Primitive int type.
   | Bool           -- ^ Primitive boolean type.
   | String         -- ^ Primitive string 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.

src/Data/Abstract/Value.hs

@@ -6,10 +6,11 @@ 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 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
@@ -19,6 +20,8 @@ type ValueConstructors location term
     , Float
     , Integer
     , String
+    , Rational
+    , Symbol
     , Tuple
     ]
 
@@ -41,7 +44,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.
@@ -69,13 +71,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)
@@ -84,8 +94,17 @@ instance Eq1 String where liftEq = genericLiftEq
 instance Ord1 String where liftCompare = genericLiftCompare
 instance Show1 String where liftShowsPrec = genericLiftShowsPrec
 
+-- | Possibly-interned Symbol values.
+--   TODO: Should this store a 'Text'?
+newtype Symbol value = Symbol ByteString
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 Symbol where liftEq = genericLiftEq
+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

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.

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`
@@ -176,9 +179,8 @@ instance Eq1 Symbol where liftEq = genericLiftEq
 instance Ord1 Symbol where liftCompare = genericLiftCompare
 instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Symbol
-instance Evaluatable Symbol
-
+instance Evaluatable Symbol where
+  eval (Symbol s) = symbol s
 
 newtype Regex a = Regex { regexContent :: ByteString }
   deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)