{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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.Except
import Control.Monad.Free.Church
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.Array
import Data.Bifunctor (first, second)
import Data.List
  ( find,
    foldl',
    genericLength,
    intercalate,
    isPrefixOf,
    transpose,
  )
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid hiding (Sum)
import Futhark.IR.Primitive (floatValue, intValue)
import qualified Futhark.IR.Primitive as P
import Futhark.Util (chunk, maybeHead, splitFromEnd)
import Futhark.Util.Loc
import Futhark.Util.Pretty hiding (apply, bool)
import Language.Futhark hiding (Value, matchDims)
import qualified Language.Futhark as F
import qualified Language.Futhark.Semantic as T
import Prelude hiding (break, mod)

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
  = -- | An explicit breakpoint in the program.
    BreakPoint
  | -- | A
    BreakNaN

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 Int64

-- | 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
s StackFrame -> [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 -> Int64 -> EvalM ()
putExtSize :: VName -> Int64 -> EvalM ()
putExtSize VName
v Int64
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 -> Int64 -> Sizes -> Sizes
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v Int64
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
i64Env (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 = (Int64 -> 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) -> (Int64 -> Int) -> Int64 -> DimDecl VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> 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 Int64

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 Int64
d ValueShape
s) = Int64
d Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
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 Int64)
structTypeShape :: Map VName ValueShape -> StructType -> Shape (Maybe Int64)
structTypeShape Map VName ValueShape
shapes = (DimDecl VName -> Maybe Int64)
-> Shape (DimDecl VName) -> Shape (Maybe Int64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DimDecl VName -> Maybe Int64
forall a vn. Num a => DimDecl vn -> Maybe a
dim (Shape (DimDecl VName) -> Shape (Maybe Int64))
-> (StructType -> Shape (DimDecl VName))
-> StructType
-> Shape (Maybe Int64)
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 ((Int64 -> DimDecl vn) -> ValueShape -> Shape (DimDecl vn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int64 -> DimDecl vn) -> ValueShape -> Shape (DimDecl vn))
-> (Int64 -> 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) -> (Int64 -> Int) -> Int64 -> DimDecl vn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> 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
i64Env (Sizes -> Env) -> Sizes -> Env
forall a b. (a -> b) -> a -> b
$ VName -> Int64 -> Sizes
forall k a. k -> a -> Map k a
M.singleton VName
d1 (Int64 -> Sizes) -> Int64 -> Sizes
forall a b. (a -> b) -> a -> b
$ Int -> Int64
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 Int64
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 (SignedValue IntValue
x) == :: Value -> Value -> Bool
== ValuePrim (SignedValue IntValue
y) =
    PrimValue -> PrimValue -> Bool
P.doCmpEq (IntValue -> PrimValue
P.IntValue IntValue
x) (IntValue -> PrimValue
P.IntValue IntValue
y)
  ValuePrim (UnsignedValue IntValue
x) == ValuePrim (UnsignedValue IntValue
y) =
    PrimValue -> PrimValue -> Bool
P.doCmpEq (IntValue -> PrimValue
P.IntValue IntValue
x) (IntValue -> PrimValue
P.IntValue IntValue
y)
  ValuePrim (FloatValue FloatValue
x) == ValuePrim (FloatValue FloatValue
y) =
    PrimValue -> PrimValue -> Bool
P.doCmpEq (FloatValue -> PrimValue
P.FloatValue FloatValue
x) (FloatValue -> PrimValue
P.FloatValue FloatValue
y)
  ValuePrim (BoolValue Bool
x) == ValuePrim (BoolValue Bool
y) =
    PrimValue -> PrimValue -> Bool
P.doCmpEq (Bool -> PrimValue
P.BoolValue Bool
x) (Bool -> PrimValue
P.BoolValue Bool
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 = Int -> Value -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0
  pprPrec :: Int -> Value -> Doc
pprPrec Int
_ (ValuePrim PrimValue
v) = PrimValue -> Doc
forall a. Pretty a => a -> Doc
ppr PrimValue
v
  pprPrec Int
_ (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)
  pprPrec Int
_ (ValueRecord Map Name Value
m) = Map Name Value -> Doc
forall a. Pretty a => Map Name a -> Doc
prettyRecord Map Name Value
m
  pprPrec Int
_ ValueFun {} = String -> Doc
text String
"#<fun>"
  pprPrec Int
p (ValueSum ValueShape
_ Name
n [Value]
vs) =
    Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (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
<> [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 (Int -> Value -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
1) [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 Int64) -> ValueShape -> Maybe ValueShape
checkShape :: Shape (Maybe Int64) -> ValueShape -> Maybe ValueShape
checkShape (ShapeDim Maybe Int64
Nothing Shape (Maybe Int64)
shape1) (ShapeDim Int64
d2 ValueShape
shape2) =
  Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int64
d2 (ValueShape -> ValueShape) -> Maybe ValueShape -> Maybe ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Shape (Maybe Int64) -> ValueShape -> Maybe ValueShape
checkShape Shape (Maybe Int64)
shape1 ValueShape
shape2
checkShape (ShapeDim (Just Int64
d1) Shape (Maybe Int64)
shape1) (ShapeDim Int64
d2 ValueShape
shape2) = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int64
d1 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
d2
  Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int64
d2 (ValueShape -> ValueShape) -> Maybe ValueShape -> Maybe ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Shape (Maybe Int64) -> ValueShape -> Maybe ValueShape
checkShape Shape (Maybe Int64)
shape1 ValueShape
shape2
checkShape (ShapeDim Maybe Int64
d1 Shape (Maybe Int64)
shape1) ValueShape
ShapeLeaf =
  -- This case is for handling polymorphism, when a function doesn't
  -- know that the array it produced actually has more dimensions.
  Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim (Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe Int64
0 Maybe Int64
d1) (ValueShape -> ValueShape) -> Maybe ValueShape -> Maybe ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Shape (Maybe Int64) -> ValueShape -> Maybe ValueShape
checkShape Shape (Maybe Int64)
shape1 ValueShape
forall d. Shape d
ShapeLeaf
checkShape (ShapeRecord Map Name (Shape (Maybe Int64))
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 Int64) -> ValueShape -> Maybe ValueShape)
-> Map Name (Shape (Maybe Int64))
-> 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 Int64) -> ValueShape -> Maybe ValueShape
checkShape Map Name (Shape (Maybe Int64))
shapes1 Map Name ValueShape
shapes2)
checkShape (ShapeRecord Map Name (Shape (Maybe Int64))
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
$ Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe Int64
0 (Maybe Int64 -> Int64) -> Shape (Maybe Int64) -> ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (Shape (Maybe Int64)) -> Shape (Maybe Int64)
forall d. Map Name (Shape d) -> Shape d
ShapeRecord Map Name (Shape (Maybe Int64))
shapes1
checkShape (ShapeSum Map Name [Shape (Maybe Int64)]
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 Int64)] -> [ValueShape] -> Maybe [ValueShape])
-> Map Name [Shape (Maybe Int64)]
-> 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 Int64) -> ValueShape -> Maybe ValueShape)
-> [Shape (Maybe Int64)] -> [ValueShape] -> Maybe [ValueShape]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Shape (Maybe Int64) -> ValueShape -> Maybe ValueShape
checkShape) Map Name [Shape (Maybe Int64)]
shapes1 Map Name [ValueShape]
shapes2)
checkShape (ShapeSum Map Name [Shape (Maybe Int64)]
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
$ Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe Int64
0 (Maybe Int64 -> Int64) -> Shape (Maybe Int64) -> ValueShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name [Shape (Maybe Int64)] -> Shape (Maybe Int64)
forall d. Map Name [Shape d] -> Shape d
ShapeSum Map Name [Shape (Maybe Int64)]
shapes1
checkShape Shape (Maybe Int64)
_ 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 Int64 () -> [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
v Value -> [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

asInt64 :: Value -> Int64
asInt64 :: Value -> Int64
asInt64 = Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> (Value -> Integer) -> Value -> Int64
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
  | -- | A polymorphic value that must be instantiated.
    TermPoly (Maybe T.BoundV) (StructType -> EvalM Value)
  | 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,
    -- | A mapping from type parameters to the shapes of
    -- the value to which they were initially bound.
    Env -> Map VName ValueShape
envShapes :: M.Map VName ValueShape
  }

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 []

i64Env :: M.Map VName Int64 -> Env
i64Env :: Sizes -> Env
i64Env = 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
. (Int64 -> (Maybe BoundV, Value))
-> Sizes -> Map VName (Maybe BoundV, Value)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Int64 -> (Maybe BoundV, Value)
f
  where
    f :: Int64 -> (Maybe BoundV, Value)
f Int64
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
Int64,
        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
$ Int64 -> IntValue
Int64Value Int64
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 = Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim ([Value] -> Int64
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 PatLit
l Info PatternType
t SrcLoc
_) Value
v = do
  Value
l' <- case PatLit
l of
    PatLitInt Integer
x -> 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 -> Exp -> EvalM Value
eval Env
env (Exp -> EvalM Value) -> Exp -> EvalM Value
forall a b. (a -> b) -> a -> b
$ Integer -> Info PatternType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
Integer -> f PatternType -> SrcLoc -> ExpBase f vn
IntLit Integer
x Info PatternType
t SrcLoc
forall a. Monoid a => a
mempty
    PatLitFloat Double
x -> 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 -> Exp -> EvalM Value
eval Env
env (Exp -> EvalM Value) -> Exp -> EvalM Value
forall a b. (a -> b) -> a -> b
$ Double -> Info PatternType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
Double -> f PatternType -> SrcLoc -> ExpBase f vn
FloatLit Double
x Info PatternType
t SrcLoc
forall a. Monoid a => a
mempty
    PatLitPrim PrimValue
lv -> Value -> MaybeT EvalM Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> MaybeT EvalM Value) -> Value -> MaybeT EvalM Value
forall a b. (a -> b) -> a -> b
$ PrimValue -> Value
ValuePrim PrimValue
lv
  if Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
l'
    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 Int64
  | IndexingSlice (Maybe Int64) (Maybe Int64) (Maybe Int64)

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

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

    slice :: (Int64, Int64, Int64)
slice =
      case (Maybe Int64
start, Maybe Int64
end, Maybe Int64
stride) of
        (Just Int64
start', Maybe Int64
_, Maybe Int64
_) ->
          let end' :: Int64
end' = Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe Int64
n Maybe Int64
end
           in (Int64
start', Int64
end', Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe Int64
1 Maybe Int64
stride)
        (Maybe Int64
Nothing, Just Int64
end', Maybe Int64
_) ->
          let start' :: Int64
start' = Int64
0
           in (Int64
start', Int64
end', Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe Int64
1 Maybe Int64
stride)
        (Maybe Int64
Nothing, Maybe Int64
Nothing, Just Int64
stride') ->
          ( if Int64
stride' Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0 then Int64
0 else Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
-Int64
1,
            if Int64
stride' Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0 then Int64
n else -Int64
1,
            Int64
stride'
          )
        (Maybe Int64
Nothing, Maybe Int64
Nothing, Maybe Int64
Nothing) ->
          (Int64
0, Int64
n, Int64
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 Int64
_ ValueShape
shape) =
  [Indexing] -> ValueShape -> ValueShape
indexShape [Indexing]
is ValueShape
shape
indexShape (IndexingSlice Maybe Int64
start Maybe Int64
end Maybe Int64
stride : [Indexing]
is) (ShapeDim Int64
d ValueShape
shape) =
  Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int64
n (ValueShape -> ValueShape) -> ValueShape -> ValueShape
forall a b. (a -> b) -> a -> b
$ [Indexing] -> ValueShape -> ValueShape
indexShape [Indexing]
is ValueShape
shape
  where
    n :: Int64
n = Int64 -> ([Int] -> Int64) -> Maybe [Int] -> Int64
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int64
0 [Int] -> Int64
forall i a. Num i => [a] -> i
genericLength (Maybe [Int] -> Int64) -> Maybe [Int] -> Int64
forall a b. (a -> b) -> a -> b
$ Maybe Int64 -> Maybe Int64 -> Maybe Int64 -> Int64 -> Maybe [Int]
indexesFor Maybe Int64
start Maybe Int64
end Maybe Int64
stride Int64
d
indexShape [Indexing]
_ ValueShape
shape =
  ValueShape
shape

indexArray :: [Indexing] -> Value -> Maybe Value
indexArray :: [Indexing] -> Value -> Maybe Value
indexArray (IndexingFix Int64
i : [Indexing]
is) (ValueArray ValueShape
_ Array Int Value
arr)
  | Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0,
    Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
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
! Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
  | Bool
otherwise =
    Maybe Value
forall a. Maybe a
Nothing
  where
    n :: Int64
n = Array Int Value -> Int64
forall int. Integral int => Array Int Value -> int
arrayLength Array Int Value
arr
indexArray (IndexingSlice Maybe Int64
start Maybe Int64
end Maybe Int64
stride : [Indexing]
is) (ValueArray (ShapeDim Int64
_ ValueShape
rowshape) Array Int Value
arr) = do
  [Int]
js <- Maybe Int64 -> Maybe Int64 -> Maybe Int64 -> Int64 -> Maybe [Int]
indexesFor Maybe Int64
start Maybe Int64
end Maybe Int64
stride (Int64 -> Maybe [Int]) -> Int64 -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ Array Int Value -> Int64
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
arr Array 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 Int64
i : [Indexing]
is) (ValueArray ValueShape
shape Array Int Value
arr) Value
v
  | Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0,
    Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
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 :: Int64
n = Array Int Value -> Int64
forall int. Integral int => Array Int Value -> int
arrayLength Array Int Value
arr
    i' :: Int
i' = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
updateArray (IndexingSlice Maybe Int64
start Maybe Int64
end Maybe Int64
stride : [Indexing]
is) (ValueArray ValueShape
shape Array Int Value
arr) (ValueArray ValueShape
_ Array Int Value
v) = do
  [Int]
arr_is <- Maybe Int64 -> Maybe Int64 -> Maybe Int64 -> Int64 -> Maybe [Int]
indexesFor Maybe Int64
start Maybe Int64
end Maybe Int64
stride (Int64 -> Maybe [Int]) -> Int64 -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ Array Int Value -> Int64
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
arr Array 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 Exp
x) =
  Int64 -> Indexing
