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

-- | 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,

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

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

import Control.Monad.Except
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Char
import Data.Foldable (toList)
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 qualified Data.Text.IO as T
import Data.Traversable
import Data.Void
import Futhark.Server
import qualified Futhark.Test.Values as V
import qualified Futhark.Test.Values.Parser as V
import Futhark.Util (nubOrd)
import Futhark.Util.Pretty hiding (float, line, sep, string, (</>), (<|>))
import Language.Futhark.Prop (primValueType)
import Language.Futhark.Syntax (PrimValue (..))
import System.IO
import System.IO.Temp
import Text.Megaparsec

-- | Like a 'Server', but keeps a bit more state to make FutharkScript
-- more convenient.
data ScriptServer = ScriptServer Server (IORef Int)

-- | Start a server, execute an action, then shut down the server.
-- Similar to 'withServer'.
withScriptServer :: FilePath -> [FilePath] -> (ScriptServer -> IO a) -> IO a
withScriptServer :: FilePath -> [FilePath] -> (ScriptServer -> IO a) -> IO a
withScriptServer FilePath
prog [FilePath]
options ScriptServer -> IO a
f = FilePath -> [FilePath] -> (Server -> IO a) -> IO a
forall a. FilePath -> [FilePath] -> (Server -> IO a) -> IO a
withServer FilePath
prog [FilePath]
options ((Server -> IO a) -> IO a) -> (Server -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Server
server -> do
  IORef Int
counter <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
  ScriptServer -> IO a
f (ScriptServer -> IO a) -> ScriptServer -> IO a
forall a b. (a -> b) -> a -> b
$ Server -> IORef Int -> ScriptServer
ScriptServer Server
server IORef Int
counter

-- | 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 EntryName [Exp]
  | Const PrimValue
  | Tuple [Exp]
  | Record [(T.Text, Exp)]
  | -- | Server-side variable, *not* Futhark variable (these are
    -- handled in 'Call').
    ServerVar TypeName VarName
  deriving (Int -> Exp -> ShowS
[Exp] -> ShowS
Exp -> FilePath
(Int -> Exp -> ShowS)
-> (Exp -> FilePath) -> ([Exp] -> ShowS) -> Show Exp
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Exp] -> ShowS
$cshowList :: [Exp] -> ShowS
show :: Exp -> FilePath
$cshow :: Exp -> FilePath
showsPrec :: Int -> Exp -> ShowS
$cshowsPrec :: Int -> Exp -> ShowS
Show)

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 TypeName
_ TypeName
v) = Doc
"$" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> TypeName -> Doc
strictText TypeName
v
  pprPrec Int
_ (Const PrimValue
v) = PrimValue -> Doc
forall a. Pretty a => a -> Doc
ppr PrimValue
v
  pprPrec Int
