{-# 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 TypeBinding
abbr (Map VName TypeBinding -> Map VName TypeBinding)
-> Map VName TypeBinding -> Map VName TypeBinding
forall a b. (a -> b) -> a -> b
$ Env -> Map VName TypeBinding
envType Env
env }
evalDec Env
env (ModDec (ModBind VName
v [ModParamBase Info VName]
ps Maybe (SigExpBase Info VName, Info (Map VName VName))
ret ModExp
body Maybe DocComment
_ SrcLoc
loc)) = do
  Module
mod <- Env -> ModExp -> EvalM Module
evalModExp Env
env (ModExp -> EvalM Module) -> ModExp -> EvalM Module
forall a b. (a -> b) -> a -> b
$ [ModParamBase Info VName] -> ModExp
wrapInLambda [ModParamBase Info VName]
ps
  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
$ Map VName Module -> Env
modEnv (VName -> Module -> Map VName Module
forall k a. k -> a -> Map k a
M.singleton VName
v Module
mod) Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env
  where wrapInLambda :: [ModParamBase Info VName] -> ModExp
wrapInLambda [] = case Maybe (SigExpBase Info VName, Info (Map VName VName))
ret of
                            Just (SigExpBase Info VName
se, Info (Map VName VName)
substs) -> 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
body SigExpBase Info VName
se Info (Map VName VName)
substs SrcLoc
loc
                            Maybe (SigExpBase Info VName, Info (Map VName VName))