IndexingFix (Int64 -> Indexing) -> (Value -> Int64) -> Value -> Indexing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Int64
asInt64 (Value -> Indexing) -> EvalM Value -> EvalM Indexing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Exp -> EvalM Value
eval Env
env Exp
x
evalDimIndex Env
env (DimSlice Maybe Exp
start Maybe Exp
end Maybe Exp
stride) =
  Maybe Int64 -> Maybe Int64 -> Maybe Int64 -> Indexing
IndexingSlice (Maybe Int64 -> Maybe Int64 -> Maybe Int64 -> Indexing)
-> EvalM (Maybe Int64)
-> EvalM (Maybe Int64 -> Maybe Int64 -> Indexing)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> EvalM Int64) -> Maybe Exp -> EvalM (Maybe Int64)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Int64) -> EvalM Value -> EvalM Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Int64
asInt64 (EvalM Value -> EvalM Int64)
-> (Exp -> EvalM Value) -> Exp -> EvalM Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Exp -> EvalM Value
eval Env
env) Maybe Exp
start
    EvalM (Maybe Int64 -> Maybe Int64 -> Indexing)
-> EvalM (Maybe Int64) -> EvalM (Maybe Int64 -> Indexing)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Exp -> EvalM Int64) -> Maybe Exp -> EvalM (Maybe Int64)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Int64) -> EvalM Value -> EvalM Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Int64
asInt64 (EvalM Value -> EvalM Int64)
-> (Exp -> EvalM Value) -> Exp -> EvalM Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Exp -> EvalM Value
eval Env
env) Maybe Exp
end
    EvalM (Maybe Int64 -> Indexing)
