Merge pull request #1793 from github/array-indexing

Add support for array indexing.

src/Analysis/Abstract/BadValues.hs

@@ -28,6 +28,8 @@ instance ( Interpreter effects result rest m
       CallError val     -> yield val
       StringError val   -> yield (pack (show val))
       BoolError{}       -> yield True
+      BoundsError{}     -> yield hole
+      IndexError{}      -> yield hole
       NumericError{}    -> yield hole
       Numeric2Error{}   -> yield hole
       ComparisonError{} -> yield hole

src/Control/Abstract/Value.hs

@@ -114,6 +114,10 @@ class (Monad (m effects), Show value) => MonadValue location value (effects :: [
   -- | Construct the nil/null datatype.
   null :: m effects value
 
+  -- | @index x i@ computes @x[i]@, with zero-indexing.
+  index :: value -> value -> m effects value
+
+  -- | Determine whether the given datum is a 'Hole'.
   isHole :: value -> m effects Bool
 
   -- | Build a class value from a name and environment.
@@ -197,6 +201,7 @@ class ValueRoots location value where
 data ValueError location value resume where
   StringError            :: value          -> ValueError location value ByteString
   BoolError              :: value          -> ValueError location value Bool
+  IndexError             :: value -> value -> ValueError location value value
   NamespaceError         :: Prelude.String -> ValueError location value (Environment location value)
   ScopedEnvironmentError :: Prelude.String -> ValueError location value (Environment location value)
   CallError              :: value          -> ValueError location value value
@@ -208,6 +213,10 @@ data ValueError location value resume where
   KeyValueError          :: value          -> ValueError location value (value, value)
   -- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
   ArithmeticError :: ArithException -> ValueError location value value
+  -- Out-of-bounds error
+  BoundsError :: [value] -> Integer -> ValueError location value value
+
+
 
 instance Eq value => Eq1 (ValueError location value) where
   liftEq _ (StringError a) (StringError b)                       = a == b
@@ -215,11 +224,13 @@ instance Eq value => Eq1 (ValueError location value) where
   liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b
   liftEq _ (CallError a) (CallError b)                           = a == b
   liftEq _ (BoolError a) (BoolError c)                           = a == c
+  liftEq _ (IndexError a b) (IndexError c d)                     = (a == c) && (b == d)
   liftEq _ (Numeric2Error a b) (Numeric2Error c d)               = (a == c) && (b == d)
   liftEq _ (ComparisonError a b) (ComparisonError c d)           = (a == c) && (b == d)
   liftEq _ (Bitwise2Error a b) (Bitwise2Error c d)               = (a == c) && (b == d)
   liftEq _ (BitwiseError a) (BitwiseError b)                     = a == b
   liftEq _ (KeyValueError a) (KeyValueError b)                   = a == b
+  liftEq _ (BoundsError a b) (BoundsError c d)                   = (a == c) && (b == d)
   liftEq _ _             _                                       = False
 
 deriving instance (Show value) => Show (ValueError location value resume)

src/Data/Abstract/Type.hs

@@ -42,6 +42,7 @@ data TypeError resume where
   NumOpError       :: Type -> Type -> TypeError Type
   BitOpError       :: Type -> Type -> TypeError Type
   UnificationError :: Type -> Type -> TypeError Type
+  SubscriptError   :: Type -> Type -> TypeError Type
 
 deriving instance Show (TypeError resume)
 
@@ -49,6 +50,7 @@ instance Show1 TypeError where
   liftShowsPrec _ _ _ (NumOpError l r)       = showString "NumOpError " . shows [l, r]
   liftShowsPrec _ _ _ (BitOpError l r)       = showString "BitOpError " . shows [l, r]
   liftShowsPrec _ _ _ (UnificationError l r) = showString "UnificationError " . shows [l, r]
+  liftShowsPrec _ _ _ (SubscriptError l r)   = showString "SubscriptError " . shows [l, r]
 
 instance Eq1 TypeError where
   liftEq _ (BitOpError a b) (BitOpError c d)             = a == c && b == d
@@ -123,6 +125,10 @@ instance ( Alternative (m effects)
 
   isHole ty = pure (ty == Hole)
 
+  index (Array (mem:_)) Int   = pure mem
+  index (Product (mem:_)) Int = pure mem
+  index a b                   = throwResumable (SubscriptError a b)
+
   ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
 
   liftNumeric _ Float      = pure Float

src/Data/Abstract/Value.hs

@@ -6,6 +6,7 @@ import Data.Abstract.Environment (Environment)
 import qualified Data.Abstract.Environment as Env
 import Data.Abstract.Evaluatable
 import qualified Data.Abstract.Number as Number
+import Data.List (genericIndex, genericLength)
 import Data.Scientific (Scientific)
 import Data.Scientific.Exts
 import qualified Data.Set as Set
@@ -264,6 +265,14 @@ instance ( Monad (m effects)
 
   isHole val = pure (prjValue val == Just Hole)
 
+  index = go where
+    tryIdx list ii
+      | ii > genericLength list = throwValueError (BoundsError list ii)
+      | otherwise               = pure (genericIndex list ii)
+    go arr idx
+      | (Just (Array arr, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx arr i
+      | (Just (Tuple tup, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx tup i
+      | otherwise = throwValueError (IndexError arr idx)
 
   liftNumeric f arg
     | Just (Integer (Number.Integer i)) <- prjValue arg = integer $ f i

src/Data/Syntax/Expression.hs

@@ -5,7 +5,7 @@ import Data.Abstract.Evaluatable
 import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
 import Data.Fixed
 import Diffing.Algorithm
-import Prologue
+import Prologue hiding (index)
 
 -- | 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 }
@@ -208,7 +208,10 @@ instance Ord1 Subscript where liftCompare = genericLiftCompare
 instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Subscript
-instance Evaluatable Subscript
+instance Evaluatable Subscript where
+  eval (Subscript l [r]) = join (index <$> subtermValue l <*> subtermValue r)
+  eval (Subscript _ _)   = throwResumable (Unspecialized "Eval unspecialized for subscript with slices")
+  eval (Member _ _)      = throwResumable (Unspecialized "Eval unspecialized for member access")
 
 
 -- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop))