{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | FutharkScript is a (tiny) subset of Futhark used to write small
-- expressions that are evaluated by server executables.  The @futhark
-- literate@ command is the main user.
module Futhark.Script
  ( -- * Server
    ScriptServer,
    withScriptServer,
    withScriptServer',

    -- * Expressions, values, and types
    Func (..),
    Exp (..),
    parseExp,
    parseExpFromText,
    varsInExp,
    ScriptValueType (..),
    ScriptValue (..),
    scriptValueType,
    serverVarsInValue,
    ValOrVar (..),
    ExpValue,

    -- * Evaluation
    EvalBuiltin,
    evalExp,
    getExpValue,
    evalExpToGround,
    valueToExp,
    freeValue,
  )
where

import Control.Monad.Except
import Data.Bifunctor (bimap)
import Data.Char
import Data.Foldable (toList)
import Data.Functor
import Data.IORef
import Data.List (intersperse)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Traversable
import Data.Void
import qualified Futhark.Data.Parser as V
import Futhark.Server
import Futhark.Server.Values (getValue, putValue)
import qualified Futhark.Test.Values as V
import Futhark.Util (nubOrd)
import Futhark.Util.Pretty hiding (float, line, sep, space, string, (</>), (<|>))
import Language.Futhark.Core (Name, nameFromText, nameToText)
import Language.Futhark.Tuple (areTupleFields)
import Text.Megaparsec
import Text.Megaparsec.Char (space)
import Text.Megaparsec.Char.Lexer (charLiteral)

type TypeMap = M.Map TypeName (Maybe [(Name, TypeName)])

typeMap :: MonadIO m => Server -> m TypeMap
typeMap :: Server -> m TypeMap
typeMap Server
server = do
  IO TypeMap -> m TypeMap
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TypeMap -> m TypeMap) -> IO TypeMap -> m TypeMap
forall a b. (a -> b) -> a -> b
$ (CmdFailure -> IO TypeMap)
-> ([Text] -> IO TypeMap) -> Either CmdFailure [Text] -> IO TypeMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO TypeMap -> CmdFailure -> IO TypeMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO TypeMap
forall a. Monoid a => a
mempty) [Text] -> IO TypeMap
onTypes (Either CmdFailure [Text] -> IO TypeMap)
-> IO (Either CmdFailure [Text]) -> IO TypeMap
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Server -> IO (Either CmdFailure [Text])
cmdTypes Server
server
  where
    onTypes :: [Text] -> IO TypeMap