i (Call TypeName
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
$ TypeName -> Doc
strictText TypeName
v Doc -> Doc -> Doc
<+> [Doc] -> Doc
spread ((Exp -> Doc) -> [Exp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (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 Exp -> Doc
forall a. Pretty a => a -> Doc
ppr [Exp]
vs
  pprPrec Int
_ (Record [(TypeName, 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
$ ((TypeName, Exp) -> Doc) -> [(TypeName, Exp)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName, Exp) -> Doc
forall a a. (Pretty a, Pretty a) => (a, a) -> Doc
field [(TypeName, Exp)]
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
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

parseEntryName :: Parser EntryName
parseEntryName :: Parser TypeName
parseEntryName =
  (FilePath -> TypeName)
-> ParsecT Void TypeName Identity FilePath -> Parser TypeName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> TypeName
T.pack (ParsecT Void TypeName Identity FilePath -> Parser TypeName)
-> ParsecT Void TypeName Identity FilePath -> Parser TypeName
forall a b. (a -> b) -> a -> b
$ (:) (Char -> ShowS)
-> ParsecT Void TypeName Identity Char
-> ParsecT Void TypeName Identity ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token TypeName -> Bool)
-> ParsecT Void TypeName Identity (Token TypeName)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token TypeName -> Bool
isAlpha ParsecT Void TypeName Identity ShowS
-> ParsecT Void TypeName Identity FilePath
-> ParsecT Void TypeName Identity FilePath
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void TypeName Identity Char
-> ParsecT Void TypeName Identity FilePath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ((Token TypeName -> Bool)
-> ParsecT Void TypeName Identity (Token TypeName)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token TypeName -> Bool
constituent)
  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
'_'

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 = Parser TypeName -> Parser TypeName -> Parser a -> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Parser () -> Parser TypeName -> Parser TypeName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser TypeName
"(") (Parser () -> Parser TypeName -> Parser TypeName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser TypeName
")")

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

-- | Parse a FutharkScript expression.
parseExp :: Parser () -> Parser Exp
parseExp :: Parser () -> Parser Exp
parseExp Parser ()
sep =
  [Parser Exp] -> Parser Exp
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser () -> Parser Exp -> Parser Exp
forall a. Parser () -> Parser a -> Parser a
inParens Parser ()
sep ([Exp] -> Exp
mkTuple ([Exp] -> Exp)
-> ParsecT Void TypeName Identity [Exp] -> Parser Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser () -> Parser Exp
parseExp Parser ()
sep Parser Exp
-> Parser TypeName -> ParsecT Void TypeName Identity [Exp]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` Parser TypeName
pComma)),
      Parser () -> Parser Exp -> Parser Exp
forall a. Parser () -> Parser a -> Parser a
inBraces Parser ()
sep ([(TypeName, Exp)] -> Exp
Record ([(TypeName, Exp)] -> Exp)
-> ParsecT Void TypeName Identity [(TypeName, Exp)] -> Parser Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void TypeName Identity (TypeName, Exp)
pField ParsecT Void TypeName Identity (TypeName, Exp)
-> Parser TypeName
-> ParsecT Void TypeName Identity [(TypeName, Exp)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` Parser TypeName
pComma)),
      TypeName -> [Exp] -> Exp
Call (TypeName -> [Exp] -> Exp)
-> Parser TypeName -> ParsecT Void TypeName Identity ([Exp] -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser TypeName -> Parser TypeName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser TypeName
parseEntryName ParsecT Void TypeName Identity ([Exp] -> Exp)
-> ParsecT Void TypeName Identity [Exp] -> Parser Exp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Exp -> ParsecT Void TypeName Identity [Exp]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser () -> Parser Exp
parseExp Parser ()
sep),
      PrimValue -> Exp
Const (PrimValue -> Exp)
-> ParsecT Void TypeName Identity PrimValue -> Parser Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ()
-> ParsecT Void TypeName Identity PrimValue
-> ParsecT Void TypeName Identity PrimValue
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep ParsecT Void TypeName Identity PrimValue
V.parsePrimValue
    ]
  where
    pField :: ParsecT Void TypeName Identity (TypeName, Exp)
pField = (,) (TypeName -> Exp -> (TypeName, Exp))
-> Parser TypeName
-> ParsecT Void TypeName Identity (Exp -> (TypeName, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TypeName
parseEntryName ParsecT Void TypeName Identity (Exp -> (TypeName, Exp))
-> Parser Exp -> ParsecT Void TypeName Identity (TypeName, Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser TypeName
pEquals Parser TypeName -> Parser Exp -> Parser Exp
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> Parser Exp
parseExp Parser ()
sep)
    pEquals :: Parser TypeName
pEquals = Parser () -> Parser TypeName -> Parser TypeName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser TypeName
"="
    pComma :: Parser TypeName
pComma = Parser () -> Parser TypeName -> Parser TypeName
forall a. Parser () -> Parser a -> Parser a
lexeme Parser ()
sep Parser TypeName
","
    mkTuple :: [Exp] -> Exp
mkTuple [Exp
v] = Exp
v
    mkTuple [Exp]
vs = [Exp] -> Exp
Tuple [Exp]
vs

prettyFailure :: CmdFailure -> T.Text
prettyFailure :: CmdFailure -> TypeName
prettyFailure (CmdFailure [TypeName]
bef [TypeName]
aft) =
  [TypeName] -> TypeName
T.unlines ([TypeName] -> TypeName) -> [TypeName] -> TypeName
forall a b. (a -> b) -> a -> b
$ [TypeName]
bef [TypeName] -> [TypeName] -> [TypeName]
forall a. [a] -> [a] -> [a]
++ [TypeName]
aft

cmdMaybe :: (MonadError T.Text m, MonadIO m) => IO (Maybe CmdFailure) -> m ()
cmdMaybe :: IO (Maybe CmdFailure) -> m ()
cmdMaybe IO (Maybe CmdFailure)
m = m () -> (CmdFailure -> m ()) -> Maybe CmdFailure -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (TypeName -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypeName -> m ())
-> (CmdFailure -> TypeName) -> CmdFailure -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> TypeName
prettyFailure) (Maybe CmdFailure -> m ()) -> m (Maybe CmdFailure) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe CmdFailure) -> m (Maybe CmdFailure)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe CmdFailure)
m

cmdEither :: (MonadError T.Text m, MonadIO m) => IO (Either CmdFailure a) -> m a
cmdEither :: IO (Either CmdFailure a) -> m a
cmdEither IO (Either CmdFailure a)
m = (CmdFailure -> m a) -> (a -> m a) -> Either CmdFailure a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TypeName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypeName -> m a) -> (CmdFailure -> TypeName) -> CmdFailure -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmdFailure -> TypeName
prettyFailure) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CmdFailure a -> m a) -> m (Either CmdFailure a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either CmdFailure a) -> m (Either CmdFailure a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Either CmdFailure a)
m

readVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> m V.Value
readVar :: Server -> TypeName -> m Value
readVar Server
server TypeName
v =
  (TypeName -> m Value)
-> (Value -> m Value) -> Either TypeName Value -> m Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TypeName -> 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 TypeName Value -> m Value)
-> (IO (Either TypeName Value) -> m (Either TypeName Value))
-> IO (Either TypeName Value)
-> m Value
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either TypeName Value) -> m (Either TypeName Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either TypeName Value) -> m Value)
-> IO (Either TypeName Value) -> m Value
forall a b. (a -> b) -> a -> b
$
    FilePath
-> (FilePath -> Handle -> IO (Either TypeName Value))
-> IO (Either TypeName Value)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"futhark-server-read" ((FilePath -> Handle -> IO (Either TypeName Value))
 -> IO (Either TypeName Value))
-> (FilePath -> Handle -> IO (Either TypeName Value))
-> IO (Either TypeName Value)
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpf Handle
tmpf_h -> do
      Handle -> IO ()
hClose Handle
tmpf_h
      Maybe CmdFailure
store_res <- Server -> FilePath -> [TypeName] -> IO (Maybe CmdFailure)
cmdStore Server
server FilePath
tmpf [TypeName
v]
      case Maybe CmdFailure
store_res of
        Just CmdFailure
err -> Either TypeName Value -> IO (Either TypeName Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TypeName Value -> IO (Either TypeName Value))
-> Either TypeName Value -> IO (Either TypeName Value)
forall a b. (a -> b) -> a -> b
$ TypeName -> Either TypeName Value
forall a b. a -> Either a b
Left (TypeName -> Either TypeName Value)
-> TypeName -> Either TypeName Value
forall a b. (a -> b) -> a -> b
$ CmdFailure -> TypeName
prettyFailure CmdFailure
err
        Maybe CmdFailure
Nothing -> do
          ByteString
s <- FilePath -> IO ByteString
LBS.readFile FilePath
tmpf
          case ByteString -> Maybe [Value]
V.readValues ByteString
s of
            Just [Value
val] -> Either TypeName Value -> IO (Either TypeName Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TypeName Value -> IO (Either TypeName Value))
-> Either TypeName Value -> IO (Either TypeName Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either TypeName Value
forall a b. b -> Either a b
Right Value
val
            Maybe [Value]
_ -> Either TypeName Value -> IO (Either TypeName Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TypeName Value -> IO (Either TypeName Value))
-> Either TypeName Value -> IO (Either TypeName Value)
forall a b. (a -> b) -> a -> b
$ TypeName -> Either TypeName Value
forall a b. a -> Either a b
Left TypeName
"Invalid data file produced by Futhark server."

writeVar :: (MonadError T.Text m, MonadIO m) => Server -> VarName -> PrimValue -> m ()
writeVar :: Server -> TypeName -> PrimValue -> m ()
writeVar Server
server TypeName
v PrimValue
val =
  IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError TypeName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ())
-> ((FilePath -> Handle -> IO (Maybe CmdFailure))
    -> IO (Maybe CmdFailure))
-> (FilePath -> Handle -> IO (Maybe CmdFailure))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe CmdFailure) -> IO (Maybe CmdFailure)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CmdFailure) -> IO (Maybe CmdFailure))
-> ((FilePath -> Handle -> IO (Maybe CmdFailure))
    -> IO (Maybe CmdFailure))
-> (FilePath -> Handle -> IO (Maybe CmdFailure))
-> IO (Maybe CmdFailure)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> (FilePath -> Handle -> IO (Maybe CmdFailure))
-> IO (Maybe CmdFailure)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"futhark-server-write" ((FilePath -> Handle -> IO (Maybe CmdFailure)) -> m ())
-> (FilePath -> Handle -> IO (Maybe CmdFailure)) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpf Handle
tmpf_h -> do
    Handle -> TypeName -> IO ()
T.hPutStr Handle
tmpf_h (TypeName -> IO ()) -> TypeName -> IO ()
forall a b. (a -> b) -> a -> b
$ PrimValue -> TypeName
forall a. Pretty a => a -> TypeName
prettyText PrimValue
val
    Handle -> IO ()
hClose Handle
tmpf_h
    let t :: TypeName
t = PrimType -> TypeName
forall a. Pretty a => a -> TypeName
prettyText (PrimType -> TypeName) -> PrimType -> TypeName
forall a b. (a -> b) -> a -> b
$ PrimValue -> PrimType
primValueType PrimValue
val
    Server
-> FilePath -> [(TypeName, TypeName)] -> IO (Maybe CmdFailure)
cmdRestore Server
server FilePath
tmpf [(TypeName
v, TypeName
t)]

-- | 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.
    SFun EntryName [TypeName] [TypeName] [ScriptValue v]

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 TypeName
t a
v) = TypeName -> b -> ScriptValue b
forall v. TypeName -> v -> ScriptValue v
SValue TypeName
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 TypeName
fname [TypeName]
ins [TypeName]
outs [ScriptValue a]
vs) =
    TypeName
-> [TypeName] -> [TypeName] -> [ScriptValue b] -> ScriptValue b
forall v.
TypeName
-> [TypeName] -> [TypeName] -> [ScriptValue v] -> ScriptValue v
SFun TypeName
fname [TypeName]
ins [TypeName]
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 (Int -> ScriptValueType -> ShowS
[ScriptValueType] -> ShowS
ScriptValueType -> FilePath
(Int -> ScriptValueType -> ShowS)
-> (ScriptValueType -> FilePath)
-> ([ScriptValueType] -> ShowS)
-> Show ScriptValueType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ScriptValueType] -> ShowS
$cshowList :: [ScriptValueType] -> ShowS
show :: ScriptValueType -> FilePath
$cshow :: ScriptValueType -> FilePath
showsPrec :: Int -> ScriptValueType -> ShowS
$cshowsPrec :: Int -> ScriptValueType -> ShowS
Show)

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

-- | The value that is produced by expression evaluation.  This
-- representation keeps all values on the server.
type ExpValue = V.Compound (ScriptValue VarName)

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

serverVarsInValue :: ExpValue -> S.Set VarName
serverVarsInValue :: ExpValue -> Set TypeName
serverVarsInValue = [TypeName] -> Set TypeName
forall a. Ord a => [a] -> Set a
S.fromList ([TypeName] -> Set TypeName)
-> (ExpValue -> [TypeName]) -> ExpValue -> Set TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptValue TypeName -> [TypeName])
-> [ScriptValue TypeName] -> [TypeName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScriptValue TypeName -> [TypeName]
forall a. ScriptValue a -> [a]
isVar ([ScriptValue TypeName] -> [TypeName])
-> (ExpValue -> [ScriptValue TypeName]) -> ExpValue -> [TypeName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpValue -> [ScriptValue TypeName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where
    isVar :: ScriptValue a -> [a]
isVar (SValue TypeName
_ a
x) = [a
x]
    isVar (SFun TypeName
_ [TypeName]
_ [TypeName]
_ [ScriptValue a]
closure) = (ScriptValue a -> [a]) -> [ScriptValue a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ScriptValue a -> [a]
isVar ([ScriptValue a] -> [a]) -> [ScriptValue a] -> [a]
forall a b. (a -> b) -> a -> b
$ [ScriptValue a] -> [ScriptValue a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [ScriptValue a]
closure

-- | Convert a value into a corresponding expression.
valueToExp :: ExpValue -> Exp
valueToExp :: ExpValue -> Exp
valueToExp (V.ValueAtom (SValue TypeName
t TypeName
v)) =
  TypeName -> TypeName -> Exp
ServerVar TypeName
t TypeName
v
valueToExp (V.ValueAtom (SFun TypeName
fname [TypeName]
_ [TypeName]
_ [ScriptValue TypeName]
closure)) =
  TypeName -> [Exp] -> Exp
Call TypeName
fname ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (ScriptValue TypeName -> Exp) -> [ScriptValue TypeName] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (ExpValue -> Exp
valueToExp (ExpValue -> Exp)
-> (ScriptValue TypeName -> ExpValue)
-> ScriptValue TypeName
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptValue TypeName -> ExpValue
forall v. v -> Compound v
V.ValueAtom) [ScriptValue TypeName]
closure
valueToExp (V.ValueRecord Map TypeName ExpValue
fs) =
  [(TypeName, Exp)] -> Exp
Record ([(TypeName, Exp)] -> Exp) -> [(TypeName, Exp)] -> Exp
forall a b. (a -> b) -> a -> b
$ Map TypeName Exp -> [(TypeName, Exp)]
forall k a. Map k a -> [(k, a)]
M.toList (Map TypeName Exp -> [(TypeName, Exp)])
-> Map TypeName Exp -> [(TypeName, Exp)]
forall a b. (a -> b) -> a -> b
$ (ExpValue -> Exp) -> Map TypeName ExpValue -> Map TypeName Exp
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ExpValue -> Exp
valueToExp Map TypeName 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

-- | Evaluate a FutharkScript expression relative to some running server.
evalExp :: (MonadError T.Text m, MonadIO m) => ScriptServer -> Exp -> m ExpValue
evalExp :: ScriptServer -> Exp -> m ExpValue
evalExp (ScriptServer Server
server IORef Int
counter) Exp
top_level_e = do
  IORef [TypeName]
vars <- IO (IORef [TypeName]) -> m (IORef [TypeName])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [TypeName]) -> m (IORef [TypeName]))
-> IO (IORef [TypeName]) -> m (IORef [TypeName])
forall a b. (a -> b) -> a -> b
$ [TypeName] -> IO (IORef [TypeName])
forall a. a -> IO (IORef a)
newIORef []
  let newVar :: TypeName -> m TypeName
newVar TypeName
base = IO TypeName -> m TypeName
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TypeName -> m TypeName) -> IO TypeName -> m TypeName
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 :: TypeName
v = TypeName
base TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> Int -> TypeName
forall a. Pretty a => a -> TypeName
prettyText Int
x
        IORef [TypeName] -> ([TypeName] -> [TypeName]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [TypeName]
vars (TypeName
v TypeName -> [TypeName] -> [TypeName]
forall a. a -> [a] -> [a]
:)
        TypeName -> IO TypeName
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeName
v

      evalExpToVar :: Exp -> f TypeName
evalExpToVar Exp
e = do
        ExpValue
vs <- Exp -> f ExpValue
evalExpToVars Exp
e
        case ExpValue
vs of
          V.ValueAtom (SValue TypeName
_ TypeName
v) -> TypeName -> f TypeName
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeName
v
          V.ValueAtom SFun {} ->
            TypeName -> f TypeName
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypeName -> f TypeName) -> TypeName -> f TypeName
forall a b. (a -> b) -> a -> b
$ TypeName
"Expression " TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> Exp -> TypeName
forall a. Pretty a => a -> TypeName
prettyText Exp
e TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
" not fully applied."
          ExpValue
_ ->
            TypeName -> f TypeName
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypeName -> f TypeName) -> TypeName -> f TypeName
forall a b. (a -> b) -> a -> b
$ TypeName
"Expression " TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> Exp -> TypeName
forall a. Pretty a => a -> TypeName
prettyText Exp
e TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
" produced more than one value."
      evalExpToVars :: Exp -> f ExpValue
evalExpToVars (ServerVar TypeName
t TypeName
v) =
        ExpValue -> f ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> f ExpValue) -> ExpValue -> f ExpValue
forall a b. (a -> b) -> a -> b
$ ScriptValue TypeName -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue TypeName -> ExpValue)
-> ScriptValue TypeName -> ExpValue
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeName -> ScriptValue TypeName
forall v. TypeName -> v -> ScriptValue v
SValue TypeName
t TypeName
v
      evalExpToVars (Call TypeName
name [Exp]
es) = do
        [TypeName]
ins <- (Exp -> f TypeName) -> [Exp] -> f [TypeName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> f TypeName
evalExpToVar [Exp]
es
        [TypeName]
in_types <- IO (Either CmdFailure [TypeName]) -> f [TypeName]
forall (m :: * -> *) a.
(MonadError TypeName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (IO (Either CmdFailure [TypeName]) -> f [TypeName])
-> IO (Either CmdFailure [TypeName]) -> f [TypeName]
forall a b. (a -> b) -> a -> b
$ Server -> TypeName -> IO (Either CmdFailure [TypeName])
cmdInputs Server
server TypeName
name
        [TypeName]
out_types <- IO (Either CmdFailure [TypeName]) -> f [TypeName]
forall (m :: * -> *) a.
(MonadError TypeName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (IO (Either CmdFailure [TypeName]) -> f [TypeName])
-> IO (Either CmdFailure [TypeName]) -> f [TypeName]
forall a b. (a -> b) -> a -> b
$ Server -> TypeName -> IO (Either CmdFailure [TypeName])
cmdOutputs Server
server TypeName
name
        if [TypeName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeName]
in_types Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [TypeName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeName]
ins
          then do
            [TypeName]
outs <- Int -> f TypeName -> f [TypeName]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([TypeName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeName]
out_types) (f TypeName -> f [TypeName]) -> f TypeName -> f [TypeName]
forall a b. (a -> b) -> a -> b
$ TypeName -> f TypeName
forall (m :: * -> *). MonadIO m => TypeName -> m TypeName
newVar TypeName
"out"
            f [TypeName] -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f [TypeName] -> f ()) -> f [TypeName] -> f ()
forall a b. (a -> b) -> a -> b
$ IO (Either CmdFailure [TypeName]) -> f [TypeName]
forall (m :: * -> *) a.
(MonadError TypeName m, MonadIO m) =>
IO (Either CmdFailure a) -> m a
cmdEither (IO (Either CmdFailure [TypeName]) -> f [TypeName])
-> IO (Either CmdFailure [TypeName]) -> f [TypeName]
forall a b. (a -> b) -> a -> b
$ Server
-> TypeName
-> [TypeName]
-> [TypeName]
-> IO (Either CmdFailure [TypeName])
cmdCall Server
server TypeName
name [TypeName]
outs [TypeName]
ins
            ExpValue -> f ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> f ExpValue) -> ExpValue -> f ExpValue
forall a b. (a -> b) -> a -> b
$ [ScriptValue TypeName] -> ExpValue
forall v. [v] -> Compound v
V.mkCompound ([ScriptValue TypeName] -> ExpValue)
-> [ScriptValue TypeName] -> ExpValue
forall a b. (a -> b) -> a -> b
$ (TypeName -> TypeName -> ScriptValue TypeName)
-> [TypeName] -> [TypeName] -> [ScriptValue TypeName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TypeName -> TypeName -> ScriptValue TypeName
forall v. TypeName -> v -> ScriptValue v
SValue [TypeName]
out_types [TypeName]
outs
          else
            ExpValue -> f ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> f ExpValue)
-> ([ScriptValue TypeName] -> ExpValue)
-> [ScriptValue TypeName]
-> f ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptValue TypeName -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue TypeName -> ExpValue)
-> ([ScriptValue TypeName] -> ScriptValue TypeName)
-> [ScriptValue TypeName]
-> ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName
-> [TypeName]
-> [TypeName]
-> [ScriptValue TypeName]
-> ScriptValue TypeName
forall v.
TypeName
-> [TypeName] -> [TypeName] -> [ScriptValue v] -> ScriptValue v
SFun TypeName
name [TypeName]
in_types [TypeName]
out_types ([ScriptValue TypeName] -> f ExpValue)
-> [ScriptValue TypeName] -> f ExpValue
forall a b. (a -> b) -> a -> b
$
              (TypeName -> TypeName -> ScriptValue TypeName)
-> [TypeName] -> [TypeName] -> [ScriptValue TypeName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TypeName -> TypeName -> ScriptValue TypeName
forall v. TypeName -> v -> ScriptValue v
SValue [TypeName]
in_types [TypeName]
ins
      evalExpToVars (Const PrimValue
val) = do
        TypeName
v <- TypeName -> f TypeName
forall (m :: * -> *). MonadIO m => TypeName -> m TypeName
newVar TypeName
"const"
        Server -> TypeName -> PrimValue -> f ()
forall (m :: * -> *).
(MonadError TypeName m, MonadIO m) =>
Server -> TypeName -> PrimValue -> m ()
writeVar Server
server TypeName
v PrimValue
val
        ExpValue -> f ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpValue -> f ExpValue) -> ExpValue -> f ExpValue
forall a b. (a -> b) -> a -> b
$ ScriptValue TypeName -> ExpValue
forall v. v -> Compound v
V.ValueAtom (ScriptValue TypeName -> ExpValue)
-> ScriptValue TypeName -> ExpValue
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeName -> ScriptValue TypeName
forall v. TypeName -> v -> ScriptValue v
SValue (PrimType -> TypeName
forall a. Pretty a => a -> TypeName
prettyText (PrimValue -> PrimType
primValueType PrimValue
val)) TypeName
v
      evalExpToVars (Tuple [Exp]
es) =
        [ExpValue] -> ExpValue
forall v. [Compound v] -> Compound v
V.ValueTuple ([ExpValue] -> ExpValue) -> f [ExpValue] -> f ExpValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> f ExpValue) -> [Exp] -> f [ExpValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> f ExpValue
evalExpToVars [Exp]
es
      evalExpToVars e :: Exp
e@(Record [(TypeName, Exp)]
m) = do
        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([TypeName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TypeName] -> [TypeName]
forall a. Ord a => [a] -> [a]
nubOrd (((TypeName, Exp) -> TypeName) -> [(TypeName, Exp)] -> [TypeName]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName, Exp) -> TypeName
forall a b. (a, b) -> a
fst [(TypeName, Exp)]
m)) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [TypeName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (((TypeName, Exp) -> TypeName) -> [(TypeName, Exp)] -> [TypeName]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName, Exp) -> TypeName
forall a b. (a, b) -> a
fst [(TypeName, Exp)]
m)) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
          TypeName -> f ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypeName -> f ()) -> TypeName -> f ()
forall a b. (a -> b) -> a -> b
$ TypeName
"Record " TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> Exp -> TypeName
forall a. Pretty a => a -> TypeName
prettyText Exp
e TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
" has duplicate fields."
        Map TypeName ExpValue -> ExpValue
forall v. Map TypeName (Compound v) -> Compound v
V.ValueRecord (Map TypeName ExpValue -> ExpValue)
-> f (Map TypeName ExpValue) -> f ExpValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> f ExpValue)
-> Map TypeName Exp -> f (Map TypeName ExpValue)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Exp -> f ExpValue
evalExpToVars ([(TypeName, Exp)] -> Map TypeName Exp
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(TypeName, Exp)]
m)

  let freeNonresultVars :: ExpValue -> m ExpValue
freeNonresultVars ExpValue
v = do
        let v_vars :: Set TypeName
v_vars = ExpValue -> Set TypeName
serverVarsInValue ExpValue
v
        [TypeName]
to_free <- IO [TypeName] -> m [TypeName]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [TypeName] -> m [TypeName]) -> IO [TypeName] -> m [TypeName]
forall a b. (a -> b) -> a -> b
$ (TypeName -> Bool) -> [TypeName] -> [TypeName]
forall a. (a -> Bool) -> [a] -> [a]
filter (TypeName -> Set TypeName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set TypeName
v_vars) ([TypeName] -> [TypeName]) -> IO [TypeName] -> IO [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [TypeName] -> IO [TypeName]
forall a. IORef a -> IO a
readIORef IORef [TypeName]
vars
        IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError TypeName m, MonadIO m) =>
