{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
-- | An interpreter operating on type-checked source Futhark terms.
-- Relatively slow.
module Language.Futhark.Interpreter
  ( Ctx(..)
  , Env
  , InterpreterError
  , initialCtx
  , interpretExp
  , interpretDec
  , interpretImport
  , interpretFunction
  , ExtOp(..)
  , BreakReason(..)
  , StackFrame(..)
  , typeCheckerEnv
  , Value (ValuePrim, ValueArray, ValueRecord)
  , fromTuple
  , isEmptyArray
  , prettyEmptyArray
  ) where

import Control.Monad.Trans.Maybe
import Control.Monad.Free.Church
import Control.Monad.Except
import Control.Monad.State
import Control.Monad.Reader
import Data.Array
import Data.Bifunctor (first)
import Data.List
  (transpose, genericLength, isPrefixOf, foldl', find, intercalate)
import Data.Maybe
import qualified Data.Map as M
import qualified Data.List.NonEmpty as NE
import Data.Monoid hiding (Sum)

import Language.Futhark hiding (Value, matchDims)
import qualified Language.Futhark as F
import Futhark.IR.Primitive (intValue, floatValue)
import qualified Futhark.IR.Primitive as P
import qualified Language.Futhark.Semantic as T

import Futhark.Util.Pretty hiding (apply, bool)
import Futhark.Util (chunk, splitFromEnd, maybeHead)
import Futhark.Util.Loc

import Prelude hiding (mod, break)

data StackFrame = StackFrame { StackFrame -> Loc
stackFrameLoc :: Loc
                             , StackFrame -> Ctx
stackFrameCtx :: Ctx
                             }

instance Located StackFrame where
  locOf :: StackFrame -> Loc
locOf = StackFrame -> Loc
stackFrameLoc

-- | What is the reason for this break point?
data BreakReason
  = BreakPoint -- ^ An explicit breakpoint in the program.
  | BreakNaN -- ^ A

data ExtOp a = ExtOpTrace Loc String a
             | ExtOpBreak BreakReason (NE.NonEmpty StackFrame) a
             | ExtOpError InterpreterError

instance Functor ExtOp where
  fmap :: (a -> b) -> ExtOp a -> ExtOp b
fmap a -> b
f (ExtOpTrace Loc
w String
s a
x) = Loc -> String -> b -> ExtOp b
forall a. Loc -> String -> a -> ExtOp a
ExtOpTrace Loc
w String
s (b -> ExtOp b) -> b -> ExtOp b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
  fmap a -> b
f (ExtOpBreak BreakReason
why NonEmpty StackFrame
backtrace a
x) = BreakReason -> NonEmpty StackFrame -> b -> ExtOp b
forall a. BreakReason -> NonEmpty StackFrame -> a -> ExtOp a
ExtOpBreak BreakReason
why NonEmpty StackFrame
backtrace (b -> ExtOp b) -> b -> ExtOp b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
  fmap a -> b
_ (ExtOpError InterpreterError
err) = InterpreterError -> ExtOp b
forall a. InterpreterError -> ExtOp a
ExtOpError InterpreterError
err

type Stack = [StackFrame]

type Sizes = M.Map VName Int32

-- | The monad in which evaluation takes place.
newtype EvalM a = EvalM (ReaderT (Stack, M.Map FilePath Env)
                         (StateT Sizes (F ExtOp)) a)
  deriving (Applicative EvalM
a -> EvalM a
Applicative EvalM
-> (forall a b. EvalM a -> (a -> EvalM b) -> EvalM b)
-> (forall a b. EvalM a -> EvalM b -> EvalM b)
-> (forall a. a -> EvalM a)
-> Monad EvalM
EvalM a -> (a -> EvalM b) -> EvalM b
EvalM a -> EvalM b -> EvalM b
forall a. a -> EvalM a
forall a b. EvalM a -> EvalM b -> EvalM b
forall a b. EvalM a -> (a -> EvalM b) -> EvalM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> EvalM a
$creturn :: forall a. a -> EvalM a
>> :: EvalM a -> EvalM b -> EvalM b
$c>> :: forall a b. EvalM a -> EvalM b -> EvalM b
>>= :: EvalM a -> (a -> EvalM b) -> EvalM b
$c>>= :: forall a b. EvalM a -> (a -> EvalM b) -> EvalM b
$cp1Monad :: Applicative EvalM
Monad, Functor EvalM
a -> EvalM a
Functor EvalM
-> (forall a. a -> EvalM a)
-> (forall a b. EvalM (a -> b) -> EvalM a -> EvalM b)
-> (forall a b c. (a -> b -> c) -> EvalM a -> EvalM b -> EvalM c)
-> (forall a b. EvalM a -> EvalM b -> EvalM b)
-> (forall a b. EvalM a -> EvalM b -> EvalM a)
-> Applicative EvalM
EvalM a -> EvalM b -> EvalM b
EvalM a -> EvalM b -> EvalM a
EvalM (a -> b) -> EvalM a -> EvalM b
(a -> b -> c) -> EvalM a -> EvalM b -> EvalM c
forall a. a -> EvalM a
forall a b. EvalM a -> EvalM b -> EvalM a
forall a b. EvalM a -> EvalM b -> EvalM b
forall a b. EvalM (a -> b) -> EvalM a -> EvalM b
forall a b c. (a -> b -> c) -> EvalM a -> EvalM b -> EvalM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: EvalM a -> EvalM b -> EvalM a
$c<* :: forall a b. EvalM a -> EvalM b -> EvalM a
*> :: EvalM a -> EvalM b -> EvalM b
$c*> :: forall a b. EvalM a -> EvalM b -> EvalM b
liftA2 :: (a -> b -> c) -> EvalM a -> EvalM b -> EvalM c
$cliftA2 :: forall a b c. (a -> b -> c) -> EvalM a -> EvalM b -> EvalM c
<*> :: EvalM (a -> b) -> EvalM a -> EvalM b
$c<*> :: forall a b. EvalM (a -> b) -> EvalM a -> EvalM b
pure :: a -> EvalM a
$cpure :: forall a. a -> EvalM a
$cp1Applicative :: Functor EvalM
Applicative, a -> EvalM b -> EvalM a
(a -> b) -> EvalM a -> EvalM b
(forall a b. (a -> b) -> EvalM a -> EvalM b)
-> (forall a b. a -> EvalM b -> EvalM a) -> Functor EvalM
forall a b. a -> EvalM b -> EvalM a
forall a b. (a -> b) -> EvalM a -> EvalM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EvalM b -> EvalM a
$c<$ :: forall a b. a -> EvalM b -> EvalM a
fmap :: (a -> b) -> EvalM a -> EvalM b
$cfmap :: forall a b. (a -> b) -> EvalM a -> EvalM b
Functor,
            MonadFree ExtOp,
            MonadReader (Stack, M.Map FilePath Env),
            MonadState Sizes)

runEvalM :: M.Map FilePath Env -> EvalM a -> F ExtOp a
runEvalM :: Map String Env -> EvalM a -> F ExtOp a
runEvalM Map String Env
imports (EvalM ReaderT ([StackFrame], Map String Env) (StateT Sizes (F ExtOp)) a
m) = StateT Sizes (F ExtOp) a -> Sizes -> F ExtOp a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ReaderT ([StackFrame], Map String Env) (StateT Sizes (F ExtOp)) a
-> ([StackFrame], Map String Env) -> StateT Sizes (F ExtOp) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT ([StackFrame], Map String Env) (StateT Sizes (F ExtOp)) a
m ([StackFrame]
forall a. Monoid a => a
mempty, Map String Env
imports)) Sizes
forall a. Monoid a => a
mempty

stacking :: SrcLoc -> Env -> EvalM a -> EvalM a
stacking :: SrcLoc -> Env -> EvalM a -> EvalM a
stacking SrcLoc
loc Env
env = (([StackFrame], Map String Env) -> ([StackFrame], Map String Env))
-> EvalM a -> EvalM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((([StackFrame], Map String Env) -> ([StackFrame], Map String Env))
 -> EvalM a -> EvalM a)
-> (([StackFrame], Map String Env)
    -> ([StackFrame], Map String Env))
-> EvalM a
-> EvalM a
forall a b. (a -> b) -> a -> b
$ \([StackFrame]
ss, Map String Env
imports) ->
  if SrcLoc -> Bool
isNoLoc SrcLoc
loc
  then ([StackFrame]
ss, Map String Env
imports)
  else let s :: StackFrame
s = Loc -> Ctx -> StackFrame
StackFrame (SrcLoc -> Loc
forall a. Located a => a -> Loc
locOf SrcLoc
loc) (Env -> Map String Env -> Ctx
Ctx Env
env Map String Env
imports)
       in (StackFrame
sStackFrame -> [StackFrame] -> [StackFrame]
forall a. a -> [a] -> [a]
:[StackFrame]
ss, Map String Env
imports)
  where isNoLoc :: SrcLoc -> Bool
        isNoLoc :: SrcLoc -> Bool
isNoLoc = (Loc -> Loc -> Bool
forall a. Eq a => a -> a -> Bool
==Loc
NoLoc) (Loc -> Bool) -> (SrcLoc -> Loc) -> SrcLoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> Loc
forall a. Located a => a -> Loc
locOf

stacktrace :: EvalM [Loc]
stacktrace :: EvalM [Loc]
stacktrace = (([StackFrame], Map String Env) -> [Loc]) -> EvalM [Loc]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((([StackFrame], Map String Env) -> [Loc]) -> EvalM [Loc])
-> (([StackFrame], Map String Env) -> [Loc]) -> EvalM [Loc]
forall a b. (a -> b) -> a -> b
$ (StackFrame -> Loc) -> [StackFrame] -> [Loc]
forall a b. (a -> b) -> [a] -> [b]
map StackFrame -> Loc
stackFrameLoc ([StackFrame] -> [Loc])
-> (([StackFrame], Map String Env) -> [StackFrame])
-> ([StackFrame], Map String Env)
-> [Loc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([StackFrame], Map String Env) -> [StackFrame]
forall a b. (a, b) -> a
fst

lookupImport :: FilePath -> EvalM (Maybe Env)
lookupImport :: String -> EvalM (Maybe Env)
lookupImport String
f = (([StackFrame], Map String Env) -> Maybe Env) -> EvalM (Maybe Env)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((([StackFrame], Map String Env) -> Maybe Env)
 -> EvalM (Maybe Env))
-> (([StackFrame], Map String Env) -> Maybe Env)
-> EvalM (Maybe Env)
forall a b. (a -> b) -> a -> b
$ String -> Map String Env -> Maybe Env
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
f (Map String Env -> Maybe Env)
-> (([StackFrame], Map String Env) -> Map String Env)
-> ([StackFrame], Map String Env)
-> Maybe Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([StackFrame], Map String Env) -> Map String Env
forall a b. (a, b) -> b
snd

putExtSize :: VName -> Int32 -> EvalM ()
putExtSize :: VName -> Int32 -> EvalM ()
putExtSize VName
v Int32
x = (Sizes -> Sizes) -> EvalM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Sizes -> Sizes) -> EvalM ()) -> (Sizes -> Sizes) -> EvalM ()
forall a b. (a -> b) -> a -> b
$ VName -> Int32 -> Sizes -> Sizes
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v Int32
x

getSizes :: EvalM Sizes
getSizes :: EvalM Sizes
getSizes = EvalM Sizes
forall s (m :: * -> *). MonadState s m => m s
get

extSizeEnv :: EvalM Env
extSizeEnv :: EvalM Env
extSizeEnv = Sizes -> Env
i32Env (Sizes -> Env) -> EvalM Sizes -> EvalM Env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalM Sizes
getSizes

prettyRecord :: Pretty a => M.Map Name a -> Doc
prettyRecord :: Map Name a -> Doc
prettyRecord Map Name a
m
  | Just [a]
vs <- Map Name a -> Maybe [a]
forall a. Map Name a -> Maybe [a]
areTupleFields Map Name a
m =
      Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
ppr [a]
vs
  | Bool
otherwise =
      Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((Name, a) -> Doc) -> [(Name, a)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Name, a) -> Doc