onTypes [Text]
types = [(Text, Maybe [(Name, Text)])] -> TypeMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Maybe [(Name, Text)])] -> TypeMap)
-> ([Maybe [(Name, Text)]] -> [(Text, Maybe [(Name, Text)])])
-> [Maybe [(Name, Text)]]
-> TypeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Maybe [(Name, Text)]] -> [(Text, Maybe [(Name, Text)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
types ([Maybe [(Name, Text)]] -> TypeMap)
-> IO [Maybe [(Name, Text)]] -> IO TypeMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> IO (Maybe [(Name, Text)]))
-> [Text] -> IO [Maybe [(Name, Text)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> IO (Maybe [(Name, Text)])
onType [Text]
types
    onType :: Text -> IO (Maybe [(Name, Text)])
onType Text
t =
      (CmdFailure -> Maybe [(Name, Text)])
-> ([Text] -> Maybe [(Name, Text)])
-> Either CmdFailure [Text]
-> Maybe [(Name, Text)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe [(Name, Text)] -> CmdFailure -> Maybe [(Name, Text)]
forall a b. a -> b -> a
const Maybe [(Name, Text)]
forall a. Maybe a
Nothing) ([(Name, Text)] -> Maybe [(Name, Text)]
forall a. a -> Maybe a
Just ([(Name, Text)] -> Maybe [(Name, Text)])
-> ([Text] -> [(Name, Text)]) -> [Text] -> Maybe [(Name, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> (Name, Text)) -> [Text] -> [(Name, Text)]
forall a b. (a -> b) -> [a] -> [b]
map Text -> (Name, Text)
onField) (Either CmdFailure [Text] -> Maybe [(Name, Text)])
-> IO (Either CmdFailure [Text]) -> IO (Maybe [(Name, Text)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server -> Text -> IO (Either CmdFailure [Text])
cmdFields Server
server Text
t
    onField :: Text -> (Name, Text)
onField = (Text -> Name) -> (Text -> Text) -> (Text, Text) -> (Name, Text)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> Name
nameFromText (Int -> Text -> Text
T.drop Int
1) ((Text, Text) -> (Name, Text))
-> (Text -> (Text, Text)) -> Text -> (Name, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> (Text, Text)
T.breakOn Text
" "

isRecord :: TypeName -> TypeMap -> Maybe [(Name, TypeName)]
isRecord :: Text -> TypeMap -> Maybe [(Name, Text)]
isRecord Text
t TypeMap
m = Maybe (Maybe [(Name, Text)]) -> Maybe [(Name, Text)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe [(Name, Text)]) -> Maybe [(Name, Text)])
-> Maybe (Maybe [(Name, Text)]) -> Maybe [(Name, Text)]
forall a b. (a -> b) -> a -> b
$ Text -> TypeMap -> Maybe (Maybe [(Name, Text)])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
t TypeMap
m

isTuple :: TypeName -> TypeMap -> Maybe [TypeName]
isTuple :: Text -> TypeMap -> Maybe [Text]
isTuple Text
t TypeMap
m = Map Name Text -> Maybe [Text]
forall a. Map Name a -> Maybe [a]
areTupleFields (Map Name Text -> Maybe [Text])
-> ([(Name, Text)] -> Map Name Text)
-> [(Name, Text)]
-> Maybe [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Text)] -> Maybe [Text])
-> Maybe [(Name, Text)] -> Maybe [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> TypeMap -> Maybe [(Name, Text)]
isRecord Text
t TypeMap
m

-- | Like a 'Server', but keeps a bit more state to make FutharkScript
-- more convenient.
data ScriptServer = ScriptServer
  { ScriptServer -> Server
scriptServer :: Server,
    ScriptServer -> IORef Int
scriptCounter :: IORef Int,
    ScriptServer -> TypeMap
scriptTypes :: TypeMap
  }

-- | Run an action with a 'ScriptServer' produced by an existing
-- 'Server', without shutting it down at the end.
withScriptServer' :: MonadIO m => Server -> (ScriptServer -> m a) -> m a
withScriptServer' :: Server -> (ScriptServer -> m a) -> m a
withScriptServer' Server
server ScriptServer -> m a
f = do
  IORef Int
counter <- IO (IORef Int) -> m (IORef Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> m (IORef Int))
-> IO (IORef Int) -> m (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
  TypeMap
types <- Server -> m TypeMap
forall (m :: * -> *). MonadIO m => Server -> m TypeMap
typeMap Server
server
  ScriptServer -> m a
f (ScriptServer -> m a) -> ScriptServer -> m a
forall a b. (a -> b) -> a -> b
$ Server -> IORef Int -> TypeMap -> ScriptServer
ScriptServer Server
server IORef Int
counter TypeMap
types

-- | Start a server, execute an action, then shut down the server.
-- Similar to 'withServer'.
withScriptServer :: ServerCfg -> (ScriptServer -> IO a) -> IO a
withScriptServer :: ServerCfg -> (ScriptServer -> IO a) -> IO a
withScriptServer ServerCfg
cfg ScriptServer -> IO a
f =
  ServerCfg -> (Server -> IO a) -> IO a
forall a. ServerCfg -> (Server -> IO a) -> IO a
withServer ServerCfg
cfg ((Server -> IO a) -> IO a) -> (Server -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ (Server -> (ScriptServer -> IO a) -> IO a)
-> (ScriptServer -> IO a) -> Server -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Server -> (ScriptServer -> IO a) -> IO a
forall (m :: * -> *) a.
MonadIO m =>
Server -> (ScriptServer -> m a) -> m a
withScriptServer' ScriptServer -> IO a
f

-- | A function called in a 'Call' expression can be either a Futhark
-- function or a builtin function.
data Func = FuncFut EntryName | FuncBuiltin T.Text
  deriving (Int -> Func -> ShowS
[Func] -> ShowS
Func -> String
(Int -> Func -> ShowS)
-> (Func -> String) -> ([Func] -> ShowS) -> Show Func
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Func] -> ShowS
$cshowList :: [Func] -> ShowS
show :: Func -> String
$cshow :: Func -> String
showsPrec :: Int -> Func -> ShowS
$cshowsPrec :: Int -> Func -> ShowS
Show)

-- | A FutharkScript expression.  This is a simple AST that might not
-- correspond exactly to what the user wrote (e.g. no parentheses or
-- source locations).  This is fine for small expressions, which is
-- all this is meant for.
data Exp
  = Call Func [Exp]
  | Const V.Value
  | Tuple [Exp]
  | Record [(T.Text, Exp)]
  | StringLit T.Text
  | Let [VarName] Exp Exp
  | -- | Server-side variable, *not* Futhark variable (these are
    -- handled in 'Call').
    ServerVar TypeName VarName
  deriving (Int -> Exp -> ShowS
[Exp] -> ShowS
Exp -> String
(Int -> Exp -> ShowS)
-> (Exp -> String) -> ([Exp] -> ShowS) -> Show Exp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exp] -> ShowS
$cshowList :: [Exp] -> ShowS
show :: Exp -> String
$cshow :: Exp -> String
showsPrec :: Int -> Exp -> ShowS
$cshowsPrec :: Int -> Exp -> ShowS
Show)

instance Pretty Func where
  ppr :: Func -> Doc
ppr (FuncFut Text
f) = Text -> Doc
forall a. Pretty a => a -> Doc
ppr Text
f
  ppr (FuncBuiltin Text
f) = Doc
"$" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
forall a. Pretty a => a -> Doc
ppr Text
f

instance Pretty Exp where
  ppr :: Exp -> Doc
ppr = Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
0
  pprPrec :: Int -> Exp -> Doc
pprPrec Int
_ (ServerVar Text
_ Text
v) = Doc
"$" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
forall a. Pretty a => a -> Doc
ppr Text
v
  pprPrec Int
_ (Const Value
v) = [Doc] -> Doc
stack ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Text -> Doc) -> [Text] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
strictText ([Text] -> [Doc]) -> [Text] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Value -> Text
V.valueText Value
v
  pprPrec Int
i (Let [Text]
pat Exp
e1 Exp
e2) =
    Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"let" Doc -> Doc -> Doc
<+> Doc
pat' Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
e1 Doc -> Doc -> Doc
<+> Doc
"in" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
e2
    where
      pat' :: Doc
pat' = case [Text]
pat of
        [Text
x] -> Text -> Doc
forall a. Pretty a => a -> Doc
ppr Text
x
        [Text]
_ -> 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
$ (Text -> Doc) -> [Text] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
forall a. Pretty a => a -> Doc
ppr [Text]
pat
  pprPrec Int
_ (Call Func
v []) = Func -> Doc
forall a. Pretty a => a -> Doc
ppr Func
v
  pprPrec Int
i (Call Func
v [Exp]
args) =
    Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Func -> Doc
forall a. Pretty a => a -> Doc
ppr Func
v Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread ((Exp -> Doc) -> [Exp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
align (Doc -> Doc) -> (Exp -> Doc) -> Exp -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
pprPrec Int
1) [Exp]
args)
  pprPrec Int
_ (Tuple [Exp]
vs) =
    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
$ (Exp -> Doc) -> [Exp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
align (Doc -> Doc) -> (Exp -> Doc) -> Exp -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Doc
forall a. Pretty a => a -> Doc
ppr) [Exp]
vs
  pprPrec Int
_ (StringLit Text
s) = String -> Doc
forall a. Pretty a => a -> Doc
ppr (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
s
  pprPrec Int
_ (Record [(Text, Exp)]
m) = 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
$ ((Text, Exp) -> Doc) -> [(Text, Exp)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Exp) -> Doc
forall a a. (Pretty a, Pretty a) => (a, a) -> Doc
field [(Text, Exp)]
m
    where
      field :: (a, a) -> Doc
field (a
k, a
v) = Doc -> Doc
align (a -> Doc
forall a. Pretty a => a -> Doc
ppr a
k Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
equals Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
v)

type Parser = Parsec Void T.Text

lexeme :: Parser () -> Parser a -> Parser a
lexeme :: Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser a
p = Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
sep

inParens :: Parser () -> Parser a -> Parser a
inParens :: Parser () -> Parser a -> Parser a
inParens Parser ()
sep = ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text -> Parser a -> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity Text
"(") (Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity Text
")")

inBraces :: Parser () -> Parser a -> Parser a
inBraces :: Parser () -> Parser a -> Parser a
inBraces Parser ()
sep = ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text -> Parser a -> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity Text
"{") (Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity Text
"}")

-- | Parse a FutharkScript expression, given a whitespace parser.
parseExp :: Parsec Void T.Text () -> Parsec Void T.Text Exp
parseExp :: Parser () -> Parsec Void Text Exp
parseExp Parser ()
sep =
  [Parsec Void Text Exp] -> Parsec Void Text Exp
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity Text
"let"
        ParsecT Void Text Identity Text
-> ([Text] -> Exp -> Exp -> Exp)
-> ParsecT Void Text Identity ([Text] -> Exp -> Exp -> Exp)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Text] -> Exp -> Exp -> Exp
Let
        ParsecT Void Text Identity ([Text] -> Exp -> Exp -> Exp)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity (Exp -> Exp -> Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity [Text]
pPat
        ParsecT Void Text Identity (Exp -> Exp -> Exp)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Exp -> Exp -> Exp)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity Text
"="
        ParsecT Void Text Identity (Exp -> Exp -> Exp)
-> Parsec Void Text Exp -> ParsecT Void Text Identity (Exp -> Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void Text Exp
parseExp Parser ()
sep
        ParsecT Void Text Identity (Exp -> Exp)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Exp -> Exp)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity Text
"in"
        ParsecT Void Text Identity (Exp -> Exp)
-> Parsec Void Text Exp -> Parsec Void Text Exp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void Text Exp
parseExp Parser ()
sep,
      Parsec Void Text Exp -> Parsec Void Text Exp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parsec Void Text Exp -> Parsec Void Text Exp)
-> Parsec Void Text Exp -> Parsec Void Text Exp
forall a b. (a -> b) -> a -> b
$ Func -> [Exp] -> Exp
Call (Func -> [Exp] -> Exp)
-> ParsecT Void Text Identity Func
-> ParsecT Void Text Identity ([Exp] -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Func
parseFunc ParsecT Void Text Identity ([Exp] -> Exp)
-> ParsecT Void Text Identity [Exp] -> Parsec Void Text Exp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Void Text Exp -> ParsecT Void Text Identity [Exp]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parsec Void Text Exp
pAtom,
      Parsec Void Text Exp
pAtom
    ]
    Parsec Void Text Exp -> String -> Parsec Void Text Exp
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"expression"
  where
    pField :: ParsecT Void Text Identity (Text, Exp)
pField = (,) (Text -> Exp -> (Text, Exp))
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Exp -> (Text, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
pVarName ParsecT Void Text Identity (Exp -> (Text, Exp))
-> Parsec Void Text Exp -> ParsecT Void Text Identity (Text, Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParsecT Void Text Identity Text
pEquals ParsecT Void Text Identity Text
-> Parsec Void Text Exp -> Parsec Void Text Exp
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parsec Void Text Exp
parseExp Parser ()
sep)
    pEquals :: ParsecT Void Text Identity Text
pEquals = Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity Text
"="
    pComma :: ParsecT Void Text Identity Text
pComma = Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void Text Identity Text
","
    mkTuple :: [Exp] -> Exp
mkTuple [Exp
v] = Exp
v
    mkTuple [Exp]
vs = [Exp] -> Exp
Tuple [Exp]
vs

    pAtom :: Parsec Void Text Exp
pAtom =
      [Parsec Void Text Exp] -> Parsec Void Text Exp
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Parsec Void Text Exp -> Parsec Void Text Exp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parsec Void Text Exp -> Parsec Void Text Exp)
-> Parsec Void Text Exp -> Parsec Void Text Exp
forall a b. (a -> b) -> a -> b
$ Parser () -> Parsec Void Text Exp -> Parsec Void Text Exp
forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep ([Exp] -> Exp
mkTuple ([Exp] -> Exp)
-> ParsecT Void Text Identity [Exp] -> Parsec Void Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser () -> Parsec Void Text Exp
parseExp Parser ()
sep Parsec Void Text Exp
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Exp]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` ParsecT Void Text Identity Text
pComma)),
          Parser () -> Parsec Void Text Exp -> Parsec Void Text Exp
forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep (Parsec Void Text Exp -> Parsec Void Text Exp)
-> Parsec Void Text Exp -> Parsec Void Text Exp
forall a b. (a -> b) -> a -> b
$ Parser () -> Parsec Void Text Exp
parseExp Parser ()
sep,
          Parser () -> Parsec Void Text Exp -> Parsec Void Text Exp
forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep ([(Text, Exp)] -> Exp
Record ([(Text, Exp)] -> Exp)
-> ParsecT Void Text Identity [(Text, Exp)] -> Parsec Void Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity (Text, Exp)
pField ParsecT Void Text Identity (Text, Exp)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [(Text, Exp)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` ParsecT Void Text Identity Text
pComma)),
          Text -> Exp
