diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index afb01920b..5b8f408e1 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -48,6 +48,16 @@ class (Monad m, Show value) => MonadValue value m where -- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values. liftComparison :: Comparator -> (value -> value -> m value) + -- | Lift a unary bitwise operator to values. This is usually 'complement'. + liftBitwise :: (forall a . Bits a => a -> a) + -> (value -> m value) + + -- | Lift a binary bitwise operator to values. The Integral constraint is + -- necessary to satisfy implementation details of Haskell left/right shift, + -- but it's fine, since these are only ever operating on integral values. + liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a) + -> (value -> value -> m value) + -- | Construct an abstract boolean value. boolean :: Bool -> m value @@ -188,6 +198,15 @@ instance ( Monad m pair = (left, right) + liftBitwise operator target + | Just (Value.Integer (Number.Integer i)) <- prjValue target = integer $ operator i + | otherwise = fail ("Type error: invalid unary bitwise operation on " <> show target) + + liftBitwise2 operator left right + | Just (Value.Integer (Number.Integer i), Value.Integer (Number.Integer j)) <- prjPair pair = integer $ operator i j + | otherwise = fail ("Type error: invalid binary bitwise operation on " <> show pair) + where pair = (left, right) + abstract names (Subterm body _) = do l <- label body injValue . Closure names l . bindEnv (foldr Set.delete (freeVariables body) names) <$> askLocalEnv @@ -236,6 +255,12 @@ instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, Mon (Int, Type.Float) -> pure Type.Float _ -> unify left right + liftBitwise _ Int = pure Int + liftBitwise _ t = fail ("Invalid type passed to unary bitwise operation: " <> show t) + + liftBitwise2 _ Int Int = pure Int + liftBitwise2 _ t1 t2 = fail ("Invalid types passed to binary bitwise operation: " <> show (t1, t2)) + liftComparison (Concrete _) left right = case (left, right) of (Type.Float, Int) -> pure Bool (Int, Type.Float) -> pure Bool diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index a03663b4d..758e79a2b 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -157,9 +157,18 @@ instance Eq1 Bitwise where liftEq = genericLiftEq instance Ord1 Bitwise where liftCompare = genericLiftCompare instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Bitwise -instance Evaluatable Bitwise - +instance Evaluatable Bitwise where + eval = traverse subtermValue >=> go where + genLShift x y = shiftL x (fromIntegral y) + genRShift x y = shiftR x (fromIntegral y) + go x = case x of + (BOr a b) -> liftBitwise2 (.|.) a b + (BAnd a b) -> liftBitwise2 (.&.) a b + (BXOr a b) -> liftBitwise2 xor a b + (LShift a b) -> liftBitwise2 genLShift a b + (RShift a b) -> liftBitwise2 genRShift a b + (UnsignedRShift a b) -> liftBitwise2 genRShift a b + (Complement a) -> liftBitwise complement a -- | Member Access (e.g. a.b) data MemberAccess a diff --git a/src/Prologue.hs b/src/Prologue.hs index 5d70b0572..83ec1a50c 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -1,11 +1,14 @@ {-# LANGUAGE UndecidableInstances #-} module Prologue -( module X -, foldMapA -) where + ( module X + , foldMapA + , maybeM + , maybeFail + ) where import Data.Bifunctor.Join as X +import Data.Bits as X import Data.ByteString as X (ByteString) import Data.Functor.Both as X (Both, runBothWith, both) import Data.IntMap as X (IntMap) @@ -73,3 +76,11 @@ import GHC.Stack as X -- | Fold a collection by mapping each element onto an 'Alternative' action. foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a foldMapA f = getAlt . foldMap (Alt . f) + +-- | Extract the 'Just' of a 'Maybe' in an 'Applicative' context or, given 'Nothing', run the provided action. +maybeM :: Applicative f => f a -> Maybe a -> f a +maybeM f = maybe f pure + +-- | Either extract the 'Just' of a 'Maybe' or invoke 'fail' with the provided string. +maybeFail :: MonadFail m => String -> Maybe a -> m a +maybeFail s = maybeM (X.fail s)