forall a a. (Pretty a, Pretty a) => (a, a) -> Doc
field ([(Name, a)] -> [Doc]) -> [(Name, a)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Map Name a -> [(Name, a)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name a
m
      where field :: (a, a) -> Doc
field (a
k, a
v) = a -> Doc
forall a. Pretty a => a -> Doc
ppr a
k Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
v

valueStructType :: ValueType -> StructType
valueStructType :: ValueType -> StructType
valueStructType = (Int32 -> DimDecl VName) -> ValueType -> StructType
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Int -> DimDecl VName
forall vn. Int -> DimDecl vn
ConstDim (Int -> DimDecl VName) -> (Int32 -> Int) -> Int32 -> DimDecl VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)

-- | A shape is a tree to accomodate the case of records.  It is
-- parameterised over the representation of dimensions.
data Shape d = ShapeDim d (Shape d)
             | ShapeLeaf
             | ShapeRecord (M.Map Name (Shape d))
             | ShapeSum (M.Map Name [Shape d])
             deriving (Shape d -> Shape d -> Bool
(Shape d -> Shape d -> Bool)
-> (Shape d -> Shape d -> Bool) -> Eq (Shape d)
forall d. Eq d => Shape d -> Shape d -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Shape d -> Shape d -> Bool
$c/= :: forall d. Eq d => Shape d -> Shape d -> Bool
== :: Shape d -> Shape d -> Bool
$c== :: forall d. Eq d => Shape d -> Shape d -> Bool
Eq, Int -> Shape d -> ShowS
[Shape d] -> ShowS
Shape d -> String
(Int -> Shape d -> ShowS)
-> (Shape d -> String) -> ([Shape d] -> ShowS) -> Show (Shape d)
forall d. Show d => Int -> Shape d -> ShowS
forall d. Show d => [Shape d] -> ShowS
forall d. Show d => Shape d -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Shape d] -> ShowS
$cshowList :: forall d. Show d => [Shape d] -> ShowS
show :: Shape d -> String
$cshow :: forall d. Show d => Shape d -> String
showsPrec :: Int -> Shape d -> ShowS
$cshowsPrec :: forall d. Show d => Int -> Shape d -> ShowS
Show, a -> Shape b -> Shape a
(a -> b) -> Shape a -> Shape b
(forall a b. (a -> b) -> Shape a -> Shape b)
-> (forall a b. a -> Shape b -> Shape a) -> Functor Shape
forall a b. a -> Shape b -> Shape a
forall a b. (a -> b) -> Shape a -> Shape b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Shape b -> Shape a
$c<$ :: forall a b. a -> Shape b -> Shape a
fmap :: (a -> b) -> Shape a -> Shape b
$cfmap :: forall a b. (a -> b) -> Shape a -> Shape b
Functor, Shape a -> Bool
(a -> m) -> Shape a -> m
(a -> b -> b) -> b -> Shape a -> b
(forall m. Monoid m => Shape m -> m)
-> (forall m a. Monoid m => (a -> m) -> Shape a -> m)
-> (forall m a. Monoid m => (a -> m) -> Shape a -> m)
-> (forall a b. (a -> b -> b) -> b -> Shape a -> b)
-> (forall a b. (a -> b -> b) -> b -> Shape a -> b)
-> (forall b a. (b -> a -> b) -> b -> Shape a -> b)
-> (forall b a. (b -> a -> b) -> b -> Shape a -> b)
-> (forall a. (a -> a -> a) -> Shape a -> a)
-> (forall a. (a -> a -> a) -> Shape a -> a)
-> (forall a. Shape a -> [a])
-> (forall a. Shape a -> Bool)
-> (forall a. Shape a -> Int)
-> (forall a. Eq a => a -> Shape a -> Bool)
-> (forall a. Ord a => Shape a -> a)
-> (forall a. Ord a => Shape a -> a)
-> (forall a. Num a => Shape a -> a)
-> (forall a. Num a => Shape a -> a)
-> Foldable Shape
forall a. Eq a => a -> Shape a -> Bool
forall a. Num a => Shape a -> a
forall a. Ord a => Shape a -> a
forall m. Monoid m => Shape m -> m
forall a. Shape a -> Bool
forall a. Shape a -> Int
forall a. Shape a -> [a]
forall a. (a -> a -> a) -> Shape a -> a
forall m a. Monoid m => (a -> m) -> Shape a -> m
forall b a. (b -> a -> b) -> b -> Shape a -> b
forall a b. (a -> b -> b) -> b -> Shape a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Shape a -> a
$cproduct :: forall a. Num a => Shape a -> a
sum :: Shape a -> a
$csum :: forall a. Num a => Shape a -> a
minimum :: Shape a -> a
$cminimum :: forall a. Ord a => Shape a -> a
maximum :: Shape a -> a
$cmaximum :: forall a. Ord a => Shape a -> a
elem :: a -> Shape a -> Bool
$celem :: forall a. Eq a => a -> Shape a -> Bool
length :: Shape a -> Int
$clength :: forall a. Shape a -> Int
null :: Shape a -> Bool
$cnull :: forall a. Shape a -> Bool
toList :: Shape a -> [a]
$ctoList :: forall a. Shape a -> [a]
foldl1 :: (a -> a -> a) -> Shape a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Shape a -> a
foldr1 :: (a -> a -> a) -> Shape a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Shape a -> a
foldl' :: (b -> a -> b) -> b -> Shape a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Shape a -> b
foldl :: (b -> a -> b) -> b -> Shape a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Shape a -> b
foldr' :: (a -> b -> b) -> b -> Shape a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Shape a -> b
foldr :: (a -> b -> b) -> b -> Shape a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Shape a -> b
foldMap' :: (a -> m) -> Shape a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Shape a -> m
foldMap :: (a -> m) -> Shape a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Shape a -> m
fold :: Shape m -> m
$cfold :: forall m. Monoid m => Shape m -> m
Foldable, Functor Shape
Foldable Shape
Functor Shape
-> Foldable Shape
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Shape a -> f (Shape b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Shape (f a) -> f (Shape a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Shape a -> m (Shape b))
-> (forall (m :: * -> *) a. Monad m => Shape (m a) -> m (Shape a))
-> Traversable Shape
(a -> f b) -> Shape a -> f (Shape b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Shape (m a) -> m (Shape a)
forall (f :: * -> *) a. Applicative f => Shape (f a) -> f (Shape a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Shape a -> m (Shape b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Shape a -> f (Shape b)
sequence :: Shape (m a) -> m (Shape a)
$csequence :: forall (m :: * -> *) a. Monad m => Shape (m a) -> m (Shape a)
mapM :: (a -> m b) -> Shape a -> m (Shape b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Shape a -> m (Shape b)
sequenceA :: Shape (f a) -> f (Shape a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Shape (f a) -> f (Shape a)
traverse :: (a -> f b) -> Shape a -> f (Shape b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Shape a -> f (Shape b)
$cp2Traversable :: Foldable Shape
$cp1Traversable :: Functor Shape
Traversable)

type ValueShape = Shape Int32

instance Pretty d => Pretty (Shape d) where
  ppr :: Shape d -> Doc
ppr Shape d
ShapeLeaf = Doc
forall a. Monoid a => a
mempty
  ppr (ShapeDim d
d Shape d
s) = Doc -> Doc
brackets (d -> Doc
forall a. Pretty a => a -> Doc
ppr d
d) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Shape d -> Doc
forall a. Pretty a => a -> Doc
ppr Shape d
s
  ppr (ShapeRecord Map Name (Shape d)
m) = Map Name (Shape d) -> Doc
forall a. Pretty a => Map Name a -> Doc
prettyRecord Map Name (Shape d)
m
  ppr (ShapeSum Map Name [Shape d]
cs) =
    [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat (Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
" | ") [Doc]
cs')
    where ppConstr :: (a, [a]) -> Doc
ppConstr (a
name, [a]
fs) = [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc
text String
"#" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
name) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
ppr [a]
fs
          cs' :: [Doc]
cs' = ((Name, [Shape d]) -> Doc) -> [(Name, [Shape d])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Shape d]) -> Doc
forall a a. (Pretty a, Pretty a) => (a, [a]) -> Doc
ppConstr ([(Name, [Shape d])] -> [Doc]) -> [(Name, [Shape d])] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Map Name [Shape d] -> [(Name, [Shape d])]
forall k a. Map k a -> [(k, a)]
M.toList Map Name [Shape d]
cs

emptyShape :: ValueShape -> Bool
emptyShape :: ValueShape -> Bool
emptyShape (ShapeDim Int32
d ValueShape
s) = Int32
d Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0 Bool -> Bool -> Bool
|| ValueShape -> Bool
emptyShape ValueShape
s
emptyShape ValueShape
_ = Bool
False

typeShape :: M.Map VName (Shape d) -> TypeBase d () -> Shape d
typeShape :: Map VName (Shape d) -> TypeBase d () -> Shape d
typeShape Map VName (Shape d)
shapes = TypeBase d () -> Shape d
go
  where go :: TypeBase d () -> Shape d
go (Array ()
_ Uniqueness
_ ScalarTypeBase d ()
et ShapeDecl d
shape) =
          (d -> Shape d -> Shape d) -> Shape d -> [d] -> Shape d
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr d -> Shape d -> Shape d
forall d. d -> Shape d -> Shape d
ShapeDim (TypeBase d () -> Shape d
go (ScalarTypeBase d () -> TypeBase d ()
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar ScalarTypeBase d ()
et)) ([d] -> Shape d) -> [d] -> Shape d
forall a b. (a -> b) -> a -> b
$ ShapeDecl d -> [d]
forall dim. ShapeDecl dim -> [dim]
shapeDims ShapeDecl d
shape
        go (Scalar (Record Map Name (TypeBase d ())
fs)) =
          Map Name (Shape d) -> Shape d
forall d. Map Name (Shape d) -> Shape d
ShapeRecord (Map Name (Shape d) -> Shape d) -> Map Name (Shape d) -> Shape d
forall a b. (a -> b) -> a -> b
$ (TypeBase d () -> Shape d)
-> Map Name (TypeBase d ()) -> Map Name (Shape d)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map TypeBase d () -> Shape d
go Map Name (TypeBase d ())
fs
        go (Scalar (Sum Map Name [TypeBase d ()]
cs)) =
          Map Name [Shape d] -> Shape d
forall d. Map Name [Shape d] -> Shape d
ShapeSum (Map Name [Shape d] -> Shape d) -> Map Name [Shape d] -> Shape d
forall a b. (a -> b) -> a -> b
$ ([TypeBase d ()] -> [Shape d])
-> Map Name [TypeBase d ()] -> Map Name [Shape d]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((TypeBase d () -> Shape d) -> [TypeBase d ()] -> [Shape d]
forall a b. (a -> b) -> [a] -> [b]
map TypeBase d () -> Shape d
go) Map Name [TypeBase d ()]
cs
        go (Scalar (TypeVar ()
_ Uniqueness
_ (TypeName [] VName
v) []))
          | Just Shape d
shape <- VName -> Map VName (Shape d) -> Maybe (Shape d)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
v Map VName (Shape d)
shapes =
              Shape d
shape
        go TypeBase d ()
_ =
          Shape d
forall d. Shape d
ShapeLeaf

structTypeShape :: M.Map VName ValueShape -> StructType -> Shape (Maybe Int32)
structTypeShape :: Map VName ValueShape -> StructType -> Shape (Maybe Int32)
structTypeShape Map VName ValueShape
shapes = (DimDecl VName -> Maybe Int32)
-> Shape (DimDecl VName) -> Shape (Maybe Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DimDecl VName -> Maybe Int32
forall a vn. Num a => DimDecl vn -> Maybe a
dim (Shape (DimDecl VName) -> Shape (Maybe Int32))
-> (StructType -> Shape (DimDecl VName))
-> StructType
-> Shape (Maybe Int32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map VName (Shape (DimDecl VName))
-> StructType -> Shape (DimDecl VName)
forall d. Map VName (Shape d) -> TypeBase d () -> Shape d
typeShape Map VName (Shape (DimDecl VName))
forall vn. Map VName (Shape (DimDecl vn))
shapes'
  where dim :: DimDecl vn -> Maybe a
dim (ConstDim Int
d) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d
        dim DimDecl vn
_ = Maybe a
forall a. Maybe a
Nothing
        shapes' :: Map VName (Shape (DimDecl vn))
shapes' = (ValueShape -> Shape (DimDecl vn))
-> Map VName ValueShape -> Map VName (Shape (DimDecl vn))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Int32 -> DimDecl vn) -> ValueShape -> Shape (DimDecl vn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int32 -> DimDecl vn) -> ValueShape -> Shape (DimDecl vn))
-> (Int32 -> DimDecl vn) -> ValueShape -> Shape (DimDecl vn)
forall a b. (a -> b) -> a -> b
$ Int -> DimDecl vn
forall vn. Int -> DimDecl vn
ConstDim (Int -> DimDecl vn) -> (Int32 -> Int) -> Int32 -> DimDecl vn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Map VName ValueShape
shapes

resolveTypeParams :: [VName] -> StructType -> StructType -> Env
resolveTypeParams :: [VName] -> StructType -> StructType -> Env
resolveTypeParams [VName]
names = StructType -> StructType -> Env
forall as. TypeBase (DimDecl VName) as -> StructType -> Env
match
  where match :: TypeBase (DimDecl VName) as -> StructType -> Env
match (Scalar (TypeVar as
_ Uniqueness
_ TypeName
tn [TypeArg (DimDecl VName)]
_)) StructType
t
          | TypeName -> VName
typeLeaf TypeName
tn VName -> [VName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [VName]
names =
              Map VName StructType -> Env
typeEnv (Map VName StructType -> Env) -> Map VName StructType -> Env
forall a b. (a -> b) -> a -> b
$ VName -> StructType -> Map VName StructType
forall k a. k -> a -> Map k a
M.singleton (TypeName -> VName
typeLeaf TypeName
tn) StructType
t
        match (Scalar (Record Map Name (TypeBase (DimDecl VName) as)
poly_fields)) (Scalar (Record Map Name StructType
fields)) =
          [Env] -> Env
forall a. Monoid a => [a] -> a
mconcat ([Env] -> Env) -> [Env] -> Env
forall a b. (a -> b) -> a -> b
$ Map Name Env -> [Env]
forall k a. Map k a -> [a]
M.elems (Map Name Env -> [Env]) -> Map Name Env -> [Env]
forall a b. (a -> b) -> a -> b
$
          (TypeBase (DimDecl VName) as -> StructType -> Env)
-> Map Name (TypeBase (DimDecl VName) as)
-> Map Name StructType
-> Map Name Env
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith TypeBase (DimDecl VName) as -> StructType -> Env
match Map Name (TypeBase (DimDecl VName) as)
poly_fields Map Name StructType
fields
        match (Scalar (Sum Map Name [TypeBase (DimDecl VName) as]
poly_fields)) (Scalar (Sum Map Name [StructType]
fields)) =
          [Env] -> Env
forall a. Monoid a => [a] -> a
mconcat ([Env] -> Env) -> [Env] -> Env
forall a b. (a -> b) -> a -> b
$ ([Env] -> Env) -> [[Env]] -> [Env]
forall a b. (a -> b) -> [a] -> [b]
map [Env] -> Env
forall a. Monoid a => [a] -> a
mconcat ([[Env]] -> [Env]) -> [[Env]] -> [Env]
forall a b. (a -> b) -> a -> b
$ Map Name [Env] -> [[Env]]
forall k a. Map k a -> [a]
M.elems (Map Name [Env] -> [[Env]]) -> Map Name [Env] -> [[Env]]
forall a b. (a -> b) -> a -> b
$
          ([TypeBase (DimDecl VName) as] -> [StructType] -> [Env])
-> Map Name [TypeBase (DimDecl VName) as]
-> Map Name [StructType]
-> Map Name [Env]
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith ((TypeBase (DimDecl VName) as -> StructType -> Env)
-> [TypeBase (DimDecl VName) as] -> [StructType] -> [Env]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TypeBase (DimDecl VName) as -> StructType -> Env
match) Map Name [TypeBase (DimDecl VName) as]
poly_fields Map Name [StructType]
fields
        match (Scalar (Arrow as
_ PName
_  TypeBase (DimDecl VName) as
poly_t1 TypeBase (DimDecl VName) as
poly_t2)) (Scalar (Arrow ()
_ PName
_ StructType
t1 StructType
t2)) =
          TypeBase (DimDecl VName) as -> StructType -> Env
match TypeBase (DimDecl VName) as
poly_t1 StructType
t1 Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> TypeBase (DimDecl VName) as -> StructType -> Env
match TypeBase (DimDecl VName) as
poly_t2 StructType
t2
        match TypeBase (DimDecl VName) as
poly_t StructType
t
          | DimDecl VName
d1 : [DimDecl VName]
_ <- ShapeDecl (DimDecl VName) -> [DimDecl VName]
forall dim. ShapeDecl dim -> [dim]
shapeDims (TypeBase (DimDecl VName) as -> ShapeDecl (DimDecl VName)
forall dim as. TypeBase dim as -> ShapeDecl dim
arrayShape TypeBase (DimDecl VName) as
poly_t),
            DimDecl VName
d2 : [DimDecl VName]
_ <- ShapeDecl (DimDecl VName) -> [DimDecl VName]
forall dim. ShapeDecl dim -> [dim]
shapeDims (StructType -> ShapeDecl (DimDecl VName)
forall dim as. TypeBase dim as -> ShapeDecl dim
arrayShape StructType
t) =
              DimDecl VName -> DimDecl VName -> Env
forall vn. DimDecl VName -> DimDecl vn -> Env
matchDims DimDecl VName
d1 DimDecl VName
d2 Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> TypeBase (DimDecl VName) as -> StructType -> Env
match (Int -> TypeBase (DimDecl VName) as -> TypeBase (DimDecl VName) as
forall dim as. Int -> TypeBase dim as -> TypeBase dim as
stripArray Int
1 TypeBase (DimDecl VName) as
poly_t) (Int -> StructType -> StructType
forall dim as. Int -> TypeBase dim as -> TypeBase dim as
stripArray Int
1 StructType
t)
        match TypeBase (DimDecl VName) as
_ StructType
_ = Env
forall a. Monoid a => a
mempty

        matchDims :: DimDecl VName -> DimDecl vn -> Env
matchDims (NamedDim (QualName [VName]
_ VName
d1)) (ConstDim Int
d2)
          | VName
d1 VName -> [VName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [VName]
names =
              Sizes -> Env
i32Env (Sizes -> Env) -> Sizes -> Env
forall a b. (a -> b) -> a -> b
$ VName -> Int32 -> Sizes
forall k a. k -> a -> Map k a
M.singleton VName
d1 (Int32 -> Sizes) -> Int32 -> Sizes
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d2
        matchDims DimDecl VName
_ DimDecl vn
_ = Env
forall a. Monoid a => a
mempty

resolveExistentials :: [VName] -> StructType -> ValueShape -> M.Map VName Int32
resolveExistentials :: [VName] -> StructType -> ValueShape -> Sizes
resolveExistentials [VName]
names = StructType -> ValueShape -> Sizes
forall as a. TypeBase (DimDecl VName) as -> Shape a -> Map VName a
match
  where match :: TypeBase (DimDecl VName) as -> Shape a -> Map VName a
match (Scalar (Record Map Name (TypeBase (DimDecl VName) as)
poly_fields)) (ShapeRecord Map Name (Shape a)
fields) =
          [Map VName a] -> Map VName a
forall a. Monoid a => [a] -> a
mconcat ([Map VName a] -> Map VName a) -> [Map VName a] -> Map VName a
forall a b. (a -> b) -> a -> b
$ Map Name (Map VName a) -> [Map VName a]
forall k a. Map k a -> [a]
M.elems (Map Name (Map VName a) -> [Map VName a])
-> Map Name (Map VName a) -> [Map VName a]
forall a b. (a -> b) -> a -> b
$
          (TypeBase (DimDecl VName) as -> Shape a -> Map VName a)
-> Map Name (TypeBase (DimDecl VName) as)
-> Map Name (Shape a)
-> Map Name (Map VName a)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith TypeBase (DimDecl VName) as -> Shape a -> Map VName a
match Map Name (TypeBase (DimDecl VName) as)
poly_fields Map Name (Shape a)
fields
        match (Scalar (Sum Map Name [TypeBase (DimDecl VName) as]
poly_fields)) (ShapeSum Map Name [Shape a]
fields) =
          [Map VName a] -> Map VName a
forall a. Monoid a => [a] -> a
mconcat ([Map VName a] -> Map VName a) -> [Map VName a] -> Map VName a
forall a b. (a -> b) -> a -> b
$ ([Map VName a] -> Map VName a) -> [[Map VName a]] -> [Map VName a]
forall a b. (a -> b) -> [a] -> [b]
map [Map VName a] -> Map VName a
forall a. Monoid a => [a] -> a
mconcat ([[Map VName a]] -> [Map VName a])
-> [[Map VName a]] -> [Map VName a]
forall a b. (a -> b) -> a -> b
$ Map Name [Map VName a] -> [[Map VName a]]
forall k a. Map k a -> [a]
M.elems (Map Name [Map VName a] -> [[Map VName a]])
-> Map Name [Map VName a] -> [[Map VName a]]
forall a b. (a -> b) -> a -> b
$
          ([TypeBase (DimDecl VName) as] -> [Shape a] -> [Map VName a])
-> Map Name [TypeBase (DimDecl VName) as]
-> Map Name [Shape a]
-> Map Name [Map VName a]
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith ((TypeBase (DimDecl VName) as -> Shape a -> Map VName a)
-> [TypeBase (DimDecl VName) as] -> [Shape a] -> [Map VName a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TypeBase (DimDecl VName) as -> Shape a -> Map VName a
match) Map Name [TypeBase (DimDecl VName) as]
poly_fields Map Name [Shape a]
fields
        match TypeBase (DimDecl VName) as
poly_t (ShapeDim a
d2 Shape a
rowshape)
          | DimDecl VName
d1 : [DimDecl VName]
_ <- ShapeDecl (DimDecl VName) -> [DimDecl VName]
forall dim. ShapeDecl dim -> [dim]
shapeDims (TypeBase (DimDecl VName) as -> ShapeDecl (DimDecl VName)
forall dim as. TypeBase dim as -> ShapeDecl dim
arrayShape TypeBase (DimDecl VName) as
poly_t) =
              DimDecl VName -> a -> Map VName a
forall a. DimDecl VName -> a -> Map VName a
matchDims DimDecl VName
d1 a
d2 Map VName a -> Map VName a -> Map VName a
forall a. Semigroup a => a -> a -> a
<> TypeBase (DimDecl VName) as -> Shape a -> Map VName a
match (Int -> TypeBase (DimDecl VName) as -> TypeBase (DimDecl VName) as
forall dim as. Int -> TypeBase dim as -> TypeBase dim as
stripArray Int
1 TypeBase (DimDecl VName) as
poly_t) Shape a
rowshape
        match TypeBase (DimDecl VName) as
_ Shape a
_ = Map VName a
forall a. Monoid a => a
mempty

        matchDims :: DimDecl VName -> a -> Map VName a
matchDims (NamedDim (QualName [VName]
_ VName
d1)) a
d2
          | VName
d1 VName -> [VName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [VName]
names = VName -> a -> Map VName a
forall k a. k -> a -> Map k a
M.singleton VName
d1 a
d2
        matchDims DimDecl VName
_ a
_ = Map VName a
forall a. Monoid a => a
mempty

-- | A fully evaluated Futhark value.
data Value = ValuePrim !PrimValue
           | ValueArray ValueShape !(Array Int Value)
             -- Stores the full shape.
           | ValueRecord (M.Map Name Value)
           | ValueFun (Value -> EvalM Value)
           | ValueSum ValueShape Name [Value]
             -- Stores the full shape.

instance Eq Value where
  ValuePrim PrimValue
x == :: Value -> Value -> Bool
== ValuePrim PrimValue
y = PrimValue
x PrimValue -> PrimValue -> Bool
forall a. Eq a => a -> a -> Bool
== PrimValue
y
  ValueArray ValueShape
_ Array Int Value
x == ValueArray ValueShape
_ Array Int Value
y = Array Int Value
x Array Int Value -> Array Int Value -> Bool
forall a. Eq a => a -> a -> Bool
== Array Int Value
y
  ValueRecord Map Name Value
x == ValueRecord Map Name Value
y = Map Name Value
x Map Name Value -> Map Name Value -> Bool
forall a. Eq a => a -> a -> Bool
== Map Name Value
y
  ValueSum ValueShape
_ Name
n1 [Value]
vs1 == ValueSum ValueShape
_ Name
n2 [Value]
vs2 = Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n2 Bool -> Bool -> Bool
&& [Value]
vs1 [Value] -> [Value] -> Bool
forall a. Eq a => a -> a -> Bool
== [Value]
vs2
  Value
_ == Value
_ = Bool
False

instance Pretty Value where
  ppr :: Value -> Doc
ppr (ValuePrim PrimValue
v)  = PrimValue -> Doc
forall a. Pretty a => a -> Doc
ppr PrimValue
v
  ppr (ValueArray ValueShape
_ Array Int Value
a) =
    let elements :: [Value]
elements  = Array Int Value -> [Value]
forall i e. Array i e -> [e]
elems Array Int Value
a -- [Value]
        (Value
x:[Value]
_)     = [Value]
elements
        separator :: Doc
separator = case Value
x of
                      ValueArray ValueShape
_ Array Int Value
_ -> Doc
comma Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
line
                      Value
_              -> Doc
comma Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
space
     in Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
cat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
separator ((Value -> Doc) -> [Value] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Doc
forall a. Pretty a => a -> Doc
ppr [Value]
elements)

  ppr (ValueRecord Map Name Value
m) = Map Name Value -> Doc
forall a. Pretty a => Map Name a -> Doc
prettyRecord Map Name Value
m
  ppr ValueFun{} = String -> Doc
text String
"#<fun>"
  ppr (ValueSum ValueShape
_ Name
n [Value]
vs) = String -> Doc
text String
"#" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
sep (Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
n Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (Value -> Doc) -> [Value] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Doc
forall a. Pretty a => a -> Doc
ppr [Value]
vs)

valueShape :: Value -> ValueShape
valueShape :: Value -> ValueShape
valueShape (ValueArray ValueShape
shape Array Int Value
_) = ValueShape
shape
valueShape (ValueRecord Map Name Value
fs) = Map Name ValueShape -> ValueShape
forall d. Map Name (Shape d) -> Shape d
ShapeRecord (Map Name ValueShape -> ValueShape)
-> Map Name ValueShape -> ValueShape
forall a b. (a -> b) -> a -> b
$ (Value -> ValueShape) -> Map Name Value -> Map Name ValueShape
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Value -> ValueShape
valueShape Map Name Value
fs
valueShape (ValueSum ValueShape
shape Name
_ [Value]
_) = ValueShape
shape
valueShape Value
_ = ValueShape
forall d. Shape d
ShapeLeaf

checkShape :: Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape
checkShape :: Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape
checkShape (ShapeDim Maybe Int32
Nothing Shape (Maybe Int32)
shape1) (ShapeDim Int32
d2 ValueShape
shape2) =
  Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int32
d2 (ValueShape -> ValueShape) -> Maybe ValueShape -> Maybe ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape
checkShape Shape (Maybe Int32)
shape1 ValueShape
shape2
checkShape (ShapeDim (Just Int32
d1) Shape (Maybe Int32)
shape1) (ShapeDim Int32
d2 ValueShape
shape2) = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int32
d1 Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
d2
  Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int32
d2 (ValueShape -> ValueShape) -> Maybe ValueShape -> Maybe ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape
checkShape Shape (Maybe Int32)
shape1 ValueShape
shape2
checkShape (ShapeDim Maybe Int32
d1 Shape (Maybe Int32)
shape1) ValueShape
ShapeLeaf =
  -- This case is for handling polymorphism, when a function doesn't
  -- know that the array it produced actually has more dimensions.
  Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim (Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
d1) (ValueShape -> ValueShape) -> Maybe ValueShape -> Maybe ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape
checkShape Shape (Maybe Int32)
shape1 ValueShape
forall d. Shape d
ShapeLeaf
checkShape (ShapeRecord Map Name (Shape (Maybe Int32))
shapes1) (ShapeRecord Map Name ValueShape
shapes2) =
  Map Name ValueShape -> ValueShape
forall d. Map Name (Shape d) -> Shape d
ShapeRecord (Map Name ValueShape -> ValueShape)
-> Maybe (Map Name ValueShape) -> Maybe ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (Maybe ValueShape) -> Maybe (Map Name ValueShape)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ((Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape)
-> Map Name (Shape (Maybe Int32))
-> Map Name ValueShape
-> Map Name (Maybe ValueShape)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape
checkShape Map Name (Shape (Maybe Int32))
shapes1 Map Name ValueShape
shapes2)
checkShape (ShapeRecord Map Name (Shape (Maybe Int32))
shapes1) ValueShape
ShapeLeaf =
  ValueShape -> Maybe ValueShape
forall a. a -> Maybe a
Just (ValueShape -> Maybe ValueShape) -> ValueShape -> Maybe ValueShape
forall a b. (a -> b) -> a -> b
$ Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 (Maybe Int32 -> Int32) -> Shape (Maybe Int32) -> ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (Shape (Maybe Int32)) -> Shape (Maybe Int32)
forall d. Map Name (Shape d) -> Shape d
ShapeRecord Map Name (Shape (Maybe Int32))
shapes1
checkShape (ShapeSum Map Name [Shape (Maybe Int32)]
shapes1) (ShapeSum Map Name [ValueShape]
shapes2) =
  Map Name [ValueShape] -> ValueShape
forall d. Map Name [Shape d] -> Shape d
ShapeSum (Map Name [ValueShape] -> ValueShape)
-> Maybe (Map Name [ValueShape]) -> Maybe ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (Maybe [ValueShape]) -> Maybe (Map Name [ValueShape])
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (([Shape (Maybe Int32)] -> [ValueShape] -> Maybe [ValueShape])
-> Map Name [Shape (Maybe Int32)]
-> Map Name [ValueShape]
-> Map Name (Maybe [ValueShape])
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith ((Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape)
-> [Shape (Maybe Int32)] -> [ValueShape] -> Maybe [ValueShape]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape
checkShape) Map Name [Shape (Maybe Int32)]
shapes1 Map Name [ValueShape]
shapes2)
checkShape (ShapeSum Map Name [Shape (Maybe Int32)]
shapes1) ValueShape
ShapeLeaf =
  ValueShape -> Maybe ValueShape
forall a. a -> Maybe a
Just (ValueShape -> Maybe ValueShape) -> ValueShape -> Maybe ValueShape
forall a b. (a -> b) -> a -> b
$ Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 (Maybe Int32 -> Int32) -> Shape (Maybe Int32) -> ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name [Shape (Maybe Int32)] -> Shape (Maybe Int32)
forall d. Map Name [Shape d] -> Shape d
ShapeSum Map Name [Shape (Maybe Int32)]
shapes1
checkShape Shape (Maybe Int32)
_ ValueShape
shape2 =
  ValueShape -> Maybe ValueShape
forall a. a -> Maybe a
Just ValueShape
shape2

-- | Does the value correspond to an empty array?
isEmptyArray :: Value -> Bool
isEmptyArray :: Value -> Bool
isEmptyArray = ValueShape -> Bool
emptyShape (ValueShape -> Bool) -> (Value -> ValueShape) -> Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueShape
valueShape

-- | String representation of an empty array with the provided element
-- type.  This is pretty ad-hoc - don't expect good results unless the
-- element type is a primitive.
prettyEmptyArray :: TypeBase () () -> Value -> String
prettyEmptyArray :: TypeBase () () -> Value -> String
prettyEmptyArray TypeBase () ()
t Value
v =
  String
"empty(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValueShape -> String
forall a. Pretty a => Shape a -> String
dims (Value -> ValueShape
valueShape Value
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeBase () () -> String
forall a. Pretty a => a -> String
pretty TypeBase () ()
t' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  where t' :: TypeBase () ()
t' = Int -> TypeBase () () -> TypeBase () ()
forall dim as. Int -> TypeBase dim as -> TypeBase dim as
stripArray (TypeBase () () -> Int
forall dim as. TypeBase dim as -> Int
arrayRank TypeBase () ()
t) TypeBase () ()
t
        dims :: Shape a -> String
dims (ShapeDim a
n Shape a
rowshape) =
          String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
pretty a
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Shape a -> String
dims Shape a
rowshape
        dims Shape a
_ = String
""

-- | Create an array value; failing if that would result in an
-- irregular array.
mkArray :: TypeBase Int32 () -> [Value] -> Maybe Value
mkArray :: ValueType -> [Value] -> Maybe Value
mkArray ValueType
t [] =
  Value -> Maybe Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ValueShape -> [Value] -> Value
toArray (Map VName ValueShape -> ValueType -> ValueShape
forall d. Map VName (Shape d) -> TypeBase d () -> Shape d
typeShape Map VName ValueShape
forall a. Monoid a => a
mempty ValueType
t) []
mkArray ValueType
_ (Value
v:[Value]
vs) = do
  let v_shape :: ValueShape
v_shape = Value -> ValueShape
valueShape Value
v
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((ValueShape -> ValueShape -> Bool
forall a. Eq a => a -> a -> Bool
==ValueShape
v_shape) (ValueShape -> Bool) -> (Value -> ValueShape) -> Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueShape
valueShape) [Value]
vs
  Value -> Maybe Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ValueShape -> [Value] -> Value
toArray' ValueShape
v_shape ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ Value
vValue -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:[Value]
vs

arrayLength :: Integral int => Array Int Value -> int
arrayLength :: Array Int Value -> int
arrayLength = Int -> int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> int) -> (Array Int Value -> Int) -> Array Int Value -> int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> (Array Int Value -> Int) -> Array Int Value -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int)
-> (Array Int Value -> (Int, Int)) -> Array Int Value -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array Int Value -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds

toTuple :: [Value] -> Value
toTuple :: [Value] -> Value
toTuple = Map Name Value -> Value
ValueRecord (Map Name Value -> Value)
-> ([Value] -> Map Name Value) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, Value)] -> Map Name Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Value)] -> Map Name Value)
-> ([Value] -> [(Name, Value)]) -> [Value] -> Map Name Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> [Value] -> [(Name, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
tupleFieldNames

fromTuple :: Value -> Maybe [Value]
fromTuple :: Value -> Maybe [Value]
fromTuple (ValueRecord Map Name Value
m) = Map Name Value -> Maybe [Value]
forall a. Map Name a -> Maybe [a]
areTupleFields Map Name Value
m
fromTuple Value
_ = Maybe [Value]
forall a. Maybe a
Nothing

asInteger :: Value -> Integer
asInteger :: Value -> Integer
asInteger (ValuePrim (SignedValue IntValue
v)) = IntValue -> Integer
forall int. Integral int => IntValue -> int
P.valueIntegral IntValue
v
asInteger (ValuePrim (UnsignedValue IntValue
v)) =
  Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (IntValue -> Word64
forall int. Integral int => IntValue -> int
P.valueIntegral (IntValue -> IntType -> IntValue
P.doZExt IntValue
v IntType
Int64) :: Word64)
asInteger Value
v = String -> Integer
forall a. HasCallStack => String -> a
error (String -> Integer) -> String -> Integer
forall a b. (a -> b) -> a -> b
$ String
"Unexpectedly not an integer: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
v

asInt :: Value -> Int
asInt :: Value -> Int
asInt = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> (Value -> Integer) -> Value -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Integer
asInteger

asSigned :: Value -> IntValue
asSigned :: Value -> IntValue
asSigned (ValuePrim (SignedValue IntValue
v)) = IntValue
v
asSigned Value
v = String -> IntValue
forall a. HasCallStack => String -> a
error (String -> IntValue) -> String -> IntValue
forall a b. (a -> b) -> a -> b
$ String
"Unexpected not a signed integer: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
v

asInt32 :: Value -> Int32
asInt32 :: Value -> Int32
asInt32 = Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int32) -> (Value -> Integer) -> Value -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Integer
asInteger

asBool :: Value -> Bool
asBool :: Value -> Bool
asBool (ValuePrim (BoolValue Bool
x)) = Bool
x
asBool Value
v = String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"Unexpectedly not a boolean: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
v

lookupInEnv :: (Env -> M.Map VName x)
            -> QualName VName -> Env -> Maybe x
lookupInEnv :: (Env -> Map VName x) -> QualName VName -> Env -> Maybe x
lookupInEnv Env -> Map VName x
onEnv QualName VName
qv Env
env = Env -> [VName] -> Maybe x
f Env
env ([VName] -> Maybe x) -> [VName] -> Maybe x
forall a b. (a -> b) -> a -> b
$ QualName VName -> [VName]
forall vn. QualName vn -> [vn]
qualQuals QualName VName
qv
  where f :: Env -> [VName] -> Maybe x
f Env
m (VName
q:[VName]
qs) =
          case VName -> Map VName TermBinding -> Maybe TermBinding
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
q (Map VName TermBinding -> Maybe TermBinding)
-> Map VName TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ Env -> Map VName TermBinding
envTerm Env
m of
            Just (TermModule (Module Env
mod)) -> Env -> [VName] -> Maybe x
f Env
mod [VName]
qs
            Maybe TermBinding
_ -> Maybe x
forall a. Maybe a
Nothing
        f Env
m [] = VName -> Map VName x -> Maybe x
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
qv) (Map VName x -> Maybe x) -> Map VName x -> Maybe x
forall a b. (a -> b) -> a -> b
$ Env -> Map VName x
onEnv Env
m

lookupVar :: QualName VName -> Env -> Maybe TermBinding
lookupVar :: QualName VName -> Env -> Maybe TermBinding
lookupVar = (Env -> Map VName TermBinding)
-> QualName VName -> Env -> Maybe TermBinding
forall x. (Env -> Map VName x) -> QualName VName -> Env -> Maybe x
lookupInEnv Env -> Map VName TermBinding
envTerm

lookupType :: QualName VName -> Env -> Maybe T.TypeBinding
lookupType :: QualName VName -> Env -> Maybe TypeBinding
lookupType = (Env -> Map VName TypeBinding)
-> QualName VName -> Env -> Maybe TypeBinding
forall x. (Env -> Map VName x) -> QualName VName -> Env -> Maybe x
lookupInEnv Env -> Map VName TypeBinding
envType

-- | A TermValue with a 'Nothing' type annotation is an intrinsic.
data TermBinding = TermValue (Maybe T.BoundV) Value
                 | TermPoly (Maybe T.BoundV) (StructType -> EvalM Value)
                   -- ^ A polymorphic value that must be instantiated.
                 | TermModule Module

data Module = Module Env
            | ModuleFun (Module -> EvalM Module)

-- | The actual type- and value environment.
data Env = Env { Env -> Map VName TermBinding
envTerm :: M.Map VName TermBinding
               , Env -> Map VName TypeBinding
envType :: M.Map VName T.TypeBinding
               , Env -> Map VName ValueShape
envShapes :: M.Map VName ValueShape
                 -- ^ A mapping from type parameters to the shapes of
                 -- the value to which they were initially bound.
               }

instance Monoid Env where
  mempty :: Env
mempty = Map VName TermBinding
-> Map VName TypeBinding -> Map VName ValueShape -> Env
Env Map VName TermBinding
forall a. Monoid a => a
mempty Map VName TypeBinding
forall a. Monoid a => a
mempty Map VName ValueShape
forall a. Monoid a => a
mempty

instance Semigroup Env where
  Env Map VName TermBinding
vm1 Map VName TypeBinding
tm1 Map VName ValueShape
sm1 <> :: Env -> Env -> Env
<> Env Map VName TermBinding
vm2 Map VName TypeBinding
tm2 Map VName ValueShape
sm2 =
    Map VName TermBinding
-> Map VName TypeBinding -> Map VName ValueShape -> Env
Env (Map VName TermBinding
vm1 Map VName TermBinding
-> Map VName TermBinding -> Map VName TermBinding
forall a. Semigroup a => a -> a -> a
<> Map VName TermBinding
vm2) (Map VName TypeBinding
tm1 Map VName TypeBinding
-> Map VName TypeBinding -> Map VName TypeBinding
forall a. Semigroup a => a -> a -> a
<> Map VName TypeBinding
tm2) (Map VName ValueShape
sm1 Map VName ValueShape
-> Map VName ValueShape -> Map VName ValueShape
forall a. Semigroup a => a -> a -> a
<> Map VName ValueShape
sm2)

-- | An error occurred during interpretation due to an error in the
-- user program.  Actual interpreter errors will be signaled with an
-- IO exception ('error').
newtype InterpreterError = InterpreterError String

valEnv :: M.Map VName (Maybe T.BoundV, Value) -> Env
valEnv :: Map VName (Maybe BoundV, Value) -> Env
valEnv Map VName (Maybe BoundV, Value)
m = Env :: Map VName TermBinding
-> Map VName TypeBinding -> Map VName ValueShape -> Env
Env { envTerm :: Map VName TermBinding
envTerm = ((Maybe BoundV, Value) -> TermBinding)
-> Map VName (Maybe BoundV, Value) -> Map VName TermBinding
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Maybe BoundV -> Value -> TermBinding)
-> (Maybe BoundV, Value) -> TermBinding
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe BoundV -> Value -> TermBinding
TermValue) Map VName (Maybe BoundV, Value)
m
               , envType :: Map VName TypeBinding
envType = Map VName TypeBinding
forall a. Monoid a => a
mempty
               , envShapes :: Map VName ValueShape
envShapes = Map VName ValueShape
forall a. Monoid a => a
mempty
               }

modEnv :: M.Map VName Module -> Env
modEnv :: Map VName Module -> Env
modEnv Map VName Module
m = Env :: Map VName TermBinding
-> Map VName TypeBinding -> Map VName ValueShape -> Env
Env { envTerm :: Map VName TermBinding
envTerm = (Module -> TermBinding)
-> Map VName Module -> Map VName TermBinding
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Module -> TermBinding
TermModule Map VName Module
m
               , envType :: Map VName TypeBinding
envType = Map VName TypeBinding
forall a. Monoid a => a
mempty
               , envShapes :: Map VName ValueShape
envShapes = Map VName ValueShape
forall a. Monoid a => a
mempty
               }

typeEnv :: M.Map VName StructType -> Env
typeEnv :: Map VName StructType -> Env
typeEnv Map VName StructType
m = Env :: Map VName TermBinding
-> Map VName TypeBinding -> Map VName ValueShape -> Env
Env { envTerm :: Map VName TermBinding
envTerm = Map VName TermBinding
forall a. Monoid a => a
mempty
                , envType :: Map VName TypeBinding
envType = (StructType -> TypeBinding)
-> Map VName StructType -> Map VName TypeBinding
forall a b k. (a -> b) -> Map k a -> Map k b
M.map StructType -> TypeBinding
tbind Map VName StructType
m
                , envShapes :: Map VName ValueShape
envShapes = Map VName ValueShape
forall a. Monoid a => a
mempty
                }
  where tbind :: StructType -> TypeBinding
tbind = Liftedness -> [TypeParam] -> StructType -> TypeBinding
T.TypeAbbr Liftedness
Unlifted []

i32Env :: M.Map VName Int32 -> Env
i32Env :: Sizes -> Env
i32Env = Map VName (Maybe BoundV, Value) -> Env
valEnv (Map VName (Maybe BoundV, Value) -> Env)
-> (Sizes -> Map VName (Maybe BoundV, Value)) -> Sizes -> Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32 -> (Maybe BoundV, Value))
-> Sizes -> Map VName (Maybe BoundV, Value)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Int32 -> (Maybe BoundV, Value)
f
  where f :: Int32 -> (Maybe BoundV, Value)
f Int32
x = (BoundV -> Maybe BoundV
forall a. a -> Maybe a
Just (BoundV -> Maybe BoundV) -> BoundV -> Maybe BoundV
forall a b. (a -> b) -> a -> b
$ [TypeParam] -> StructType -> BoundV
T.BoundV [] (StructType -> BoundV) -> StructType -> BoundV
forall a b. (a -> b) -> a -> b
$ ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase (DimDecl VName) ()
forall dim as. PrimType -> ScalarTypeBase dim as
Prim (PrimType -> ScalarTypeBase (DimDecl VName) ())
-> PrimType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
Signed IntType
Int32,
               PrimValue -> Value
ValuePrim (PrimValue -> Value) -> PrimValue -> Value
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int32 -> IntValue
Int32Value Int32
x)

instance Show InterpreterError where
  show :: InterpreterError -> String
show (InterpreterError String
s) = String
s

bad :: SrcLoc -> Env -> String -> EvalM a
bad :: SrcLoc -> Env -> String -> EvalM a
bad SrcLoc
loc Env
env String
s = SrcLoc -> Env -> EvalM a -> EvalM a
forall a. SrcLoc -> Env -> EvalM a -> EvalM a
stacking SrcLoc
loc Env
env (EvalM a -> EvalM a) -> EvalM a -> EvalM a
forall a b. (a -> b) -> a -> b
$ do
  [String]
ss <- (Loc -> String) -> [Loc] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (SrcLoc -> String
forall a. Located a => a -> String
locStr (SrcLoc -> String) -> (Loc -> SrcLoc) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf) ([Loc] -> [String]) -> EvalM [Loc] -> EvalM [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalM [Loc]
stacktrace
  ExtOp a -> EvalM a
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (ExtOp a -> EvalM a) -> ExtOp a -> EvalM a
forall a b. (a -> b) -> a -> b
$ InterpreterError -> ExtOp a
forall a. InterpreterError -> ExtOp a
ExtOpError (InterpreterError -> ExtOp a) -> InterpreterError -> ExtOp a
forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
InterpreterError (String -> InterpreterError) -> String -> InterpreterError
forall a b. (a -> b) -> a -> b
$ String
"Error at\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [String] -> String
prettyStacktrace Int
0 [String]
ss String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

trace :: Value -> EvalM ()
trace :: Value -> EvalM ()
trace Value
v = do
  -- We take the second-to-top element of the stack, because any
  -- actual call to 'implicits.trace' is going to be in the trace
  -- function in the prelude, which is not interesting.
  Loc
top <- Loc -> Maybe Loc -> Loc
forall a. a -> Maybe a -> a
fromMaybe Loc
forall a. IsLocation a => a
noLoc (Maybe Loc -> Loc) -> ([Loc] -> Maybe Loc) -> [Loc] -> Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Loc] -> Maybe Loc
forall a. [a] -> Maybe a
maybeHead ([Loc] -> Maybe Loc) -> ([Loc] -> [Loc]) -> [Loc] -> Maybe Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Loc] -> [Loc]
forall a. Int -> [a] -> [a]
drop Int
1 ([Loc] -> Loc) -> EvalM [Loc] -> EvalM Loc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalM [Loc]
stacktrace
  ExtOp () -> EvalM ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (ExtOp () -> EvalM ()) -> ExtOp () -> EvalM ()
forall a b. (a -> b) -> a -> b
$ Loc -> String -> () -> ExtOp ()
forall a. Loc -> String -> a -> ExtOp a
ExtOpTrace Loc
top (Value -> String
forall a. Pretty a => a -> String
prettyOneLine Value
v) ()

typeCheckerEnv :: Env -> T.Env
typeCheckerEnv :: Env -> Env
typeCheckerEnv Env
env =
  -- FIXME: some shadowing issues are probably not right here.
  let valMap :: TermBinding -> Maybe BoundV
valMap (TermValue (Just BoundV
t) Value
_) = BoundV -> Maybe BoundV
forall a. a -> Maybe a
Just BoundV
t
      valMap TermBinding
_ = Maybe BoundV
forall a. Maybe a
Nothing
      vtable :: Map VName BoundV
vtable = (TermBinding -> Maybe BoundV)
-> Map VName TermBinding -> Map VName BoundV
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe TermBinding -> Maybe BoundV
valMap (Map VName TermBinding -> Map VName BoundV)
-> Map VName TermBinding -> Map VName BoundV
forall a b. (a -> b) -> a -> b
$ Env -> Map VName TermBinding
envTerm Env
env
      nameMap :: VName -> Maybe ((Namespace, Name), QualName VName)
nameMap VName
k | VName
k VName -> Map VName BoundV -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map VName BoundV
vtable = ((Namespace, Name), QualName VName)
-> Maybe ((Namespace, Name), QualName VName)
forall a. a -> Maybe a
Just ((Namespace
T.Term, VName -> Name
baseName VName
k), VName -> QualName VName
forall v. v -> QualName v
qualName VName
k)
                | Bool
otherwise = Maybe ((Namespace, Name), QualName VName)
forall a. Maybe a
Nothing
  in Env
forall a. Monoid a => a
mempty { envNameMap :: NameMap
T.envNameMap = [((Namespace, Name), QualName VName)] -> NameMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((Namespace, Name), QualName VName)] -> NameMap)
-> [((Namespace, Name), QualName VName)] -> NameMap
forall a b. (a -> b) -> a -> b
$ (VName -> Maybe ((Namespace, Name), QualName VName))
-> [VName] -> [((Namespace, Name), QualName VName)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VName -> Maybe ((Namespace, Name), QualName VName)
nameMap ([VName] -> [((Namespace, Name), QualName VName)])
-> [VName] -> [((Namespace, Name), QualName VName)]
forall a b. (a -> b) -> a -> b
$ Map VName TermBinding -> [VName]
forall k a. Map k a -> [k]
M.keys (Map VName TermBinding -> [VName])
-> Map VName TermBinding -> [VName]
forall a b. (a -> b) -> a -> b
$ Env -> Map VName TermBinding
envTerm Env
env
            , envVtable :: Map VName BoundV
T.envVtable = Map VName BoundV
vtable }

break :: EvalM ()
break :: EvalM ()
break = do
  -- We don't want the env of the function that is calling
  -- intrinsics.break, since that is just going to be the boring
  -- wrapper function (intrinsics are never called directly).
  -- This is why we go a step up the stack.
  [StackFrame]
backtrace <- (([StackFrame], Map String Env) -> [StackFrame])
-> EvalM [StackFrame]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((([StackFrame], Map String Env) -> [StackFrame])
 -> EvalM [StackFrame])
-> (([StackFrame], Map String Env) -> [StackFrame])
-> EvalM [StackFrame]
forall a b. (a -> b) -> a -> b
$ Int -> [StackFrame] -> [StackFrame]
forall a. Int -> [a] -> [a]
drop Int
1 ([StackFrame] -> [StackFrame])
-> (([StackFrame], Map String Env) -> [StackFrame])
-> ([StackFrame], Map String Env)
-> [StackFrame]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([StackFrame], Map String Env) -> [StackFrame]
forall a b. (a, b) -> a
fst
  case [StackFrame] -> Maybe (NonEmpty StackFrame)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [StackFrame]
backtrace of
    Maybe (NonEmpty StackFrame)
Nothing -> () -> EvalM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just NonEmpty StackFrame
backtrace' -> ExtOp () -> EvalM ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (ExtOp () -> EvalM ()) -> ExtOp () -> EvalM ()
forall a b. (a -> b) -> a -> b
$ BreakReason -> NonEmpty StackFrame -> () -> ExtOp ()
forall a. BreakReason -> NonEmpty StackFrame -> a -> ExtOp a
ExtOpBreak BreakReason
BreakPoint NonEmpty StackFrame
backtrace' ()

fromArray :: Value -> (ValueShape, [Value])
fromArray :: Value -> (ValueShape, [Value])
fromArray (ValueArray ValueShape
shape Array Int Value
as) = (ValueShape
shape, Array Int Value -> [Value]
forall i e. Array i e -> [e]
elems Array Int Value
as)
fromArray Value
v = String -> (ValueShape, [Value])
forall a. HasCallStack => String -> a
error (String -> (ValueShape, [Value]))
-> String -> (ValueShape, [Value])
forall a b. (a -> b) -> a -> b
$ String
"Expected array value, but found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
v

toArray :: ValueShape -> [Value] -> Value
toArray :: ValueShape -> [Value] -> Value
toArray ValueShape
shape [Value]
vs = ValueShape -> Array Int Value -> Value
ValueArray ValueShape
shape ((Int, Int) -> [Value] -> Array Int Value
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [Value] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
vs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Value]
vs)