StringLit (Text -> Exp) -> (String -> Text) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Exp)
-> ParsecT Void Text Identity String -> Parsec Void Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ()
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep (ParsecT Void Text Identity Text
"\"" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity String
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
charLiteral ParsecT Void Text Identity Text
"\""),
          Value -> Exp
Const (Value -> Exp)
-> ParsecT Void Text Identity Value -> Parsec Void Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> ParsecT Void Text Identity Value
V.parseValue Parser ()
sep,
          Func -> [Exp] -> Exp
Call (Func -> [Exp] -> Exp)
-> ParsecT Void Text Identity Func
-> ParsecT Void Text Identity ([Exp] -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Func
parseFunc ParsecT Void Text Identity ([Exp] -> Exp)
-> ParsecT Void Text Identity [Exp] -> Parsec Void Text Exp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Exp] -> ParsecT Void Text Identity [Exp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        ]

    pPat :: ParsecT Void Text Identity [Text]
pPat =
      [ParsecT Void Text Identity [Text]]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Parser ()
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep (ParsecT Void Text Identity [Text]
 -> ParsecT Void Text Identity [Text])
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text
pVarName ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` ParsecT Void Text Identity Text
pComma,
          Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text])
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
pVarName
        ]

    parseFunc :: ParsecT Void Text Identity Func
parseFunc =
      [ParsecT Void Text Identity Func]
-> ParsecT Void Text Identity Func
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Text -> Func
FuncBuiltin (Text -> Func)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Func
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity Text
"$" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
pVarName),
          Text -> Func
FuncFut (Text -> Func)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Func
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
pVarName
        ]

    reserved :: [Text]
reserved = [Text
"let", Text
"in"]

    pVarName :: ParsecT Void Text Identity Text
pVarName = Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> (ParsecT Void Text Identity Text
    -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ do
      Text
v <- (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack (ParsecT Void Text Identity String
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ (:) (Char -> ShowS)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isAlpha ParsecT Void Text Identity ShowS
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
constituent)
      Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text
v Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
reserved
      Text -> ParsecT Void Text Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
v
      where
        constituent :: Char -> Bool
constituent Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'

-- | Parse a FutharkScript expression with normal whitespace handling.
parseExpFromText :: FilePath -> T.Text -> Either T.Text Exp
parseExpFromText :: String -> Text -> Either Text Exp
parseExpFromText String
f Text
s =
  (ParseErrorBundle Text Void -> Either Text Exp)
-> (Exp -> Either Text Exp)
-> Either (ParseErrorBundle Text Void) Exp
-> Either Text Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp)
-> (ParseErrorBundle Text Void -> Text)
-> ParseErrorBundle Text Void
-> Either Text Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) Exp -> Either Text Exp
forall a b. b -> Either a b
Right (Either (ParseErrorBundle Text Void) Exp -> Either Text Exp)
-> Either (ParseErrorBundle Text Void) Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Parsec Void Text Exp
-> String -> Text -> Either (ParseErrorBundle Text Void) Exp
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser () -> Parsec Void Text Exp
parseExp Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space) String
f Text
s

readVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> m V.Value
readVar :: Server -> Text -> m Value
readVar Server
server Text
v =
  (Text -> m Value)
-> (Value -> m Value) -> Either Text Value -> m Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> m Value
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Value -> m Value) -> m (Either Text Value) -> m Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either Text Value) -> m (Either Text Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> Text -> IO (Either Text Value)
getValue Server
server Text
v)

writeVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> V.Value -> m ()
writeVar :: Server -> Text -> Value -> m ()
writeVar Server
server Text
v Value
val =
  IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe CmdFailure) -> IO (Maybe CmdFailure)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> Text -> Value -> IO (Maybe CmdFailure)
putValue Server
server Text
v Value
val)

-- | A ScriptValue is either a base value or a partially applied
-- function.  We don't have real first-class functions in
-- FutharkScript, but we sort of have closures.
data ScriptValue v
  = SValue TypeName v
  | -- | Ins, then outs.  Yes, this is the opposite of more or less
    -- everywhere else.
    SFun EntryName [TypeName] [TypeName] [ScriptValue v]
  deriving (Int -> ScriptValue v -> ShowS
[ScriptValue v] -> ShowS
ScriptValue v -> String
(Int -> ScriptValue v -> ShowS)
-> (ScriptValue v -> String)
-> ([ScriptValue v] -> ShowS)
-> Show (ScriptValue v)
forall v. Show v => Int -> ScriptValue v -> ShowS
forall v. Show v => [ScriptValue v] -> ShowS
forall v. Show v => ScriptValue v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptValue v] -> ShowS
$cshowList :: forall v. Show v => [ScriptValue v] -> ShowS
show :: ScriptValue v -> String
$cshow :: forall v. Show v => ScriptValue v -> String
showsPrec :: Int -> ScriptValue v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> ScriptValue v -> ShowS
Show)

instance Functor ScriptValue where
  fmap :: (a -> b) -> ScriptValue a -> ScriptValue b
fmap = (a -> b) -> ScriptValue a -> ScriptValue b
forall (t :: * -> *) a b. Traversable t => (a -> b) -> t a -> t b
fmapDefault

instance Foldable ScriptValue where
  foldMap :: (a -> m) -> ScriptValue a -> m
foldMap = (a -> m) -> ScriptValue a -> m
forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault

instance Traversable ScriptValue where
  traverse :: (a -> f b) -> ScriptValue a -> f (ScriptValue b)
traverse a -> f b
f (SValue Text
t a
v) = Text -> b -> ScriptValue b
forall v. Text -> v -> ScriptValue v
SValue Text
t (b -> ScriptValue b) -> f b -> f (ScriptValue b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
v
  traverse a -> f b
f (SFun Text
fname [Text]
ins [Text]
outs [ScriptValue a]
vs) =
    Text -> [Text] -> [Text] -> [ScriptValue b] -> ScriptValue b
forall v.
Text -> [Text] -> [Text] -> [ScriptValue v] -> ScriptValue v
SFun Text
fname [Text]
ins [Text]
outs ([ScriptValue b] -> ScriptValue b)
-> f [ScriptValue b] -> f (ScriptValue b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ScriptValue a -> f (ScriptValue b))
-> [ScriptValue a] -> f [ScriptValue b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> ScriptValue a -> f (ScriptValue b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) [ScriptValue a]
vs

-- | The type of a 'ScriptValue' - either a value type or a function type.
data ScriptValueType
  = STValue TypeName
  | -- | Ins, then outs.
    STFun [TypeName] [TypeName]
  deriving (ScriptValueType -> ScriptValueType -> Bool
(ScriptValueType -> ScriptValueType -> Bool)
-> (ScriptValueType -> ScriptValueType -> Bool)
-> Eq ScriptValueType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptValueType -> ScriptValueType -> Bool
$c/= :: ScriptValueType -> ScriptValueType -> Bool
== :: ScriptValueType -> ScriptValueType -> Bool
$c== :: ScriptValueType -> ScriptValueType -> Bool
Eq, Int -> ScriptValueType -> ShowS
[ScriptValueType] -> ShowS
ScriptValueType -> String
(Int -> ScriptValueType -> ShowS)
-> (ScriptValueType -> String)
-> ([ScriptValueType] -> ShowS)
-> Show ScriptValueType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptValueType] -> ShowS
$cshowList :: [ScriptValueType] -> ShowS
show :: ScriptValueType -> String
$cshow :: ScriptValueType -> String
showsPrec :: Int -> ScriptValueType -> ShowS
$cshowsPrec :: Int -> ScriptValueType -> ShowS
Show)

instance Pretty ScriptValueType where
  ppr :: ScriptValueType -> Doc
ppr (STValue Text
t) = Text -> Doc
forall a. Pretty a => a -> Doc
ppr Text
t
  ppr (STFun [Text]
ins [Text]
outs) =
    [Doc] -> Doc
spread ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
"->" ((Text -> Doc) -> [Text] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
forall a. Pretty a => a -> Doc
ppr [Text]
ins [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc
outs'])
    where
      outs' :: Doc
outs' = case [Text]
outs of
        [Text
out] -> Text -> Doc
strictText Text
out
        [Text]
_ -> 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
$ (Text -> Doc) -> [Text] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
strictText [Text]
outs

-- | A Haskell-level value or a variable on the server.
data ValOrVar = VVal V.Value | VVar VarName
  deriving (Int -> ValOrVar -> ShowS
[ValOrVar] -> ShowS
ValOrVar -> String
(Int -> ValOrVar -> ShowS)
-> (ValOrVar -> String) -> ([ValOrVar] -> ShowS) -> Show ValOrVar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValOrVar] -> ShowS
$cshowList :: [ValOrVar] -> ShowS
show :: ValOrVar -> String
$cshow :: ValOrVar -> String
showsPrec :: Int -> ValOrVar -> ShowS
$cshowsPrec :: Int -> ValOrVar -> ShowS
Show)

-- | The intermediate values produced by an expression - in
-- particular, these may not be on the server.
type ExpValue = V.Compound (ScriptValue ValOrVar)

-- | The type of a 'ScriptValue'.
scriptValueType :: ScriptValue v -> ScriptValueType
scriptValueType :: ScriptValue v -> ScriptValueType
scriptValueType (SValue Text
t v
_) = Text -> ScriptValueType
STValue Text
t
scriptValueType (SFun Text
_ [Text]
ins [Text]
outs [ScriptValue v]
_) = [Text] -> [Text] -> ScriptValueType
STFun [Text]
ins [Text]
outs

-- | The set of server-side variables in the value.
serverVarsInValue :: ExpValue -> S.Set VarName
serverVarsInValue :: ExpValue -> Set Text
serverVarsInValue = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text)
-> (ExpValue -> [Text]) -> ExpValue -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptValue ValOrVar -> [Text])
-> [ScriptValue ValOrVar] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScriptValue ValOrVar -> [Text]
isVar ([ScriptValue ValOrVar] -> [Text])
-> (ExpValue -> [ScriptValue ValOrVar]) -> ExpValue -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpValue -> [ScriptValue ValOrVar]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where
    isVar :: ScriptValue ValOrVar -> [Text]
isVar (SValue Text
_ (VVar Text
x)) = [Text
x]
    isVar (SValue Text
_ (VVal Value
_)) = []
    isVar (SFun Text
_ [Text]
_ [Text]
_ [ScriptValue ValOrVar]
closure) = (ScriptValue ValOrVar -> [Text])
-> [ScriptValue ValOrVar] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScriptValue ValOrVar -> [Text]
isVar ([ScriptValue ValOrVar] -> [Text])
-> [ScriptValue ValOrVar] -> [Text]
forall a b. (a -> b) -> a -> b
$ [ScriptValue ValOrVar] -> [ScriptValue ValOrVar]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [ScriptValue ValOrVar]
closure

-- | Convert a value into a corresponding expression.
valueToExp :: ExpValue -> Exp
valueToExp :: ExpValue -> Exp
valueToExp (V.ValueAtom (SValue Text
t (VVar Text
v))) =
  Text -> Text -> Exp
ServerVar Text
t Text
v
valueToExp (V.ValueAtom (SValue Text
_ (VVal Value
v))) =
  Value -> Exp
Const Value
v
valueToExp (V.ValueAtom (SFun Text
fname [Text]
_ [Text]
_ [ScriptValue ValOrVar]
closure)) =
  Func -> [Exp] -> Exp
Call (Text -> Func
FuncFut Text
fname) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (ScriptValue ValOrVar -> Exp) -> [ScriptValue ValOrVar] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (ExpValue -> Exp
valueToExp (ExpValue -> Exp)
-> (ScriptValue ValOrVar -> ExpValue)
-> ScriptValue ValOrVar
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom) [ScriptValue ValOrVar]
closure
valueToExp (V.ValueRecord Map Text ExpValue
fs) =
  [(Text, Exp)] -> Exp
Record ([(Text, Exp)] -> Exp) -> [(Text, Exp)] -> Exp
forall a b. (a -> b) -> a -> b
$ Map Text Exp -> [(Text, Exp)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Text Exp -> [(Text, Exp)]) -> Map Text Exp -> [(Text, Exp)]
forall a b. (a -> b) -> a -> b
$ (ExpValue -> Exp) -> Map Text ExpValue -> Map Text Exp
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ExpValue -> Exp
valueToExp Map Text ExpValue
fs
valueToExp (V.ValueTuple [ExpValue]
fs) =
  [Exp] -> Exp
Tuple ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (ExpValue -> Exp) -> [ExpValue] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map ExpValue -> Exp
valueToExp [ExpValue]
fs

-- | How to evaluate a builtin function.
type EvalBuiltin m = T.Text -> [V.CompoundValue] -> m V.CompoundValue

-- | Symbol table used for local variable lookups during expression evaluation.
type VTable = M.Map VarName ExpValue

-- | Evaluate a FutharkScript expression relative to some running server.
evalExp ::
  forall m.
  (MonadError T.Text m, MonadIO m) =>
  EvalBuiltin m ->
  ScriptServer ->
  Exp ->
  m ExpValue
evalExp :: EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
evalExp EvalBuiltin m
builtin ScriptServer
sserver Exp
top_level_e = do
  IORef [Text]
vars <- IO (IORef [Text]) -> m (IORef [Text])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [Text]) -> m (IORef [Text]))
-> IO (IORef [Text]) -> m (IORef [Text])
forall a b. (a -> b) -> a -> b
$ [Text] -> IO (IORef [Text])
forall a. a -> IO (IORef a)
newIORef []
  let ( ScriptServer
          { scriptServer :: ScriptServer -> Server
scriptServer = Server
server,
            scriptCounter :: ScriptServer -> IORef Int
scriptCounter = IORef Int
counter,
            scriptTypes :: ScriptServer -> TypeMap
scriptTypes = TypeMap
types
          }
        ) = ScriptServer
sserver
      newVar :: Text -> m Text
newVar Text
base = IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ do
        Int
x <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
counter
        IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Int
counter (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        let v :: Text
v = Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Pretty a => a -> Text
prettyText Int
x
        IORef [Text] -> ([Text] -> [Text]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [Text]
vars (Text
v Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
        Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
v

      mkRecord :: Text -> [Text] -> m Text
mkRecord Text
t [Text]
vs = do
        Text
v <- Text -> m Text
forall (m :: * -> *). MonadIO m => Text -> m Text
newVar Text
"record"
        IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> Text -> Text -> [Text] -> IO (Maybe CmdFailure)
cmdNew Server
server Text
v Text
t [Text]
vs
        Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
v

      toVal :: ValOrVar -> m V.Value
      toVal :: ValOrVar -> m Value
toVal (VVal Value
v) = Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
      toVal (VVar Text
v) = Server -> Text -> m Value
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> Text -> m Value
readVar Server
server Text
v

      toVar :: ValOrVar -> m VarName
      toVar :: ValOrVar -> m Text
toVar (VVar Text
v) = Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
v
      toVar (VVal Value
val) = do
        Text
v <- Text -> m Text
forall (m :: * -> *). MonadIO m => Text -> m Text
newVar Text
"const"
        Server -> Text -> Value -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> Text -> Value -> m ()
writeVar Server
server Text
v Value
val
        Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
v

      scriptValueToValOrVar :: ScriptValue a -> m a
scriptValueToValOrVar (SFun Text
f [Text]
_ [Text]
_ [ScriptValue a]
_) =
        Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ Text
"Function " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not fully applied."
      scriptValueToValOrVar (SValue Text
_ a
v) =
        a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

      scriptValueToVal :: ScriptValue ValOrVar -> m V.Value
      scriptValueToVal :: ScriptValue ValOrVar -> m Value
scriptValueToVal = ValOrVar -> m Value
toVal (ValOrVar -> m Value)
-> (ScriptValue ValOrVar -> m ValOrVar)
-> ScriptValue ValOrVar
-> m Value
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ScriptValue ValOrVar -> m ValOrVar
forall (m :: * -> *) a. MonadError Text m => ScriptValue a -> m a
scriptValueToValOrVar

      scriptValueToVar :: ScriptValue ValOrVar -> m VarName
      scriptValueToVar :: ScriptValue ValOrVar -> m Text
scriptValueToVar = ValOrVar -> m Text
toVar (ValOrVar -> m Text)
-> (ScriptValue ValOrVar -> m ValOrVar)
-> ScriptValue ValOrVar
-> m Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ScriptValue ValOrVar -> m ValOrVar
forall (m :: * -> *) a. MonadError Text m => ScriptValue a -> m a
scriptValueToValOrVar

      interValToVal :: ExpValue -> m V.CompoundValue
      interValToVal :: ExpValue -> m CompoundValue
interValToVal = (ScriptValue ValOrVar -> m Value) -> ExpValue -> m CompoundValue
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ScriptValue ValOrVar -> m Value
scriptValueToVal

      -- Apart from type checking, this function also converts
      -- FutharkScript tuples/records to Futhark-level tuples/records.
      interValToVar :: m VarName -> TypeName -> ExpValue -> m VarName
      interValToVar :: m Text -> Text -> ExpValue -> m Text
interValToVar m Text
_ Text
t (V.ValueAtom ScriptValue ValOrVar
v)
        | Text -> ScriptValueType
STValue Text
t ScriptValueType -> ScriptValueType -> Bool
forall a. Eq a => a -> a -> Bool
== ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ScriptValue ValOrVar
v = ScriptValue ValOrVar -> m Text
scriptValueToVar ScriptValue ValOrVar
v
      interValToVar m Text
bad Text
t (V.ValueTuple [ExpValue]
vs)
        | Just [Text]
ts <- Text -> TypeMap -> Maybe [Text]
isTuple Text
t TypeMap
types,
          [ExpValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ts =
            Text -> [Text] -> m Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Text -> [Text] -> m Text
mkRecord Text
t ([Text] -> m Text) -> m [Text] -> m Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Text -> ExpValue -> m Text) -> [Text] -> [ExpValue] -> m [Text]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (m Text -> Text -> ExpValue -> m Text
interValToVar m Text
bad) [Text]
ts [ExpValue]
vs
      interValToVar m Text
bad Text
t (V.ValueRecord Map Text ExpValue
vs)
        | Just [(Name, Text)]
fs <- Text -> TypeMap -> Maybe [(Name, Text)]
isRecord Text
t TypeMap
types,
          Just [ExpValue]
vs' <- ((Name, Text) -> Maybe ExpValue)
-> [(Name, Text)] -> Maybe [ExpValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Text -> Map Text ExpValue -> Maybe ExpValue
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Text ExpValue
vs) (Text -> Maybe ExpValue)
-> ((Name, Text) -> Text) -> (Name, Text) -> Maybe ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
nameToText (Name -> Text) -> ((Name, Text) -> Name) -> (Name, Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Text) -> Name
forall a b. (a, b) -> a
fst) [(Name, Text)]
fs =
            Text -> [Text] -> m Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
Text -> [Text] -> m Text
mkRecord Text
t ([Text] -> m Text) -> m [Text] -> m Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Text -> ExpValue -> m Text) -> [Text] -> [ExpValue] -> m [Text]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (m Text -> Text -> ExpValue -> m Text
interValToVar m Text
bad) (((Name, Text) -> Text) -> [(Name, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Text) -> Text
forall a b. (a, b) -> b
snd [(Name, Text)]
fs) [ExpValue]
vs'
      interValToVar m Text
bad Text
_ ExpValue
_ = m Text
bad

      valToInterVal :: V.CompoundValue -> ExpValue
      valToInterVal :: CompoundValue -> ExpValue
valToInterVal = (Value -> ScriptValue ValOrVar) -> CompoundValue -> ExpValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> ScriptValue ValOrVar) -> CompoundValue -> ExpValue)
-> (Value -> ScriptValue ValOrVar) -> CompoundValue -> ExpValue
forall a b. (a -> b) -> a -> b
$ \Value
v ->
        Text -> ValOrVar -> ScriptValue ValOrVar
forall v. Text -> v -> ScriptValue v
SValue (ValueType -> Text
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
v)) (ValOrVar -> ScriptValue ValOrVar)
-> ValOrVar -> ScriptValue ValOrVar
forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
v

      letMatch :: [VarName] -> ExpValue -> m VTable
      letMatch :: [Text] -> ExpValue -> m (Map Text ExpValue)
letMatch [Text]
vs ExpValue
val
        | [ExpValue]
vals <- ExpValue -> [ExpValue]
forall v. Compound v -> [Compound v]
V.unCompound ExpValue
val,
          [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ExpValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExpValue]
vals =
            Map Text ExpValue -> m (Map Text ExpValue)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text ExpValue -> m (Map Text ExpValue))
-> Map Text ExpValue -> m (Map Text ExpValue)
forall a b. (a -> b) -> a -> b
$ [(Text, ExpValue)] -> Map Text ExpValue
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Text] -> [ExpValue] -> [(Text, ExpValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
vs [ExpValue]
vals)
        | Bool
otherwise =
            Text -> m (Map Text ExpValue)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m (Map Text ExpValue)) -> Text -> m (Map Text ExpValue)
forall a b. (a -> b) -> a -> b
$
              Text
"Pat: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine [Text]
vs
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nDoes not match value of type: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine ((ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
val)

      evalExp' :: VTable -> Exp -> m ExpValue
      evalExp' :: Map Text ExpValue -> Exp -> m ExpValue
evalExp' Map Text ExpValue
_ (ServerVar Text
t Text
v) =
        ExpValue -> m ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue ValOrVar -> ExpValue)
-> ScriptValue ValOrVar -> ExpValue
forall a b. (a -> b) -> a -> b
$ Text -> ValOrVar -> ScriptValue ValOrVar
forall v. Text -> v -> ScriptValue v
SValue Text
t (ValOrVar -> ScriptValue ValOrVar)
-> ValOrVar -> ScriptValue ValOrVar
forall a b. (a -> b) -> a -> b
$ Text -> ValOrVar
VVar Text
v
      evalExp' Map Text ExpValue
vtable (Call (FuncBuiltin Text
name) [Exp]
es) = do
        CompoundValue
v <- EvalBuiltin m
builtin Text
name ([CompoundValue] -> m CompoundValue)
-> m [CompoundValue] -> m CompoundValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Exp -> m CompoundValue) -> [Exp] -> m [CompoundValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ExpValue -> m CompoundValue
interValToVal (ExpValue -> m CompoundValue)
-> (Exp -> m ExpValue) -> Exp -> m CompoundValue
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Map Text ExpValue -> Exp -> m ExpValue
evalExp' Map Text ExpValue
vtable) [Exp]
es
        ExpValue -> m ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ CompoundValue -> ExpValue
valToInterVal CompoundValue
v
      evalExp' Map Text ExpValue
vtable (Call (FuncFut Text
name) [Exp]
es)
        | Just ExpValue
e <- Text -> Map Text ExpValue -> Maybe ExpValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Map Text ExpValue
vtable = do
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Exp] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
es) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
              Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Locally bound name cannot be invoked as a function: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
prettyText Text
name
            ExpValue -> m ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpValue
e
      evalExp' Map Text ExpValue
vtable (Call (FuncFut Text
name) [Exp]
es) = do
        [Text]
in_types <- ([InputType] -> [Text]) -> m [InputType] -> m [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InputType -> Text) -> [InputType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map InputType -> Text
inputType) (m [InputType] -> m [Text]) -> m [InputType] -> m [Text]
forall a b. (a -> b) -> a -> b
$ IO (Either CmdFailure [InputType]) -> m [InputType]
forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (IO (Either CmdFailure [InputType]) -> m [InputType])
-> IO (Either CmdFailure [InputType]) -> m [InputType]
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure [InputType])
cmdInputs Server
server Text
name
        [Text]
out_types <- ([OutputType] -> [Text]) -> m [OutputType] -> m [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((OutputType -> Text) -> [OutputType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map OutputType -> Text
outputType) (m [OutputType] -> m [Text]) -> m [OutputType] -> m [Text]
forall a b. (a -> b) -> a -> b
$ IO (Either CmdFailure [OutputType]) -> m [OutputType]
forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (IO (Either CmdFailure [OutputType]) -> m [OutputType])
-> IO (Either CmdFailure [OutputType]) -> m [OutputType]
forall a b. (a -> b) -> a -> b
$ Server -> Text -> IO (Either CmdFailure [OutputType])
cmdOutputs Server
server Text
name

        [ExpValue]
es' <- (Exp -> m ExpValue) -> [Exp] -> m [ExpValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map Text ExpValue -> Exp -> m ExpValue
evalExp' Map Text ExpValue
vtable) [Exp]
es
        let es_types :: [Compound ScriptValueType]
es_types = (ExpValue -> Compound ScriptValueType)
-> [ExpValue] -> [Compound ScriptValueType]
forall a b. (a -> b) -> [a] -> [b]
map ((ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType) [ExpValue]
es'

        let cannotApply :: m a
cannotApply =
              Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$
                Text
"Function \""
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" expects arguments of types:\n"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound Text -> Text
forall a. Pretty a => a -> Text
prettyText ([Compound Text] -> Compound Text
forall v. [Compound v] -> Compound v
V.mkCompound ([Compound Text] -> Compound Text)
-> [Compound Text] -> Compound Text
forall a b. (a -> b) -> a -> b
$ (Text -> Compound Text) -> [Text] -> [Compound Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Compound Text
forall v. v -> Compound v
V.ValueAtom [Text]
in_types)
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nBut called with arguments of types:\n"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound (Compound ScriptValueType) -> Text
forall a. Pretty a => a -> Text
prettyText ([Compound (Compound ScriptValueType)]
-> Compound (Compound ScriptValueType)
forall v. [Compound v] -> Compound v
V.mkCompound ([Compound (Compound ScriptValueType)]
 -> Compound (Compound ScriptValueType))
-> [Compound (Compound ScriptValueType)]
-> Compound (Compound ScriptValueType)
forall a b. (a -> b) -> a -> b
$ (Compound ScriptValueType -> Compound (Compound ScriptValueType))
-> [Compound ScriptValueType]
-> [Compound (Compound ScriptValueType)]
forall a b. (a -> b) -> [a] -> [b]
map Compound ScriptValueType -> Compound (Compound ScriptValueType)
forall v. v -> Compound v
V.ValueAtom [Compound ScriptValueType]
es_types)

        -- Careful to not require saturated application, but do still
        -- check for over-saturation.
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Compound ScriptValueType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Compound ScriptValueType]
es_types Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
in_types) m ()
forall a. m a
cannotApply
        [Text]
ins <- (Text -> ExpValue -> m Text) -> [Text] -> [ExpValue] -> m [Text]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (m Text -> Text -> ExpValue -> m Text
interValToVar m Text
forall a. m a
cannotApply) [Text]
in_types [ExpValue]
es'

        if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
in_types Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ins
          then do
            [Text]
outs <- Int -> m Text -> m [Text]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
out_types) (m Text -> m [Text]) -> m Text -> m [Text]
forall a b. (a -> b) -> a -> b
$ Text -> m Text
forall (m :: * -> *). MonadIO m => Text -> m Text
newVar Text
"out"
            m [Text] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [Text] -> m ()) -> m [Text] -> m ()
forall a b. (a -> b) -> a -> b
$ IO (Either CmdFailure [Text]) -> m [Text]
forall (m :: * -> *) a.
(MonadError Text m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (IO (Either CmdFailure [Text]) -> m [Text])
-> IO (Either CmdFailure [Text]) -> m [Text]
forall a b. (a -> b) -> a -> b
$ Server -> Text -> [Text] -> [Text] -> IO (Either CmdFailure [Text])
cmdCall Server
server Text
name [Text]
outs [Text]
ins
            ExpValue -> m ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ [ExpValue] -> ExpValue
forall v. [Compound v] -> Compound v
V.mkCompound ([ExpValue] -> ExpValue) -> [ExpValue] -> ExpValue
forall a b. (a -> b) -> a -> b
$ (ScriptValue ValOrVar -> ExpValue)
-> [ScriptValue ValOrVar] -> [ExpValue]
forall a b. (a -> b) -> [a] -> [b]
map ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom ([ScriptValue ValOrVar] -> [ExpValue])
-> [ScriptValue ValOrVar] -> [ExpValue]
forall a b. (a -> b) -> a -> b
$ (Text -> ValOrVar -> ScriptValue ValOrVar)
-> [Text] -> [ValOrVar] -> [ScriptValue ValOrVar]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> ValOrVar -> ScriptValue ValOrVar
forall v. Text -> v -> ScriptValue v
SValue [Text]
out_types ([ValOrVar] -> [ScriptValue ValOrVar])
-> [ValOrVar] -> [ScriptValue ValOrVar]
forall a b. (a -> b) -> a -> b
$ (Text -> ValOrVar) -> [Text] -> [ValOrVar]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ValOrVar
VVar [Text]
outs
          else
            ExpValue -> m ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue)
-> ([ScriptValue ValOrVar] -> ExpValue)
-> [ScriptValue ValOrVar]
-> m ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue ValOrVar -> ExpValue)
-> ([ScriptValue ValOrVar] -> ScriptValue ValOrVar)
-> [ScriptValue ValOrVar]
-> ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> [Text]
-> [Text]
-> [ScriptValue ValOrVar]
-> ScriptValue ValOrVar
forall v.
Text -> [Text] -> [Text] -> [ScriptValue v] -> ScriptValue v
SFun Text
name [Text]
in_types [Text]
out_types ([ScriptValue ValOrVar] -> m ExpValue)
-> [ScriptValue ValOrVar] -> m ExpValue
forall a b. (a -> b) -> a -> b
$
              (Text -> ValOrVar -> ScriptValue ValOrVar)
-> [Text] -> [ValOrVar] -> [ScriptValue ValOrVar]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> ValOrVar -> ScriptValue ValOrVar
forall v. Text -> v -> ScriptValue v
SValue [Text]
in_types ([ValOrVar] -> [ScriptValue ValOrVar])
-> [ValOrVar] -> [ScriptValue ValOrVar]
forall a b. (a -> b) -> a -> b
$
                (Text -> ValOrVar) -> [Text] -> [ValOrVar]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ValOrVar
VVar [Text]
ins
      evalExp' Map Text ExpValue
_ (StringLit Text
s) =
        case Text -> Maybe Value
forall t. PutValue t => t -> Maybe Value
V.putValue Text
s of
          Just Value
s' ->
            ExpValue -> m ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue ValOrVar -> ExpValue)
-> ScriptValue ValOrVar -> ExpValue
forall a b. (a -> b) -> a -> b
$ Text -> ValOrVar -> ScriptValue ValOrVar
forall v. Text -> v -> ScriptValue v
SValue (ValueType -> Text
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
s')) (ValOrVar -> ScriptValue ValOrVar)
-> ValOrVar -> ScriptValue ValOrVar
forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
s'
          Maybe Value
Nothing -> String -> m ExpValue
forall a. HasCallStack => String -> a
error (String -> m ExpValue) -> String -> m ExpValue
forall a b. (a -> b) -> a -> b
$ String
"Unable to write value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Pretty a => a -> String
pretty Text
s
      evalExp' Map Text ExpValue
_ (Const Value
val) =
        ExpValue -> m ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> m ExpValue) -> ExpValue -> m ExpValue
forall a b. (a -> b) -> a -> b
$ ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue ValOrVar -> ExpValue)
-> ScriptValue ValOrVar -> ExpValue
forall a b. (a -> b) -> a -> b
$ Text -> ValOrVar -> ScriptValue ValOrVar
forall v. Text -> v -> ScriptValue v
SValue (ValueType -> Text
V.valueTypeTextNoDims (Value -> ValueType
V.valueType Value
val)) (ValOrVar -> ScriptValue ValOrVar)
-> ValOrVar -> ScriptValue ValOrVar
forall a b. (a -> b) -> a -> b
$ Value -> ValOrVar
VVal Value
val
      evalExp' Map Text ExpValue
vtable (Tuple [Exp]
es) =
        [ExpValue] -> ExpValue
forall v. [Compound v] -> Compound v
V.ValueTuple ([ExpValue] -> ExpValue) -> m [ExpValue] -> m ExpValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> m ExpValue) -> [Exp] -> m [ExpValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map Text ExpValue -> Exp -> m ExpValue
evalExp' Map Text ExpValue
vtable) [Exp]
es
      evalExp' Map Text ExpValue
vtable e :: Exp
e@(Record [(Text, Exp)]
m) = do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
nubOrd (((Text, Exp) -> Text) -> [(Text, Exp)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Exp) -> Text
forall a b. (a, b) -> a
fst [(Text, Exp)]
m)) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (((Text, Exp) -> Text) -> [(Text, Exp)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Exp) -> Text
forall a b. (a, b) -> a
fst [(Text, Exp)]
m)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          Text -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text
"Record " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Exp -> Text
forall a. Pretty a => a -> Text
prettyText Exp
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has duplicate fields."
        Map Text ExpValue -> ExpValue
forall v. Map Text (Compound v) -> Compound v
V.ValueRecord (Map Text ExpValue -> ExpValue)
-> m (Map Text ExpValue) -> m ExpValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> m ExpValue) -> Map Text Exp -> m (Map Text ExpValue)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map Text ExpValue -> Exp -> m ExpValue
evalExp' Map Text ExpValue
vtable) ([(Text, Exp)] -> Map Text Exp
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Exp)]
m)
      evalExp' Map Text ExpValue
vtable (Let [Text]
pat Exp
e1 Exp
e2) = do
        ExpValue
v <- Map Text ExpValue -> Exp -> m ExpValue
evalExp' Map Text ExpValue
vtable Exp
e1
        Map Text ExpValue
pat_vtable <- [Text] -> ExpValue -> m (Map Text ExpValue)
letMatch [Text]
pat ExpValue
v
        Map Text ExpValue -> Exp -> m ExpValue
evalExp' (Map Text ExpValue
pat_vtable Map Text ExpValue -> Map Text ExpValue -> Map Text ExpValue
forall a. Semigroup a => a -> a -> a
<> Map Text ExpValue
vtable) Exp
e2

  let freeNonresultVars :: ExpValue -> m ExpValue
freeNonresultVars ExpValue
v = do
        let v_vars :: Set Text
v_vars = ExpValue -> Set Text
serverVarsInValue ExpValue
v
        [Text]
to_free <- IO [Text] -> m [Text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> m [Text]) -> IO [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Text
v_vars) ([Text] -> [Text]) -> IO [Text] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [Text] -> IO [Text]
forall a. IORef a -> IO a
readIORef IORef [Text]
vars
        IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server [Text]
to_free
        ExpValue -> m ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpValue
v
      freeVarsOnError :: e -> m b
freeVarsOnError e
e = do
        -- We are intentionally ignoring any errors produced by
        -- cmdFree, because we already have another error to
        -- propagate.  Also, not all of the variables that we put in
        -- 'vars' might actually exist server-side, if we failed in a
        -- Call.
        m (Maybe CmdFailure) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe CmdFailure) -> m ()) -> m (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe CmdFailure) -> m (Maybe CmdFailure)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CmdFailure) -> m (Maybe CmdFailure))
-> IO (Maybe CmdFailure) -> m (Maybe CmdFailure)
forall a b. (a -> b) -> a -> b
$ Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree Server
server ([Text] -> IO (Maybe CmdFailure))
-> IO [Text] -> IO (Maybe CmdFailure)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef [Text] -> IO [Text]
forall a. IORef a -> IO a
readIORef IORef [Text]
vars
        e -> m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
  (ExpValue -> m ExpValue
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
ExpValue -> m ExpValue
freeNonresultVars (ExpValue -> m ExpValue) -> m ExpValue -> m ExpValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Map Text ExpValue -> Exp -> m ExpValue
evalExp' Map Text ExpValue
forall a. Monoid a => a
mempty Exp
top_level_e) m ExpValue -> (Text -> m ExpValue) -> m ExpValue
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` Text -> m ExpValue
forall (m :: * -> *) e b. (MonadIO m, MonadError e m) => e -> m b
freeVarsOnError