-> EvalM (Maybe Int64) -> EvalM Indexing
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Exp -> EvalM Int64) -> Maybe Exp -> EvalM (Maybe Int64)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Int64) -> EvalM Value -> EvalM Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Int64
asInt64 (EvalM Value -> EvalM Int64)
-> (Exp -> EvalM Value) -> Exp -> EvalM Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Exp -> EvalM Value
eval Env
env) Maybe Exp
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 (Int64Value Int64
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
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
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 Int64)
-> 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 Int64
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] -> Exp -> StructType -> EvalM Value
evalFunction Env
env [VName]
_ [] Exp
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
v Value -> [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 -> Exp -> EvalM Value
eval Env
env' Exp
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) Exp
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
i64Env
                  ( [VName] -> StructType -> ValueShape -> Sizes
resolveExistentials
                      [VName]
missing_sizes
                      (Pattern -> StructType
patternStructType Pattern
p)
                      (Value -> ValueShape
valueShape Value
v)
                  )
      Env -> [VName] -> [Pattern] -> Exp -> StructType -> EvalM Value
evalFunction Env
env'' [VName]
missing_sizes [Pattern]
ps Exp
body StructType
rettype

evalFunctionBinding ::
  Env ->
  [TypeParam] ->
  [Pattern] ->
  StructType ->
  [VName] ->
  Exp ->
  EvalM TermBinding