toArray' :: ValueShape -> [Value] -> Value
toArray' :: ValueShape -> [Value] -> Value
toArray' ValueShape
rowshape [Value]
vs = ValueShape -> Array Int Value -> Value
ValueArray ValueShape
shape ((Int, Int) -> [Value] -> Array Int Value
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [Value] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
vs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Value]
vs)
  where shape :: ValueShape
shape = Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim ([Value] -> Int32
forall i a. Num i => [a] -> i
genericLength [Value]
vs) ValueShape
rowshape

apply :: SrcLoc -> Env -> Value -> Value -> EvalM Value
apply :: SrcLoc -> Env -> Value -> Value -> EvalM Value
apply SrcLoc
loc Env
env (ValueFun Value -> EvalM Value
f) Value
v = SrcLoc -> Env -> EvalM Value -> EvalM Value
forall a. SrcLoc -> Env -> EvalM a -> EvalM a
stacking SrcLoc
loc Env
env (Value -> EvalM Value
f Value
v)
apply SrcLoc
_ Env
_ Value
f Value
_ = String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Cannot apply non-function: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
f

apply2 :: SrcLoc -> Env -> Value -> Value -> Value -> EvalM Value
apply2 :: SrcLoc -> Env -> Value -> Value -> Value -> EvalM Value
apply2 SrcLoc
loc Env
env Value
f Value
x Value
y = SrcLoc -> Env -> EvalM Value -> EvalM Value
forall a. SrcLoc -> Env -> EvalM a -> EvalM a
stacking SrcLoc
loc Env
env (EvalM Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ do Value
f' <- SrcLoc -> Env -> Value -> Value -> EvalM Value
apply SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty Value
f Value
x
                                             SrcLoc -> Env -> Value -> Value -> EvalM Value
apply SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty Value
f' Value
y

matchPattern :: Env -> Pattern -> Value -> EvalM Env
matchPattern :: Env -> Pattern -> Value -> EvalM Env
matchPattern Env
env Pattern
p Value
v = do
  Maybe Env
m <- MaybeT EvalM Env -> EvalM (Maybe Env)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT EvalM Env -> EvalM (Maybe Env))
-> MaybeT EvalM Env -> EvalM (Maybe Env)
forall a b. (a -> b) -> a -> b
$ Env -> Pattern -> Value -> MaybeT EvalM Env
patternMatch Env
env Pattern
p Value
v
  case Maybe Env
m of
    Maybe Env
Nothing   -> String -> EvalM Env
forall a. HasCallStack => String -> a
error (String -> EvalM Env) -> String -> EvalM Env
forall a b. (a -> b) -> a -> b
$ String
"matchPattern: missing case for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Pretty a => a -> String
pretty Pattern
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
v
    Just Env
env' -> Env -> EvalM Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env'

patternMatch :: Env -> Pattern -> Value -> MaybeT EvalM Env
patternMatch :: Env -> Pattern -> Value -> MaybeT EvalM Env
patternMatch Env
env (Id VName
v (Info PatternType
t) SrcLoc
_) Value
val =
  EvalM Env -> MaybeT EvalM Env
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EvalM Env -> MaybeT EvalM Env) -> EvalM Env -> MaybeT EvalM Env
forall a b. (a -> b) -> a -> b
$ Env -> EvalM Env
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env -> EvalM Env) -> Env -> EvalM Env
forall a b. (a -> b) -> a -> b
$
  Map VName (Maybe BoundV, Value) -> Env
valEnv (VName -> (Maybe BoundV, Value) -> Map VName (Maybe BoundV, Value)
forall k a. k -> a -> Map k a
M.singleton VName
v (BoundV -> Maybe BoundV
forall a. a -> Maybe a
Just (BoundV -> Maybe BoundV) -> BoundV -> Maybe BoundV
forall a b. (a -> b) -> a -> b
$ [TypeParam] -> StructType -> BoundV
T.BoundV [] (StructType -> BoundV) -> StructType -> BoundV
forall a b. (a -> b) -> a -> b
$ PatternType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatternType
t, Value
val)) Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env
patternMatch Env
env Wildcard{} Value
_ =
  EvalM Env -> MaybeT EvalM Env
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EvalM Env -> MaybeT EvalM Env) -> EvalM Env -> MaybeT EvalM Env
forall a b. (a -> b) -> a -> b
$ Env -> EvalM Env
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
patternMatch Env
env (TuplePattern [Pattern]
ps SrcLoc
_) (ValueRecord Map Name Value
vs) =
  (Env -> (Pattern, Value) -> MaybeT EvalM Env)
-> Env -> [(Pattern, Value)] -> MaybeT EvalM Env
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Env
env' (Pattern
p,Value
v) -> Env -> Pattern -> Value -> MaybeT EvalM Env
patternMatch Env
env' Pattern
p Value
v) Env
env ([(Pattern, Value)] -> MaybeT EvalM Env)
-> [(Pattern, Value)] -> MaybeT EvalM Env
forall a b. (a -> b) -> a -> b
$
  [Pattern] -> [Value] -> [(Pattern, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pattern]
ps (((Name, Value) -> Value) -> [(Name, Value)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Value) -> Value
forall a b. (a, b) -> b
snd ([(Name, Value)] -> [Value]) -> [(Name, Value)] -> [Value]
forall a b. (a -> b) -> a -> b
$ Map Name Value -> [(Name, Value)]
forall a. Map Name a -> [(Name, a)]
sortFields Map Name Value
vs)
patternMatch Env
env (RecordPattern [(Name, Pattern)]
ps SrcLoc
_) (ValueRecord Map Name Value
vs) =
  (Env -> (Pattern, Value) -> MaybeT EvalM Env)
-> Env -> Map Name (Pattern, Value) -> MaybeT EvalM Env
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Env
env' (Pattern
p,Value
v) -> Env -> Pattern -> Value -> MaybeT EvalM Env
patternMatch Env
env' Pattern
p Value
v) Env
env (Map Name (Pattern, Value) -> MaybeT EvalM Env)
-> Map Name (Pattern, Value) -> MaybeT EvalM Env
forall a b. (a -> b) -> a -> b
$
  (Pattern -> Value -> (Pattern, Value))
-> Map Name Pattern -> Map Name Value -> Map Name (Pattern, Value)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith (,) ([(Name, Pattern)] -> Map Name Pattern
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, Pattern)]
ps) Map Name Value
vs
patternMatch Env
env (PatternParens Pattern
p SrcLoc
_) Value
v = Env -> Pattern -> Value -> MaybeT EvalM Env
patternMatch Env
env Pattern
p Value
v
patternMatch Env
env (PatternAscription Pattern
p TypeDeclBase Info VName
_ SrcLoc
_) Value
v =
  Env -> Pattern -> Value -> MaybeT EvalM Env
patternMatch Env
env Pattern
p Value
v
patternMatch Env
env (PatternLit ExpBase Info VName
e Info PatternType
_ SrcLoc
_) Value
v = do
  Value
v' <- EvalM Value -> MaybeT EvalM Value
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EvalM Value -> MaybeT EvalM Value)
-> EvalM Value -> MaybeT EvalM Value
forall a b. (a -> b) -> a -> b
$ Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e
  if Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
v'
    then Env -> MaybeT EvalM Env
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env
env
    else MaybeT EvalM Env
forall (m :: * -> *) a. MonadPlus m => m a
mzero
patternMatch Env
env (PatternConstr Name
n Info PatternType
_ [Pattern]
ps SrcLoc
_) (ValueSum ValueShape
_ Name
n' [Value]
vs)
  | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' =
      (Env -> (Pattern, Value) -> MaybeT EvalM Env)
-> Env -> [(Pattern, Value)] -> MaybeT EvalM Env
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Env
env' (Pattern
p,Value
v) -> Env -> Pattern -> Value -> MaybeT EvalM Env
patternMatch Env
env' Pattern
p Value
v) Env
env ([(Pattern, Value)] -> MaybeT EvalM Env)
-> [(Pattern, Value)] -> MaybeT EvalM Env
forall a b. (a -> b) -> a -> b
$ [Pattern] -> [Value] -> [(Pattern, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pattern]
ps [Value]
vs
patternMatch Env
_ Pattern
_ Value
_ = MaybeT EvalM Env
forall (m :: * -> *) a. MonadPlus m => m a
mzero

data Indexing = IndexingFix Int32
              | IndexingSlice (Maybe Int32) (Maybe Int32) (Maybe Int32)

instance Pretty Indexing where
  ppr :: Indexing -> Doc
ppr (IndexingFix Int32
i) = Int32 -> Doc
forall a. Pretty a => a -> Doc
ppr Int32
i
  ppr (IndexingSlice Maybe Int32
i Maybe Int32
j (Just Int32
s)) =
    Doc -> (Int32 -> Doc) -> Maybe Int32 -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty Int32 -> Doc
forall a. Pretty a => a -> Doc
ppr Maybe Int32
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> (Int32 -> Doc) -> Maybe Int32 -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty Int32 -> Doc
forall a. Pretty a => a -> Doc
ppr Maybe Int32
j Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Int32 -> Doc
forall a. Pretty a => a -> Doc
ppr Int32
s
  ppr (IndexingSlice Maybe Int32
i (Just Int32
j) Maybe Int32
s) =
    Doc -> (Int32 -> Doc) -> Maybe Int32 -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty Int32 -> Doc
forall a. Pretty a => a -> Doc
ppr Maybe Int32
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Int32 -> Doc
forall a. Pretty a => a -> Doc
ppr Int32
j Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> (Int32 -> Doc) -> Maybe Int32 -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty ((String -> Doc
text String
":" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>) (Doc -> Doc) -> (Int32 -> Doc) -> Int32 -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Doc
forall a. Pretty a => a -> Doc
ppr) Maybe Int32
s
  ppr (IndexingSlice Maybe Int32
i Maybe Int32
Nothing Maybe Int32
Nothing) =
    Doc -> (Int32 -> Doc) -> Maybe Int32 -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty Int32 -> Doc
forall a. Pretty a => a -> Doc
ppr Maybe Int32
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":"

indexesFor :: Maybe Int32 -> Maybe Int32 -> Maybe Int32
           -> Int32 -> Maybe [Int]
indexesFor :: Maybe Int32 -> Maybe Int32 -> Maybe Int32 -> Int32 -> Maybe [Int]
indexesFor Maybe Int32
start Maybe Int32
end Maybe Int32
stride Int32
n
  | (Int32
start', Int32
end', Int32
stride') <- (Int32, Int32, Int32)
slice,
    Int32
end' Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
start' Bool -> Bool -> Bool
|| Int32 -> Int32
forall p. (Eq p, Num p) => p -> p
signum' (Int32
end' Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
start') Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32 -> Int32
forall p. (Eq p, Num p) => p -> p
signum' Int32
stride',
    Int32
stride' Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int32
0,
    [Int32]
is <- [Int32
start', Int32
start'Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+Int32
stride' .. Int32
end'Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
-Int32 -> Int32
forall a. Num a => a -> a
signum Int32
stride'],
    (Int32 -> Bool) -> [Int32] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Int32 -> Bool
inBounds [Int32]
is =
      [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just ([Int] -> Maybe [Int]) -> [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ (Int32 -> Int) -> [Int32] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int32]
is
  | Bool
otherwise =
      Maybe [Int]
forall a. Maybe a
Nothing
  where inBounds :: Int32 -> Bool
inBounds Int32
i = Int32
i Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32
0 Bool -> Bool -> Bool
&& Int32
i Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
n

        slice :: (Int32, Int32, Int32)
slice =
          case (Maybe Int32
start, Maybe Int32
end, Maybe Int32
stride) of
            (Just Int32
start', Maybe Int32
_, Maybe Int32
_) ->
              let end' :: Int32
end' = Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
n Maybe Int32
end
              in (Int32
start', Int32
end', Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
1 Maybe Int32
stride)
            (Maybe Int32
Nothing, Just Int32
end', Maybe Int32
_) ->
              let start' :: Int32
start' = Int32
0
              in (Int32
start', Int32
end', Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
1 Maybe Int32
stride)
            (Maybe Int32
Nothing, Maybe Int32
Nothing, Just Int32
stride') ->
              (if Int32
stride' Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
0 then Int32
0 else Int32
nInt32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
-Int32
1,
               if Int32
stride' Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
0 then Int32
n else -Int32
1,
               Int32
stride')
            (Maybe Int32
Nothing, Maybe Int32
Nothing, Maybe Int32
Nothing) ->
              (Int32
0, Int32
n, Int32
1)

-- | 'signum', but with 0 as 1.
signum' :: (Eq p, Num p) => p -> p
signum' :: p -> p
signum' p
0 = p
1
signum' p
x = p -> p
forall a. Num a => a -> a
signum p
x

indexShape :: [Indexing] -> ValueShape -> ValueShape
indexShape :: [Indexing] -> ValueShape -> ValueShape
indexShape (IndexingFix{}:[Indexing]
is) (ShapeDim Int32
_ ValueShape
shape) =
  [Indexing] -> ValueShape -> ValueShape
indexShape [Indexing]
is ValueShape
shape
indexShape (IndexingSlice Maybe Int32
start Maybe Int32
end Maybe Int32
stride:[Indexing]
is) (ShapeDim Int32
d ValueShape
shape) =
  Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int32
n (ValueShape -> ValueShape) -> ValueShape -> ValueShape
forall a b. (a -> b) -> a -> b
$ [Indexing] -> ValueShape -> ValueShape
indexShape [Indexing]
is ValueShape
shape
  where n :: Int32
n = Int32 -> ([Int] -> Int32) -> Maybe [Int] -> Int32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int32
0 [Int] -> Int32
forall i a. Num i => [a] -> i
genericLength (Maybe [Int] -> Int32) -> Maybe [Int] -> Int32
forall a b. (a -> b) -> a -> b
$ Maybe Int32 -> Maybe Int32 -> Maybe Int32 -> Int32 -> Maybe [Int]
indexesFor Maybe Int32
start Maybe Int32
end Maybe Int32
stride Int32
d
indexShape [Indexing]
_ ValueShape
shape =
  ValueShape
shape

indexArray :: [Indexing] -> Value -> Maybe Value
indexArray :: [Indexing] -> Value -> Maybe Value
indexArray (IndexingFix Int32
i:[Indexing]
is) (ValueArray ValueShape
_ Array Int Value
arr)
  | Int32
i Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32
0, Int32
i Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
n =
      [Indexing] -> Value -> Maybe Value
indexArray [Indexing]
is (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Array Int Value
arr Array Int Value -> Int -> Value
forall i e. Ix i => Array i e -> i -> e
! Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i
  | Bool
otherwise =
      Maybe Value
forall a. Maybe a
Nothing
  where n :: Int32
n = Array Int Value -> Int32
forall int. Integral int => Array Int Value -> int
arrayLength Array Int Value
arr
indexArray (IndexingSlice Maybe Int32
start Maybe Int32
end Maybe Int32
stride:[Indexing]
is) (ValueArray (ShapeDim Int32
_ ValueShape
rowshape) Array Int Value
arr) = do
  [Int]
js <- Maybe Int32 -> Maybe Int32 -> Maybe Int32 -> Int32 -> Maybe [Int]
indexesFor Maybe Int32
start Maybe Int32
end Maybe Int32
stride (Int32 -> Maybe [Int]) -> Int32 -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ Array Int Value -> Int32
forall int. Integral int => Array Int Value -> int
arrayLength Array Int Value
arr
  ValueShape -> [Value] -> Value
toArray' ([Indexing] -> ValueShape -> ValueShape
indexShape [Indexing]
is ValueShape
rowshape) ([Value] -> Value) -> Maybe [Value] -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Maybe Value) -> [Int] -> Maybe [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Indexing] -> Value -> Maybe Value
indexArray [Indexing]
is (Value -> Maybe Value) -> (Int -> Value) -> Int -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Array Int Value
arrArray Int Value -> Int -> Value
forall i e. Ix i => Array i e -> i -> e
!)) [Int]
js
indexArray [Indexing]
_ Value
v = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v

updateArray :: [Indexing] -> Value -> Value -> Maybe Value
updateArray :: [Indexing] -> Value -> Value -> Maybe Value
updateArray (IndexingFix Int32
i:[Indexing]
is) (ValueArray ValueShape
shape Array Int Value
arr) Value
v
  | Int32
i Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32
0, Int32
i Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
n = do
      Value
v' <- [Indexing] -> Value -> Value -> Maybe Value
updateArray [Indexing]
is (Array Int Value
arr Array Int Value -> Int -> Value
forall i e. Ix i => Array i e -> i -> e
! Int
i') Value
v
      Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ValueShape -> Array Int Value -> Value
ValueArray ValueShape
shape (Array Int Value -> Value) -> Array Int Value -> Value
forall a b. (a -> b) -> a -> b
$ Array Int Value
arr Array Int Value -> [(Int, Value)] -> Array Int Value
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [(Int
i', Value
v')]
  | Bool
otherwise =
      Maybe Value
forall a. Maybe a
Nothing
  where n :: Int32
n = Array Int Value -> Int32
forall int. Integral int => Array Int Value -> int
arrayLength Array Int Value
arr
        i' :: Int
i' = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i
updateArray (IndexingSlice Maybe Int32
start Maybe Int32
end Maybe Int32
stride:[Indexing]
is) (ValueArray ValueShape
shape Array Int Value
arr) (ValueArray ValueShape
_ Array Int Value
v) = do
  [Int]
arr_is <- Maybe Int32 -> Maybe Int32 -> Maybe Int32 -> Int32 -> Maybe [Int]
indexesFor Maybe Int32
start Maybe Int32
end Maybe Int32
stride (Int32 -> Maybe [Int]) -> Int32 -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ Array Int Value -> Int32
forall int. Integral int => Array Int Value -> int
arrayLength Array Int Value
arr
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
arr_is Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Array Int Value -> Int
forall int. Integral int => Array Int Value -> int
arrayLength Array Int Value
v
  let update :: Array Int Value -> (Int, Value) -> Maybe (Array Int Value)
update Array Int Value
arr' (Int
i, Value
v') = do
        Value
x <- [Indexing] -> Value -> Value -> Maybe Value
updateArray [Indexing]
is (Array Int Value
arrArray Int Value -> Int -> Value
forall i e. Ix i => Array i e -> i -> e
!Int
i) Value
v'
        Array Int Value -> Maybe (Array Int Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Array Int Value -> Maybe (Array Int Value))
-> Array Int Value -> Maybe (Array Int Value)
forall a b. (a -> b) -> a -> b
$ Array Int Value
arr' Array Int Value -> [(Int, Value)] -> Array Int Value
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [(Int
i, Value
x)]
  (Array Int Value -> Value)
-> Maybe (Array Int Value) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValueShape -> Array Int Value -> Value
ValueArray ValueShape
shape) (Maybe (Array Int Value) -> Maybe Value)
-> Maybe (Array Int Value) -> Maybe Value
forall a b. (a -> b) -> a -> b
$ (Array Int Value -> (Int, Value) -> Maybe (Array Int Value))
-> Array Int Value -> [(Int, Value)] -> Maybe (Array Int Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Array Int Value -> (Int, Value) -> Maybe (Array Int Value)
update Array Int Value
arr ([(Int, Value)] -> Maybe (Array Int Value))
-> [(Int, Value)] -> Maybe (Array Int Value)
forall a b. (a -> b) -> a -> b
$ [Int] -> [Value] -> [(Int, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
arr_is ([Value] -> [(Int, Value)]) -> [Value] -> [(Int, Value)]
forall a b. (a -> b) -> a -> b
$ Array Int Value -> [Value]
forall i e. Array i e -> [e]
elems Array Int Value
v
updateArray [Indexing]
_ Value
_ Value
v = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v

evalDimIndex :: Env -> DimIndex -> EvalM Indexing
evalDimIndex :: Env -> DimIndex -> EvalM Indexing
evalDimIndex Env
env (DimFix ExpBase Info VName
x) =
  Int32 -> Indexing
IndexingFix (Int32 -> Indexing) -> (Value -> Int32) -> Value -> Indexing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Int32
asInt32 (Value -> Indexing) -> EvalM Value -> EvalM Indexing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
x
evalDimIndex Env
env (DimSlice Maybe (ExpBase Info VName)
start Maybe (ExpBase Info VName)
end Maybe (ExpBase Info VName)
stride) =
  Maybe Int32 -> Maybe Int32 -> Maybe Int32 -> Indexing
IndexingSlice (Maybe Int32 -> Maybe Int32 -> Maybe Int32 -> Indexing)
-> EvalM (Maybe Int32)
-> EvalM (Maybe Int32 -> Maybe Int32 -> Indexing)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpBase Info VName -> EvalM Int32)
-> Maybe (ExpBase Info VName) -> EvalM (Maybe Int32)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Int32) -> EvalM Value -> EvalM Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Int32
asInt32 (EvalM Value -> EvalM Int32)
-> (ExpBase Info VName -> EvalM Value)
-> ExpBase Info VName
-> EvalM Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ExpBase Info VName -> EvalM Value
eval Env
env) Maybe (ExpBase Info VName)
start
                EvalM (Maybe Int32 -> Maybe Int32 -> Indexing)
-> EvalM (Maybe Int32) -> EvalM (Maybe Int32 -> Indexing)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ExpBase Info VName -> EvalM Int32)
-> Maybe (ExpBase Info VName) -> EvalM (Maybe Int32)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Int32) -> EvalM Value -> EvalM Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Int32
asInt32 (EvalM Value -> EvalM Int32)
-> (ExpBase Info VName -> EvalM Value)
-> ExpBase Info VName
-> EvalM Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ExpBase Info VName -> EvalM Value
eval Env
env) Maybe (ExpBase Info VName)
end
                EvalM (Maybe Int32 -> Indexing)
-> EvalM (Maybe Int32) -> EvalM Indexing
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ExpBase Info VName -> EvalM Int32)
-> Maybe (ExpBase Info VName) -> EvalM (Maybe Int32)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Int32) -> EvalM Value -> EvalM Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Int32
asInt32 (EvalM Value -> EvalM Int32)
-> (ExpBase Info VName -> EvalM Value)
-> ExpBase Info VName
-> EvalM Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ExpBase Info VName -> EvalM Value
eval Env
env) Maybe (ExpBase Info VName)
stride