-- | Read actual values from the server.  Fails for values that have
-- no well-defined external representation.
getExpValue ::
  (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m V.CompoundValue
getExpValue :: ScriptServer -> ExpValue -> m CompoundValue
getExpValue ScriptServer
server ExpValue
e =
  (ScriptValue Value -> m Value)
-> Compound (ScriptValue Value) -> m CompoundValue
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ScriptValue Value -> m Value
forall (m :: * -> *) a. MonadError Text m => ScriptValue a -> m a
toGround (Compound (ScriptValue Value) -> m CompoundValue)
-> m (Compound (ScriptValue Value)) -> m CompoundValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ScriptValue ValOrVar -> m (ScriptValue Value))
-> ExpValue -> m (Compound (ScriptValue Value))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ValOrVar -> m Value)
-> ScriptValue ValOrVar -> m (ScriptValue Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ValOrVar -> m Value
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ValOrVar -> m Value
onLeaf) ExpValue
e
  where
    onLeaf :: ValOrVar -> m Value
onLeaf (VVar Text
v) = Server -> Text -> m Value
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
Server -> Text -> m Value
readVar (ScriptServer -> Server
scriptServer ScriptServer
server) Text
v
    onLeaf (VVal Value
v) = Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
    toGround :: ScriptValue a -> m a