evalFunctionBinding :: Env
-> [TypeParam]
-> [Pattern]
-> StructType
-> [VName]
-> Exp
-> EvalM TermBinding
evalFunctionBinding Env
env [TypeParam]
tparams [Pattern]
ps StructType
ret [VName]
retext Exp
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] -> Exp -> StructType -> EvalM Value
evalFunction Env
env [] [Pattern]
ps Exp
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] -> Exp -> StructType -> EvalM Value
evalFunction Env
env' [VName]
missing_sizes [Pattern]
ps Exp
fbody StructType
ret'

evalArg :: Env -> Exp -> Maybe VName -> EvalM Value
evalArg :: Env -> Exp -> Maybe VName -> EvalM Value
evalArg Env
env Exp
e Maybe VName
ext = do
  Value
v <- Env -> Exp -> EvalM Value
eval Env
env Exp
e
  case Maybe VName
ext of
    Just VName
ext' -> VName -> Int64 -> EvalM ()
putExtSize VName
ext' (Int64 -> EvalM ()) -> Int64 -> EvalM ()
forall a b. (a -> b) -> a -> b
$ Value -> Int64
asInt64 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, Int64) -> EvalM ()) -> [(VName, Int64)] -> EvalM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((VName -> Int64 -> EvalM ()) -> (VName, Int64) -> EvalM ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry VName -> Int64 -> EvalM ()
putExtSize) ([(VName, Int64)] -> EvalM ()) -> [(VName, Int64)] -> EvalM ()
forall a b. (a -> b) -> a -> b
$
    Sizes -> [(VName, Int64)]