evalIndex :: SrcLoc -> Env -> [Indexing] -> Value -> EvalM Value
evalIndex :: SrcLoc -> Env -> [Indexing] -> Value -> EvalM Value
evalIndex SrcLoc
loc Env
env [Indexing]
is Value
arr = do
  let oob :: EvalM a
oob = SrcLoc -> Env -> String -> EvalM a
forall a. SrcLoc -> Env -> String -> EvalM a
bad SrcLoc
loc Env
env (String -> EvalM a) -> String -> EvalM a
forall a b. (a -> b) -> a -> b
$ String
"Index [" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Indexing -> String) -> [Indexing] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Indexing -> String
forall a. Pretty a => a -> String
pretty [Indexing]
is) String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
            String
"] out of bounds for array of shape " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
            ValueShape -> String
forall a. Pretty a => a -> String
pretty (Value -> ValueShape
valueShape Value
arr) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."
  EvalM Value -> (Value -> EvalM Value) -> Maybe Value -> EvalM Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EvalM Value
forall a. EvalM a
oob Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Value -> EvalM Value) -> Maybe Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ [Indexing] -> Value -> Maybe Value
indexArray [Indexing]
is Value
arr

-- | Expand type based on information that was not available at
-- type-checking time (the structure of abstract types).
evalType :: Env -> StructType -> StructType
evalType :: Env -> StructType -> StructType
evalType Env
_ (Scalar (Prim PrimType
pt)) = ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase (DimDecl VName) ()
forall dim as. PrimType -> ScalarTypeBase dim as
Prim PrimType
pt
evalType Env
env (Scalar (Record Map Name StructType
fs)) = ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ Map Name StructType -> ScalarTypeBase (DimDecl VName) ()
forall dim as. Map Name (TypeBase dim as) -> ScalarTypeBase dim as
Record (Map Name StructType -> ScalarTypeBase (DimDecl VName) ())
-> Map Name StructType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ (StructType -> StructType)
-> Map Name StructType -> Map Name StructType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Env -> StructType -> StructType
evalType Env
env) Map Name StructType
fs
evalType Env
env (Scalar (Arrow () PName
p StructType
t1 StructType
t2)) =
  ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ ()
-> PName
-> StructType
-> StructType
-> ScalarTypeBase (DimDecl VName) ()
forall dim as.
as
-> PName
-> TypeBase dim as
-> TypeBase dim as
-> ScalarTypeBase dim as
Arrow () PName
p (Env -> StructType -> StructType
evalType Env
env StructType
t1) (Env -> StructType -> StructType
evalType Env
env StructType
t2)
evalType Env
env t :: StructType
t@(Array ()
_ Uniqueness
u ScalarTypeBase (DimDecl VName) ()
_ ShapeDecl (DimDecl VName)
shape) =
  let et :: StructType
et = Int -> StructType -> StructType
forall dim as. Int -> TypeBase dim as -> TypeBase dim as
stripArray (ShapeDecl (DimDecl VName) -> Int
forall dim. ShapeDecl dim -> Int
shapeRank ShapeDecl (DimDecl VName)
shape) StructType
t
      et' :: StructType
et' = Env -> StructType -> StructType
evalType Env
env StructType
et
      shape' :: ShapeDecl (DimDecl VName)
shape' = (DimDecl VName -> DimDecl VName)
-> ShapeDecl (DimDecl VName) -> ShapeDecl (DimDecl VName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DimDecl VName -> DimDecl VName
evalDim ShapeDecl (DimDecl VName)
shape
  in StructType -> ShapeDecl (DimDecl VName) -> Uniqueness -> StructType
forall as dim.
Monoid as =>
TypeBase dim as -> ShapeDecl dim -> Uniqueness -> TypeBase dim as
arrayOf StructType
et' ShapeDecl (DimDecl VName)
shape' Uniqueness
u
  where evalDim :: DimDecl VName -> DimDecl VName
evalDim (NamedDim QualName VName
qn)
          | Just (TermValue Maybe BoundV
_ (ValuePrim (SignedValue (Int32Value Int32
x)))) <-
              QualName VName -> Env -> Maybe TermBinding
lookupVar QualName VName
qn Env
env =
              Int -> DimDecl VName
forall vn. Int -> DimDecl vn
ConstDim (Int -> DimDecl VName) -> Int -> DimDecl VName
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
x
        evalDim DimDecl VName
d = DimDecl VName
d
evalType Env
env t :: StructType
t@(Scalar (TypeVar () Uniqueness
_ TypeName
tn [TypeArg (DimDecl VName)]
args)) =
  case QualName VName -> Env -> Maybe TypeBinding
lookupType (TypeName -> QualName VName
qualNameFromTypeName TypeName
tn) Env
env of
    Just (T.TypeAbbr Liftedness
_ [TypeParam]
ps StructType
t') ->
      let (Map VName (DimDecl VName)
substs, Map VName TypeBinding
types) = [(Map VName (DimDecl VName), Map VName TypeBinding)]
-> (Map VName (DimDecl VName), Map VName TypeBinding)
forall a. Monoid a => [a] -> a
mconcat ([(Map VName (DimDecl VName), Map VName TypeBinding)]
 -> (Map VName (DimDecl VName), Map VName TypeBinding))
-> [(Map VName (DimDecl VName), Map VName TypeBinding)]
-> (Map VName (DimDecl VName), Map VName TypeBinding)
forall a b. (a -> b) -> a -> b
$ (TypeParam
 -> TypeArg (DimDecl VName)
 -> (Map VName (DimDecl VName), Map VName TypeBinding))
-> [TypeParam]
-> [TypeArg (DimDecl VName)]
-> [(Map VName (DimDecl VName), Map VName TypeBinding)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TypeParam
-> TypeArg (DimDecl VName)
-> (Map VName (DimDecl VName), Map VName TypeBinding)
forall k.
Ord k =>
TypeParamBase k
-> TypeArg (DimDecl VName)
-> (Map k (DimDecl VName), Map k TypeBinding)
matchPtoA [TypeParam]
ps [TypeArg (DimDecl VName)]
args
          onDim :: DimDecl VName -> DimDecl VName
onDim (NamedDim QualName VName
v) = DimDecl VName -> Maybe (DimDecl VName) -> DimDecl VName
forall a. a -> Maybe a -> a
fromMaybe (QualName VName -> DimDecl VName
forall vn. QualName vn -> DimDecl vn
NamedDim QualName VName
v) (Maybe (DimDecl VName) -> DimDecl VName)
-> Maybe (DimDecl VName) -> DimDecl VName
forall a b. (a -> b) -> a -> b
$ VName -> Map VName (DimDecl VName) -> Maybe (DimDecl VName)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
v) Map VName (DimDecl VName)
substs
          onDim DimDecl VName
d = DimDecl VName
d
      in if [TypeParam] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParam]
ps then (DimDecl VName -> DimDecl VName) -> StructType -> StructType
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DimDecl VName -> DimDecl VName
onDim StructType
t'
         else Env -> StructType -> StructType
evalType (Map VName TermBinding
-> Map VName TypeBinding -> Map VName ValueShape -> Env
Env Map VName TermBinding
forall a. Monoid a => a
mempty Map VName TypeBinding
types Map VName ValueShape
forall a. Monoid a => a
mempty Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env) (StructType -> StructType) -> StructType -> StructType
forall a b. (a -> b) -> a -> b
$ (DimDecl VName -> DimDecl VName) -> StructType -> StructType
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DimDecl VName -> DimDecl VName
onDim StructType
t'
    Maybe TypeBinding
Nothing -> StructType
t

  where matchPtoA :: TypeParamBase k
-> TypeArg (DimDecl VName)
-> (Map k (DimDecl VName), Map k TypeBinding)
matchPtoA (TypeParamDim k
p SrcLoc
_) (TypeArgDim (NamedDim QualName VName
qv) SrcLoc
_) =
          (k -> DimDecl VName -> Map k (DimDecl VName)
forall k a. k -> a -> Map k a
M.singleton k
p (DimDecl VName -> Map k (DimDecl VName))
-> DimDecl VName -> Map k (DimDecl VName)
forall a b. (a -> b) -> a -> b
$ QualName VName -> DimDecl VName
forall vn. QualName vn -> DimDecl vn
NamedDim QualName VName
qv, Map k TypeBinding
forall a. Monoid a => a
mempty)
        matchPtoA (TypeParamDim k
p SrcLoc
_) (TypeArgDim (ConstDim Int
k) SrcLoc
_) =
          (k -> DimDecl VName -> Map k (DimDecl VName)
forall k a. k -> a -> Map k a
M.singleton k
p (DimDecl VName -> Map k (DimDecl VName))
-> DimDecl VName -> Map k (DimDecl VName)
forall a b. (a -> b) -> a -> b
$ Int -> DimDecl VName
forall vn. Int -> DimDecl vn
ConstDim Int
k, Map k TypeBinding
forall a. Monoid a => a
mempty)
        matchPtoA (TypeParamType Liftedness
l k
p SrcLoc
_) (TypeArgType StructType
t' SrcLoc
_) =
          let t'' :: StructType
t'' = Env -> StructType -> StructType
evalType Env
env StructType
t'
          in (Map k (DimDecl VName)
forall a. Monoid a => a
mempty, k -> TypeBinding -> Map k TypeBinding
forall k a. k -> a -> Map k a
M.singleton k
p (TypeBinding -> Map k TypeBinding)
-> TypeBinding -> Map k TypeBinding
forall a b. (a -> b) -> a -> b
$ Liftedness -> [TypeParam] -> StructType -> TypeBinding
T.TypeAbbr Liftedness
l [] StructType
t'')
        matchPtoA TypeParamBase k
_ TypeArg (DimDecl VName)
_ = (Map k (DimDecl VName), Map k TypeBinding)
forall a. Monoid a => a
mempty
evalType Env
env (Scalar (Sum Map Name [StructType]
cs)) = ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ Map Name [StructType] -> ScalarTypeBase (DimDecl VName) ()
forall dim as. Map Name [TypeBase dim as] -> ScalarTypeBase dim as
Sum (Map Name [StructType] -> ScalarTypeBase (DimDecl VName) ())
-> Map Name [StructType] -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ (([StructType] -> [StructType])
-> Map Name [StructType] -> Map Name [StructType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([StructType] -> [StructType])
 -> Map Name [StructType] -> Map Name [StructType])
-> ((StructType -> StructType) -> [StructType] -> [StructType])
-> (StructType -> StructType)
-> Map Name [StructType]
-> Map Name [StructType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StructType -> StructType) -> [StructType] -> [StructType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Env -> StructType -> StructType
evalType Env
env) Map Name [StructType]
cs

evalTermVar :: Env -> QualName VName -> StructType -> EvalM Value
evalTermVar :: Env -> QualName VName -> StructType -> EvalM Value
evalTermVar Env
env QualName VName
qv StructType
t =
  case QualName VName -> Env -> Maybe TermBinding
lookupVar QualName VName
qv Env
env of
    Just (TermPoly Maybe BoundV
_ StructType -> EvalM Value
v) -> do Env
size_env <- EvalM Env
extSizeEnv
                              StructType -> EvalM Value
v (StructType -> EvalM Value) -> StructType -> EvalM Value
forall a b. (a -> b) -> a -> b
$ Env -> StructType -> StructType
evalType (Env
size_env Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env) StructType
t
    Just (TermValue Maybe BoundV
_ Value
v) -> Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
    Maybe TermBinding
_ -> String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"`" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> QualName VName -> String
forall a. Pretty a => a -> String
pretty QualName VName
qv String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"` is not bound to a value."

typeValueShape :: Env -> StructType -> EvalM ValueShape
typeValueShape :: Env -> StructType -> EvalM ValueShape
typeValueShape Env
env StructType
t = do
  Env
size_env <- EvalM Env
extSizeEnv
  let t' :: StructType
t' = Env -> StructType -> StructType
evalType (Env
size_env Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env) StructType
t
  case (DimDecl VName -> Maybe Int32)
-> Shape (DimDecl VName) -> Maybe ValueShape
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DimDecl VName -> Maybe Int32
forall a vn. Num a => DimDecl vn -> Maybe a
dim (Shape (DimDecl VName) -> Maybe ValueShape)
-> Shape (DimDecl VName) -> Maybe ValueShape
forall a b. (a -> b) -> a -> b
$ Map VName (Shape (DimDecl VName))
-> StructType -> Shape (DimDecl VName)
forall d. Map VName (Shape d) -> TypeBase d () -> Shape d
typeShape Map VName (Shape (DimDecl VName))
forall a. Monoid a => a
mempty StructType
t' of
    Maybe ValueShape
Nothing -> String -> EvalM ValueShape
forall a. HasCallStack => String -> a
error (String -> EvalM ValueShape) -> String -> EvalM ValueShape
forall a b. (a -> b) -> a -> b
$ String
"typeValueShape: failed to fully evaluate type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ StructType -> String
forall a. Pretty a => a -> String
pretty StructType
t'
    Just ValueShape
shape -> ValueShape -> EvalM ValueShape
forall (m :: * -> *) a. Monad m => a -> m a
return ValueShape
shape
  where dim :: DimDecl vn -> Maybe a
dim (ConstDim Int
x) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
        dim DimDecl vn
_ = Maybe a
forall a. Maybe a
Nothing

evalFunction :: Env -> [VName] -> [Pattern] -> Exp -> StructType -> EvalM Value

-- We treat zero-parameter lambdas as simply an expression to
-- evaluate immediately.  Note that this is *not* the same as a lambda
-- that takes an empty tuple '()' as argument!  Zero-parameter lambdas
-- can never occur in a well-formed Futhark program, but they are
-- convenient in the interpreter.
evalFunction :: Env
-> [VName]
-> [Pattern]
-> ExpBase Info VName
-> StructType
-> EvalM Value
evalFunction Env
env [VName]
_ [] ExpBase Info VName
body StructType
rettype =
  -- Eta-expand the rest to make any sizes visible.
  [Value] -> Env -> StructType -> EvalM Value
forall as.
[Value] -> Env -> TypeBase (DimDecl VName) as -> EvalM Value
etaExpand [] Env
env StructType
rettype
  where etaExpand :: [Value] -> Env -> TypeBase (DimDecl VName) as -> EvalM Value
etaExpand [Value]
vs Env
env' (Scalar (Arrow as
_ PName
_ TypeBase (DimDecl VName) as
pt TypeBase (DimDecl VName) as
rt)) =
          Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> Value
ValueFun ((Value -> EvalM Value) -> Value)
-> (Value -> EvalM Value) -> Value
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
          Env
env'' <- Env -> Pattern -> Value -> EvalM Env
matchPattern Env
env' (Info PatternType -> SrcLoc -> Pattern
forall (f :: * -> *) vn.
f PatternType -> SrcLoc -> PatternBase f vn
Wildcard (PatternType -> Info PatternType
forall a. a -> Info a
Info (PatternType -> Info PatternType)
-> PatternType -> Info PatternType
forall a b. (a -> b) -> a -> b
$ TypeBase (DimDecl VName) as -> PatternType
forall dim as. TypeBase dim as -> TypeBase dim Aliasing
fromStruct TypeBase (DimDecl VName) as
pt) SrcLoc
forall a. IsLocation a => a
noLoc) Value
v
          [Value] -> Env -> TypeBase (DimDecl VName) as -> EvalM Value
etaExpand (Value
vValue -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:[Value]
vs) Env
env'' TypeBase (DimDecl VName) as
rt
        etaExpand [Value]
vs Env
env' TypeBase (DimDecl VName) as
_ = do
          Value
f <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env' ExpBase Info VName
body
          (Value -> Value -> EvalM Value) -> Value -> [Value] -> EvalM Value
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (SrcLoc -> Env -> Value -> Value -> EvalM Value
apply SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty) Value
f ([Value] -> EvalM Value) -> [Value] -> EvalM Value
forall a b. (a -> b) -> a -> b
$ [Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
vs

evalFunction Env
env [VName]
missing_sizes (Pattern
p:[Pattern]
ps) ExpBase Info VName
body StructType
rettype =
  Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> Value
ValueFun ((Value -> EvalM Value) -> Value)
-> (Value -> EvalM Value) -> Value
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
    Env
env' <- Env -> Pattern -> Value -> EvalM Env
matchPattern Env
env Pattern
p Value
v
    -- Fix up the last sizes, if any.
    let env'' :: Env
env'' | [VName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VName]
missing_sizes = Env
env'
              | Bool
otherwise = Env
env' Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<>
                            Sizes -> Env
i32Env ([VName] -> StructType -> ValueShape -> Sizes
resolveExistentials [VName]
missing_sizes
                                    (Pattern -> StructType
patternStructType Pattern
p) (Value -> ValueShape
valueShape Value
v))
    Env
-> [VName]
-> [Pattern]
-> ExpBase Info VName
-> StructType
-> EvalM Value
evalFunction Env
env'' [VName]
missing_sizes [Pattern]
ps ExpBase Info VName
body StructType
rettype

evalFunctionBinding :: Env
                    -> [TypeParam] -> [Pattern] -> StructType -> [VName] -> Exp
                    -> EvalM TermBinding
evalFunctionBinding :: Env
-> [TypeParam]
-> [Pattern]
-> StructType
-> [VName]
-> ExpBase Info VName
-> EvalM TermBinding
evalFunctionBinding Env
env [TypeParam]
tparams [Pattern]
ps StructType
ret [VName]
retext ExpBase Info VName
fbody = do
  let ret' :: StructType
ret' = Env -> StructType -> StructType
evalType Env
env StructType
ret
      arrow :: (PName, TypeBase dim ()) -> TypeBase dim () -> TypeBase dim ()
arrow (PName
xp, TypeBase dim ()
xt) TypeBase dim ()
yt = ScalarTypeBase dim () -> TypeBase dim ()
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase dim () -> TypeBase dim ())
-> ScalarTypeBase dim () -> TypeBase dim ()
forall a b. (a -> b) -> a -> b
$ ()
-> PName
-> TypeBase dim ()
-> TypeBase dim ()
-> ScalarTypeBase dim ()
forall dim as.
as
-> PName
-> TypeBase dim as
-> TypeBase dim as
-> ScalarTypeBase dim as
Arrow () PName
xp TypeBase dim ()
xt TypeBase dim ()
yt
      ftype :: StructType