IO (Maybe CmdFailure) -> m ()
cmdMaybe (IO (Maybe CmdFailure) -> m ()) -> IO (Maybe CmdFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Server -> [TypeName] -> IO (Maybe CmdFailure)
cmdFree Server
server [TypeName]
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 -> [TypeName] -> IO (Maybe CmdFailure)
cmdFree Server
server ([TypeName] -> IO (Maybe CmdFailure))
-> IO [TypeName] -> IO (Maybe CmdFailure)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef [TypeName] -> IO [TypeName]
forall a. IORef a -> IO a
readIORef IORef [TypeName]
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 TypeName 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
=<< Exp -> m ExpValue
forall (f :: * -> *).
(MonadError TypeName f, MonadIO f) =>
Exp -> f ExpValue
evalExpToVars Exp
top_level_e) m ExpValue -> (TypeName -> m ExpValue) -> m ExpValue
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` TypeName -> 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.Compound V.Value)
getExpValue :: ScriptServer -> ExpValue -> m (Compound Value)
getExpValue (ScriptServer Server
server IORef Int
_) ExpValue
e =
  (ScriptValue Value -> m Value)
-> Compound (ScriptValue Value) -> m (Compound Value)
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 TypeName m =>
ScriptValue a -> m a
toGround (Compound (ScriptValue Value) -> m (Compound Value))
-> m (Compound (ScriptValue Value)) -> m (Compound Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ScriptValue TypeName -> 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 ((TypeName -> m Value)
-> ScriptValue TypeName -> m (ScriptValue Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Server -> TypeName -> m Value
forall (m :: * -> *).
(MonadError TypeName m, MonadIO m) =>
Server -> TypeName -> m Value
readVar Server
server)) ExpValue
e
  where
    toGround :: ScriptValue a -> m a
toGround (SFun TypeName
fname [TypeName]
_ [TypeName]
_ [ScriptValue a]
_) =
      TypeName -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypeName -> m a) -> TypeName -> m a
forall a b. (a -> b) -> a -> b
$ TypeName
"Function " TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
fname TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
" not fully applied."
    toGround (SValue TypeName
_ 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.
evalExpToGround ::
  (MonadError T.Text m, MonadIO m) => ScriptServer -> Exp -> m (V.Compound V.Value)
evalExpToGround :: ScriptServer -> Exp -> m (Compound Value)
evalExpToGround ScriptServer
server Exp
e = ScriptServer -> ExpValue -> m (Compound Value)
forall (m :: * -> *).
(MonadError TypeName m, MonadIO m) =>
ScriptServer -> ExpValue -> m (Compound Value)
getExpValue ScriptServer
server (ExpValue -> m (Compound Value))
-> m ExpValue -> m (Compound Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptServer -> Exp -> m ExpValue
forall (m :: * -> *).
(MonadError TypeName m, MonadIO m) =>
ScriptServer -> Exp -> m ExpValue
evalExp ScriptServer
server Exp
e

-- | 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 TypeName
varsInExp ServerVar {} = Set TypeName
forall a. Monoid a => a
mempty
varsInExp (Call TypeName
v [Exp]
es) = TypeName -> Set TypeName -> Set TypeName
forall a. Ord a => a -> Set a -> Set a
S.insert TypeName
v (Set TypeName -> Set TypeName) -> Set TypeName -> Set TypeName
forall a b. (a -> b) -> a -> b
$ (Exp -> Set TypeName) -> [Exp] -> Set TypeName
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set TypeName
varsInExp [Exp]
es
varsInExp (Tuple [Exp]
es) = (Exp -> Set TypeName) -> [Exp] -> Set TypeName
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set TypeName
varsInExp [Exp]
es
varsInExp (Record [(TypeName, Exp)]
fs) = ((TypeName, Exp) -> Set TypeName)
-> [(TypeName, Exp)] -> Set TypeName
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Exp -> Set TypeName) -> (TypeName, Exp) -> Set TypeName
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> Set TypeName
varsInExp) [(TypeName, Exp)]
fs
varsInExp Const {} = Set TypeName
forall a. Monoid a => a
mempty

-- | 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
server IORef Int
_) =
  IO (Maybe CmdFailure) -> m ()
forall (m :: * -> *).
(MonadError TypeName 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 -> [TypeName] -> IO (Maybe CmdFailure)
cmdFree Server
server ([TypeName] -> IO (Maybe CmdFailure))
-> (ExpValue -> [TypeName]) -> ExpValue -> IO (Maybe CmdFailure)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TypeName -> [TypeName]
forall a. Set a -> [a]
S.toList (Set TypeName -> [TypeName])
-> (ExpValue -> Set TypeName) -> ExpValue -> [TypeName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpValue -> Set TypeName
serverVarsInValue