forall k a. Map k a -> [(k, a)]
M.toList (Sizes -> [(VName, Int64)]) -> Sizes -> [(VName, Int64)]
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 -> Exp -> 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 Exp
e SrcLoc
_) = Env -> Exp -> EvalM Value
eval Env
env Exp
e
eval Env
env (QualParens (QualName VName
qv, SrcLoc
_) Exp
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 -> Exp -> EvalM Value
eval (Env
m' Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env) Exp
e
eval Env
env (TupLit [Exp]
vs SrcLoc
_) = [Value] -> Value
toTuple ([Value] -> Value) -> EvalM [Value] -> EvalM Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> EvalM Value) -> [Exp] -> EvalM [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> Exp -> EvalM Value
eval Env
env) [Exp]
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 Exp
e SrcLoc
_) = do
      Value
v <- Env -> Exp -> EvalM Value
eval Env
env Exp
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 -> Exp -> EvalM Value
eval Env
env (Exp -> EvalM Value) -> Exp -> EvalM Value
forall a b. (a -> b) -> a -> b
$ QualName VName -> Info PatternType -> SrcLoc -> Exp
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 (Exp
v : [Exp]
vs) Info PatternType
_ SrcLoc
_) = do
  Value
v' <- Env -> Exp -> EvalM Value
eval Env
env Exp
v
  [Value]
vs' <- (Exp -> EvalM Value) -> [Exp] -> EvalM [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> Exp -> EvalM Value
eval Env
env) [Exp]
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 Exp
start Maybe Exp
maybe_second Inclusiveness Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
start
  Maybe Integer
maybe_second' <- (Exp -> EvalM Integer) -> Maybe Exp -> 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)
-> (Exp -> EvalM Value) -> Exp -> EvalM Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Exp -> EvalM Value
eval Env
env) Maybe Exp
maybe_second
  Inclusiveness Integer
end' <- (Exp -> EvalM Integer)
-> Inclusiveness Exp -> 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)
-> (Exp -> EvalM Value) -> Exp -> EvalM Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Exp -> EvalM Value
eval Env
env) Inclusiveness Exp
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
x 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
x)
          (UpToExclusive Integer
x, Just Integer
second') ->
            (Integer
x 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
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 Exp
e TypeDeclBase Info VName
_ SrcLoc
_) = Env -> Exp -> EvalM Value
eval Env
env Exp
e
eval Env
env (Coerce Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
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 Int64) -> ValueShape -> Maybe ValueShape
checkShape (Map VName ValueShape -> StructType -> Shape (Maybe Int64)
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 Exp
e Exp
body (Info PatternType
ret, Info [VName]
retext) SrcLoc
_) = do
  Value
v <- Env -> Exp -> EvalM Value
eval Env
env Exp
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 -> Exp -> EvalM Value
eval Env
env' Exp
body
eval Env
env (LetFun VName
f ([TypeParam]
tparams, [Pattern]
ps, Maybe (TypeExp VName)
_, Info StructType
ret, Exp
fbody) Exp
body Info PatternType
_ SrcLoc
_) = do
  TermBinding
binding <- Env
-> [TypeParam]
-> [Pattern]
-> StructType
-> [VName]
-> Exp
-> EvalM TermBinding
evalFunctionBinding Env
env [TypeParam]
tparams [Pattern]
ps StructType
ret [] Exp
fbody
  Env -> Exp -> 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}) Exp
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
      (Exp
x, Info (StructType
_, Maybe VName
xext))
      (Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
x
      if Bool
x'
        then Env -> Exp -> EvalM Value
eval Env
env Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
y
    | Bool
otherwise = do
      Value
op' <- Env -> Exp -> EvalM Value
eval Env
env (Exp -> EvalM Value) -> Exp -> EvalM Value
forall a b. (a -> b) -> a -> b
$ QualName VName -> Info PatternType -> SrcLoc -> Exp
forall (f :: * -> *) vn.
QualName vn -> f PatternType -> SrcLoc -> ExpBase f vn
Var QualName VName
op Info PatternType
op_t SrcLoc
loc
      Value
x' <- Env -> Exp -> Maybe VName -> EvalM Value
evalArg Env
env Exp
x Maybe VName
xext
      Value
y' <- Env -> Exp -> Maybe VName -> EvalM Value
evalArg Env
env Exp
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 Exp
cond Exp
e1 Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
e1 else Env -> Exp -> EvalM Value
eval Env
env Exp
e2
eval Env
env (Apply Exp
f Exp
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 -> Exp -> Maybe VName -> EvalM Value
evalArg Env
env Exp
x Maybe VName
ext
  Value
f' <- Env -> Exp -> EvalM Value
eval Env
env Exp
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 Exp
e SrcLoc
_) = do
  Value
ev <- Env -> Exp -> EvalM Value
eval Env
env Exp
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 Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
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 Exp
src [DimIndex]
is Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
src EvalM (Value -> Maybe Value) -> EvalM Value -> EvalM (Maybe Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Env -> Exp -> EvalM Value
eval Env
env Exp
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 Exp
src [Name]
all_fs Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
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 Exp
v Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
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 -> Exp -> 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) Exp
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 Exp
body Maybe (TypeExp VName)
_ (Info (Aliasing
_, StructType
rt)) SrcLoc
_) =
  Env -> [VName] -> [Pattern] -> Exp -> StructType -> EvalM Value
evalFunction Env
env [] [Pattern]
ps Exp
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
_ Exp
e (Info (PName
_, StructType
_, Maybe VName
argext), Info (PName, StructType)
_) (Info PatternType
t, Info [VName]
retext) SrcLoc
loc) = do
  Value
v <- Env -> Exp -> Maybe VName -> EvalM Value
evalArg Env
env Exp
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
_ Exp
e (Info (PName, StructType)
_, Info (PName
_, StructType
_, Maybe VName
argext)) (Info PatternType
t) SrcLoc
loc) = do
  Value
y <- Env -> Exp -> Maybe VName -> EvalM Value
evalArg Env
env Exp
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 Exp
init_e LoopFormBase Info VName
form Exp
body (Info (PatternType
ret, [VName]
retext)) SrcLoc
_) = do
  Value
init_v <- Env -> Exp -> EvalM Value
eval Env
env Exp
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 Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
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 Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
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 Exp
cond ->
        Exp -> Value -> EvalM Value
whileLoop Exp
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
i64Env 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 -> Exp -> 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
Int64,
                      PrimValue -> Value
ValuePrim (IntValue -> PrimValue
SignedValue IntValue
i)
                    )
                )
                Env -> Env -> Env
forall a. Semigroup a => a -> a -> a
<> Env
env'
            )
            Exp
body

    whileLoop :: Exp -> Value -> EvalM Value
whileLoop Exp
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 -> Exp -> EvalM Value
eval Env
env' Exp
cond
      if Bool
continue
        then Exp -> Value -> EvalM Value
whileLoop Exp
cond (Value -> EvalM Value) -> EvalM Value -> EvalM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> Exp -> EvalM Value
eval Env
env' Exp
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 -> Exp -> EvalM Value
eval Env
env'' Exp
body
eval Env
env (Project Name
f Exp
e Info PatternType
_ SrcLoc
_) = do
  Value
v <- Env -> Exp -> EvalM Value
eval Env
env Exp
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 Exp
what Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
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 -> Exp -> EvalM Value
eval Env
env Exp
e
eval Env
env (Constr Name
c [Exp]
es (Info PatternType
t) SrcLoc
_) = do
  [Value]
vs <- (Exp -> EvalM Value) -> [Exp] -> EvalM [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> Exp -> EvalM Value
eval Env
env) [Exp]
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 Exp
e NonEmpty (CaseBase Info VName)
cs (Info PatternType
ret, Info [VName]
retext) SrcLoc
_) = do
  Value
v <- Env -> Exp -> EvalM Value
eval Env
env Exp
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
_ Exp
e SrcLoc
_) = Env -> Exp -> EvalM Value
eval Env
env Exp
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 Exp
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 -> Exp -> EvalM Value
eval Env
env' Exp
cExp