toGround (SFun Text
fname [Text]
_ [Text]
_ [ScriptValue a]
_) =
      Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ Text
"Function " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not fully applied."
    toGround (SValue Text
_ a
v) = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

-- | Like 'evalExp', but requires all values to be non-functional.  If
-- the value has a bad type, return that type instead.  Other
-- evaluation problems (e.g. type failures) raise errors.
evalExpToGround ::
  (MonadError T.Text m, MonadIO m) =>
  EvalBuiltin m ->
  ScriptServer ->
  Exp ->
  m (Either (V.Compound ScriptValueType) V.CompoundValue)
evalExpToGround :: EvalBuiltin m
-> ScriptServer
-> Exp
-> m (Either (Compound ScriptValueType) CompoundValue)
evalExpToGround EvalBuiltin m
builtin ScriptServer
server Exp
e = do
  ExpValue
v <- EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
evalExp EvalBuiltin m
builtin ScriptServer
server Exp
e
  -- This assumes that the only error that can occur during
  -- getExpValue is trying to read an opaque.
  (CompoundValue -> Either (Compound ScriptValueType) CompoundValue
forall a b. b -> Either a b
Right (CompoundValue -> Either (Compound ScriptValueType) CompoundValue)
-> m CompoundValue
-> m (Either (Compound ScriptValueType) CompoundValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptServer -> ExpValue -> m CompoundValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue ScriptServer
server ExpValue
v)
    m (Either (Compound ScriptValueType) CompoundValue)
-> (Text -> m (Either (Compound ScriptValueType) CompoundValue))
-> m (Either (Compound ScriptValueType) CompoundValue)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` m (Either (Compound ScriptValueType) CompoundValue)
-> Text -> m (Either (Compound ScriptValueType) CompoundValue)
forall a b. a -> b -> a
const (Either (Compound ScriptValueType) CompoundValue
-> m (Either (Compound ScriptValueType) CompoundValue)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Compound ScriptValueType) CompoundValue
 -> m (Either (Compound ScriptValueType) CompoundValue))
-> Either (Compound ScriptValueType) CompoundValue
-> m (Either (Compound ScriptValueType) CompoundValue)
forall a b. (a -> b) -> a -> b
$ Compound ScriptValueType
-> Either (Compound ScriptValueType) CompoundValue
forall a b. a -> Either a b
Left (Compound ScriptValueType
 -> Either (Compound ScriptValueType) CompoundValue)
-> Compound ScriptValueType
-> Either (Compound ScriptValueType) CompoundValue
forall a b. (a -> b) -> a -> b
$ (ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
v)

-- | The set of Futhark variables that are referenced by the
-- expression - these will have to be entry points in the Futhark
-- program.
varsInExp :: Exp -> S.Set EntryName
varsInExp :: Exp -> Set Text
varsInExp ServerVar {} = Set Text
forall a. Monoid a => a
mempty
varsInExp (Call (FuncFut Text
v) [Exp]
es) = Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
S.insert Text
v (Set Text -> Set Text) -> Set Text -> Set Text
forall a b. (a -> b) -> a -> b
$ (Exp -> Set Text) -> [Exp] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set Text
varsInExp [Exp]
es
varsInExp (Call (FuncBuiltin Text
_) [Exp]
es) = (Exp -> Set Text) -> [Exp] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set Text
varsInExp [Exp]
es
varsInExp (Tuple [Exp]
es) = (Exp -> Set Text) -> [Exp] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set Text
varsInExp [Exp]
es
varsInExp (Record [(Text, Exp)]
fs) = ((Text, Exp) -> Set Text) -> [(Text, Exp)] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Exp -> Set Text) -> (Text, Exp) -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set Text
varsInExp) [(Text, Exp)]
fs
varsInExp Const {} = Set Text
forall a. Monoid a => a
mempty
varsInExp StringLit {} = Set Text
forall a. Monoid a => a
mempty
varsInExp (Let [Text]
pat Exp
e1 Exp
e2) = Exp -> Set Text
varsInExp Exp
e1 Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Bool) -> Set Text -> Set Text
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
pat) (Exp -> Set Text
varsInExp Exp
e2)

-- | Release all the server-side variables in the value.  Yes,
-- FutharkScript has manual memory management...
freeValue :: (MonadError T.Text m, MonadIO m) => ScriptServer -> ExpValue -> m ()
freeValue :: ScriptServer -> ExpValue -> m ()
freeValue ScriptServer
server =
  IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ())
-> (ExpValue -> IO (Maybe CmdFailure)) -> ExpValue -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Server -> [Text] -> IO (Maybe CmdFailure)
cmdFree (ScriptServer -> Server
scriptServer ScriptServer
server) ([Text] -> IO (Maybe CmdFailure))
-> (ExpValue -> [Text]) -> ExpValue -> IO (Maybe CmdFailure)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text])
-> (ExpValue -> Set Text) -> ExpValue -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpValue -> Set Text
serverVarsInValue