github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-24 07:25:44 +03:00
Code Issues Projects Releases Wiki Activity

use the Numeric effect

Browse Source
This commit is contained in:
Ayman Nadeem 2018-12-14 13:17:38 -05:00
parent b24c5d5ebb
commit 6849fd8610
6 changed files with 47 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
src/Control/Abstract/Value.hs
View File

@ -33,6 +33,11 @@ module Control.Abstract.Value
, String(..)
, StringC(..)
, runString
, integer
, float
, rational
, liftNumeric
, liftNumeric2
, Numeric(..)
, NumericC(..)
, runNumeric
@ -45,7 +50,7 @@ import Control.Effect.Carrier
import Data.Abstract.BaseError
import Data.Abstract.Module
import Data.Abstract.Name
import Data.Abstract.Number as Number
import Data.Abstract.Number (Number, SomeNumber)
import Data.Scientific (Scientific)
import Data.Span
import Prelude hiding (String)
@ -253,6 +258,37 @@ runString :: Carrier (String value :+: sig) (StringC value (Eff m))
-> Evaluator term address value m a
runString = raiseHandler $ runStringC . interpret
-- | Construct an abstract integral value.
integer :: (Member (Numeric value) sig, Carrier sig m) => Integer -> m value
integer t = send (Integer t ret)
-- | Construct a floating-point value.
float :: (Member (Numeric value) sig, Carrier sig m) => Scientific -> m value
float t = send (Float t ret)
-- | Construct a rational value.
rational :: (Member (Numeric value) sig, Carrier sig m) => Rational -> m value
rational t = send (Rational t ret)
-- | Lift a unary operator over a 'Num' to a function on 'value's.
liftNumeric :: (Member (Numeric value) sig, Carrier sig m)
=> (forall a . Num a => a -> a)
-> value
-> m value
liftNumeric t v = send (LiftNumeric t v ret)
-- | Lift a pair of binary operators to a function on 'value's.
-- 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 :: (Member (Numeric value) sig, Carrier sig m)
=> (forall a b. Number a -> Number b -> SomeNumber)
-> value
-> value
-> m value
liftNumeric2 t v1 v2 = send (LiftNumeric2 t v1 v2 ret)
data Numeric value (m :: * -> *) k
= Integer Integer (value -> k)
| Float Scientific (value -> k)
@ -276,15 +312,6 @@ runNumeric :: Carrier (Numeric value :+: sig) (NumericC value (Eff m))
runNumeric = raiseHandler $ runNumericC . interpret
class Show value => AbstractIntro value where
-- | Construct an abstract integral value.
integer :: Integer -> value
-- | Construct a floating-point value.
float :: Scientific -> value
-- | Construct a rational value.
rational :: Rational -> value
-- | Construct a key-value pair for use in a hash.
kvPair :: value -> value -> value
@ -301,18 +328,6 @@ class AbstractIntro value => AbstractValue term address value carrier where
-- | Cast numbers to integers
castToInteger :: value -> Evaluator term address value carrier value
-- | Lift a unary operator over a 'Num' to a function on 'value's.
liftNumeric :: (forall a . Num a => a -> a)
-> (value -> Evaluator term address value carrier value)
-- | Lift a pair of binary operators to a function on 'value's.
-- 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 b. Number a -> Number b -> SomeNumber)
-> (value -> value -> Evaluator term address value carrier value)
-- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
liftComparison :: Comparator -> (value -> value -> Evaluator term address value carrier value)

6
src/Data/Abstract/Value/Abstract.hs
View File

@ -108,9 +108,6 @@ instance AbstractHole Abstract where
hole = Abstract
instance AbstractIntro Abstract where
integer _ = Abstract
float _ = Abstract
rational _ = Abstract
hash _ = Abstract
kvPair _ _ = Abstract
null = Abstract
@ -130,9 +127,6 @@ instance AbstractValue term address Abstract m where
index _ _ = pure Abstract
liftNumeric _ _ = pure Abstract
liftNumeric2 _ _ _ = pure Abstract
liftBitwise _ _ = pure Abstract
liftBitwise2 _ _ _ = pure Abstract

56
src/Data/Abstract/Value/Concrete.hs
View File

