Merge branch 'master' into export-wrapper

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

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

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)