Nothing           -> ModExp
body
        wrapInLambda [ModParamBase Info VName
p] = ModParamBase Info VName
-> Maybe (SigExpBase Info VName, Info (Map VName VName))
-> ModExp
-> SrcLoc
-> ModExp
forall (f :: * -> *) vn.
ModParamBase f vn
-> Maybe (SigExpBase f vn, f (Map VName VName))
-> ModExpBase f vn
-> SrcLoc
-> ModExpBase f vn
ModLambda ModParamBase Info VName
p Maybe (SigExpBase Info VName, Info (Map VName VName))
ret ModExp
body SrcLoc
loc
        wrapInLambda (ModParamBase Info VName
p:[ModParamBase Info VName]
ps') = ModParamBase Info VName
-> Maybe (SigExpBase Info VName, Info (Map VName VName))
-> ModExp
-> SrcLoc
-> ModExp
forall (f :: * -> *) vn.
ModParamBase f vn
-> Maybe (SigExpBase f vn, f (Map VName VName))
-> ModExpBase f vn
-> SrcLoc
-> ModExpBase f vn
ModLambda ModParamBase Info VName
p Maybe (SigExpBase Info VName, Info (Map VName VName))
forall a. Maybe a
Nothing ([ModParamBase Info VName] -> ModExp
wrapInLambda [ModParamBase Info VName]
ps') SrcLoc
loc

-- | The interpreter context.  All evaluation takes place with respect
-- to a context, and it can be extended with more definitions, which
-- is how the REPL works.
data Ctx = Ctx { Ctx -> Env
ctxEnv :: Env
               , Ctx -> Map String Env
ctxImports :: M.Map FilePath Env
               }

nanValue :: PrimValue -> Bool
nanValue :: PrimValue -> Bool
nanValue (FloatValue FloatValue
v) =
  case FloatValue
v of Float32Value Float
x -> Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
x
            Float64Value Double
x -> Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
x
nanValue PrimValue
_ = Bool
False

breakOnNaN :: [PrimValue] -> PrimValue -> EvalM ()
breakOnNaN :: [PrimValue] -> PrimValue -> EvalM ()
breakOnNaN [PrimValue]
inputs PrimValue
result
  | Bool -> Bool
not ((PrimValue -> Bool) -> [PrimValue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PrimValue -> Bool
nanValue [PrimValue]
inputs) Bool -> Bool -> Bool
&& PrimValue -> Bool
nanValue PrimValue
result = do
      [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]
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
BreakNaN NonEmpty StackFrame
backtrace' ()
breakOnNaN [PrimValue]
_ PrimValue
_ =
  () -> EvalM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | The initial environment contains definitions of the various intrinsic functions.
initialCtx :: Ctx
initialCtx :: Ctx
initialCtx =
  Env -> Map String Env -> Ctx
Ctx (Map VName TermBinding
-> Map VName TypeBinding -> Map VName ValueShape -> Env
Env (VName
-> TermBinding -> Map VName TermBinding -> Map VName TermBinding
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Name -> Int -> VName
VName (String -> Name
nameFromString String
"intrinsics") Int
0)
            (Module -> TermBinding
TermModule (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 TypeBinding
types Map VName ValueShape
forall a. Monoid a => a
mempty)) Map VName TermBinding
terms)
        Map VName TypeBinding
types Map VName ValueShape
forall a. Monoid a => a
mempty)
      Map String Env
forall a. Monoid a => a
mempty
  where
    terms :: Map VName TermBinding
terms = (VName -> Intrinsic -> Maybe TermBinding)
-> Map VName Intrinsic -> Map VName TermBinding
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
M.mapMaybeWithKey (Maybe TermBinding -> Intrinsic -> Maybe TermBinding
forall a b. a -> b -> a
const (Maybe TermBinding -> Intrinsic -> Maybe TermBinding)
-> (VName -> Maybe TermBinding)
-> VName
-> Intrinsic
-> Maybe TermBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe TermBinding
def (String -> Maybe TermBinding)
-> (VName -> String) -> VName -> Maybe TermBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> String
baseString) Map VName Intrinsic
intrinsics
    types :: Map VName TypeBinding
types = (VName -> Intrinsic -> Maybe TypeBinding)
-> Map VName Intrinsic -> Map VName TypeBinding
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
M.mapMaybeWithKey (Maybe TypeBinding -> Intrinsic -> Maybe TypeBinding
forall a b. a -> b -> a
const (Maybe TypeBinding -> Intrinsic -> Maybe TypeBinding)
-> (VName -> Maybe TypeBinding)
-> VName
-> Intrinsic
-> Maybe TypeBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe TypeBinding
tdef (String -> Maybe TypeBinding)
-> (VName -> String) -> VName -> Maybe TypeBinding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> String
baseString) Map VName Intrinsic
intrinsics

    sintOp :: (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
sintOp IntType -> BinOp
f = [ (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
putS, BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp (IntType -> BinOp
f IntType
Int8))
               , (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
putS, BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp (IntType -> BinOp
f IntType
Int16))
               , (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
putS, BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp (IntType -> BinOp
f IntType
Int32))
               , (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
putS, BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp (IntType -> BinOp
f IntType
Int64))]
    uintOp :: (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
uintOp IntType -> BinOp
f = [ (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
putU, BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp (IntType -> BinOp
f IntType
Int8))
               , (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
putU, BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp (IntType -> BinOp
f IntType
Int16))
               , (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
putU, BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp (IntType -> BinOp
f IntType
Int32))
               , (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
putU, BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp (IntType -> BinOp
f IntType
Int64))]
    intOp :: (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
intOp IntType -> BinOp
f = (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
sintOp IntType -> BinOp
f [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
forall a. [a] -> [a] -> [a]
++ (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
uintOp IntType -> BinOp
f
    floatOp :: (FloatType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
floatOp FloatType -> BinOp
f = [ (PrimValue -> Maybe PrimValue
getF, PrimValue -> Maybe PrimValue
putF, BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp (FloatType -> BinOp
f FloatType
Float32))
                , (PrimValue -> Maybe PrimValue
getF, PrimValue -> Maybe PrimValue
putF, BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp (FloatType -> BinOp
f FloatType
Float64))]
    arithOp :: (IntType -> BinOp) -> (FloatType -> BinOp) -> Maybe TermBinding
arithOp IntType -> BinOp
f FloatType -> BinOp
g = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$ (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
intOp IntType -> BinOp
f [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
forall a. [a] -> [a] -> [a]
++ (FloatType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
floatOp FloatType -> BinOp
g

    flipCmps :: [(a, b, a -> b -> c)] -> [(a, b, b -> a -> c)]
flipCmps = ((a, b, a -> b -> c) -> (a, b, b -> a -> c))
-> [(a, b, a -> b -> c)] -> [(a, b, b -> a -> c)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
f, b
g, a -> b -> c
h) -> (a
f, b
g, (a -> b -> c) -> b -> a -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> c
h))
    sintCmp :: (IntType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
sintCmp IntType -> CmpOp
f = [ (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp (IntType -> CmpOp
f IntType
Int8))
                , (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp (IntType -> CmpOp
f IntType
Int16))
                , (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp (IntType -> CmpOp
f IntType
Int32))
                , (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp (IntType -> CmpOp
f IntType
Int64))]
    uintCmp :: (IntType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
uintCmp IntType -> CmpOp
f = [ (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp (IntType -> CmpOp
f IntType
Int8))
                , (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp (IntType -> CmpOp
f IntType
Int16))
                , (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp (IntType -> CmpOp
f IntType
Int32))
                , (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp (IntType -> CmpOp
f IntType
Int64))]
    floatCmp :: (FloatType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
floatCmp FloatType -> CmpOp
f = [ (PrimValue -> Maybe PrimValue
getF, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp (FloatType -> CmpOp
f FloatType
Float32))
                 , (PrimValue -> Maybe PrimValue
getF, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp (FloatType -> CmpOp
f FloatType
Float64))]
    boolCmp :: CmpOp
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
boolCmp CmpOp
f = [ (PrimValue -> Maybe PrimValue
getB, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (Bool -> PrimValue) -> Bool -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PrimValue
BoolValue, CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp CmpOp
f) ]

    getV :: PrimValue -> Maybe PrimValue
getV (SignedValue IntValue
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
P.IntValue IntValue
x
    getV (UnsignedValue IntValue
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
P.IntValue IntValue
x
    getV (FloatValue FloatValue
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ FloatValue -> PrimValue
P.FloatValue FloatValue
x
    getV (BoolValue Bool
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ Bool -> PrimValue
P.BoolValue Bool
x
    putV :: PrimValue -> PrimValue
putV (P.IntValue IntValue
x) = IntValue -> PrimValue
SignedValue IntValue
x
    putV (P.FloatValue FloatValue
x) = FloatValue -> PrimValue
FloatValue FloatValue
x
    putV (P.BoolValue Bool
x) = Bool -> PrimValue
BoolValue Bool
x
    putV PrimValue
P.Checked = Bool -> PrimValue
BoolValue Bool
True

    getS :: PrimValue -> Maybe PrimValue
getS (SignedValue IntValue
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
P.IntValue IntValue
x
    getS PrimValue
_               = Maybe PrimValue
forall a. Maybe a
Nothing
    putS :: PrimValue -> Maybe PrimValue
putS (P.IntValue IntValue
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
SignedValue IntValue
x
    putS PrimValue
_              = Maybe PrimValue
forall a. Maybe a
Nothing

    getU :: PrimValue -> Maybe PrimValue
getU (UnsignedValue IntValue
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
P.IntValue IntValue
x
    getU PrimValue
_                 = Maybe PrimValue
forall a. Maybe a
Nothing
    putU :: PrimValue -> Maybe PrimValue
putU (P.IntValue IntValue
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> PrimValue
UnsignedValue IntValue
x
    putU PrimValue
_              = Maybe PrimValue
forall a. Maybe a
Nothing

    getF :: PrimValue -> Maybe PrimValue
getF (FloatValue FloatValue
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ FloatValue -> PrimValue
P.FloatValue FloatValue
x
    getF PrimValue
_              = Maybe PrimValue
forall a. Maybe a
Nothing
    putF :: PrimValue -> Maybe PrimValue
putF (P.FloatValue FloatValue
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ FloatValue -> PrimValue
FloatValue FloatValue
x
    putF PrimValue
_                = Maybe PrimValue
forall a. Maybe a
Nothing

    getB :: PrimValue -> Maybe PrimValue
getB (BoolValue Bool
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ Bool -> PrimValue
P.BoolValue Bool
x
    getB PrimValue
_             = Maybe PrimValue
forall a. Maybe a
Nothing
    putB :: PrimValue -> Maybe PrimValue
putB (P.BoolValue Bool
x) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue) -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ Bool -> PrimValue
BoolValue Bool
x
    putB PrimValue
_               = Maybe PrimValue
forall a. Maybe a
Nothing

    fun1 :: (Value -> EvalM Value) -> TermBinding
fun1 Value -> EvalM Value
f =
      Maybe BoundV -> Value -> TermBinding
TermValue Maybe BoundV
forall a. Maybe a
Nothing (Value -> TermBinding) -> Value -> TermBinding
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 -> Value -> EvalM Value
f Value
x
    fun2 :: (Value -> Value -> EvalM Value) -> TermBinding
fun2 Value -> Value -> EvalM Value
f =
      Maybe BoundV -> Value -> TermBinding
TermValue Maybe BoundV
forall a. Maybe a
Nothing (Value -> TermBinding) -> Value -> TermBinding
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 ->
      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
y -> Value -> Value -> EvalM Value
f Value
x Value
y
    fun2t :: (Value -> Value -> EvalM Value) -> TermBinding
fun2t Value -> Value -> EvalM Value
f =
      Maybe BoundV -> Value -> TermBinding
TermValue Maybe BoundV
forall a. Maybe a
Nothing (Value -> TermBinding) -> Value -> TermBinding
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 ->
      case Value -> Maybe [Value]
fromTuple Value
v of Just [Value
x,Value
y] -> Value -> Value -> EvalM Value
f Value
x Value
y
                          Maybe [Value]
_ -> String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Expected pair; got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
v
    fun3t :: (Value -> Value -> Value -> EvalM Value) -> TermBinding
fun3t Value -> Value -> Value -> EvalM Value
f =
      Maybe BoundV -> Value -> TermBinding
TermValue Maybe BoundV
forall a. Maybe a
Nothing (Value -> TermBinding) -> Value -> TermBinding
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 ->
      case Value -> Maybe [Value]
fromTuple Value
v of Just [Value
x,Value
y,Value
z] -> Value -> Value -> Value -> EvalM Value
f Value
x Value
y Value
z
                          Maybe [Value]
_ -> String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Expected triple; got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
v

    fun6t :: (Value -> Value -> Value -> Value -> Value -> Value -> EvalM Value)
-> TermBinding
fun6t Value -> Value -> Value -> Value -> Value -> Value -> EvalM Value
f =
      Maybe BoundV -> Value -> TermBinding
TermValue Maybe BoundV
forall a. Maybe a
Nothing (Value -> TermBinding) -> Value -> TermBinding
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 ->
      case Value -> Maybe [Value]
fromTuple Value
v of Just [Value
x,Value
y,Value
z,Value
a,Value
b,Value
c] -> Value -> Value -> Value -> Value -> Value -> Value -> EvalM Value
f Value
x Value
y Value
z Value
a Value
b Value
c
                          Maybe [Value]
_ -> String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Expected sextuple; got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
v

    bopDef :: [(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef [(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
fs = (Value -> Value -> EvalM Value) -> TermBinding
fun2 ((Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
x Value
y ->
      case (Value
x, Value
y) of
        (ValuePrim PrimValue
x', ValuePrim PrimValue
y')
          | Just PrimValue
z <- [Maybe PrimValue] -> Maybe PrimValue
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe PrimValue] -> Maybe PrimValue)
-> [Maybe PrimValue] -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ ((PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)
 -> Maybe PrimValue)
-> [(PrimValue -> Maybe t, a -> Maybe PrimValue,
     t -> t -> Maybe a)]
-> [Maybe PrimValue]
forall a b. (a -> b) -> [a] -> [b]
map ((PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)
-> (PrimValue, PrimValue) -> Maybe PrimValue
forall (m :: * -> *) t t a b.
Monad m =>
(t -> m t, a -> m b, t -> t -> m a) -> (t, t) -> m b
`bopDef'` (PrimValue
x', PrimValue
y')) [(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
fs -> do
              [PrimValue] -> PrimValue -> EvalM ()
breakOnNaN [PrimValue
x', PrimValue
y'] PrimValue
z
              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
z
        (Value, Value)
_ ->
          SrcLoc -> Env -> String -> EvalM Value
forall a. SrcLoc -> Env -> String -> EvalM a
bad SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Cannot apply operator to arguments " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          ShowS
quote (Value -> String
forall a. Pretty a => a -> String
pretty Value
x) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" and " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
quote (Value -> String
forall a. Pretty a => a -> String
pretty Value
y) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."
      where bopDef' :: (t -> m t, a -> m b, t -> t -> m a) -> (t, t) -> m b
bopDef' (t -> m t
valf, a -> m b
retf, t -> t -> m a
op) (t
x, t
y) = do
              t
x' <- t -> m t
valf t
x
              t
y' <- t -> m t
valf t
y
              a -> m b
retf (a -> m b) -> m a -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< t -> t -> m a
op t
x' t
y'

    unopDef :: [(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> Maybe a)]
-> TermBinding
unopDef [(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> Maybe a)]
fs = (Value -> EvalM Value) -> TermBinding
fun1 ((Value -> EvalM Value) -> TermBinding)
-> (Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
x ->
      case Value
x of
        (ValuePrim PrimValue
x')
          | Just PrimValue
r <- [Maybe PrimValue] -> Maybe PrimValue
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe PrimValue] -> Maybe PrimValue)
-> [Maybe PrimValue] -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ ((PrimValue -> Maybe t, a -> Maybe PrimValue, t -> Maybe a)
 -> Maybe PrimValue)
-> [(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> Maybe a)]
-> [Maybe PrimValue]
forall a b. (a -> b) -> [a] -> [b]
map ((PrimValue -> Maybe t, a -> Maybe PrimValue, t -> Maybe a)
-> PrimValue -> Maybe PrimValue
forall (m :: * -> *) t t a b.
Monad m =>
(t -> m t, a -> m b, t -> m a) -> t -> m b
`unopDef'` PrimValue
x') [(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> Maybe a)]
fs -> do
              [PrimValue] -> PrimValue -> EvalM ()
breakOnNaN [PrimValue
x'] PrimValue
r
              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
r
        Value
_ ->
          SrcLoc -> Env -> String -> EvalM Value
forall a. SrcLoc -> Env -> String -> EvalM a
bad SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Cannot apply function to argument " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          ShowS
quote (Value -> String
forall a. Pretty a => a -> String
pretty Value
x) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."
      where unopDef' :: (t -> m t, a -> m b, t -> m a) -> t -> m b
unopDef' (t -> m t
valf, a -> m b
retf, t -> m a
op) t
x = do
              t
x' <- t -> m t
valf t
x
              a -> m b
retf (a -> m b) -> m a -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< t -> m a
op t
x'

    tbopDef :: (PrimValue -> PrimValue -> Maybe PrimValue) -> TermBinding
tbopDef PrimValue -> PrimValue -> Maybe PrimValue
f = (Value -> EvalM Value) -> TermBinding
fun1 ((Value -> EvalM Value) -> TermBinding)
-> (Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
v ->
      case Value -> Maybe [Value]
fromTuple Value
v of
        Just [ValuePrim PrimValue
x, ValuePrim PrimValue
y]
          | Just PrimValue
x' <- PrimValue -> Maybe PrimValue
getV PrimValue
x,
            Just PrimValue
y' <- PrimValue -> Maybe PrimValue
getV PrimValue
y,
            Just PrimValue
z <- PrimValue -> PrimValue
putV (PrimValue -> PrimValue) -> Maybe PrimValue -> Maybe PrimValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrimValue -> PrimValue -> Maybe PrimValue
f PrimValue
x' PrimValue
y' -> do
              [PrimValue] -> PrimValue -> EvalM ()
breakOnNaN [PrimValue
x, PrimValue
y] PrimValue
z
              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
z
        Maybe [Value]
_ ->
          SrcLoc -> Env -> String -> EvalM Value
forall a. SrcLoc -> Env -> String -> EvalM a
bad SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Cannot apply operator to argument " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          ShowS
quote (Value -> String
forall a. Pretty a => a -> String
pretty Value
v) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."

    def :: String -> Maybe TermBinding
def String
"!" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> Maybe a)]
-> TermBinding
unopDef [ (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
putS, UnOp -> PrimValue -> Maybe PrimValue
P.doUnOp (UnOp -> PrimValue -> Maybe PrimValue)
-> UnOp -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> UnOp
P.Complement IntType
Int8)
                             , (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
putS, UnOp -> PrimValue -> Maybe PrimValue
P.doUnOp (UnOp -> PrimValue -> Maybe PrimValue)
-> UnOp -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> UnOp
P.Complement IntType
Int16)
                             , (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
putS, UnOp -> PrimValue -> Maybe PrimValue
P.doUnOp (UnOp -> PrimValue -> Maybe PrimValue)
-> UnOp -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> UnOp
P.Complement IntType
Int32)
                             , (PrimValue -> Maybe PrimValue
getS, PrimValue -> Maybe PrimValue
putS, UnOp -> PrimValue -> Maybe PrimValue
P.doUnOp (UnOp -> PrimValue -> Maybe PrimValue)
-> UnOp -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> UnOp
P.Complement IntType
Int64)
                             , (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
putU, UnOp -> PrimValue -> Maybe PrimValue
P.doUnOp (UnOp -> PrimValue -> Maybe PrimValue)
-> UnOp -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> UnOp
P.Complement IntType
Int8)
                             , (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
putU, UnOp -> PrimValue -> Maybe PrimValue
P.doUnOp (UnOp -> PrimValue -> Maybe PrimValue)
-> UnOp -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> UnOp
P.Complement IntType
Int16)
                             , (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
putU, UnOp -> PrimValue -> Maybe PrimValue
P.doUnOp (UnOp -> PrimValue -> Maybe PrimValue)
-> UnOp -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> UnOp
P.Complement IntType
Int32)
                             , (PrimValue -> Maybe PrimValue
getU, PrimValue -> Maybe PrimValue
putU, UnOp -> PrimValue -> Maybe PrimValue
P.doUnOp (UnOp -> PrimValue -> Maybe PrimValue)
-> UnOp -> PrimValue -> Maybe PrimValue
forall a b. (a -> b) -> a -> b
$ IntType -> UnOp
P.Complement IntType
Int64)
                             , (PrimValue -> Maybe PrimValue
getB, PrimValue -> Maybe PrimValue
putB, UnOp -> PrimValue -> Maybe PrimValue
P.doUnOp UnOp
P.Not) ]

    def String
"+" = (IntType -> BinOp) -> (FloatType -> BinOp) -> Maybe TermBinding
arithOp (IntType -> Overflow -> BinOp
`P.Add` Overflow
P.OverflowWrap) FloatType -> BinOp
P.FAdd
    def String
"-" = (IntType -> BinOp) -> (FloatType -> BinOp) -> Maybe TermBinding
arithOp (IntType -> Overflow -> BinOp
`P.Sub` Overflow
P.OverflowWrap) FloatType -> BinOp
P.FSub
    def String
"*" = (IntType -> BinOp) -> (FloatType -> BinOp) -> Maybe TermBinding
arithOp (IntType -> Overflow -> BinOp
`P.Mul` Overflow
P.OverflowWrap) FloatType -> BinOp
P.FMul
    def String
"**" = (IntType -> BinOp) -> (FloatType -> BinOp) -> Maybe TermBinding
arithOp IntType -> BinOp
P.Pow FloatType -> BinOp
P.FPow
    def String
"/" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$
              (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
sintOp (IntType -> Safety -> BinOp
`P.SDiv` Safety
P.Unsafe) [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
forall a. [a] -> [a] -> [a]
++
              (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
uintOp (IntType -> Safety -> BinOp
`P.UDiv` Safety
P.Unsafe) [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
forall a. [a] -> [a] -> [a]
++
              (FloatType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
floatOp FloatType -> BinOp
P.FDiv
    def String
"%" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$
              (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
sintOp (IntType -> Safety -> BinOp
`P.SMod` Safety
P.Unsafe) [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
forall a. [a] -> [a] -> [a]
++
              (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
uintOp (IntType -> Safety -> BinOp
`P.UMod` Safety
P.Unsafe) [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
forall a. [a] -> [a] -> [a]
++
              (FloatType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
floatOp FloatType -> BinOp
P.FMod
    def String
"//" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$
               (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
sintOp (IntType -> Safety -> BinOp
`P.SQuot` Safety
P.Unsafe) [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
forall a. [a] -> [a] -> [a]
++
               (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
uintOp (IntType -> Safety -> BinOp
`P.UDiv` Safety
P.Unsafe)
    def String
"%%" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$
               (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
sintOp (IntType -> Safety -> BinOp
`P.SRem` Safety
P.Unsafe) [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
forall a. [a] -> [a] -> [a]
++
               (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
uintOp (IntType -> Safety -> BinOp
`P.UMod` Safety
P.Unsafe)
    def String
"^" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$ (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
intOp IntType -> BinOp
P.Xor
    def String
"&" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$ (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
intOp IntType -> BinOp
P.And
    def String
"|" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$ (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
intOp IntType -> BinOp
P.Or
    def String
">>" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$ (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
sintOp IntType -> BinOp
P.AShr [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
forall a. [a] -> [a] -> [a]
++ (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
uintOp IntType -> BinOp
P.LShr
    def String
"<<" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$ (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
intOp IntType -> BinOp
P.Shl
    def String
">>>" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe PrimValue)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$ (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
sintOp IntType -> BinOp
P.LShr [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
forall a. [a] -> [a] -> [a]
++ (IntType -> BinOp)
-> [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe PrimValue)]
uintOp IntType -> BinOp
P.LShr
    def String
"==" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> EvalM Value) -> TermBinding
fun2 ((Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$
               \Value
xs Value
ys -> 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 -> PrimValue) -> Bool -> PrimValue
forall a b. (a -> b) -> a -> b
$ Value
xs Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
ys
    def String
"!=" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> EvalM Value) -> TermBinding
fun2 ((Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$
               \Value
xs Value
ys -> 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 -> PrimValue) -> Bool -> PrimValue
forall a b. (a -> b) -> a -> b
$ Value
xs Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
ys

    -- The short-circuiting is handled directly in 'eval'; these cases
    -- are only used when partially applying and such.
    def String
"&&" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> EvalM Value) -> TermBinding
fun2 ((Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
x Value
y ->
      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 -> PrimValue) -> Bool -> PrimValue
forall a b. (a -> b) -> a -> b
$ Value -> Bool
asBool Value
x Bool -> Bool -> Bool
&& Value -> Bool
asBool Value
y
    def String
"||" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> EvalM Value) -> TermBinding
fun2 ((Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
x Value
y ->
      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 -> PrimValue) -> Bool -> PrimValue
forall a b. (a -> b) -> a -> b
$ Value -> Bool
asBool Value
x Bool -> Bool -> Bool
|| Value -> Bool
asBool Value
y

    def String
"<" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe Bool)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$
              (IntType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
sintCmp IntType -> CmpOp
P.CmpSlt [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++ (IntType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
uintCmp IntType -> CmpOp
P.CmpUlt [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++
              (FloatType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
floatCmp FloatType -> CmpOp
P.FCmpLt [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++ CmpOp
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
boolCmp CmpOp
P.CmpLlt
    def String
">" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe Bool)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a b a b c. [(a, b, a -> b -> c)] -> [(a, b, b -> a -> c)]
flipCmps ([(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe Bool)]
 -> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
      PrimValue -> PrimValue -> Maybe Bool)])
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a b. (a -> b) -> a -> b
$
              (IntType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
sintCmp IntType -> CmpOp
P.CmpSlt [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++ (IntType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
uintCmp IntType -> CmpOp
P.CmpUlt [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++
              (FloatType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
floatCmp FloatType -> CmpOp
P.FCmpLt [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++ CmpOp
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
boolCmp CmpOp
P.CmpLlt
    def String
"<=" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe Bool)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$
               (IntType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
sintCmp IntType -> CmpOp
P.CmpSle [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++ (IntType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
uintCmp IntType -> CmpOp
P.CmpUle [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++
               (FloatType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
floatCmp FloatType -> CmpOp
P.FCmpLe [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++ CmpOp
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
boolCmp CmpOp
P.CmpLle
    def String
">=" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> t -> Maybe a)]
-> TermBinding
bopDef ([(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe Bool)]
 -> TermBinding)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a b a b c. [(a, b, a -> b -> c)] -> [(a, b, b -> a -> c)]
flipCmps ([(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
   PrimValue -> PrimValue -> Maybe Bool)]
 -> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
      PrimValue -> PrimValue -> Maybe Bool)])
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a b. (a -> b) -> a -> b
$
               (IntType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
sintCmp IntType -> CmpOp
P.CmpSle [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++ (IntType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
uintCmp IntType -> CmpOp
P.CmpUle [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++
               (FloatType -> CmpOp)
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
floatCmp FloatType -> CmpOp
P.FCmpLe [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
  PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
forall a. [a] -> [a] -> [a]
++ CmpOp
-> [(PrimValue -> Maybe PrimValue, Bool -> Maybe PrimValue,
     PrimValue -> PrimValue -> Maybe Bool)]
boolCmp CmpOp
P.CmpLle

    def String
s
      | Just BinOp
bop <- (BinOp -> Bool) -> [BinOp] -> Maybe BinOp
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
sString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (BinOp -> String) -> BinOp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinOp -> String
forall a. Pretty a => a -> String
pretty) [BinOp]
P.allBinOps =
          TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (PrimValue -> PrimValue -> Maybe PrimValue) -> TermBinding
tbopDef ((PrimValue -> PrimValue -> Maybe PrimValue) -> TermBinding)
-> (PrimValue -> PrimValue -> Maybe PrimValue) -> TermBinding
forall a b. (a -> b) -> a -> b
$ BinOp -> PrimValue -> PrimValue -> Maybe PrimValue
P.doBinOp BinOp
bop
      | Just CmpOp
unop <- (CmpOp -> Bool) -> [CmpOp] -> Maybe CmpOp
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
sString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (CmpOp -> String) -> CmpOp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmpOp -> String
forall a. Pretty a => a -> String
pretty) [CmpOp]
P.allCmpOps =
          TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (PrimValue -> PrimValue -> Maybe PrimValue) -> TermBinding
tbopDef ((PrimValue -> PrimValue -> Maybe PrimValue) -> TermBinding)
-> (PrimValue -> PrimValue -> Maybe PrimValue) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \PrimValue
x PrimValue
y -> Bool -> PrimValue
P.BoolValue (Bool -> PrimValue) -> Maybe Bool -> Maybe PrimValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmpOp -> PrimValue -> PrimValue -> Maybe Bool
P.doCmpOp CmpOp
unop PrimValue
x PrimValue
y
      | Just ConvOp
cop <- (ConvOp -> Bool) -> [ConvOp] -> Maybe ConvOp
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
sString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (ConvOp -> String) -> ConvOp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvOp -> String
forall a. Pretty a => a -> String
pretty) [ConvOp]
P.allConvOps =
          TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> Maybe a)]
-> TermBinding
unopDef [(PrimValue -> Maybe PrimValue
getV, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (PrimValue -> PrimValue) -> PrimValue -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimValue -> PrimValue
putV, ConvOp -> PrimValue -> Maybe PrimValue
P.doConvOp ConvOp
cop)]
      | Just UnOp
unop <- (UnOp -> Bool) -> [UnOp] -> Maybe UnOp
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
sString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (UnOp -> String) -> UnOp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnOp -> String
forall a. Pretty a => a -> String
pretty) [UnOp]
P.allUnOps =
          TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> Maybe a)]
-> TermBinding
unopDef [(PrimValue -> Maybe PrimValue
getV, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (PrimValue -> PrimValue) -> PrimValue -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimValue -> PrimValue
putV, UnOp -> PrimValue -> Maybe PrimValue
P.doUnOp UnOp
unop)]

      | Just ([PrimType]
pts, PrimType
_, [PrimValue] -> Maybe PrimValue
f) <- String
-> Map
     String ([PrimType], PrimType, [PrimValue] -> Maybe PrimValue)
-> Maybe ([PrimType], PrimType, [PrimValue] -> Maybe PrimValue)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
s Map String ([PrimType], PrimType, [PrimValue] -> Maybe PrimValue)
P.primFuns =
          case [PrimType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimType]
pts of
            Int
1 -> TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ [(PrimValue -> Maybe PrimValue, PrimValue -> Maybe PrimValue,
  PrimValue -> Maybe PrimValue)]
-> TermBinding
forall t a.
[(PrimValue -> Maybe t, a -> Maybe PrimValue, t -> Maybe a)]
-> TermBinding
unopDef [(PrimValue -> Maybe PrimValue
getV, PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just (PrimValue -> Maybe PrimValue)
-> (PrimValue -> PrimValue) -> PrimValue -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimValue -> PrimValue
putV, [PrimValue] -> Maybe PrimValue
f ([PrimValue] -> Maybe PrimValue)
-> (PrimValue -> [PrimValue]) -> PrimValue -> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimValue -> [PrimValue]
forall (f :: * -> *) a. Applicative f => a -> f a
pure)]
            Int
_ -> TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> TermBinding
fun1 ((Value -> EvalM Value) -> TermBinding)
-> (Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
x -> do
              let getV' :: Value -> Maybe PrimValue
getV' (ValuePrim PrimValue
v) = PrimValue -> Maybe PrimValue
forall a. a -> Maybe a
Just PrimValue
v
                  getV' Value
_ = Maybe PrimValue
forall a. Maybe a
Nothing
              case (Value -> Maybe PrimValue) -> [Value] -> Maybe [PrimValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Maybe PrimValue
getV' ([Value] -> Maybe [PrimValue])
-> Maybe [Value] -> Maybe [PrimValue]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> Maybe [Value]
fromTuple Value
x of
                Just [PrimValue]
vs
                  | Just PrimValue
res <- (PrimValue -> PrimValue) -> Maybe PrimValue -> Maybe PrimValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimValue -> PrimValue
putV (Maybe PrimValue -> Maybe PrimValue)
-> ([PrimValue] -> Maybe PrimValue)
-> [PrimValue]
-> Maybe PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PrimValue] -> Maybe PrimValue
f ([PrimValue] -> Maybe PrimValue)
-> Maybe [PrimValue] -> Maybe PrimValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (PrimValue -> Maybe PrimValue) -> [PrimValue] -> Maybe [PrimValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PrimValue -> Maybe PrimValue
getV [PrimValue]
vs -> do
                      [PrimValue] -> PrimValue -> EvalM ()
breakOnNaN [PrimValue]
vs PrimValue
res
                      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
res
                Maybe [PrimValue]
_ ->
                  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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Pretty a => a -> String
pretty String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
x

      | String
"sign_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s =
          TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> TermBinding
fun1 ((Value -> EvalM Value) -> TermBinding)
-> (Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
x ->
          case Value
x of (ValuePrim (UnsignedValue IntValue
x')) ->
                      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
x'
                    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 sign: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
x
      | String
"unsign_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s =
          TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> TermBinding
fun1 ((Value -> EvalM Value) -> TermBinding)
-> (Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
x ->
          case Value
x of (ValuePrim (SignedValue IntValue
x')) ->
                      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
x'
                    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 unsign: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
x

    def String
s | String
"map_stream" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s =
              TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> EvalM Value) -> TermBinding
fun2t Value -> Value -> EvalM Value
stream

    def String
s | String
"reduce_stream" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s =
              TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value -> EvalM Value) -> TermBinding
fun3t ((Value -> Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
_ Value
f Value
arg -> Value -> Value -> EvalM Value
stream Value
f Value
arg

    def String
"map" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ Maybe BoundV -> (StructType -> EvalM Value) -> TermBinding
TermPoly Maybe BoundV
forall a. Maybe a
Nothing ((StructType -> EvalM Value) -> TermBinding)
-> (StructType -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \StructType
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
$ (Value -> EvalM Value) -> Value
ValueFun ((Value -> EvalM Value) -> Value)
-> (Value -> EvalM Value) -> Value
forall a b. (a -> b) -> a -> b
$ \Value
v ->
      case (Value -> Maybe [Value]
fromTuple Value
v, StructType -> ([StructType], StructType)
forall dim as.
TypeBase dim as -> ([TypeBase dim as], TypeBase dim as)
unfoldFunType StructType
t) of
        (Just [Value
f, Value
xs], ([StructType
_], StructType
ret_t))
          | Just ValueShape
rowshape <- StructType -> Maybe ValueShape
typeRowShape StructType
ret_t ->
              ValueShape -> [Value] -> Value
toArray' ValueShape
rowshape ([Value] -> Value) -> EvalM [Value] -> EvalM Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> EvalM Value) -> [Value] -> EvalM [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcLoc -> Env -> Value -> Value -> EvalM Value
apply SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty Value
f) ((ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (ValueShape, [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> (ValueShape, [Value])
fromArray Value
xs)
          | Bool
otherwise ->
              String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Bad return type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ StructType -> String
forall a. Pretty a => a -> String
pretty StructType
ret_t
        (Maybe [Value], ([StructType], StructType))
_ ->
          String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Invalid arguments to map intrinsic:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
          [String] -> String
unlines [StructType -> String
forall a. Pretty a => a -> String
pretty StructType
t, Value -> String
forall a. Pretty a => a -> String
pretty Value
v]
      where typeRowShape :: StructType -> Maybe ValueShape
typeRowShape = Shape (Maybe Int32) -> Maybe ValueShape
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Shape (Maybe Int32) -> Maybe ValueShape)
-> (StructType -> Shape (Maybe Int32))
-> StructType
-> Maybe ValueShape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map VName ValueShape -> StructType -> Shape (Maybe Int32)
structTypeShape Map VName ValueShape
forall a. Monoid a => a
mempty (StructType -> Shape (Maybe Int32))
-> (StructType -> StructType) -> StructType -> Shape (Maybe Int32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> StructType -> StructType
forall dim as. Int -> TypeBase dim as -> TypeBase dim as
stripArray Int
1

    def String
s | String
"reduce" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value -> EvalM Value) -> TermBinding
fun3t ((Value -> Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
f Value
ne Value
xs ->
      (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 -> Value -> EvalM Value
apply2 SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty Value
f) Value
ne ([Value] -> EvalM Value) -> [Value] -> EvalM Value
forall a b. (a -> b) -> a -> b
$ (ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (ValueShape, [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> (ValueShape, [Value])
fromArray Value
xs

    def String
"scan" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value -> EvalM Value) -> TermBinding
fun3t ((Value -> Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
f Value
ne Value
xs -> do
      let next :: ([Value], Value) -> Value -> EvalM ([Value], Value)
next ([Value]
out, Value
acc) Value
x = do
            Value
x' <- SrcLoc -> Env -> Value -> Value -> Value -> EvalM Value
apply2 SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty Value
f Value
acc Value
x
            ([Value], Value) -> EvalM ([Value], Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
x'Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:[Value]
out, Value
x')
      ValueShape -> [Value] -> Value
toArray' (Value -> ValueShape
valueShape Value
ne) ([Value] -> Value)
-> (([Value], Value) -> [Value]) -> ([Value], Value) -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> [Value]
forall a. [a] -> [a]
reverse ([Value] -> [Value])
-> (([Value], Value) -> [Value]) -> ([Value], Value) -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Value], Value) -> [Value]
forall a b. (a, b) -> a
fst (([Value], Value) -> Value)
-> EvalM ([Value], Value) -> EvalM Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (([Value], Value) -> Value -> EvalM ([Value], Value))
-> ([Value], Value) -> [Value] -> EvalM ([Value], Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([Value], Value) -> Value -> EvalM ([Value], Value)
next ([], Value
ne) ((ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (ValueShape, [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> (ValueShape, [Value])
fromArray Value
xs)

    def String
"scatter" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value -> EvalM Value) -> TermBinding
fun3t ((Value -> Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
arr Value
is Value
vs ->
      case Value
arr of
        ValueArray ValueShape
shape Array Int Value
arr' ->
          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 -> 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 -> (Int, Value) -> Array Int Value)
-> Array Int Value -> [(Int, Value)] -> Array Int Value
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Array Int Value -> (Int, Value) -> Array Int Value
update Array Int Value
arr' ([(Int, Value)] -> Array Int Value)
-> [(Int, Value)] -> Array Int Value
forall a b. (a -> b) -> a -> b
$
          [Int] -> [Value] -> [(Int, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Value -> Int) -> [Value] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Int
asInt ([Value] -> [Int]) -> [Value] -> [Int]
forall a b. (a -> b) -> a -> b
$ (ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (ValueShape, [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> (ValueShape, [Value])
fromArray Value
is) ((ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (ValueShape, [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> (ValueShape, [Value])
fromArray Value
vs)
        Value
_ ->
          String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"scatter expects array, but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
arr
      where update :: Array Int Value -> (Int, Value) -> Array Int Value
update Array Int Value
arr' (Int
i, Value
v) =
              if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array Int Value -> Int
forall int. Integral int => Array Int Value -> int
arrayLength Array Int Value
arr'
              then 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)] else Array Int Value
arr'

    def String
"hist" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value -> Value -> Value -> Value -> EvalM Value)
-> TermBinding
fun6t ((Value
  -> Value -> Value -> Value -> Value -> Value -> EvalM Value)
 -> TermBinding)
-> (Value
    -> Value -> Value -> Value -> Value -> Value -> EvalM Value)
-> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
_ Value
arr Value
fun Value
_ Value
is Value
vs ->
      case Value
arr of
        ValueArray ValueShape
shape Array Int Value
arr' ->
          ValueShape -> Array Int Value -> Value
ValueArray ValueShape
shape (Array Int Value -> Value)
-> EvalM (Array Int Value) -> EvalM Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Array Int Value -> (Int, Value) -> EvalM (Array Int Value))
-> Array Int Value -> [(Int, Value)] -> EvalM (Array Int Value)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Value -> Array Int Value -> (Int, Value) -> EvalM (Array Int Value)
update Value
fun) Array Int Value
arr'
          ([Int] -> [Value] -> [(Int, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Value -> Int) -> [Value] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Int
asInt ([Value] -> [Int]) -> [Value] -> [Int]
forall a b. (a -> b) -> a -> b
$ (ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (ValueShape, [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> (ValueShape, [Value])
fromArray Value
is) ((ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (ValueShape, [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> (ValueShape, [Value])
fromArray Value
vs))
        Value
_ ->
          String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"hist expects array, but got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
arr
      where update :: Value -> Array Int Value -> (Int, Value) -> EvalM (Array Int Value)
update Value
fun Array Int Value
arr' (Int
i, Value
v) =
              if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array Int Value -> Int
forall int. Integral int => Array Int Value -> int
arrayLength Array Int Value
arr'
              then do
                Value
v' <- SrcLoc -> Env -> Value -> Value -> Value -> EvalM Value
apply2 SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty Value
fun (Array Int Value
arr' Array Int Value -> Int -> Value
forall i e. Ix i => Array i e -> i -> e
! Int
i) Value
v
                Array Int Value -> EvalM (Array Int Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Array Int Value -> EvalM (Array Int Value))
-> Array Int Value -> EvalM (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
v')]
              else Array Int Value -> EvalM (Array Int Value)
forall (m :: * -> *) a. Monad m => a -> m a
return Array Int Value
arr'

    def String
"partition" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value -> EvalM Value) -> TermBinding
fun3t ((Value -> Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
k Value
f Value
xs -> do
      let (ShapeDim Int32
_ ValueShape
rowshape, [Value]
xs') = Value -> (ValueShape, [Value])
fromArray Value
xs

          next :: [[Value]] -> Value -> EvalM [[Value]]
next [[Value]]
outs Value
x = do
            Int
i <- Value -> Int
asInt (Value -> Int) -> EvalM Value -> EvalM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
            [[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
$ Int -> Value -> [[Value]] -> [[Value]]
forall t t. (Eq t, Num t) => t -> t -> [[t]] -> [[t]]
insertAt Int
i Value
x [[Value]]
outs
          pack :: [[Value]] -> Value
pack [[Value]]
parts =
            [Value] -> Value
toTuple [ValueShape -> [Value] -> Value
toArray' ValueShape
rowshape ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ [[Value]] -> [Value]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Value]]
parts,
                     ValueShape -> [Value] -> Value
toArray' ValueShape
rowshape ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$
                     ([Value] -> Value) -> [[Value]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (PrimValue -> Value
ValuePrim (PrimValue -> Value) -> ([Value] -> PrimValue) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntValue -> PrimValue
SignedValue (IntValue -> PrimValue)
-> ([Value] -> IntValue) -> [Value] -> PrimValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> IntValue
Int32Value (Int32 -> IntValue) -> ([Value] -> Int32) -> [Value] -> IntValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Int32
forall i a. Num i => [a] -> i
genericLength) [[Value]]
parts]

      [[Value]] -> Value
pack ([[Value]] -> Value)
-> ([[Value]] -> [[Value]]) -> [[Value]] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Value] -> [Value]) -> [[Value]] -> [[Value]]
forall a b. (a -> b) -> [a] -> [b]
map [Value] -> [Value]
forall a. [a] -> [a]
reverse ([[Value]] -> Value) -> EvalM [[Value]] -> EvalM Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ([[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 [[Value]] -> Value -> EvalM [[Value]]
next (Int -> [Value] -> [[Value]]
forall a. Int -> a -> [a]
replicate (Value -> Int
asInt Value
k) []) [Value]
xs'
      where insertAt :: t -> t -> [[t]] -> [[t]]
insertAt t
0 t
x ([t]
l:[[t]]
ls) = (t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
l)[t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
:[[t]]
ls
            insertAt t
i t
x ([t]
l:[[t]]
ls) = [t]
l[t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
:t -> t -> [[t]] -> [[t]]
insertAt (t
it -> t -> t
forall a. Num a => a -> a -> a
-t
1) t
x [[t]]
ls
            insertAt t
_ t
_ [[t]]
ls = [[t]]
ls

    def String
"unzip" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> TermBinding
fun1 ((Value -> EvalM Value) -> TermBinding)
-> (Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
x -> do
      let ShapeDim Int32
_ (ShapeRecord Map Name ValueShape
fs) = Value -> ValueShape
valueShape Value
x
          Just [ValueShape
xs_shape, ValueShape
ys_shape] = Map Name ValueShape -> Maybe [ValueShape]
forall a. Map Name a -> Maybe [a]
areTupleFields Map Name ValueShape
fs
          listPair :: ([Value], [Value]) -> [Value]
listPair ([Value]
xs, [Value]
ys) =
            [ValueShape -> [Value] -> Value
toArray' ValueShape
xs_shape [Value]
xs, ValueShape -> [Value] -> Value
toArray' ValueShape
ys_shape [Value]
ys]

      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] -> Value
toTuple ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ ([Value], [Value]) -> [Value]
listPair (([Value], [Value]) -> [Value]) -> ([Value], [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ [(Value, Value)] -> ([Value], [Value])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Value, Value)] -> ([Value], [Value]))
-> [(Value, Value)] -> ([Value], [Value])
forall a b. (a -> b) -> a -> b
$ (Value -> (Value, Value)) -> [Value] -> [(Value, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe [Value] -> (Value, Value)
forall b. Pretty b => Maybe [b] -> (b, b)
fromPair (Maybe [Value] -> (Value, Value))
-> (Value -> Maybe [Value]) -> Value -> (Value, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe [Value]
fromTuple) ([Value] -> [(Value, Value)]) -> [Value] -> [(Value, Value)]
forall a b. (a -> b) -> a -> b
$ (ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (ValueShape, [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> (ValueShape, [Value])
fromArray Value
x
      where fromPair :: Maybe [b] -> (b, b)
fromPair (Just [b
x,b
y]) = (b
x,b
y)
            fromPair Maybe [b]
l = String -> (b, b)
forall a. HasCallStack => String -> a
error (String -> (b, b)) -> String -> (b, b)
forall a b. (a -> b) -> a -> b
$ String
"Not a pair: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe [b] -> String
forall a. Pretty a => a -> String
pretty Maybe [b]
l

    def String
"zip" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> EvalM Value) -> TermBinding
fun2t ((Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
xs Value
ys -> do
      let ShapeDim Int32
_ ValueShape
xs_rowshape = Value -> ValueShape
valueShape Value
xs
          ShapeDim Int32
_ ValueShape
ys_rowshape = Value -> ValueShape
valueShape Value
ys
      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' (Map Name ValueShape -> ValueShape
forall d. Map Name (Shape d) -> Shape d
ShapeRecord ([ValueShape] -> Map Name ValueShape
forall a. [a] -> Map Name a
tupleFields [ValueShape
xs_rowshape, ValueShape
ys_rowshape])) ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$
        ([Value] -> Value) -> [[Value]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map [Value] -> Value
toTuple ([[Value]] -> [Value]) -> [[Value]] -> [Value]
forall a b. (a -> b) -> a -> b
$ [[Value]] -> [[Value]]
forall a. [[a]] -> [[a]]
transpose [(ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (ValueShape, [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> (ValueShape, [Value])
fromArray Value
xs, (ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (ValueShape, [Value]) -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> (ValueShape, [Value])
fromArray Value
ys]

    def String
"concat" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> EvalM Value) -> TermBinding
fun2t ((Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
xs Value
ys -> do
      let (ShapeDim Int32
_ ValueShape
rowshape, [Value]
xs') = Value -> (ValueShape, [Value])
fromArray Value
xs
          (ValueShape
_, [Value]
ys') = Value -> (ValueShape, [Value])
fromArray Value
ys
      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
rowshape ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ [Value]
xs' [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value]
ys'

    def String
"transpose" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> TermBinding
fun1 ((Value -> EvalM Value) -> TermBinding)
-> (Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
xs -> do
      let (ShapeDim Int32
n (ShapeDim Int32
m ValueShape
shape), [Value]
xs') = Value -> (ValueShape, [Value])
fromArray Value
xs
      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 (Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int32
m (Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int32
n ValueShape
shape)) ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$
        ([Value] -> Value) -> [[Value]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (ValueShape -> [Value] -> Value
toArray (Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int32
n ValueShape
shape)) ([[Value]] -> [Value]) -> [[Value]] -> [Value]
forall a b. (a -> b) -> a -> b
$ [[Value]] -> [[Value]]
forall a. [[a]] -> [[a]]
transpose ([[Value]] -> [[Value]]) -> [[Value]] -> [[Value]]
forall a b. (a -> b) -> a -> b
$ (Value -> [Value]) -> [Value] -> [[Value]]
forall a b. (a -> b) -> [a] -> [b]
map ((ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (Value -> (ValueShape, [Value])) -> Value -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> (ValueShape, [Value])
fromArray) [Value]
xs'

    def String
"rotate" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> EvalM Value) -> TermBinding
fun2t ((Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
i Value
xs -> do
      let (ValueShape
shape, [Value]
xs') = Value -> (ValueShape, [Value])
fromArray Value
xs
      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
$
        if Value -> Int
asInt Value
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then let ([Value]
bef, [Value]
aft) = Int -> [Value] -> ([Value], [Value])
forall a. Int -> [a] -> ([a], [a])
splitAt (Value -> Int
asInt Value
i) [Value]
xs'
             in ValueShape -> [Value] -> Value
toArray ValueShape
shape ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ [Value]
aft [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value]
bef
        else let ([Value]
bef, [Value]
aft) = Int -> [Value] -> ([Value], [Value])
forall a. Int -> [a] -> ([a], [a])
splitFromEnd (-Value -> Int
asInt Value
i) [Value]
xs'
             in ValueShape -> [Value] -> Value
toArray ValueShape
shape ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ [Value]
aft [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value]
bef

    def String
"flatten" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> TermBinding
fun1 ((Value -> EvalM Value) -> TermBinding)
-> (Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
xs -> do
      let (ShapeDim Int32
n (ShapeDim Int32
m ValueShape
shape), [Value]
xs') = Value -> (ValueShape, [Value])
fromArray Value
xs
      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 (Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim (Int32
nInt32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
*Int32
m) ValueShape
shape) ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> [Value]) -> [Value] -> [Value]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((ValueShape, [Value]) -> [Value]
forall a b. (a, b) -> b
snd ((ValueShape, [Value]) -> [Value])
-> (Value -> (ValueShape, [Value])) -> Value -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> (ValueShape, [Value])
fromArray) [Value]
xs'

    def String
"unflatten" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value -> EvalM Value) -> TermBinding
fun3t ((Value -> Value -> Value -> EvalM Value) -> TermBinding)
-> (Value -> Value -> Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
n Value
m Value
xs -> do
      let (ShapeDim Int32
_ ValueShape
innershape, [Value]
xs') = Value -> (ValueShape, [Value])
fromArray Value
xs
          rowshape :: ValueShape
rowshape = Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim (Value -> Int32
asInt32 Value
m) ValueShape
innershape
          shape :: ValueShape
shape = Int32 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim (Value -> Int32
asInt32 Value
n) ValueShape
rowshape
      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
shape ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ ([Value] -> Value) -> [[Value]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (ValueShape -> [Value] -> Value
toArray ValueShape
rowshape) ([[Value]] -> [Value]) -> [[Value]] -> [Value]
forall a b. (a -> b) -> a -> b
$ Int -> [Value] -> [[Value]]
forall a. Int -> [a] -> [[a]]
chunk (Value -> Int
asInt Value
m) [Value]
xs'

    def String
"opaque" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> TermBinding
fun1 Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return

    def String
"trace" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> TermBinding
fun1 ((Value -> EvalM Value) -> TermBinding)
-> (Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
v -> Value -> EvalM ()
trace Value
v EvalM () -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v

    def String
"break" = TermBinding -> Maybe TermBinding
forall a. a -> Maybe a
Just (TermBinding -> Maybe TermBinding)
-> TermBinding -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ (Value -> EvalM Value) -> TermBinding
fun1 ((Value -> EvalM Value) -> TermBinding)
-> (Value -> EvalM Value) -> TermBinding
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
      EvalM ()
break
      Value -> EvalM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v

    def String
s | String -> Name
nameFromString String
s Name -> Map Name PrimType -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Name PrimType
namesToPrimTypes = Maybe TermBinding
forall a. Maybe a
Nothing

    def String
s = String -> Maybe TermBinding
forall a. HasCallStack => String -> a
error (String -> Maybe TermBinding) -> String -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ String
"Missing intrinsic: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

    tdef :: String -> Maybe TypeBinding
tdef String
s = do
      PrimType
t <- String -> Name
nameFromString String
s Name -> Map Name PrimType -> Maybe PrimType
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name PrimType
namesToPrimTypes
      TypeBinding -> Maybe TypeBinding
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeBinding -> Maybe TypeBinding)
-> TypeBinding -> Maybe TypeBinding
forall a b. (a -> b) -> a -> b
$ Liftedness -> [TypeParam] -> StructType -> TypeBinding
T.TypeAbbr Liftedness
Unlifted [] (StructType -> TypeBinding) -> StructType -> TypeBinding
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
t

    stream :: Value -> Value -> EvalM Value
stream Value
f arg :: Value
arg@(ValueArray ValueShape
_ Array Int Value
xs) =
      let n :: Value
n = 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 -> IntValue) -> Int32 -> IntValue
forall a b. (a -> b) -> a -> b
$ Array Int Value -> Int32
forall int. Integral int => Array Int Value -> int
arrayLength Array Int Value
xs
      in SrcLoc -> Env -> Value -> Value -> Value -> EvalM Value
apply2 SrcLoc
forall a. IsLocation a => a
noLoc Env
forall a. Monoid a => a
mempty Value
f Value
n Value
arg
    stream Value
_ Value
arg = String -> EvalM Value
forall a. HasCallStack => String -> a
error (String -> EvalM Value) -> String -> EvalM Value
forall a b. (a -> b) -> a -> b
$ String
"Cannot stream: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Pretty a => a -> String
pretty Value
arg


interpretExp :: Ctx -> Exp -> F ExtOp Value
interpretExp :: Ctx -> ExpBase Info VName -> F ExtOp Value
interpretExp Ctx
ctx ExpBase Info VName
e = Map String Env -> EvalM Value -> F ExtOp Value
forall a. Map String Env -> EvalM a -> F ExtOp a
runEvalM (Ctx -> Map String Env
ctxImports Ctx
ctx) (EvalM Value -> F ExtOp Value) -> EvalM Value -> F ExtOp Value
forall a b. (a -> b) -> a -> b
$ Env -> ExpBase Info VName -> EvalM Value
eval (Ctx -> Env
ctxEnv Ctx
ctx) ExpBase Info VName
e

interpretDec :: Ctx -> Dec -> F ExtOp Ctx
interpretDec :: Ctx -> DecBase Info VName -> F ExtOp Ctx
interpretDec Ctx
ctx DecBase Info VName
d = do
  Env
env <- Map String Env -> EvalM Env -> F ExtOp Env
forall a. Map String Env -> EvalM a -> F ExtOp a
runEvalM (Ctx -> Map String Env
ctxImports Ctx
ctx) (EvalM Env -> F ExtOp Env) -> EvalM Env -> F ExtOp Env
forall a b. (a -> b) -> a -> b
$ Env -> DecBase Info VName -> EvalM Env
evalDec (Ctx -> Env
ctxEnv Ctx
ctx) DecBase Info VName
d
  Ctx -> F ExtOp Ctx
forall (m :: * -> *) a. Monad m => a -> m a
return Ctx
ctx { ctxEnv :: Env
ctxEnv = Env
env }

interpretImport :: Ctx -> (FilePath, Prog) -> F ExtOp Ctx
interpretImport :: Ctx -> (String, Prog) -> F ExtOp Ctx
interpretImport Ctx
ctx (String
fp, Prog
prog) = do
  Env
env <- Map String Env -> EvalM Env -> F ExtOp Env
forall a. Map String Env -> EvalM a -> F ExtOp a
runEvalM (Ctx -> Map String Env
ctxImports Ctx
ctx) (EvalM Env -> F ExtOp Env) -> EvalM Env -> F ExtOp Env
forall a b. (a -> b) -> a -> b
$ (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 (Ctx -> Env
ctxEnv Ctx
ctx) ([DecBase Info VName] -> EvalM Env)
-> [DecBase Info VName] -> EvalM Env
forall a b. (a -> b) -> a -> b
$ Prog -> [DecBase Info VName]
forall (f :: * -> *) vn. ProgBase f vn -> [DecBase f vn]
progDecs Prog
prog
  Ctx -> F ExtOp Ctx
forall (m :: * -> *) a. Monad m => a -> m a
return Ctx
ctx { ctxImports :: Map String Env
ctxImports = String -> Env -> Map String Env -> Map String Env
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
fp Env
env (Map String Env -> Map String Env)
-> Map String Env -> Map String Env
forall a b. (a -> b) -> a -> b
$ Ctx -> Map String Env
ctxImports Ctx
ctx }

checkEntryArgs :: VName -> [F.Value] -> StructType -> Either String ()
checkEntryArgs :: VName -> [Value] -> StructType -> Either String ()
checkEntryArgs VName
entry [Value]
args StructType
entry_t
  | [StructType]
args_ts [StructType] -> [StructType] -> Bool
forall a. Eq a => a -> a -> Bool
== [StructType]
param_ts =
      () -> Either String ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise =
      String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Pretty a => a -> String
pretty (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Doc
expected Doc -> Doc -> Doc
</>
      Doc
"Got input of types" Doc -> Doc -> Doc
</>
      Int -> Doc -> Doc
indent Int
2 ([Doc] -> Doc
stack ((StructType -> Doc) -> [StructType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> Doc
forall a. Pretty a => a -> Doc
ppr [StructType]
args_ts))
  where ([StructType]
param_ts, StructType
_) = StructType -> ([StructType], StructType)
forall dim as.
TypeBase dim as -> ([TypeBase dim as], TypeBase dim as)
unfoldFunType StructType
entry_t
        args_ts :: [StructType]
args_ts = (Value -> StructType) -> [Value] -> [StructType]
forall a b. (a -> b) -> [a] -> [b]
map (ValueType -> StructType
valueStructType (ValueType -> StructType)
-> (Value -> ValueType) -> Value -> StructType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueType
valueType) [Value]
args
        expected :: Doc
expected
          | [StructType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StructType]
param_ts =
              Doc
"Entry point " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
pquote (VName -> Doc
forall v. IsName v => v -> Doc
pprName VName
entry) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" is not a function."
          | Bool
otherwise =
              Doc
"Entry point " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
pquote (VName -> Doc
forall v. IsName v => v -> Doc
pprName VName
entry) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" expects input of type(s)" Doc -> Doc -> Doc
</>
              Int -> Doc -> Doc
indent Int
2 ([Doc] -> Doc
stack ((StructType -> Doc) -> [StructType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> Doc
forall a. Pretty a => a -> Doc
ppr [StructType]
param_ts))

-- | Execute the named function on the given arguments; may fail
-- horribly if these are ill-typed.
interpretFunction :: Ctx -> VName -> [F.Value] -> Either String (F ExtOp Value)
interpretFunction :: Ctx -> VName -> [Value] -> Either String (F ExtOp Value)
interpretFunction Ctx
ctx VName
fname [Value]
vs = do
  StructType
ft <- case QualName VName -> Env -> Maybe TermBinding
lookupVar (VName -> QualName VName
forall v. v -> QualName v
qualName VName
fname) (Env -> Maybe TermBinding) -> Env -> Maybe TermBinding
forall a b. (a -> b) -> a -> b
$ Ctx -> Env
ctxEnv Ctx
ctx of
          Just (TermValue (Just (T.BoundV [TypeParam]
_ StructType
t)) Value
_) ->
            StructType -> Either String StructType
forall a b. b -> Either a b
Right (StructType -> Either String StructType)
-> StructType -> Either String StructType
forall a b. (a -> b) -> a -> b
$ [ValueType] -> StructType -> StructType
updateType ((Value -> ValueType) -> [Value] -> [ValueType]
forall a b. (a -> b) -> [a] -> [b]
map Value -> ValueType
valueType [Value]
vs) StructType
t
          Just (TermPoly (Just (T.BoundV [TypeParam]
_ StructType
t)) StructType -> EvalM Value
_) ->
            StructType -> Either String StructType
forall a b. b -> Either a b
Right (StructType -> Either String StructType)
-> StructType -> Either String StructType
forall a b. (a -> b) -> a -> b
$ [ValueType] -> StructType -> StructType
updateType ((Value -> ValueType) -> [Value] -> [ValueType]
forall a b. (a -> b) -> [a] -> [b]
map Value -> ValueType
valueType [Value]
vs) StructType
t
          Maybe TermBinding
_ ->
            String -> Either String StructType
forall a b. a -> Either a b
Left (String -> Either String StructType)
-> String -> Either String StructType
forall a b. (a -> b) -> a -> b
$ String
"Unknown function `" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> VName -> String
forall v. IsName v => v -> String
prettyName VName
fname String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"`."

  [Value]
vs' <- case (Value -> Maybe Value) -> [Value] -> Maybe [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Maybe Value
convertValue [Value]
vs of
           Just [Value]
vs' -> [Value] -> Either String [Value]
forall a b. b -> Either a b
Right [Value]
vs'
           Maybe [Value]
Nothing -> String -> Either String [Value]
forall a b. a -> Either a b
Left String
"Invalid input: irregular array."

  VName -> [Value] -> StructType -> Either String ()
checkEntryArgs VName
fname [Value]
vs StructType
ft

  F ExtOp Value -> Either String (F ExtOp Value)
forall a b. b -> Either a b
Right (F ExtOp Value -> Either String (F ExtOp Value))
-> F ExtOp Value -> Either String (F ExtOp Value)
forall a b. (a -> b) -> a -> b
$ Map String Env -> EvalM Value -> F ExtOp Value
forall a. Map String Env -> EvalM a -> F ExtOp a
runEvalM (Ctx -> Map String Env
ctxImports Ctx
ctx) (EvalM Value -> F ExtOp Value) -> EvalM Value -> F ExtOp Value
forall a b. (a -> b) -> a -> b
$ do
    Value
f <- Env -> QualName VName -> StructType -> EvalM Value
evalTermVar (Ctx -> Env
ctxEnv Ctx
ctx) (VName -> QualName VName
forall v. v -> QualName v
qualName VName
fname) StructType
ft
    (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]
vs'

  where updateType :: [ValueType] -> StructType -> StructType
updateType (ValueType
vt:[ValueType]
vts) (Scalar (Arrow ()
als PName
u StructType
_ StructType
rt)) =
          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 ()
als PName
u (ValueType -> StructType
valueStructType ValueType
vt) (StructType -> ScalarTypeBase (DimDecl VName) ())
-> StructType -> ScalarTypeBase (DimDecl VName) ()
forall a b. (a -> b) -> a -> b
$ [ValueType] -> StructType -> StructType
updateType [ValueType]
vts StructType
rt
        updateType [ValueType]
_ StructType
t = StructType
t

        convertValue :: Value -> Maybe Value
convertValue (F.PrimValue PrimValue
p) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ PrimValue -> Value
ValuePrim PrimValue
p
        convertValue (F.ArrayValue Array Int Value
arr ValueType
t) = ValueType -> [Value] -> Maybe Value
mkArray ValueType
t ([Value] -> Maybe Value) -> Maybe [Value] -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Value -> Maybe Value) -> [Value] -> Maybe [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Maybe Value
convertValue (Array Int Value -> [Value]
forall i e. Array i e -> [e]
elems Array Int Value
arr)