@ -222,30 +222,16 @@ instance AbstractHole (Value term address) where
hole = Hole
instance (Show address, Show term) => AbstractIntro (Value term address) where
integer t = Integer (Number.Integer t)
float t = Float (Number.Decimal t)
rational t = Rational (Number.Ratio t)
kvPair = KVPair
hash = Hash . map (uncurry KVPair)
null = Null
-- | Construct a 'Value' wrapping the value arguments (if any).
instance ( Member (Allocator address) sig
, Member (Abstract.Boolean (Value term address)) sig
, Member (Deref (Value term address)) sig
, Member (Error (LoopControl (Value term address))) sig
, Member (Error (Return (Value term address))) sig
, Member Fresh sig
instance ( Member (Abstract.Boolean (Value term address)) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
, Member (Reader Span) sig
, Member (Resumable (BaseError (ValueError term address))) sig
, Member (Resumable (BaseError (AddressError address (Value term address)))) sig
, Member (State (Heap address address (Value term address))) sig
, Member Trace sig
, Ord address
, Show address
, Show term
, Carrier sig m
@ -283,36 +269,6 @@ instance ( Member (Allocator address) sig
| (Tuple tup, Integer (Number.Integer i)) <- (arr, idx) = tryIdx tup i
| otherwise = throwValueError (IndexError arr idx)
liftNumeric f arg
| Integer (Number.Integer i) <- arg = pure . integer $ f i
| Float (Number.Decimal d) <- arg = pure . float $ f d
| Rational (Number.Ratio r) <- arg = pure . rational $ f r
| otherwise = throwValueError (NumericError arg)
liftNumeric2 f left right
| (Integer i, Integer j) <- pair = tentative f i j & specialize
| (Integer i, Rational j) <- pair = tentative f i j & specialize
| (Integer i, Float j) <- pair = tentative f i j & specialize
| (Rational i, Integer j) <- pair = tentative f i j & specialize
| (Rational i, Rational j) <- pair = tentative f i j & specialize
| (Rational i, Float j) <- pair = tentative f i j & specialize
| (Float i, Integer j) <- pair = tentative f i j & specialize
| (Float i, Rational j) <- pair = tentative f i j & specialize
| (Float i, Float j) <- pair = tentative f i j & specialize
| otherwise = throwValueError (Numeric2Error left right)
where
tentative x i j = attemptUnsafeArithmetic (x i j)
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
specialize :: AbstractValue term address (Value term address) m
=> Either ArithException Number.SomeNumber
-> Evaluator term address (Value term address) m (Value term address)
specialize (Left exc) = throwValueError (ArithmeticError exc)
specialize (Right (Number.SomeNumber (Number.Integer i))) = pure $ integer i
specialize (Right (Number.SomeNumber (Number.Ratio r))) = pure $ rational r
specialize (Right (Number.SomeNumber (Number.Decimal d))) = pure $ float d
pair = (left, right)
liftComparison comparator left right
| (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = go i j
| (Integer (Number.Integer i), Float (Number.Decimal j)) <- pair = go (fromIntegral i) j
@ -325,10 +281,10 @@ instance ( Member (Allocator address) sig
where
-- Explicit type signature is necessary here because we're passing all sorts of things
-- to these comparison functions.
go :: (AbstractValue term address (Value term address) m, Ord a) => a -> a -> Evaluator term address (Value term address) m (Value term address)
go :: Ord a => a -> a -> Evaluator term address (Value term address) m (Value term address)
go l r = case comparator of
Concrete f -> boolean (f l r)
Generalized -> pure $ integer (orderingToInt (compare l r))
Generalized -> pure $ Integer (Number.Integer (orderingToInt (compare l r)))
-- Map from [LT, EQ, GT] to [-1, 0, 1]
orderingToInt :: Ordering -> Prelude.Integer
@ -337,17 +293,17 @@ instance ( Member (Allocator address) sig
pair = (left, right)
liftBitwise operator target
| Integer (Number.Integer i) <- target = pure . integer $ operator i
| Integer (Number.Integer i) <- target = pure . Integer . Number.Integer $ operator i
| otherwise = throwValueError (BitwiseError target)
liftBitwise2 operator left right
| (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = pure . integer $ operator i j
| (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = pure . Integer . Number.Integer $ operator i j
| otherwise = throwValueError (Bitwise2Error left right)
where pair = (left, right)
unsignedRShift left right
| (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair =
if i >= 0 then pure . integer $ ourShift (fromIntegral i) (fromIntegral j)
if i >= 0 then pure . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j)
else throwValueError (Bitwise2Error left right)
| otherwise = throwValueError (Bitwise2Error left right)
where

9
src/Data/Abstract/Value/Type.hs
View File

@ -359,9 +359,6 @@ instance AbstractHole Type where
hole = Hole
instance AbstractIntro Type where
integer _ = Int
float _ = Float
rational _ = Rational
hash = Hash
kvPair k v = k :* v
@ -403,12 +400,6 @@ instance ( Member Fresh sig
_ <- unify (Array (Var field)) arr
pure (Var field)
liftNumeric _ = unify (Int :+ Float :+ Rational)
liftNumeric2 _ left right = case (left, right) of
(Float, Int) -> pure Float
(Int, Float) -> pure Float
_ -> unify left right
liftBitwise _ = unify Int
liftBitwise2 _ t1 t2 = unify Int t1 >>= flip unify t2

2
src/Data/Syntax/Directive.hs
View File

@ -39,7 +39,7 @@ instance Ord1 Line where liftCompare = genericLiftCompare
instance Show1 Line where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Line where
eval _ _ Line = integer . fromIntegral . posLine . spanStart <$> currentSpan
eval _ _ Line = currentSpan >>= integer . fromIntegral . posLine . spanStart
-- PT TODO: proper token for this
instance Tokenize Line where

6
src/Data/Syntax/Literal.hs
View File

@ -50,7 +50,7 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow
instance Evaluatable Data.Syntax.Literal.Integer where
-- TODO: We should use something more robust than shelling out to readMaybe.
eval _ _ (Data.Syntax.Literal.Integer x) =
integer <$> either (const (throwEvalError (IntegerFormatError x))) pure (parseInteger x)
either (const (throwEvalError (IntegerFormatError x))) pure (parseInteger x) >>= integer
instance Tokenize Data.Syntax.Literal.Integer where
tokenize = yield . Run . integerContent
@ -66,7 +66,7 @@ instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsP
instance Evaluatable Data.Syntax.Literal.Float where
eval _ _ (Float s) =
float <$> either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s)
either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s) >>= float
instance Tokenize Data.Syntax.Literal.Float where
tokenize = yield . Run . floatContent
@ -84,7 +84,7 @@ instance Evaluatable Data.Syntax.Literal.Rational where
let
trimmed = T.takeWhile (/= 'r') r
parsed = readMaybe @Prelude.Integer (T.unpack trimmed)
in rational <$> maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed
in maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed >>= rational
instance Tokenize Data.Syntax.Literal.Rational where
tokenize (Rational t) = yield . Run $ t