-- We hackily do multiple substitutions in modules, because otherwise
-- we would lose in cases where the parameter substitutions are [a->x,
-- b->x] when we reverse. (See issue #1250.)
reverseSubstitutions :: M.Map VName VName -> M.Map VName [VName]
reverseSubstitutions :: Map VName VName -> Map VName [VName]
reverseSubstitutions =
  ([VName] -> [VName] -> [VName])
-> [(VName, [VName])] -> Map VName [VName]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [VName] -> [VName] -> [VName]
forall a. Semigroup a => a -> a -> a
(<>) ([(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])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second VName -> [VName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VName, VName) -> (VName, [VName]))
-> ((VName, VName) -> (VName, VName))
-> (VName, VName)
-> (VName, [VName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
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

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] -> Maybe VName
forall a. [a] -> Maybe a
maybeHead ([VName] -> Maybe VName) -> Maybe [VName] -> Maybe VName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m 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
k' <- VName -> [VName]
replace VName
k
      (VName, a) -> [(VName, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (([VName] -> Maybe VName) -> Map VName [VName] -> Map VName VName
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe [VName] -> Maybe VName
forall a. [a] -> Maybe a
maybeHead 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

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 Exp
fbody Maybe DocComment
_ [AttrInfo]
_ SrcLoc
_)) = do
  TermBinding
binding <- Env
-> [TypeParam]
-> [Pattern]
-> StructType
-> [VName]
-> Exp
-> EvalM TermBinding
evalFunctionBinding Env
env [TypeParam]
tparams [Pattern]
ps StructType
ret [VName]
retext Exp
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
s String -> 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
s String -> 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
s String -> 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
s String -> 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 Int64) -> Maybe ValueShape
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Shape (Maybe Int64) -> Maybe ValueShape)
-> (StructType -> Shape (Maybe Int64))
-> StructType
-> Maybe ValueShape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map VName ValueShape -> StructType -> Shape (Maybe Int64)
structTypeShape Map VName ValueShape
forall a. Monoid a => a
mempty (StructType -> Shape (Maybe Int64))
-> (StructType -> StructType) -> StructType -> Shape (Maybe Int64)
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
"scatter_2d" = 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
_ Array Int Value
_ ->
            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 -> (Maybe [Value], Value) -> Value)