ftype = (Pattern -> StructType -> StructType)
-> StructType -> [Pattern] -> StructType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((PName, StructType) -> StructType -> StructType
forall dim.
(PName, TypeBase dim ()) -> TypeBase dim () -> TypeBase dim ()
arrow ((PName, StructType) -> StructType -> StructType)
-> (Pattern -> (PName, StructType))
-> Pattern
-> StructType
-> StructType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> (PName, StructType)
patternParam) StructType
ret' [Pattern]
ps

  -- Distinguish polymorphic and non-polymorphic bindings here.
  if [TypeParam] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParam]
tparams
  then Maybe BoundV -> Value -> TermBinding
TermValue (BoundV -> Maybe BoundV
forall a. a -> Maybe a
Just (BoundV -> Maybe BoundV) -> BoundV -> Maybe BoundV
forall a b. (a -> b) -> a -> b
$ [TypeParam] -> StructType -> BoundV
T.BoundV [] StructType
ftype) (Value -> TermBinding) -> EvalM Value -> EvalM TermBinding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
       (Env -> StructType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env StructType
ret [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env
-> [VName]
-> [Pattern]
-> ExpBase Info VName
-> StructType
-> EvalM Value
evalFunction Env
env [] [Pattern]
ps ExpBase Info VName
fbody StructType
ret')
  else TermBinding -> EvalM TermBinding
forall (m :: * -> *) a. Monad m => a -> m a
return (TermBinding -> EvalM TermBinding)
-> TermBinding -> EvalM TermBinding
forall a b. (a -> b) -> a -> b
$ Maybe BoundV -> (StructType -> EvalM Value) -> TermBinding
TermPoly (BoundV -> Maybe BoundV
forall a. a -> Maybe a
Just (BoundV -> Maybe BoundV) -> BoundV -> Maybe BoundV
forall a b. (a -> b) -> a -> b
$ [TypeParam] -> StructType -> BoundV
T.BoundV [] StructType
ftype) ((StructType -> EvalM Value) -> TermBinding)
-> (StructType -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \StructType
ftype' -> do
         let tparam_names :: [VName]
tparam_names = (TypeParam -> VName) -> [TypeParam] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map TypeParam -> VName
forall vn. TypeParamBase vn -> vn
typeParamName [TypeParam]
tparams
             env' :: Env
env' = [VName] -> StructType -> StructType -> Env
resolveTypeParams [VName]
tparam_names StructType
ftype StructType
ftype' Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env

             -- In some cases (abstract lifted types) there may be
             -- missing sizes that were not fixed by the type
             -- instantiation.  These will have to be set by looking
             -- at the actual function arguments.
             missing_sizes :: [VName]
missing_sizes =
               (VName -> Bool) -> [VName] -> [VName]
forall a. (a -> Bool) -> [a] -> [a]
filter (VName -> Map VName TermBinding -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` Env -> Map VName TermBinding
envTerm Env
env') ([VName] -> [VName]) -> [VName] -> [VName]
forall a b. (a -> b) -> a -> b
$
               (TypeParam -> VName) -> [TypeParam] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map TypeParam -> VName
forall vn. TypeParamBase vn -> vn
typeParamName ((TypeParam -> Bool) -> [TypeParam] -> [TypeParam]
forall a. (a -> Bool) -> [a] -> [a]
filter TypeParam -> Bool
forall vn. TypeParamBase vn -> Bool
isSizeParam [TypeParam]
tparams)
         Env -> StructType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env StructType
ret [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env
-> [VName]
-> [Pattern]
-> ExpBase Info VName
-> StructType
-> EvalM Value
evalFunction Env
env' [VName]
missing_sizes [Pattern]
ps ExpBase Info VName
fbody StructType
ret'

evalArg :: Env -> Exp -> Maybe VName -> EvalM Value
evalArg :: Env -> ExpBase Info VName -> Maybe VName -> EvalM Value
evalArg Env
env ExpBase Info VName
e Maybe VName
ext = do
  Value
v <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e
  case Maybe VName
ext of Just VName
ext' -> VName -> Int32 -> EvalM ()
putExtSize VName
ext' (Int32 -> EvalM ()) -> Int32 -> EvalM ()
forall a b. (a -> b) -> a -> b
$ Value -> Int32
asInt32 Value
v
              Maybe VName
Nothing -> () -> EvalM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v

returned :: Env -> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned :: Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
_ TypeBase (DimDecl VName) als
_ [] Value
v = Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
returned Env
env TypeBase (DimDecl VName) als
ret [VName]
retext Value
v = do
  ((VName, Int32) -> EvalM ()) -> [(VName, Int32)] -> EvalM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((VName -> Int32 -> EvalM ()) -> (VName, Int32) -> EvalM ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry VName -> Int32 -> EvalM ()
putExtSize) ([(VName, Int32)] -> EvalM ()) -> [(VName, Int32)] -> EvalM ()
forall a b. (a -> b) -> a -> b
$ Sizes -> [(VName, Int32)]
forall k a. Map k a -> [(k, a)]
M.toList (Sizes -> [(VName, Int32)]) -> Sizes -> [(VName, Int32)]
forall a b. (a -> b) -> a -> b
$
    [VName] -> StructType -> ValueShape -> Sizes
resolveExistentials [VName]
retext (Env -> StructType -> StructType
evalType Env
env (StructType -> StructType) -> StructType -> StructType
forall a b. (a -> b) -> a -> b
$ TypeBase (DimDecl VName) als -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct TypeBase (DimDecl VName) als
ret) (ValueShape -> Sizes) -> ValueShape -> Sizes
forall a b. (a -> b) -> a -> b
$ Value -> ValueShape
valueShape Value
v
  Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v

eval :: Env -> Exp -> EvalM Value

eval :: Env -> ExpBase Info VName -> EvalM Value
eval Env
_ (Literal PrimValue
v SrcLoc
_) = Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ PrimValue -> Value
ValuePrim PrimValue
v

eval Env
env (Parens ExpBase Info VName
e SrcLoc
_ ) = Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e

eval Env
env (QualParens (QualName VName
qv, SrcLoc
_) ExpBase Info VName
e SrcLoc
loc) = do
  Module
m <- Env -> QualName VName -> EvalM Module
evalModuleVar Env
env QualName VName
qv
  case Module
m of
    ModuleFun{} -> String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Local open of module function at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
forall a. Located a => a -> String
locStr SrcLoc
loc
    Module Env
m' -> Env -> ExpBase Info VName -> EvalM Value
eval (Env
m'Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<>Env
env) ExpBase Info VName
e

eval Env
env (TupLit [ExpBase Info VName]
vs SrcLoc
_) = [Value] -> Value
toTuple ([Value] -> Value) -> EvalM [Value] -> EvalM Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpBase Info VName -> EvalM Value)
-> [ExpBase Info VName] -> EvalM [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> ExpBase Info VName -> EvalM Value
eval Env
env) [ExpBase Info VName]
vs

eval Env
env (RecordLit [FieldBase Info VName]
fields SrcLoc
_) =
  Map Name Value -> Value
ValueRecord (Map Name Value -> Value)
-> ([(Name, Value)] -> Map Name Value) -> [(Name, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, Value)] -> Map Name Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Value)] -> Value) -> EvalM [(Name, Value)] -> EvalM Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldBase Info VName -> EvalM (Name, Value))
-> [FieldBase Info VName] -> EvalM [(Name, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldBase Info VName -> EvalM (Name, Value)
evalField [FieldBase Info VName]
fields
  where evalField :: FieldBase Info VName -> EvalM (Name, Value)
evalField (RecordFieldExplicit Name
k ExpBase Info VName
e SrcLoc
_) = do
          Value
v <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e
          (Name, Value) -> EvalM (Name, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
k, Value
v)
        evalField (RecordFieldImplicit VName
k Info PatternType
t SrcLoc
loc) = do
          Value
v <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env (ExpBase Info VName -> EvalM Value)
-> ExpBase Info VName -> EvalM Value
forall a b. (a -> b) -> a -> b
$ QualName VName -> Info PatternType -> SrcLoc -> ExpBase Info VName
forall (f :: * -> *) vn.
QualName vn -> f PatternType -> SrcLoc -> ExpBase f vn
Var (VName -> QualName VName
forall v. v -> QualName v
qualName VName
k) Info PatternType
t SrcLoc
loc
          (Name, Value) -> EvalM (Name, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (VName -> Name
baseName VName
k, Value
v)

eval Env
_ (StringLit [Word8]
vs SrcLoc
_) =
  Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ ValueShape -> [Value] -> Value
toArray' ValueShape
forall d. Shape d
ShapeLeaf ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$
  (Word8 -> Value) -> [Word8] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (PrimValue -> Value
ValuePrim (PrimValue -> Value) -> (Word8 -> PrimValue) -> Word8 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue)
-> (Word8 -> IntValue) -> Word8 -> PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> IntValue
Int8Value (Int8 -> IntValue) -> (Word8 -> Int8) -> Word8 -> IntValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Word8]
vs

eval Env
env (ArrayLit [] (Info PatternType
t) SrcLoc
_) = do
  ValueShape
t' <- Env -> StructType -> EvalM ValueShape
typeValueShape Env
env (StructType -> EvalM ValueShape) -> StructType -> EvalM ValueShape
forall a b. (a -> b) -> a -> b
$ PatternType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatternType
t
  Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ ValueShape -> [Value] -> Value
toArray ValueShape
t' []

eval Env
env (ArrayLit (ExpBase Info VName
v:[ExpBase Info VName]
vs) Info PatternType
_ SrcLoc
_) = do
  Value
v' <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
v
  [Value]
vs' <- (ExpBase Info VName -> EvalM Value)
-> [ExpBase Info VName] -> EvalM [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> ExpBase Info VName -> EvalM Value
eval Env
env) [ExpBase Info VName]
vs
  Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ ValueShape -> [Value] -> Value
toArray' (Value -> ValueShape
valueShape Value
v') (Value
v'Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:[Value]
vs')

eval Env
env (Range ExpBase Info VName
start Maybe (ExpBase Info VName)
maybe_second Inclusiveness (ExpBase Info VName)
end (Info PatternType
t, Info [VName]
retext) SrcLoc
loc) = do
  Integer
start' <- Value -> Integer
asInteger (Value -> Integer) -> EvalM Value -> EvalM Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
start
  Maybe Integer
maybe_second' <- (ExpBase Info VName -> EvalM Integer)
-> Maybe (ExpBase Info VName) -> EvalM (Maybe Integer)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Integer) -> EvalM Value -> EvalM Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Integer
asInteger (EvalM Value -> EvalM Integer)
-> (ExpBase Info VName -> EvalM Value)
-> ExpBase Info VName
-> EvalM Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ExpBase Info VName -> EvalM Value
eval Env
env) Maybe (ExpBase Info VName)
maybe_second
  Inclusiveness Integer
end' <- (ExpBase Info VName -> EvalM Integer)
-> Inclusiveness (ExpBase Info VName)
-> EvalM (Inclusiveness Integer)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Integer) -> EvalM Value -> EvalM Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Integer
asInteger (EvalM Value -> EvalM Integer)
-> (ExpBase Info VName -> EvalM Value)
-> ExpBase Info VName
-> EvalM Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> ExpBase Info VName -> EvalM Value
eval Env
env) Inclusiveness (ExpBase Info VName)
end

  let (Integer
end_adj, Integer
step, Bool
ok) =
        case (Inclusiveness Integer
end', Maybe Integer
maybe_second') of
          (DownToExclusive Integer
end'', Maybe Integer
Nothing) ->
            (Integer
end'' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1, -Integer
1, Integer
start' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
end'')
          (DownToExclusive Integer
end'', Just Integer
second') ->
            (Integer
end'' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1, Integer
second' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start', Integer
start' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
end'' Bool -> Bool -> Bool
&& Integer
second' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
start')

          (ToInclusive Integer
end'', Maybe Integer
Nothing) ->
            (Integer
end'', Integer
1, Integer
start' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
end'')
          (ToInclusive Integer
end'', Just Integer
second')
            | Integer
second' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
start' ->
                (Integer
end'', Integer
second' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start', Integer
start' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
end'')
            | Bool
otherwise ->
                (Integer
end'', Integer
second' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start', Integer
start' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
end'' Bool -> Bool -> Bool
&& Integer
second' Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
start')

          (UpToExclusive Integer
x, Maybe Integer
Nothing) ->
            (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1, Integer
1, Integer
start' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
x)
          (UpToExclusive Integer
x, Just Integer
second') ->
            (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1, Integer
second' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start', Integer
start' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
x Bool -> Bool -> Bool
&& Integer
second' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
start')

  if Bool
ok
    then Env -> PatternType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env PatternType
t [VName]
retext (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$
         ValueShape -> [Value] -> Value
toArray' ValueShape
forall d. Shape d
ShapeLeaf ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (Integer -> Value) -> [Integer] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Value
toInt [Integer
start',Integer
start'Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
step..Integer
end_adj]
    else SrcLoc -> Env -> String -> EvalM Value
forall a. SrcLoc -> Env -> String -> EvalM a
bad SrcLoc
loc Env
env (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer -> Inclusiveness Integer -> String
forall a a a.
(Pretty a, Pretty a, Pretty a) =>
a -> Maybe a -> Inclusiveness a -> String
badRange Integer
start' Maybe Integer
maybe_second' Inclusiveness Integer
end'

  where toInt :: Integer -> Value
toInt =
          case Int -> PatternType -> PatternType
forall dim as. Int -> TypeBase dim as -> TypeBase dim as
stripArray Int
1 PatternType
t of
            Scalar (Prim (Signed IntType
t')) ->
              PrimValue -> Value
ValuePrim (PrimValue -> Value) -> (Integer -> PrimValue) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntValue -> PrimValue
SignedValue (IntValue -> PrimValue)
-> (Integer -> IntValue) -> Integer -> PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntType -> Integer -> IntValue
forall int. Integral int => IntType -> int -> IntValue
intValue IntType
t'
            Scalar (Prim (Unsigned IntType
t')) ->
              PrimValue -> Value
ValuePrim (PrimValue -> Value) -> (Integer -> PrimValue) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue)
-> (Integer -> IntValue) -> Integer -> PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntType -> Integer -> IntValue
forall int. Integral int => IntType -> int -> IntValue
intValue IntType
t'
            PatternType
_ -> String -> Integer -> Value
forall a. HasCallStack => String -> a
error (String -> Integer -> Value) -> String -> Integer -> Value
forall a b. (a -> b) -> a -> b
$ String
"Nonsensical range type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PatternType -> String
forall a. Show a => a -> String
show PatternType
t

        badRange :: a -> Maybe a -> Inclusiveness a -> String
badRange a
start' Maybe a
maybe_second' Inclusiveness a
end' =
          String
"Range " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
pretty a
start' String -> ShowS
forall a. [a] -> [a] -> [a]
++
          (case Maybe a
maybe_second' of
             Maybe a
Nothing -> String
""
             Just a
second' -> String
".." String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
pretty a
second') String -> ShowS
forall a. [a] -> [a] -> [a]
++
          (case Inclusiveness a
end' of
             DownToExclusive a
x -> String
"..>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
pretty a
x
             ToInclusive a
x -> String
"..." String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
pretty a
x
             UpToExclusive a
x -> String
"..<"String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
pretty a
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++
          String
" is invalid."

eval Env
env (Var QualName VName
qv (Info PatternType
t) SrcLoc
_) = Env -> QualName VName -> StructType -> EvalM Value
evalTermVar Env
env QualName VName
qv (PatternType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatternType
t)

eval Env
env (Ascript ExpBase Info VName
e TypeDeclBase Info VName
_ SrcLoc
_ ) = Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e

eval Env
env (Coerce ExpBase Info VName
e TypeDeclBase Info VName
td (Info PatternType
ret, Info [VName]
retext) SrcLoc
loc) = do
  Value
v <- Env -> PatternType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env PatternType
ret [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e
  let t :: StructType
t = Env -> StructType -> StructType
evalType Env
env (StructType -> StructType) -> StructType -> StructType
forall a b. (a -> b) -> a -> b
$ Info StructType -> StructType
forall a. Info a -> a
unInfo (Info StructType -> StructType) -> Info StructType -> StructType
forall a b. (a -> b) -> a -> b
$ TypeDeclBase Info VName -> Info StructType
forall (f :: * -> *) vn. TypeDeclBase f vn -> f StructType
expandedType TypeDeclBase Info VName
td
  case Shape (Maybe Int32) -> ValueShape -> Maybe ValueShape
checkShape (Map VName ValueShape -> StructType -> Shape (Maybe Int32)
structTypeShape (Env -> Map VName ValueShape
envShapes Env
env) StructType
t) (Value -> ValueShape
valueShape Value
v) of
    Just ValueShape
_ -> Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
    Maybe ValueShape
Nothing ->
      SrcLoc -> Env -> String -> EvalM Value
forall a. SrcLoc -> Env -> String -> EvalM a
bad SrcLoc
loc Env
env (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Value `" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Pretty a => a -> String
pretty Value
v String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"` of shape `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ValueShape -> String
forall a. Pretty a => a -> String
pretty (Value -> ValueShape
valueShape Value
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++
      String
"` cannot match shape of type `" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
      TypeExp VName -> String
forall a. Pretty a => a -> String
pretty (TypeDeclBase Info VName -> TypeExp VName
forall (f :: * -> *) vn. TypeDeclBase f vn -> TypeExp vn
declaredType TypeDeclBase Info VName
td) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"` (`" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> StructType -> String
forall a. Pretty a => a -> String
pretty StructType
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"`)"

eval Env
env (LetPat Pattern
p ExpBase Info VName
e ExpBase Info VName
body (Info PatternType
ret, Info [VName]
retext) SrcLoc
_) = do
  Value
v <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e
  Env
env' <- Env -> Pattern -> Value -> EvalM Env
matchPattern Env
env Pattern
p Value
v
  Env -> PatternType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env PatternType
ret [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> ExpBase Info VName -> EvalM Value
eval Env
env' ExpBase Info VName
body

eval Env
env (LetFun VName
f ([TypeParam]
tparams, [Pattern]
ps, Maybe (TypeExp VName)
_, Info StructType
ret, ExpBase Info VName
fbody) ExpBase Info VName
body Info PatternType
_ SrcLoc
_) = do
  TermBinding
binding <- Env
-> [TypeParam]
-> [Pattern]
-> StructType
-> [VName]
-> ExpBase Info VName
-> EvalM TermBinding
evalFunctionBinding Env
env [TypeParam]
tparams [Pattern]
ps StructType
ret [] ExpBase Info VName
fbody
  Env -> ExpBase Info VName -> EvalM Value
eval (Env
env { envTerm :: Map VName TermBinding
envTerm = VName
-> TermBinding -> Map VName TermBinding -> Map VName TermBinding
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
f TermBinding
binding (Map VName TermBinding -> Map VName TermBinding)
-> Map VName TermBinding -> Map VName TermBinding
forall a b. (a -> b) -> a -> b
$ Env -> Map VName TermBinding
envTerm Env
env }) ExpBase Info VName
body

eval Env
_ (IntLit Integer
v (Info PatternType
t) SrcLoc
_) =
  case PatternType
t of
    Scalar (Prim (Signed IntType
it)) ->
      Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ PrimValue -> Value
ValuePrim (PrimValue -> Value) -> PrimValue -> Value
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> Integer -> IntValue
forall int. Integral int => IntType -> int -> IntValue
intValue IntType
it Integer
v
    Scalar (Prim (Unsigned IntType
it)) ->
      Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ PrimValue -> Value
ValuePrim (PrimValue -> Value) -> PrimValue -> Value
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> Integer -> IntValue
forall int. Integral int => IntType -> int -> IntValue
intValue IntType
it Integer
v
    Scalar (Prim (FloatType FloatType
ft)) ->
      Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ PrimValue -> Value
ValuePrim (PrimValue -> Value) -> PrimValue -> Value
forall a b. (a -> b) -> a -> b
$ FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue) -> FloatValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ FloatType -> Integer -> FloatValue
forall num. Real num => FloatType -> num -> FloatValue
floatValue FloatType
ft Integer
v
    PatternType
_ -> String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"eval: nonsensical type for integer literal: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PatternType -> String
forall a. Pretty a => a -> String
pretty PatternType
t

eval Env
_ (FloatLit Double
v (Info PatternType
t) SrcLoc
_) =
  case PatternType
t of
    Scalar (Prim (FloatType FloatType
ft)) ->
      Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ PrimValue -> Value
ValuePrim (PrimValue -> Value) -> PrimValue -> Value
forall a b. (a -> b) -> a -> b
$ FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue) -> FloatValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ FloatType -> Double -> FloatValue
forall num. Real num => FloatType -> num -> FloatValue
floatValue FloatType
ft Double
v
    PatternType
_ -> String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"eval: nonsensical type for float literal: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PatternType -> String
forall a. Pretty a => a -> String
pretty PatternType
t

eval Env
env (BinOp (QualName VName
op, SrcLoc
_) Info PatternType
op_t
          (ExpBase Info VName
x, Info (StructType
_, Maybe VName
xext)) (ExpBase Info VName
y, Info (StructType
_, Maybe VName
yext))
          (Info PatternType
t) (Info [VName]
retext) SrcLoc
loc)
  | VName -> String
baseString (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
op) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"&&" = do
      Bool
x' <- Value -> Bool
asBool (Value -> Bool) -> EvalM Value -> EvalM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
x
      if Bool
x'
        then Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
y
        else Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ PrimValue -> Value
ValuePrim (PrimValue -> Value) -> PrimValue -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> PrimValue
BoolValue Bool
False
  | VName -> String
baseString (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
op) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"||" = do
      Bool
x' <- Value -> Bool
asBool (Value -> Bool) -> EvalM Value -> EvalM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
x
      if Bool
x'
        then Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ PrimValue -> Value
ValuePrim (PrimValue -> Value) -> PrimValue -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> PrimValue
BoolValue Bool
True
        else Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
y
  | Bool
otherwise = do
      Value
op' <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env (ExpBase Info VName -> EvalM Value)
-> ExpBase Info VName -> EvalM Value
forall a b. (a -> b) -> a -> b
$ QualName VName -> Info PatternType -> SrcLoc -> ExpBase Info VName
forall (f :: * -> *) vn.
QualName vn -> f PatternType -> SrcLoc -> ExpBase f vn
Var QualName VName
op Info PatternType
op_t SrcLoc
loc
      Value
x' <- Env -> ExpBase Info VName -> Maybe VName -> EvalM Value
evalArg Env
env ExpBase Info VName
x Maybe VName
xext
      Value
y' <- Env -> ExpBase Info VName -> Maybe VName -> EvalM Value
evalArg Env
env ExpBase Info VName
y Maybe VName
yext
      Env -> PatternType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env PatternType
t [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SrcLoc -> Env -> Value -> Value -> Value -> EvalM Value
apply2 SrcLoc
loc Env
env Value
op' Value
x' Value
y'

eval Env
env (If ExpBase Info VName
cond ExpBase Info VName
e1 ExpBase Info VName
e2 (Info PatternType
ret, Info [VName]
retext) SrcLoc
_) = do
  Bool
cond' <- Value -> Bool
asBool (Value -> Bool) -> EvalM Value -> EvalM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
cond
  Env -> PatternType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env PatternType
ret [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    if Bool
cond' then Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e1 else Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e2

eval Env
env (Apply ExpBase Info VName
f ExpBase Info VName
x (Info (Diet
_, Maybe VName
ext)) (Info PatternType
t, Info [VName]
retext) SrcLoc
loc) = do
  -- It is important that 'x' is evaluated first in order to bring any
  -- sizes into scope that may be used in the type of 'f'.
  Value
x' <- Env -> ExpBase Info VName -> Maybe VName -> EvalM Value
evalArg Env
env ExpBase Info VName
x Maybe VName
ext
  Value
f' <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
f
  Env -> PatternType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env PatternType
t [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SrcLoc -> Env -> Value -> Value -> EvalM Value
apply SrcLoc
loc Env
env Value
f' Value
x'

eval Env
env (Negate ExpBase Info VName
e SrcLoc
_) = do
  Value
ev <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e
  PrimValue -> Value
ValuePrim (PrimValue -> Value) -> EvalM PrimValue -> EvalM Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Value
ev of
    ValuePrim (SignedValue (Int8Value Int8
v)) -> PrimValue -> EvalM PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> EvalM PrimValue) -> PrimValue -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int8 -> IntValue
Int8Value (-Int8
v)
    ValuePrim (SignedValue (Int16Value Int16
v)) -> PrimValue -> EvalM PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> EvalM PrimValue) -> PrimValue -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int16 -> IntValue
Int16Value (-Int16
v)
    ValuePrim (SignedValue (Int32Value Int32
v)) -> PrimValue -> EvalM PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> EvalM PrimValue) -> PrimValue -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int32 -> IntValue
Int32Value (-Int32
v)
    ValuePrim (SignedValue (Int64Value Int64
v)) -> PrimValue -> EvalM PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> EvalM PrimValue) -> PrimValue -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int64 -> IntValue
Int64Value (-Int64
v)
    ValuePrim (UnsignedValue (Int8Value Int8
v)) -> PrimValue -> EvalM PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> EvalM PrimValue) -> PrimValue -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int8 -> IntValue
Int8Value (-Int8
v)
    ValuePrim (UnsignedValue (Int16Value Int16
v)) -> PrimValue -> EvalM PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> EvalM PrimValue) -> PrimValue -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int16 -> IntValue
Int16Value (-Int16
v)
    ValuePrim (UnsignedValue (Int32Value Int32
v)) -> PrimValue -> EvalM PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> EvalM PrimValue) -> PrimValue -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int32 -> IntValue
Int32Value (-Int32
v)
    ValuePrim (UnsignedValue (Int64Value Int64
v)) -> PrimValue -> EvalM PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> EvalM PrimValue) -> PrimValue -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int64 -> IntValue
Int64Value (-Int64
v)
    ValuePrim (FloatValue (Float32Value Float
v)) -> PrimValue -> EvalM PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> EvalM PrimValue) -> PrimValue -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue) -> FloatValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Float -> FloatValue
Float32Value (-Float
v)
    ValuePrim (FloatValue (Float64Value Double
v)) -> PrimValue -> EvalM PrimValue
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimValue -> EvalM PrimValue) -> PrimValue -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue) -> FloatValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Double -> FloatValue
Float64Value (-Double
v)
    Value