-> Value -> [(Maybe [Value], Value)] -> Value
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Value -> (Maybe [Value], Value) -> Value
update Value
arr ([(Maybe [Value], Value)] -> Value)
-> [(Maybe [Value], Value)] -> Value
forall a b. (a -> b) -> a -> b
$
                [Maybe [Value]] -> [Value] -> [(Maybe [Value], Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Value -> Maybe [Value]) -> [Value] -> [Maybe [Value]]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Maybe [Value]
fromTuple ([Value] -> [Maybe [Value]]) -> [Value] -> [Maybe [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
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_2d 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 -> (Maybe [Value], Value) -> Value
        update :: Value -> (Maybe [Value], Value) -> Value
update Value
arr (Just idxs :: [Value]
idxs@[Value
_, Value
_], Value
v) =
          Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
arr (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ [Indexing] -> Value -> Value -> Maybe Value
updateArray ((Value -> Indexing) -> [Value] -> [Indexing]
forall a b. (a -> b) -> [a] -> [b]
map (Int64 -> Indexing
IndexingFix (Int64 -> Indexing) -> (Value -> Int64) -> Value -> Indexing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Int64
asInt64) [Value]
idxs) Value
arr Value
v
        update Value
_ (Maybe [Value], Value)
_ =
          String -> Value
forall a. HasCallStack => String -> a
error String
"scatter_2d expects 2-dimensional indices"
    def String
"scatter_3d" = 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
_ Array Int Value
_ ->
            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 -> (Maybe [Value], Value) -> Value)
-> Value -> [(Maybe [Value], Value)] -> Value
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Value -> (Maybe [Value], Value) -> Value
update Value
arr ([(Maybe [Value], Value)] -> Value)
-> [(Maybe [Value], Value)] -> Value
forall a b. (a -> b) -> a -> b
$
                [Maybe [Value]] -> [Value] -> [(Maybe [Value], Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Value -> Maybe [Value]) -> [Value] -> [Maybe [Value]]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Maybe [Value]
fromTuple ([Value] -> [Maybe [Value]]) -> [Value] -> [Maybe [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
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_3d 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 -> (Maybe [Value], Value) -> Value
        update :: Value -> (Maybe [Value], Value) -> Value
update Value
arr (Just idxs :: [Value]
idxs@[Value
_, Value
_, Value
_], Value
v) =
          Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
arr (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ [Indexing] -> Value -> Value -> Maybe Value
updateArray ((Value -> Indexing) -> [Value] -> [Indexing]
forall a b. (a -> b) -> [a] -> [b]
map (Int64 -> Indexing
IndexingFix (Int64 -> Indexing) -> (Value -> Int64) -> Value -> Indexing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Int64
asInt64) [Value]
idxs) Value
arr Value
v
        update Value
_ (Maybe [Value], Value)
_ =
          String -> Value
forall a. HasCallStack => String -> a
error String
"scatter_3d expects 3-dimensional indices"
    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 Int64
_ 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
. Int64 -> IntValue
Int64Value (Int64 -> IntValue) -> ([Value] -> Int64) -> [Value] -> IntValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Int64
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
x t -> [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
i t -> 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 Int64
_ (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 Int64
_ ValueShape
xs_rowshape = Value -> ValueShape
valueShape Value
xs
            ShapeDim Int64
_ 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 Int64
_ 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 Int64
n (ShapeDim Int64
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 (Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int64
m (Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int64
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 (Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim Int64
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
$
          let idx :: Int
idx = if [Value] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
xs' then Int
0 else Int -> Int -> Int
forall a. Integral a => a -> a -> a
rem (Value -> Int
asInt Value
i) ([Value] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
xs')
           in if Int
idx 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 Int
idx [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 (- Int
idx) [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 Int64
n (ShapeDim Int64
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 (Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
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 Int64
_ ValueShape
innershape, [Value]
xs') = Value -> (ValueShape, [Value])
fromArray Value
xs
            rowshape :: ValueShape
rowshape = Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim (Value -> Int64
asInt64 Value
m) ValueShape
innershape
            shape :: ValueShape
shape = Int64 -> ValueShape -> ValueShape
forall d. d -> Shape d -> Shape d
ShapeDim (Value -> Int64
asInt64 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
$ Int64 -> IntValue
Int64Value (Int64 -> IntValue) -> Int64 -> IntValue
forall a b. (a -> b) -> a -> b
$ Array Int Value -> Int64
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 -> Exp -> F ExtOp Value
interpretExp Ctx
ctx Exp
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 -> Exp -> EvalM Value
eval (Ctx -> Env
ctxEnv Ctx
ctx) Exp
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
_) ->
      [ValueType] -> StructType -> Either String 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
_) ->
      [ValueType] -> StructType -> Either String 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 -> Either String StructType
updateType (ValueType
vt : [ValueType]
vts) (Scalar (Arrow ()
als PName
u StructType
pt StructType
rt)) = do
      ValueType -> StructType -> Either String ()
checkInput ValueType
vt StructType
pt
      ScalarTypeBase (DimDecl VName) () -> StructType
forall dim as. ScalarTypeBase dim as -> TypeBase dim as
Scalar (ScalarTypeBase (DimDecl VName) () -> StructType)
-> (StructType -> ScalarTypeBase (DimDecl VName) ())
-> StructType
-> StructType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ()
-> 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 -> StructType)
-> Either String StructType -> Either String StructType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ValueType] -> StructType -> Either String StructType
updateType [ValueType]
vts StructType
rt
    updateType [ValueType]
_ StructType
t =
      StructType -> Either String StructType
forall a b. b -> Either a b
Right StructType
t

    -- FIXME: we don't check array sizes.
    checkInput :: ValueType -> StructType -> Either String ()
    checkInput :: ValueType -> StructType -> Either String ()
checkInput (Scalar (Prim PrimType
vt)) (Scalar (Prim PrimType
pt))
      | PrimType
vt PrimType -> PrimType -> Bool
forall a. Eq a => a -> a -> Bool
/= PrimType
pt = PrimType -> PrimType -> Either String ()
forall a a b. (Pretty a, Pretty a) => a -> a -> Either String b
badPrim PrimType
vt PrimType
pt
    checkInput (Array ()
_ Uniqueness
_ (Prim PrimType
vt) ShapeDecl Int64
_) (Array ()
_ Uniqueness
_ (Prim PrimType
pt) ShapeDecl (DimDecl VName)
_)
      | PrimType
vt PrimType -> PrimType -> Bool
forall a. Eq a => a -> a -> Bool
/= PrimType
pt = PrimType -> PrimType -> Either String ()
forall a a b. (Pretty a, Pretty a) => a -> a -> Either String b
badPrim PrimType
vt PrimType
pt
    checkInput ValueType
_ StructType
_ =
      () -> Either String ()
forall a b. b -> Either a b
Right ()

    badPrim :: a -> a -> Either String b
badPrim a
vt a
pt =
      String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b)
-> (Doc -> String) -> Doc -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
forall a. Pretty a => a -> String
pretty (Doc -> Either String b) -> Doc -> Either String b
forall a b. (a -> b) -> a -> b
$
        Doc
"Invalid argument type."
          Doc -> Doc -> Doc
</> Doc
"Expected:" Doc -> Doc -> Doc
<+> Doc -> Doc
align (a -> Doc
forall a. Pretty a => a -> Doc
ppr a
pt)
          Doc -> Doc -> Doc
</> Doc
"Got:     " Doc -> Doc -> Doc
<+> Doc -> Doc
align (a -> Doc
forall a. Pretty a => a -> Doc
ppr a
vt)

    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)