_ -> String -> EvalM PrimValue
forall a. HasCallStack => String -> a
error (String -> EvalM PrimValue) -> String -> EvalM PrimValue
forall a b. (a -> b) -> a -> b
$ String
"Cannot negate " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
ev

eval Env
env (Index ExpBase Info VName
e [DimIndex]
is (Info PatternType
t, Info [VName]
retext) SrcLoc
loc) = do
  [Indexing]
is' <- (DimIndex -> EvalM Indexing) -> [DimIndex] -> EvalM [Indexing]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> DimIndex -> EvalM Indexing
evalDimIndex Env
env) [DimIndex]
is
  Value
arr <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e
  Env -> PatternType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env PatternType
t [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SrcLoc -> Env -> [Indexing] -> Value -> EvalM Value
evalIndex SrcLoc
loc Env
env [Indexing]
is' Value
arr

eval Env
env (Update ExpBase Info VName
src [DimIndex]
is ExpBase Info VName
v SrcLoc
loc) =
  EvalM Value -> (Value -> EvalM Value) -> Maybe Value -> EvalM Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EvalM Value
forall a. EvalM a
oob Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Value -> EvalM Value) -> EvalM (Maybe Value) -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
  [Indexing] -> Value -> Value -> Maybe Value
updateArray ([Indexing] -> Value -> Value -> Maybe Value)
-> EvalM [Indexing] -> EvalM (Value -> Value -> Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DimIndex -> EvalM Indexing) -> [DimIndex] -> EvalM [Indexing]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> DimIndex -> EvalM Indexing
evalDimIndex Env
env) [DimIndex]
is EvalM (Value -> Value -> Maybe Value)
-> EvalM Value -> EvalM (Value -> Maybe Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
src EvalM (Value -> Maybe Value) -> EvalM Value -> EvalM (Maybe Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
v
  where oob :: EvalM a
oob = SrcLoc -> Env -> String -> EvalM a
forall a. SrcLoc -> Env -> String -> EvalM a
bad SrcLoc
loc Env
env String
"Bad update"

eval Env
env (RecordUpdate ExpBase Info VName
src [Name]
all_fs ExpBase Info VName
v Info PatternType
_ SrcLoc
_) =
  Value -> [Name] -> Value -> Value
update (Value -> [Name] -> Value -> Value)
-> EvalM Value -> EvalM ([Name] -> Value -> Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
src EvalM ([Name] -> Value -> Value)
-> EvalM [Name] -> EvalM (Value -> Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Name] -> EvalM [Name]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Name]
all_fs EvalM (Value -> Value) -> EvalM Value -> EvalM Value
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
v
  where update :: Value -> [Name] -> Value -> Value
update Value
_ [] Value
v' = Value
v'
        update (ValueRecord Map Name Value
src') (Name
f:[Name]
fs) Value
v'
          | Just Value
f_v <- Name -> Map Name Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
f Map Name Value
src' =
              Map Name Value -> Value
ValueRecord (Map Name Value -> Value) -> Map Name Value -> Value
forall a b. (a -> b) -> a -> b
$ Name -> Value -> Map Name Value -> Map Name Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
f (Value -> [Name] -> Value -> Value
update Value
f_v [Name]
fs Value
v') Map Name Value
src'
        update Value
_ [Name]
_ Value
_ = String -> Value
forall a. HasCallStack => String -> a
error String
"eval RecordUpdate: invalid value."

eval Env
env (LetWith IdentBase Info VName
dest IdentBase Info VName
src [DimIndex]
is ExpBase Info VName
v ExpBase Info VName
body Info PatternType
_ SrcLoc
loc) = do
  let Ident VName
src_vn (Info PatternType
src_t) SrcLoc
_ = IdentBase Info VName
src
  Value
dest' <- EvalM Value -> (Value -> EvalM Value) -> Maybe Value -> EvalM Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EvalM Value
forall a. EvalM a
oob Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Value -> EvalM Value) -> EvalM (Maybe Value) -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    [Indexing] -> Value -> Value -> Maybe Value
updateArray ([Indexing] -> Value -> Value -> Maybe Value)
-> EvalM [Indexing] -> EvalM (Value -> Value -> Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DimIndex -> EvalM Indexing) -> [DimIndex] -> EvalM [Indexing]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> DimIndex -> EvalM Indexing
evalDimIndex Env
env) [DimIndex]
is EvalM (Value -> Value -> Maybe Value)
-> EvalM Value -> EvalM (Value -> Maybe Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    Env -> QualName VName -> StructType -> EvalM Value
evalTermVar Env
env (VName -> QualName VName
forall v. v -> QualName v
qualName VName
src_vn) (PatternType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatternType
src_t) EvalM (Value -> Maybe Value) -> EvalM Value -> EvalM (Maybe Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
v
  let t :: BoundV
t = [TypeParam] -> StructType -> BoundV
T.BoundV [] (StructType -> BoundV) -> StructType -> BoundV
forall a b. (a -> b) -> a -> b
$ PatternType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct (PatternType -> StructType) -> PatternType -> StructType
forall a b. (a -> b) -> a -> b
$ Info PatternType -> PatternType
forall a. Info a -> a
unInfo (Info PatternType -> PatternType)
-> Info PatternType -> PatternType
forall a b. (a -> b) -> a -> b
$ IdentBase Info VName -> Info PatternType
forall (f :: * -> *) vn. IdentBase f vn -> f PatternType
identType IdentBase Info VName
dest
  Env -> ExpBase Info VName -> EvalM Value
eval (Map VName (Maybe BoundV, Value) -> Env
valEnv (VName -> (Maybe BoundV, Value) -> Map VName (Maybe BoundV, Value)
forall k a. k -> a -> Map k a
M.singleton (IdentBase Info VName -> VName
forall (f :: * -> *) vn. IdentBase f vn -> vn
identName IdentBase Info VName
dest) (BoundV -> Maybe BoundV
forall a. a -> Maybe a
Just BoundV
t, Value
dest')) Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env) ExpBase Info VName
body
  where oob :: EvalM a
oob = SrcLoc -> Env -> String -> EvalM a
forall a. SrcLoc -> Env -> String -> EvalM a
bad SrcLoc
loc Env
env String
"Bad update"

-- We treat zero-parameter lambdas as simply an expression to
-- evaluate immediately.  Note that this is *not* the same as a lambda
-- that takes an empty tuple '()' as argument!  Zero-parameter lambdas
-- can never occur in a well-formed Futhark program, but they are
-- convenient in the interpreter.
eval Env
env (Lambda [Pattern]
ps ExpBase Info VName
body Maybe (TypeExp VName)
_ (Info (Aliasing
_, StructType
rt)) SrcLoc
_) =
  Env
-> [VName]
-> [Pattern]
-> ExpBase Info VName
-> StructType
-> EvalM Value
evalFunction Env
env [] [Pattern]
ps ExpBase Info VName
body StructType
rt

eval Env
env (OpSection QualName VName
qv (Info PatternType
t) SrcLoc
_) = Env -> QualName VName -> StructType -> EvalM Value
evalTermVar Env
env QualName VName
qv (StructType -> EvalM Value) -> StructType -> EvalM Value
forall a b. (a -> b) -> a -> b
$ PatternType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatternType
t

eval Env
env (OpSectionLeft QualName VName
qv Info PatternType
_ ExpBase Info VName
e (Info (StructType
_, Maybe VName
argext), Info StructType
_) (Info PatternType
t, Info [VName]
retext) SrcLoc
loc) = do
  Value
v <- Env -> ExpBase Info VName -> Maybe VName -> EvalM Value
evalArg Env
env ExpBase Info VName
e Maybe VName
argext
  Value
f <- Env -> QualName VName -> StructType -> EvalM Value
evalTermVar Env
env QualName VName
qv (PatternType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatternType
t)
  Env -> PatternType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env PatternType
t [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SrcLoc -> Env -> Value -> Value -> EvalM Value
apply SrcLoc
loc Env
env Value
f Value
v

eval Env
env (OpSectionRight QualName VName
qv Info PatternType
_ ExpBase Info VName
e (Info StructType
_, Info (StructType
_, Maybe VName
argext)) (Info PatternType
t) SrcLoc
loc) = do
  Value
y <- Env -> ExpBase Info VName -> Maybe VName -> EvalM Value
evalArg Env
env ExpBase Info VName
e Maybe VName
argext
  Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> Value
ValueFun ((Value -> EvalM Value) -> Value)
-> (Value -> EvalM Value) -> Value
forall a b. (a -> b) -> a -> b
$ \Value
x -> do
    Value
f <- Env -> QualName VName -> StructType -> EvalM Value
evalTermVar Env
env QualName VName
qv (StructType -> EvalM Value) -> StructType -> EvalM Value
forall a b. (a -> b) -> a -> b
$ PatternType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatternType
t
    SrcLoc -> Env -> Value -> Value -> Value -> EvalM Value
apply2 SrcLoc
loc Env
env Value
f Value
x Value
y

eval Env
env (IndexSection [DimIndex]
is Info PatternType
_ SrcLoc
loc) = do
  [Indexing]
is' <- (DimIndex -> EvalM Indexing) -> [DimIndex] -> EvalM [Indexing]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> DimIndex -> EvalM Indexing
evalDimIndex Env
env) [DimIndex]
is
  Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> Value
ValueFun ((Value -> EvalM Value) -> Value)
-> (Value -> EvalM Value) -> Value
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Env -> [Indexing] -> Value -> EvalM Value
evalIndex SrcLoc
loc Env
env [Indexing]
is'

eval Env
_ (ProjectSection [Name]
ks Info PatternType
_ SrcLoc
_) =
  Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> Value
ValueFun ((Value -> EvalM Value) -> Value)
-> (Value -> EvalM Value) -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> [Name] -> EvalM Value) -> [Name] -> Value -> EvalM Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Value -> Name -> EvalM Value) -> Value -> [Name] -> EvalM Value
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Value -> Name -> EvalM Value
forall (m :: * -> *). Monad m => Value -> Name -> m Value
walk) [Name]
ks
  where walk :: Value -> Name -> m Value
walk (ValueRecord Map Name Value
fs) Name
f
          | Just Value
v' <- Name -> Map Name Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
f Map Name Value
fs = Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v'
        walk Value
_ Name
_ = String -> m Value
forall a. HasCallStack => String -> a
error String
"Value does not have expected field."

eval Env
env (DoLoop [VName]
sparams Pattern
pat ExpBase Info VName
init_e LoopFormBase Info VName
form ExpBase Info VName
body (Info (PatternType
ret, [VName]
retext)) SrcLoc
_) = do
  Value
init_v <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
init_e
  Env -> PatternType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env PatternType
ret [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    case LoopFormBase Info VName
form of For IdentBase Info VName
iv ExpBase Info VName
bound -> do
                   IntValue
bound' <- Value -> IntValue
asSigned (Value -> IntValue) -> EvalM Value -> EvalM IntValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
bound
                   VName -> IntValue -> IntValue -> Value -> EvalM Value
forLoop (IdentBase Info VName -> VName
forall (f :: * -> *) vn. IdentBase f vn -> vn
identName IdentBase Info VName
iv) IntValue
bound' (IntValue -> IntValue
zero IntValue
bound') Value
init_v
                 ForIn Pattern
in_pat ExpBase Info VName
in_e -> do
                   (ValueShape
_, [Value]
in_vs) <- Value -> (ValueShape, [Value])
fromArray (Value -> (ValueShape, [Value]))
-> EvalM Value -> EvalM (ValueShape, [Value])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
in_e
                   (Value -> Value -> EvalM Value) -> Value -> [Value] -> EvalM Value
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Pattern -> Value -> Value -> EvalM Value
forInLoop Pattern
in_pat) Value
init_v [Value]
in_vs
                 While ExpBase Info VName
cond ->
                   ExpBase Info VName -> Value -> EvalM Value
whileLoop ExpBase Info VName
cond Value
init_v
  where withLoopParams :: Value -> EvalM Env
withLoopParams Value
v =
          let sparams' :: Sizes
sparams' =
                [VName] -> StructType -> ValueShape -> Sizes
resolveExistentials [VName]
sparams
                (Pattern -> StructType
patternStructType Pattern
pat) (Value -> ValueShape
valueShape Value
v)
          in Env -> Pattern -> Value -> EvalM Env
matchPattern (Sizes -> Env
i32Env Sizes
sparams' Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env) Pattern
pat Value
v

        inc :: IntValue -> IntValue
inc = (IntValue -> IntValue -> IntValue
`P.doAdd` Int64 -> IntValue
Int64Value Int64
1)
        zero :: IntValue -> IntValue
zero = (IntValue -> IntValue -> IntValue
`P.doMul` Int64 -> IntValue
Int64Value Int64
0)

        forLoop :: VName -> IntValue -> IntValue -> Value -> EvalM Value
forLoop VName
iv IntValue
bound IntValue
i Value
v
          | IntValue
i IntValue -> IntValue -> Bool
forall a. Ord a => a -> a -> Bool
>= IntValue
bound = Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
          | Bool
otherwise = do
              Env
env' <- Value -> EvalM Env
withLoopParams Value
v
              VName -> IntValue -> IntValue -> Value -> EvalM Value
forLoop VName
iv IntValue
bound (IntValue -> IntValue
inc IntValue
i) (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                Env -> ExpBase Info VName -> EvalM Value
eval (Map VName (Maybe BoundV, Value) -> Env
valEnv (VName -> (Maybe BoundV, Value) -> Map VName (Maybe BoundV, Value)
forall k a. k -> a -> Map k a
M.singleton VName
iv (BoundV -> Maybe BoundV
forall a. a -> Maybe a
Just (BoundV -> Maybe BoundV) -> BoundV -> Maybe BoundV
forall a b. (a -> b) -> a -> b
$ [TypeParam] -> StructType -> BoundV
T.BoundV [] (StructType -> BoundV) -> StructType -> BoundV
forall a b. (a -> b) -> a -> b
$ ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> ScalarTypeBase (DimDecl VName) () -> StructType
forall a b. (a -> b) -> a -> b
$ PrimType -> ScalarTypeBase (DimDecl VName) ()
forall dim as. PrimType -> ScalarTypeBase dim as
Prim (PrimType -> ScalarTypeBase (DimDecl VName) ())
-> PrimType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
Signed IntType
Int32,
                                              PrimValue -> Value
ValuePrim (IntValue -> PrimValue
SignedValue IntValue
i))) Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env') ExpBase Info VName
body

        whileLoop :: ExpBase Info VName -> Value -> EvalM Value
whileLoop ExpBase Info VName
cond Value
v = do
          Env
env' <- Value -> EvalM Env
withLoopParams Value
v
          Bool
continue <- Value -> Bool
asBool (Value -> Bool) -> EvalM Value -> EvalM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExpBase Info VName -> EvalM Value
eval Env
env' ExpBase Info VName
cond
          if Bool
continue
            then ExpBase Info VName -> Value -> EvalM Value
whileLoop ExpBase Info VName
cond (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> ExpBase Info VName -> EvalM Value
eval Env
env' ExpBase Info VName
body
            else Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v

        forInLoop :: Pattern -> Value -> Value -> EvalM Value
forInLoop Pattern
in_pat Value
v Value
in_v = do
          Env
env' <- Value -> EvalM Env
withLoopParams Value
v
          Env
env'' <- Env -> Pattern -> Value -> EvalM Env
matchPattern Env
env' Pattern
in_pat Value
in_v
          Env -> ExpBase Info VName -> EvalM Value
eval Env
env'' ExpBase Info VName
body

eval Env
env (Project Name
f ExpBase Info VName
e Info PatternType
_ SrcLoc
_) = do
  Value
v <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e
  case Value
v of
    ValueRecord Map Name Value
fs | Just Value
v' <- Name -> Map Name Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
f Map Name Value
fs -> Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v'
    Value
_ -> String -> EvalM Value
forall a. HasCallStack => String -> a
error String
"Value does not have expected field."

eval Env
env (Assert ExpBase Info VName
what ExpBase Info VName
e (Info String
s) SrcLoc
loc) = do
  Bool
cond <- Value -> Bool
asBool (Value -> Bool) -> EvalM Value -> EvalM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
what
  Bool -> EvalM () -> EvalM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cond (EvalM () -> EvalM ()) -> EvalM () -> EvalM ()
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Env -> String -> EvalM ()
forall a. SrcLoc -> Env -> String -> EvalM a
bad SrcLoc
loc Env
env String
s
  Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e

eval Env
env (Constr Name
c [ExpBase Info VName]
es (Info PatternType
t) SrcLoc
_) = do
  [Value]
vs <- (ExpBase Info VName -> EvalM Value)
-> [ExpBase Info VName] -> EvalM [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> ExpBase Info VName -> EvalM Value
eval Env
env) [ExpBase Info VName]
es
  ValueShape
shape <- Env -> StructType -> EvalM ValueShape
typeValueShape Env
env (StructType -> EvalM ValueShape) -> StructType -> EvalM ValueShape
forall a b. (a -> b) -> a -> b
$ PatternType -> StructType
forall dim as. TypeBase dim as -> TypeBase dim ()
toStruct PatternType
t
  Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> EvalM Value) -> Value -> EvalM Value
forall a b. (a -> b) -> a -> b
$ ValueShape -> Name -> [Value] -> Value
ValueSum ValueShape
shape Name
c [Value]
vs

eval Env
env (Match ExpBase Info VName
e NonEmpty (CaseBase Info VName)
cs (Info PatternType
ret, Info [VName]
retext) SrcLoc
_) = do
  Value
v <- Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e
  Env -> PatternType -> [VName] -> Value -> EvalM Value
forall als.
Env
-> TypeBase (DimDecl VName) als -> [VName] -> Value -> EvalM Value
returned Env
env PatternType
ret [VName]
retext (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> [CaseBase Info VName] -> EvalM Value
match Value
v (NonEmpty (CaseBase Info VName) -> [CaseBase Info VName]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (CaseBase Info VName)
cs)
  where match :: Value -> [CaseBase Info VName] -> EvalM Value
match Value
_ [] =
          String -> EvalM Value
forall a. HasCallStack => String -> a
error String
"Pattern match failure."
        match Value
v (CaseBase Info VName
c:[CaseBase Info VName]
cs') = do
          Maybe Value
c' <- Value -> Env -> CaseBase Info VName -> EvalM (Maybe Value)
evalCase Value
v Env
env CaseBase Info VName
c
          case Maybe Value
c' of
            Just Value
v' -> Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v'
            Maybe Value
Nothing -> Value -> [CaseBase Info VName] -> EvalM Value
match Value
v [CaseBase Info VName]
cs'

eval Env
env (Attr AttrInfo
_ ExpBase Info VName
e SrcLoc
_) = Env -> ExpBase Info VName -> EvalM Value
eval Env
env ExpBase Info VName
e

evalCase :: Value -> Env -> CaseBase Info VName
         -> EvalM (Maybe Value)
evalCase :: Value -> Env -> CaseBase Info VName -> EvalM (Maybe Value)
evalCase Value
v Env
env (CasePat Pattern
p ExpBase Info VName
cExp SrcLoc
_) = MaybeT EvalM Value -> EvalM (Maybe Value)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT EvalM Value -> EvalM (Maybe Value))
-> MaybeT EvalM Value -> EvalM (Maybe Value)
forall a b. (a -> b) -> a -> b
$ do
  Env
env' <- Env -> Pattern -> Value -> MaybeT EvalM Env
patternMatch Env
env Pattern
p Value
v
  EvalM Value -> MaybeT EvalM Value
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EvalM Value -> MaybeT EvalM Value)
-> EvalM Value -> MaybeT EvalM Value
forall a b. (a -> b) -> a -> b
$ Env -> ExpBase Info VName -> EvalM Value
eval Env
env' ExpBase Info VName
cExp

substituteInModule :: M.Map VName VName -> Module -> Module
substituteInModule :: Map VName VName -> Module -> Module
substituteInModule Map VName VName
substs = Module -> Module
onModule
  where
    rev_substs :: Map VName VName
rev_substs = Map VName VName -> Map VName VName
reverseSubstitutions Map VName VName
substs
    replace :: VName -> VName
replace VName
v = VName -> Maybe VName -> VName
forall a. a -> Maybe a -> a
fromMaybe VName
v (Maybe VName -> VName) -> Maybe VName -> VName
forall a b. (a -> b) -> a -> b
$ VName -> Map VName VName -> Maybe VName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
v Map VName VName
rev_substs
    replaceQ :: QualName VName -> QualName VName
replaceQ QualName VName
v = QualName VName
-> (VName -> QualName VName) -> Maybe VName -> QualName VName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe QualName VName
v VName -> QualName VName
forall v. v -> QualName v
qualName (Maybe VName -> QualName VName) -> Maybe VName -> QualName VName
forall a b. (a -> b) -> a -> b
$ VName -> Map VName VName -> Maybe VName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (QualName VName -> VName
forall vn. QualName vn -> vn
qualLeaf QualName VName
v) Map VName VName
rev_substs
    replaceM :: (t -> a) -> Map VName t -> Map VName a
replaceM t -> a
f Map VName t
m = [(VName, a)] -> Map VName a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(VName, a)] -> Map VName a) -> [(VName, a)] -> Map VName a
forall a b. (a -> b) -> a -> b
$ do
      (VName
k, t
v) <- Map VName t -> [(VName, t)]
forall k a. Map k a -> [(k, a)]
M.toList Map VName t
m
      (VName, a) -> [(VName, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return (VName -> VName
replace VName
k, t -> a
f t
v)
    onModule :: Module -> Module
onModule (Module (Env Map VName TermBinding
terms Map VName TypeBinding
types Map VName ValueShape
_)) =
      Env -> Module
Module (Env -> Module) -> Env -> Module
forall a b. (a -> b) -> a -> b
$ Map VName TermBinding
-> Map VName TypeBinding -> Map VName ValueShape -> Env
Env ((TermBinding -> TermBinding)
-> Map VName TermBinding -> Map VName TermBinding
forall t a. (t -> a) -> Map VName t -> Map VName a
replaceM TermBinding -> TermBinding
onTerm Map VName TermBinding
terms) ((TypeBinding -> TypeBinding)
-> Map VName TypeBinding -> Map VName TypeBinding
forall t a. (t -> a) -> Map VName t -> Map VName a
replaceM TypeBinding -> TypeBinding
onType Map VName TypeBinding
types) Map VName ValueShape
forall a. Monoid a => a
mempty
    onModule (ModuleFun Module -> EvalM Module
f) =
      (Module -> EvalM Module) -> Module
ModuleFun ((Module -> EvalM Module) -> Module)
-> (Module -> EvalM Module) -> Module
forall a b. (a -> b) -> a -> b
$ \Module
m -> Module -> Module
onModule (Module -> Module) -> EvalM Module -> EvalM Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> EvalM Module
f (Map VName VName -> Module -> Module
substituteInModule Map VName VName
rev_substs Module
m)
    onTerm :: TermBinding -> TermBinding
onTerm (TermValue Maybe BoundV
t Value
v) = Maybe BoundV -> Value -> TermBinding
TermValue Maybe BoundV
t Value
v
    onTerm (TermPoly Maybe BoundV
t StructType -> EvalM Value
v) = Maybe BoundV -> (StructType -> EvalM Value) -> TermBinding
TermPoly Maybe BoundV
t StructType -> EvalM Value
v
    onTerm (TermModule Module
m) = Module -> TermBinding
TermModule (Module -> TermBinding) -> Module -> TermBinding
forall a b. (a -> b) -> a -> b
$ Module -> Module
onModule Module
m
    onType :: TypeBinding -> TypeBinding
onType (T.TypeAbbr Liftedness
l [TypeParam]
ps StructType
t) = Liftedness -> [TypeParam] -> StructType -> TypeBinding
T.TypeAbbr Liftedness
l [TypeParam]
ps (StructType -> TypeBinding) -> StructType -> TypeBinding
forall a b. (a -> b) -> a -> b
$ (DimDecl VName -> DimDecl VName) -> StructType -> StructType
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DimDecl VName -> DimDecl VName
onDim StructType
t
    onDim :: DimDecl VName -> DimDecl VName
onDim (NamedDim QualName VName
v) = QualName VName -> DimDecl VName
forall vn. QualName vn -> DimDecl vn
NamedDim (QualName VName -> DimDecl VName)
-> QualName VName -> DimDecl VName
forall a b. (a -> b) -> a -> b
$ QualName VName -> QualName VName
replaceQ QualName VName
v
    onDim (ConstDim Int
x) = Int -> DimDecl VName
forall vn. Int -> DimDecl vn
ConstDim Int
x
    onDim DimDecl VName
AnyDim = DimDecl VName
forall vn. DimDecl vn
AnyDim

reverseSubstitutions :: M.Map VName VName -> M.Map VName VName
reverseSubstitutions :: Map VName VName -> Map VName VName
reverseSubstitutions = [(VName, VName)] -> Map VName VName
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(VName, VName)] -> Map VName VName)
-> (Map VName VName -> [(VName, VName)])
-> Map VName VName
-> Map VName VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((VName, VName) -> (VName, VName))
-> [(VName, VName)] -> [(VName, VName)]
forall a b. (a -> b) -> [a] -> [b]
map ((VName -> VName -> (VName, VName))
-> (VName, VName) -> (VName, VName)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((VName -> VName -> (VName, VName))
 -> (VName, VName) -> (VName, VName))
-> (VName -> VName -> (VName, VName))
-> (VName, VName)
-> (VName, VName)
forall a b. (a -> b) -> a -> b
$ (VName -> VName -> (VName, VName))
-> VName -> VName -> (VName, VName)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)) ([(VName, VName)] -> [(VName, VName)])
-> (Map VName VName -> [(VName, VName)])
-> Map VName VName
-> [(VName, VName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map VName VName -> [(VName, VName)]
forall k a. Map k a -> [(k, a)]
M.toList

evalModuleVar :: Env -> QualName VName -> EvalM Module
evalModuleVar :: Env -> QualName VName -> EvalM Module
evalModuleVar Env
env QualName VName
qv =
  case QualName VName -> Env -> Maybe TermBinding
lookupVar QualName VName
qv Env
env of
    Just (TermModule Module
m) -> Module -> EvalM Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
    Maybe TermBinding
_ -> String -> EvalM Module
forall a. HasCallStack => String -> a
error (String -> EvalM Module) -> String -> EvalM Module
forall a b. (a -> b) -> a -> b
$ ShowS
quote (QualName VName -> String
forall a. Pretty a => a -> String
pretty QualName VName
qv) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not bound to a module."

evalModExp :: Env -> ModExp -> EvalM Module

evalModExp :: Env -> ModExp -> EvalM Module
evalModExp Env
_ (ModImport String
_ (Info String
f) SrcLoc
_) = do
  Maybe Env
f' <- String -> EvalM (Maybe Env)
lookupImport String
f
  case Maybe Env
f' of Maybe Env
Nothing -> String -> EvalM Module
forall a. HasCallStack => String -> a
error (String -> EvalM Module) -> String -> EvalM Module
forall a b. (a -> b) -> a -> b
$ String
"Unknown import " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
f
             Just Env
m -> Module -> EvalM Module
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> EvalM Module) -> Module -> EvalM Module
forall a b. (a -> b) -> a -> b
$ Env -> Module
Module Env
m

evalModExp Env
env (ModDecs [DecBase Info VName]
ds SrcLoc
_) = do
  Env Map VName TermBinding
terms Map VName TypeBinding
types Map VName ValueShape
_ <- (Env -> DecBase Info VName -> EvalM Env)
-> Env -> [DecBase Info VName] -> EvalM Env
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Env -> DecBase Info VName -> EvalM Env
evalDec Env
env [DecBase Info VName]
ds
  -- Remove everything that was present in the original Env.
  Module -> EvalM Module
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> EvalM Module) -> Module -> EvalM Module
forall a b. (a -> b) -> a -> b
$ Env -> Module
Module (Env -> Module) -> Env -> Module
forall a b. (a -> b) -> a -> b
$ Map VName TermBinding
-> Map VName TypeBinding -> Map VName ValueShape -> Env
Env (Map VName TermBinding
terms Map VName TermBinding
-> Map VName TermBinding -> Map VName TermBinding
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Env -> Map VName TermBinding
envTerm Env
env)
                        (Map VName TypeBinding
types Map VName TypeBinding
-> Map VName TypeBinding -> Map VName TypeBinding
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Env -> Map VName TypeBinding
envType Env
env)
                        Map VName ValueShape
forall a. Monoid a => a
mempty

evalModExp Env
env (ModVar QualName VName
qv SrcLoc
_) =
  Env -> QualName VName -> EvalM Module
evalModuleVar Env
env QualName VName
qv

evalModExp Env
env (ModAscript ModExp
me SigExpBase Info VName
_ (Info Map VName VName
substs) SrcLoc
_) =
  Map VName VName -> Module -> Module
substituteInModule Map VName VName
substs (Module -> Module) -> EvalM Module -> EvalM Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> ModExp -> EvalM Module
evalModExp Env
env ModExp
me

evalModExp Env
env (ModParens ModExp
me SrcLoc
_) = Env -> ModExp -> EvalM Module
evalModExp Env
env ModExp
me

evalModExp Env
env (ModLambda ModParamBase Info VName
p Maybe (SigExpBase Info VName, Info (Map VName VName))
ret ModExp
e SrcLoc
loc) =
  Module -> EvalM Module
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> EvalM Module) -> Module -> EvalM Module
forall a b. (a -> b) -> a -> b
$ (Module -> EvalM Module) -> Module
ModuleFun ((Module -> EvalM Module) -> Module)
-> (Module -> EvalM Module) -> Module
forall a b. (a -> b) -> a -> b
$ \Module
am -> do
  let env' :: Env
env' = Env
env { envTerm :: Map VName TermBinding
envTerm = VName
-> TermBinding -> Map VName TermBinding -> Map VName TermBinding
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (ModParamBase Info VName -> VName
forall (f :: * -> *) vn. ModParamBase f vn -> vn
modParamName ModParamBase Info VName
p) (Module -> TermBinding
TermModule Module
am) (Map VName TermBinding -> Map VName TermBinding)
-> Map VName TermBinding -> Map VName TermBinding
forall a b. (a -> b) -> a -> b
$ Env -> Map VName TermBinding
envTerm Env
env }
  Env -> ModExp -> EvalM Module
evalModExp Env
env' (ModExp -> EvalM Module) -> ModExp -> EvalM Module
forall a b. (a -> b) -> a -> b
$ case Maybe (SigExpBase Info VName, Info (Map VName VName))
ret of
    Maybe (SigExpBase Info VName, Info (Map VName VName))
Nothing -> ModExp
e
    Just (SigExpBase Info VName
se, Info (Map VName VName)
rsubsts) -> ModExp
-> SigExpBase Info VName
-> Info (Map VName VName)
-> SrcLoc
-> ModExp
forall (f :: * -> *) vn.
ModExpBase f vn
-> SigExpBase f vn
-> f (Map VName VName)
-> SrcLoc
-> ModExpBase f vn
ModAscript ModExp
e SigExpBase Info VName
se Info (Map VName VName)
rsubsts SrcLoc
loc

evalModExp Env
env (ModApply ModExp
f ModExp
e (Info Map VName VName
psubst) (Info Map VName VName
rsubst) SrcLoc
_) = do
  Module
f' <- Env -> ModExp -> EvalM Module
evalModExp Env
env ModExp
f
  case Module
f' of
    ModuleFun Module -> EvalM Module
f'' -> do
      Module
e' <- Env -> ModExp -> EvalM Module
evalModExp Env
env ModExp
e
      Map VName VName -> Module -> Module
substituteInModule Map VName VName
rsubst (Module -> Module) -> EvalM Module -> EvalM Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> EvalM Module
f'' (Map VName VName -> Module -> Module
substituteInModule Map VName VName
psubst Module
e')
    Module
_ -> String -> EvalM Module
forall a. HasCallStack => String -> a
error String
"Expected ModuleFun."

evalDec :: Env -> Dec -> EvalM Env

evalDec :: Env -> DecBase Info VName -> EvalM Env
evalDec Env
env (ValDec (ValBind Maybe (Info EntryPoint)
_ VName
v Maybe (TypeExp VName)
_ (Info (StructType
ret, [VName]
retext)) [TypeParam]
tparams [Pattern]
ps ExpBase Info VName
fbody Maybe DocComment
_ [AttrInfo]
_ SrcLoc
_)) = do
  TermBinding
binding <- Env
-> [TypeParam]
-> [Pattern]
-> StructType
-> [VName]
-> ExpBase Info VName
-> EvalM TermBinding
evalFunctionBinding Env
env [TypeParam]
tparams [Pattern]
ps StructType
ret [VName]
retext ExpBase Info VName
fbody
  Env -> EvalM Env
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> EvalM Env) -> Env -> EvalM Env
forall a b. (a -> b) -> a -> b
$ Env
env { envTerm :: Map VName TermBinding
envTerm = VName
-> TermBinding -> Map VName TermBinding -> Map VName TermBinding
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v TermBinding
binding (Map VName TermBinding -> Map VName TermBinding)
-> Map VName TermBinding -> Map VName TermBinding
forall a b. (a -> b) -> a -> b
$ Env -> Map VName TermBinding
envTerm Env
env }

evalDec Env
env (OpenDec ModExp
me SrcLoc
_) = do
  Module
me' <- Env -> ModExp -> EvalM Module
evalModExp Env
env ModExp
me
  case Module
me' of
    Module Env
me'' -> Env -> EvalM Env
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> EvalM Env) -> Env -> EvalM Env
forall a b. (a -> b) -> a -> b
$ Env
me'' Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env
    Module
_ -> String -> EvalM Env
forall a. HasCallStack => String -> a
error String
"Expected Module"

evalDec Env
env (ImportDec String
name Info String
name' SrcLoc
loc) =
  Env -> DecBase Info VName -> EvalM Env
evalDec Env
env (DecBase Info VName -> EvalM Env)
-> DecBase Info VName -> EvalM Env
forall a b. (a -> b) -> a -> b
$ DecBase Info VName -> SrcLoc -> DecBase Info VName
forall (f :: * -> *) vn. DecBase f vn -> SrcLoc -> DecBase f vn
LocalDec (ModExp -> SrcLoc -> DecBase Info VName
forall (f :: * -> *) vn. ModExpBase f vn -> SrcLoc -> DecBase f vn
OpenDec (String -> Info String -> SrcLoc -> ModExp
forall (f :: * -> *) vn.
String -> f String -> SrcLoc -> ModExpBase f vn
ModImport String
name Info String
name' SrcLoc
loc) SrcLoc
loc) SrcLoc
loc

evalDec Env
env (LocalDec DecBase Info VName
d SrcLoc
_) = Env -> DecBase Info VName -> EvalM Env
evalDec Env
env DecBase Info VName
d
evalDec Env
env SigDec{} = Env -> EvalM Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env
evalDec Env
env (TypeDec (TypeBind VName
v Liftedness
l [TypeParam]
ps TypeDeclBase Info VName
t Maybe DocComment
_ SrcLoc
_)) = do
  let abbr :: TypeBinding
abbr = Liftedness -> [TypeParam] -> StructType -> TypeBinding
T.TypeAbbr Liftedness
l [TypeParam]
ps (StructType -> TypeBinding) -> StructType -> TypeBinding
forall a b. (a -> b) -> a -> b
$
             Env -> StructType -> StructType
evalType Env
env (StructType -> StructType) -> StructType -> StructType
forall a b. (a -> b) -> a -> b
$ Info StructType -> StructType
forall a. Info a -> a
unInfo (Info StructType -> StructType) -> Info StructType -> StructType
forall a b. (a -> b) -> a -> b
$ TypeDeclBase Info VName -> Info StructType
forall (f :: * -> *) vn. TypeDeclBase f vn -> f StructType
expandedType TypeDeclBase Info VName
t
  Env -> EvalM Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env { envType :: Map VName TypeBinding
envType = VName
-> TypeBinding -> Map VName TypeBinding -> Map VName TypeBinding
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v