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

-- | @futhark literate@
module Futhark.CLI.Literate (main) where

import Control.Monad.Except
import Data.Bifunctor (bimap, first, second)
import Data.Bits
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Functor
import Data.Int (Int64)
import Data.List (foldl', transpose)
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Vector.Storable as SVec
import Data.Void
import Futhark.Script
import Futhark.Server
import Futhark.Test
import Futhark.Test.Values
import Futhark.Util (nubOrd, runProgramWithExitCode)
import Futhark.Util.Options
import Futhark.Util.Pretty (prettyText, prettyTextOneLine)
import qualified Futhark.Util.Pretty as PP
import System.Directory
  ( createDirectoryIfMissing,
    removeFile,
    removePathForcibly,
  )
import System.Environment (getExecutablePath)
import System.Exit
import System.FilePath
import System.IO
import System.IO.Temp (withSystemTempDirectory, withSystemTempFile)
import Text.Megaparsec hiding (failure, token)
import Text.Megaparsec.Char
import Text.Printf

data AnimParams = AnimParams
  { AnimParams -> Maybe Int
animFPS :: Maybe Int,
    AnimParams -> Maybe Bool
animLoop :: Maybe Bool,
    AnimParams -> Maybe Bool
animAutoplay :: Maybe Bool,
    AnimParams -> Maybe Text
animFormat :: Maybe T.Text
  }
  deriving (Int -> AnimParams -> ShowS
[AnimParams] -> ShowS
AnimParams -> String
(Int -> AnimParams -> ShowS)
-> (AnimParams -> String)
-> ([AnimParams] -> ShowS)
-> Show AnimParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AnimParams] -> ShowS
$cshowList :: [AnimParams] -> ShowS
show :: AnimParams -> String
$cshow :: AnimParams -> String
showsPrec :: Int -> AnimParams -> ShowS
$cshowsPrec :: Int -> AnimParams -> ShowS
Show)

defaultAnimParams :: AnimParams
defaultAnimParams :: AnimParams
defaultAnimParams =
  AnimParams :: Maybe Int -> Maybe Bool -> Maybe Bool -> Maybe Text -> AnimParams
AnimParams
    { animFPS :: Maybe Int
animFPS = Maybe Int
forall a. Maybe a
Nothing,
      animLoop :: Maybe Bool
animLoop = Maybe Bool
forall a. Maybe a
Nothing,
      animAutoplay :: Maybe Bool
animAutoplay = Maybe Bool
forall a. Maybe a
Nothing,
      animFormat :: Maybe Text
animFormat = Maybe Text
forall a. Maybe a
Nothing
    }

data Directive
  = DirectiveRes Exp
  | DirectiveBrief Directive
  | DirectiveCovert Directive
  | DirectiveImg Exp
  | DirectivePlot Exp (Maybe (Int, Int))
  | DirectiveGnuplot Exp T.Text
  | DirectiveAnim Exp AnimParams
  deriving (Int -> Directive -> ShowS
[Directive] -> ShowS
Directive -> String
(Int -> Directive -> ShowS)
-> (Directive -> String)
-> ([Directive] -> ShowS)
-> Show Directive
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Directive] -> ShowS
$cshowList :: [Directive] -> ShowS
show :: Directive -> String
$cshow :: Directive -> String
showsPrec :: Int -> Directive -> ShowS
$cshowsPrec :: Int -> Directive -> ShowS
Show)

varsInDirective :: Directive -> S.Set EntryName
varsInDirective :: Directive -> Set Text
varsInDirective (DirectiveRes Exp
e) = Exp -> Set Text
varsInExp Exp
e
varsInDirective (DirectiveBrief Directive
d) = Directive -> Set Text
varsInDirective Directive
d
varsInDirective (DirectiveCovert Directive
d) = Directive -> Set Text
varsInDirective Directive
d
varsInDirective (DirectiveImg Exp
e) = Exp -> Set Text
varsInExp Exp
e
varsInDirective (DirectivePlot Exp
e Maybe (Int, Int)
_) = Exp -> Set Text
varsInExp Exp
e
varsInDirective (DirectiveGnuplot Exp
e Text
_) = Exp -> Set Text
varsInExp Exp
e
varsInDirective (DirectiveAnim Exp
e AnimParams
_) = Exp -> Set Text
varsInExp Exp
e

pprDirective :: Bool -> Directive -> PP.Doc
pprDirective :: Bool -> Directive -> Doc
pprDirective Bool
_ (DirectiveRes Exp
e) =
  Doc
"> " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
PP.align (Exp -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Exp
e)
pprDirective Bool
_ (DirectiveBrief Directive
f) =
  Bool -> Directive -> Doc
pprDirective Bool
False Directive
f
pprDirective Bool
_ (DirectiveCovert Directive
f) =
  Bool -> Directive -> Doc
pprDirective Bool
False Directive
f
pprDirective Bool
_ (DirectiveImg Exp
e) =
  Doc
"> :img " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
PP.align (Exp -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Exp
e)
pprDirective Bool
True (DirectivePlot Exp
e (Just (Int
h, Int
w))) =
  [Doc] -> Doc
PP.stack
    [ Doc
"> :plot2d " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Exp -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Exp
e Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
";",
      Doc
"size: (" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Int
w Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"," Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Int
h Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
")"
    ]
pprDirective Bool
_ (DirectivePlot Exp
e Maybe (Int, Int)
_) =
  Doc
"> :plot2d " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
PP.align (Exp -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Exp
e)
pprDirective Bool
True (DirectiveGnuplot Exp
e Text
script) =
  [Doc] -> Doc
PP.stack ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    Doc
"> :gnuplot " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
PP.align (Exp -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Exp
e) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
";" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:
    (Text -> Doc) -> [Text] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
PP.strictText (Text -> [Text]
T.lines Text
script)
pprDirective Bool
False (DirectiveGnuplot Exp
e Text
_) =
  Doc
"> :gnuplot " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
PP.align (Exp -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Exp
e)
pprDirective Bool
False (DirectiveAnim Exp
e AnimParams
_) =
  Doc
"> :anim " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
PP.align (Exp -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Exp
e)
pprDirective Bool
True (DirectiveAnim Exp
e AnimParams
params) =
  Doc
"> :anim " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Exp -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Exp
e
    Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> if [Doc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc]
params' then Doc
forall a. Monoid a => a
mempty else [Doc] -> Doc
PP.stack ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
";" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
params'
  where
    params' :: [Doc]
params' =
      [Maybe Doc] -> [Doc]
forall a. [Maybe a] -> [a]
catMaybes
        [ Doc -> (AnimParams -> Maybe Int) -> (Int -> Doc) -> Maybe Doc
forall b t.
(Semigroup b, IsString b) =>
b -> (AnimParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc
"fps" AnimParams -> Maybe Int
animFPS Int -> Doc
forall a. Pretty a => a -> Doc
PP.ppr,
          Doc -> (AnimParams -> Maybe Bool) -> (Bool -> Doc) -> Maybe Doc
forall b t.
(Semigroup b, IsString b) =>
b -> (AnimParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc
"loop" AnimParams -> Maybe Bool
animLoop Bool -> Doc
forall p. IsString p => Bool -> p
ppBool,
          Doc -> (AnimParams -> Maybe Bool) -> (Bool -> Doc) -> Maybe Doc
forall b t.
(Semigroup b, IsString b) =>
b -> (AnimParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc
"autoplay" AnimParams -> Maybe Bool
animAutoplay Bool -> Doc
forall p. IsString p => Bool -> p
ppBool,
          Doc -> (AnimParams -> Maybe Text) -> (Text -> Doc) -> Maybe Doc
forall b t.
(Semigroup b, IsString b) =>
b -> (AnimParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc
"format" AnimParams -> Maybe Text
animFormat Text -> Doc
PP.strictText
        ]
    ppBool :: Bool -> p
ppBool Bool
b = if Bool
b then p
"true" else p
"false"
    p :: b -> (AnimParams -> Maybe t) -> (t -> b) -> Maybe b
p b
s AnimParams -> Maybe t
f t -> b
ppr = do
      t
x <- AnimParams -> Maybe t
f AnimParams
params
      b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> b -> Maybe b
forall a b. (a -> b) -> a -> b
$ b
s b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
": " b -> b -> b
forall a. Semigroup a => a -> a -> a
<> t -> b
ppr t
x

instance PP.Pretty Directive where
  ppr :: Directive -> Doc
ppr = Bool -> Directive -> Doc
pprDirective Bool
True

data Block
  = BlockCode T.Text
  | BlockComment T.Text
  | BlockDirective Directive
  deriving (Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
(Int -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show)

varsInScripts :: [Block] -> S.Set EntryName
varsInScripts :: [Block] -> Set Text
varsInScripts = (Block -> Set Text) -> [Block] -> Set Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Block -> Set Text
varsInBlock
  where
    varsInBlock :: Block -> Set Text
varsInBlock (BlockDirective Directive
d) = Directive -> Set Text
varsInDirective Directive
d
    varsInBlock BlockCode {} = Set Text
forall a. Monoid a => a
mempty
    varsInBlock BlockComment {} = Set Text
forall a. Monoid a => a
mempty

type Parser = Parsec Void T.Text

postlexeme :: Parser ()
postlexeme :: Parser ()
postlexeme = ParsecT Void Text Identity (Maybe ()) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Maybe ()) -> Parser ())
-> ParsecT Void Text Identity (Maybe ()) -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace Parser ()
-> ParsecT Void Text Identity (Maybe ())
-> ParsecT Void Text Identity (Maybe ())
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser () -> ParsecT Void Text Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser () -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol 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
"-- " ParsecT Void Text Identity Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
postlexeme)

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

token :: T.Text -> Parser ()
token :: Text -> Parser ()
token = ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> Parser ())
-> (Text -> ParsecT Void Text Identity Text) -> Text -> Parser ()
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)
-> (Text -> ParsecT Void Text Identity Text)
-> 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 a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> (Text -> ParsecT Void Text Identity Text)
-> Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string

parseInt :: Parser Int
parseInt :: Parser Int
parseInt = Parser Int -> Parser Int
forall a. Parser a -> Parser a
lexeme (Parser Int -> Parser Int) -> Parser Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read (String -> Int) -> ParsecT Void Text Identity String -> Parser Int
forall (f :: * -> *) a b. Functor 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]
some ((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
isDigit)

restOfLine :: Parser T.Text
restOfLine :: ParsecT Void Text Identity Text
restOfLine = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') 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 a
<* ParsecT Void Text Identity Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol

parseBlockComment :: Parser T.Text
parseBlockComment :: ParsecT Void Text Identity Text
parseBlockComment = [Text] -> Text
T.unlines ([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
-> ParsecT Void Text Identity [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity Text
line
  where
    line :: ParsecT Void Text Identity Text
line = (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
restOfLine) ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (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
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol ParsecT Void Text Identity Text
-> Text -> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
"")

parseTestBlock :: Parser T.Text
parseTestBlock :: ParsecT Void Text Identity Text
parseTestBlock =
  [Text] -> Text
T.unlines ([Text] -> Text)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((:) (Text -> [Text] -> [Text])
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity ([Text] -> [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
header ParsecT Void Text Identity ([Text] -> [Text])
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity [Text]
remainder)
  where
    header :: ParsecT Void Text Identity Text
header = ParsecT Void Text Identity Text
"-- ==" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
    remainder :: ParsecT Void Text Identity [Text]
remainder = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"-- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (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
parseBlockComment

parseBlockCode :: Parser T.Text
parseBlockCode :: ParsecT Void Text Identity Text
parseBlockCode = [Text] -> Text
T.unlines ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
noblanks ([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
-> ParsecT Void Text Identity [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity Text
line
  where
    noblanks :: [Text] -> [Text]
noblanks = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
T.null ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
T.null
    line :: ParsecT Void Text Identity Text
line = Parser () -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Text -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Text
"--") Parser ()
-> 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
restOfLine

parsePlotParams :: Parser (Maybe (Int, Int))
parsePlotParams :: Parser (Maybe (Int, Int))
parsePlotParams =
  ParsecT Void Text Identity (Int, Int) -> Parser (Maybe (Int, Int))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void Text Identity (Int, Int)
 -> Parser (Maybe (Int, Int)))
-> ParsecT Void Text Identity (Int, Int)
-> Parser (Maybe (Int, Int))
forall a b. (a -> b) -> a -> b
$
    ParsecT Void Text Identity Text
";" ParsecT Void Text Identity Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace Parser ()
-> 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
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol ParsecT Void Text Identity Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser ()
token Text
"-- size:"
      Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser ()
token Text
"("
      Parser ()
-> ParsecT Void Text Identity (Int, Int)
-> ParsecT Void Text Identity (Int, Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((,) (Int -> Int -> (Int, Int))
-> Parser Int -> ParsecT Void Text Identity (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
parseInt ParsecT Void Text Identity (Int -> (Int, Int))
-> Parser () -> ParsecT Void Text Identity (Int -> (Int, Int))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser ()
token Text
"," ParsecT Void Text Identity (Int -> (Int, Int))
-> Parser Int -> ParsecT Void Text Identity (Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
parseInt) ParsecT Void Text Identity (Int, Int)
-> Parser () -> ParsecT Void Text Identity (Int, Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser ()
token Text
")"

parseAnimParams :: Parser AnimParams
parseAnimParams :: Parser AnimParams
parseAnimParams =
  (Maybe AnimParams -> AnimParams)
-> ParsecT Void Text Identity (Maybe AnimParams)
-> Parser AnimParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AnimParams -> Maybe AnimParams -> AnimParams
forall a. a -> Maybe a -> a
fromMaybe AnimParams
defaultAnimParams) (ParsecT Void Text Identity (Maybe AnimParams)
 -> Parser AnimParams)
-> ParsecT Void Text Identity (Maybe AnimParams)
-> Parser AnimParams
forall a b. (a -> b) -> a -> b
$
    Parser AnimParams -> ParsecT Void Text Identity (Maybe AnimParams)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser AnimParams
 -> ParsecT Void Text Identity (Maybe AnimParams))
-> Parser AnimParams
-> ParsecT Void Text Identity (Maybe AnimParams)
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text
";" ParsecT Void Text Identity Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace Parser ()
-> 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
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol 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
"-- " ParsecT Void Text Identity Text
-> Parser AnimParams -> Parser AnimParams
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> AnimParams -> Parser AnimParams
parseParams AnimParams
defaultAnimParams
  where
    parseParams :: AnimParams -> Parser AnimParams
parseParams AnimParams
params =
      [Parser AnimParams] -> Parser AnimParams
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ [Parser AnimParams] -> Parser AnimParams
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
            [AnimParams -> Parser AnimParams
pLoop AnimParams
params, AnimParams -> Parser AnimParams
pFPS AnimParams
params, AnimParams -> Parser AnimParams
pAutoplay AnimParams
params, AnimParams -> Parser AnimParams
pFormat AnimParams
params]
            Parser AnimParams
-> (AnimParams -> Parser AnimParams) -> Parser AnimParams
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AnimParams -> Parser AnimParams
parseParams,
          AnimParams -> Parser AnimParams
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnimParams
params
        ]
    parseBool :: ParsecT Void Text Identity Bool
parseBool = Text -> Parser ()
token Text
"true" Parser () -> Bool -> ParsecT Void Text Identity Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True ParsecT Void Text Identity Bool
-> ParsecT Void Text Identity Bool
-> ParsecT Void Text Identity Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
token Text
"false" Parser () -> Bool -> ParsecT Void Text Identity Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
    pLoop :: AnimParams -> Parser AnimParams
pLoop AnimParams
params = do
      Text -> Parser ()
token Text
"loop:"
      Bool
b <- ParsecT Void Text Identity Bool
parseBool
      AnimParams -> Parser AnimParams
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnimParams
params {animLoop :: Maybe Bool
animLoop = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b}
    pFPS :: AnimParams -> Parser AnimParams
pFPS AnimParams
params = do
      Text -> Parser ()
token Text
"fps:"
      Int
fps <- Parser Int
parseInt
      AnimParams -> Parser AnimParams
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnimParams
params {animFPS :: Maybe Int
animFPS = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
fps}
    pAutoplay :: AnimParams -> Parser AnimParams
pAutoplay AnimParams
params = do
      Text -> Parser ()
token Text
"autoplay:"
      Bool
b <- ParsecT Void Text Identity Bool
parseBool
      AnimParams -> Parser AnimParams
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnimParams
params {animAutoplay :: Maybe Bool
animAutoplay = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b}
    pFormat :: AnimParams -> Parser AnimParams
pFormat AnimParams
params = do
      Text -> Parser ()
token Text
"format:"
      Text
s <- ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
lexeme (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
$ Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)
      AnimParams -> Parser AnimParams
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnimParams
params {animFormat :: Maybe Text
animFormat = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s}

parseBlock :: Parser Block
parseBlock :: Parser Block
parseBlock =
  [Parser Block] -> Parser Block
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Text -> Parser ()
token Text
"-- >" Parser ()
-> (Directive -> Block)
-> ParsecT Void Text Identity (Directive -> Block)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Directive -> Block
BlockDirective ParsecT Void Text Identity (Directive -> Block)
-> ParsecT Void Text Identity Directive -> Parser Block
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Directive
parseDirective Parser Block -> Parser () -> Parser Block
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol,
      Text -> Block
BlockCode (Text -> Block) -> ParsecT Void Text Identity Text -> Parser Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseTestBlock,
      Text -> Block
BlockCode (Text -> Block) -> ParsecT Void Text Identity Text -> Parser Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseBlockCode,
      Text -> Block
BlockComment (Text -> Block) -> ParsecT Void Text Identity Text -> Parser Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseBlockComment
    ]
  where
    parseDirective :: ParsecT Void Text Identity Directive
parseDirective =
      [ParsecT Void Text Identity Directive]
-> ParsecT Void Text Identity Directive
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Exp -> Directive
DirectiveRes (Exp -> Directive)
-> ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Directive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> ParsecT Void Text Identity Exp
parseExp Parser ()
postlexeme,
          Text -> Parser ()
directiveName Text
"covert" Parser ()
-> (Directive -> Directive)
-> ParsecT Void Text Identity (Directive -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Directive -> Directive
DirectiveCovert
            ParsecT Void Text Identity (Directive -> Directive)
-> ParsecT Void Text Identity Directive
-> ParsecT Void Text Identity Directive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Directive
parseDirective,
          Text -> Parser ()
directiveName Text
"brief" Parser ()
-> (Directive -> Directive)
-> ParsecT Void Text Identity (Directive -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Directive -> Directive
DirectiveBrief
            ParsecT Void Text Identity (Directive -> Directive)
-> ParsecT Void Text Identity Directive
-> ParsecT Void Text Identity Directive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Directive
parseDirective,
          Text -> Parser ()
directiveName Text
"img" Parser ()
-> (Exp -> Directive)
-> ParsecT Void Text Identity (Exp -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp -> Directive
DirectiveImg
            ParsecT Void Text Identity (Exp -> Directive)
-> ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity Directive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> ParsecT Void Text Identity Exp
parseExp Parser ()
postlexeme,
          Text -> Parser ()
directiveName Text
"plot2d" Parser ()
-> (Exp -> Maybe (Int, Int) -> Directive)
-> ParsecT
     Void Text Identity (Exp -> Maybe (Int, Int) -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp -> Maybe (Int, Int) -> Directive
DirectivePlot
            ParsecT Void Text Identity (Exp -> Maybe (Int, Int) -> Directive)
-> ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity (Maybe (Int, Int) -> Directive)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> ParsecT Void Text Identity Exp
parseExp Parser ()
postlexeme
            ParsecT Void Text Identity (Maybe (Int, Int) -> Directive)
-> Parser (Maybe (Int, Int))
-> ParsecT Void Text Identity Directive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe (Int, Int))
parsePlotParams,
          Text -> Parser ()
directiveName Text
"gnuplot" Parser ()
-> (Exp -> Text -> Directive)
-> ParsecT Void Text Identity (Exp -> Text -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp -> Text -> Directive
DirectiveGnuplot
            ParsecT Void Text Identity (Exp -> Text -> Directive)
-> ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity (Text -> Directive)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> ParsecT Void Text Identity Exp
parseExp Parser ()
postlexeme
            ParsecT Void Text Identity (Text -> Directive)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Directive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParsecT Void Text Identity Text
";" ParsecT Void Text Identity Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace Parser ()
-> 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
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol 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
parseBlockComment),
          Text -> Parser ()
directiveName Text
"anim" Parser ()
-> (Exp -> AnimParams -> Directive)
-> ParsecT Void Text Identity (Exp -> AnimParams -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp -> AnimParams -> Directive
DirectiveAnim
            ParsecT Void Text Identity (Exp -> AnimParams -> Directive)
-> ParsecT Void Text Identity Exp
-> ParsecT Void Text Identity (AnimParams -> Directive)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> ParsecT Void Text Identity Exp
parseExp Parser ()
postlexeme
            ParsecT Void Text Identity (AnimParams -> Directive)
-> Parser AnimParams -> ParsecT Void Text Identity Directive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser AnimParams
parseAnimParams
        ]
    directiveName :: Text -> Parser ()
directiveName Text
s = Parser () -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Text -> Parser ()
token (Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s)

parseProg :: FilePath -> T.Text -> Either T.Text [Block]
parseProg :: String -> Text -> Either Text [Block]
parseProg String
fname Text
s =
  (ParseErrorBundle Text Void -> Either Text [Block])
-> ([Block] -> Either Text [Block])
-> Either (ParseErrorBundle Text Void) [Block]
-> Either Text [Block]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Either Text [Block]
forall a b. a -> Either a b
Left (Text -> Either Text [Block])
-> (ParseErrorBundle Text Void -> Text)
-> ParseErrorBundle Text Void
-> Either Text [Block]
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) [Block] -> Either Text [Block]
forall a b. b -> Either a b
Right (Either (ParseErrorBundle Text Void) [Block]
 -> Either Text [Block])
-> Either (ParseErrorBundle Text Void) [Block]
-> Either Text [Block]
forall a b. (a -> b) -> a -> b
$
    Parsec Void Text [Block]
-> String -> Text -> Either (ParseErrorBundle Text Void) [Block]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser Block -> Parsec Void Text [Block]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Block
parseBlock Parsec Void Text [Block] -> Parser () -> Parsec Void Text [Block]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
fname Text
s

parseProgFile :: FilePath -> IO [Block]
parseProgFile :: String -> IO [Block]
parseProgFile String
prog = do
  Either Text [Block]
pres <- String -> Text -> Either Text [Block]
parseProg String
prog (Text -> Either Text [Block])
-> IO Text -> IO (Either Text [Block])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
prog
  case Either Text [Block]
pres of
    Left Text
err -> do
      Handle -> Text -> IO ()
T.hPutStr Handle
stderr Text
err
      IO [Block]
forall a. IO a
exitFailure
    Right [Block]
script ->
      [Block] -> IO [Block]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Block]
script

type ScriptM = ExceptT T.Text IO

withTempFile :: (FilePath -> ScriptM a) -> ScriptM a
withTempFile :: (String -> ScriptM a) -> ScriptM a
withTempFile String -> ScriptM a
f =
  ExceptT Text IO (ScriptM a) -> ScriptM a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ExceptT Text IO (ScriptM a) -> ScriptM a)
-> ((String -> Handle -> IO (ScriptM a))
    -> ExceptT Text IO (ScriptM a))
-> (String -> Handle -> IO (ScriptM a))
-> ScriptM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (ScriptM a) -> ExceptT Text IO (ScriptM a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ScriptM a) -> ExceptT Text IO (ScriptM a))
-> ((String -> Handle -> IO (ScriptM a)) -> IO (ScriptM a))
-> (String -> Handle -> IO (ScriptM a))
-> ExceptT Text IO (ScriptM a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String -> Handle -> IO (ScriptM a)) -> IO (ScriptM a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile String
"futhark-literate" ((String -> Handle -> IO (ScriptM a)) -> ScriptM a)
-> (String -> Handle -> IO (ScriptM a)) -> ScriptM a
forall a b. (a -> b) -> a -> b
$ \String
tmpf Handle
tmpf_h -> do
    Handle -> IO ()
hClose Handle
tmpf_h
    (Text -> ScriptM a)
-> (a -> ScriptM a) -> Either Text a -> ScriptM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> ScriptM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> ScriptM a)
-> IO (Either Text a) -> IO (ScriptM a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptM a -> IO (Either Text a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (String -> ScriptM a
f String
tmpf)

withTempDir :: (FilePath -> ScriptM a) -> ScriptM a
withTempDir :: (String -> ScriptM a) -> ScriptM a
withTempDir String -> ScriptM a
f =
  ExceptT Text IO (ScriptM a) -> ScriptM a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ExceptT Text IO (ScriptM a) -> ScriptM a)
-> ((String -> IO (ScriptM a)) -> ExceptT Text IO (ScriptM a))
-> (String -> IO (ScriptM a))
-> ScriptM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (ScriptM a) -> ExceptT Text IO (ScriptM a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ScriptM a) -> ExceptT Text IO (ScriptM a))
-> ((String -> IO (ScriptM a)) -> IO (ScriptM a))
-> (String -> IO (ScriptM a))
-> ExceptT Text IO (ScriptM a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String -> IO (ScriptM a)) -> IO (ScriptM a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"futhark-literate" ((String -> IO (ScriptM a)) -> ScriptM a)
-> (String -> IO (ScriptM a)) -> ScriptM a
forall a b. (a -> b) -> a -> b
$ \String
dir ->
    (Text -> ScriptM a)
-> (a -> ScriptM a) -> Either Text a -> ScriptM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> ScriptM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text a -> ScriptM a)
-> IO (Either Text a) -> IO (ScriptM a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptM a -> IO (Either Text a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (String -> ScriptM a
f String
dir)

ppmHeader :: Int -> Int -> BS.ByteString
ppmHeader :: Int -> Int -> ByteString
ppmHeader Int
h Int
w =
  ByteString
"P6\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS.pack (Int -> String
forall a. Show a => a -> String
show Int
w) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS.pack (Int -> String
forall a. Show a => a -> String
show Int
h) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n255\n"

rgbIntToImg ::
  (Integral a, Bits a, SVec.Storable a) =>
  Int ->
  Int ->
  SVec.Vector a ->
  BS.ByteString
rgbIntToImg :: Int -> Int -> Vector a -> ByteString
rgbIntToImg Int
h Int
w Vector a
bytes =
  Int -> Int -> ByteString
ppmHeader Int
h Int
w ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString, Maybe Int) -> ByteString
forall a b. (a, b) -> a
fst (Int -> (Int -> Maybe (Char, Int)) -> Int -> (ByteString, Maybe Int)
forall a.
Int -> (a -> Maybe (Char, a)) -> a -> (ByteString, Maybe a)
BS.unfoldrN (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) Int -> Maybe (Char, Int)
byte Int
0)
  where
    getChan :: a -> Int -> a
getChan a
word Int
chan =
      (a
word a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` (Int
chan Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8)) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFF
    byte :: Int -> Maybe (Char, Int)
byte Int
i =
      (Char, Int) -> Maybe (Char, Int)
forall a. a -> Maybe a
Just
        ( Int -> Char
chr (Int -> Char) -> (a -> Int) -> a -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> (a -> Int) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Char) -> a -> Char
forall a b. (a -> b) -> a -> b
$
            a -> Int -> a
forall a. (Bits a, Num a) => a -> Int -> a
getChan (Vector a
bytes Vector a -> Int -> a
forall a. Storable a => Vector a -> Int -> a
SVec.! (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3)) (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3)),
          Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        )

greyFloatToImg ::
  (RealFrac a, SVec.Storable a) =>
  Int ->
  Int ->
  SVec.Vector a ->
  BS.ByteString
greyFloatToImg :: Int -> Int -> Vector a -> ByteString
greyFloatToImg Int
h Int
w Vector a
bytes =
  Int -> Int -> ByteString
ppmHeader Int
h Int
w ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString, Maybe Int) -> ByteString
forall a b. (a, b) -> a
fst (Int -> (Int -> Maybe (Char, Int)) -> Int -> (ByteString, Maybe Int)
forall a.
Int -> (a -> Maybe (Char, a)) -> a -> (ByteString, Maybe a)
BS.unfoldrN (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) Int -> Maybe (Char, Int)
byte Int
0)
  where
    byte :: Int -> Maybe (Char, Int)
byte Int
i =
      (Char, Int) -> Maybe (Char, Int)
forall a. a -> Maybe a
Just (Int -> Char
chr (Int -> Char) -> (Int -> Int) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Vector a
bytes Vector a -> Int -> a
forall a. Storable a => Vector a -> Int -> a
SVec.! (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3)) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
255, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

valueToPPM :: Value -> Maybe BS.ByteString
valueToPPM :: Value -> Maybe ByteString
valueToPPM v :: Value
v@(Word32Value Vector Int
_ Vector Word32
bytes)
  | [Int
h, Int
w] <- Value -> [Int]
valueShape Value
v =
    ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
forall a.
(Integral a, Bits a, Storable a) =>
Int -> Int -> Vector a -> ByteString
rgbIntToImg Int
h Int
w Vector Word32
bytes
valueToPPM v :: Value
v@(Int32Value Vector Int
_ Vector Int32
bytes)
  | [Int
h, Int
w] <- Value -> [Int]
valueShape Value
v =
    ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Int32 -> ByteString
forall a.
(Integral a, Bits a, Storable a) =>
Int -> Int -> Vector a -> ByteString
rgbIntToImg Int
h Int
w Vector Int32
bytes
valueToPPM v :: Value
v@(Float32Value Vector Int
_ Vector Float
bytes)
  | [Int
h, Int
w] <- Value -> [Int]
valueShape Value
v =
    ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Float -> ByteString
forall a.
(RealFrac a, Storable a) =>
Int -> Int -> Vector a -> ByteString
greyFloatToImg Int
h Int
w Vector Float
bytes
valueToPPM v :: Value
v@(Float64Value Vector Int
_ Vector Double
bytes)
  | [Int
h, Int
w] <- Value -> [Int]
valueShape Value
v =
    ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Double -> ByteString
forall a.
(RealFrac a, Storable a) =>
Int -> Int -> Vector a -> ByteString
greyFloatToImg Int
h Int
w Vector Double
bytes
valueToPPM Value
_ = Maybe ByteString
forall a. Maybe a
Nothing

valueToPPMs :: Value -> Maybe [BS.ByteString]
valueToPPMs :: Value -> Maybe [ByteString]
valueToPPMs = (Value -> Maybe ByteString) -> [Value] -> Maybe [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Maybe ByteString
valueToPPM ([Value] -> Maybe [ByteString])
-> (Value -> [Value]) -> Value -> Maybe [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [Value]
valueElems

system :: FilePath -> [String] -> T.Text -> ScriptM T.Text
system :: String -> [String] -> Text -> ScriptM Text
system String
prog [String]
options Text
input = do
  Either IOException (ExitCode, String, String)
res <- IO (Either IOException (ExitCode, String, String))
-> ExceptT Text IO (Either IOException (ExitCode, String, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException (ExitCode, String, String))
 -> ExceptT Text IO (Either IOException (ExitCode, String, String)))
-> IO (Either IOException (ExitCode, String, String))
-> ExceptT Text IO (Either IOException (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> ByteString
-> IO (Either IOException (ExitCode, String, String))
runProgramWithExitCode String
prog [String]
options (ByteString -> IO (Either IOException (ExitCode, String, String)))
-> ByteString -> IO (Either IOException (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
input
  case Either IOException (ExitCode, String, String)
res of
    Left IOException
err ->
      Text -> ScriptM Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ Text
prog' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (IOException -> String
forall a. Show a => a -> String
show IOException
err)
    Right (ExitCode
ExitSuccess, String
stdout_t, String
_) ->
      Text -> ScriptM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
stdout_t
    Right (ExitFailure Int
code', String
_, String
stderr_t) ->
      Text -> ScriptM Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$
        Text
prog' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed with exit code "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
code')
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and stderr:\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
stderr_t
  where
    prog' :: Text
prog' = Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
prog Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"

ppmToPNG :: FilePath -> ScriptM FilePath
ppmToPNG :: String -> ScriptM String
ppmToPNG String
ppm = do
  ScriptM Text -> ExceptT Text IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ExceptT Text IO ())
-> ScriptM Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Text -> ScriptM Text
system String
"convert" [String
ppm, String
png] Text
forall a. Monoid a => a
mempty
  String -> ScriptM String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
png
  where
    png :: String
png = String
ppm String -> ShowS
`replaceExtension` String
"png"

formatDataForGnuplot :: [Value] -> T.Text
formatDataForGnuplot :: [Value] -> Text
formatDataForGnuplot = [Text] -> Text
T.unlines ([Text] -> Text) -> ([Value] -> [Text]) -> [Value] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Value] -> Text) -> [[Value]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Value] -> Text
line ([[Value]] -> [Text])
-> ([Value] -> [[Value]]) -> [Value] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Value]] -> [[Value]]
forall a. [[a]] -> [[a]]
transpose ([[Value]] -> [[Value]])
-> ([Value] -> [[Value]]) -> [Value] -> [[Value]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> [Value]) -> [Value] -> [[Value]]
forall a b. (a -> b) -> [a] -> [b]
map Value -> [Value]
valueElems
  where
    line :: [Value] -> Text
line = [Text] -> Text
T.unwords ([Text] -> Text) -> ([Value] -> [Text]) -> [Value] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
forall a. Pretty a => a -> Text
prettyText

imgBlock :: FilePath -> T.Text
imgBlock :: String -> Text
imgBlock String
f = Text
"\n\n![](" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")\n\n"

videoBlock :: AnimParams -> FilePath -> T.Text
videoBlock :: AnimParams -> String -> Text
videoBlock AnimParams
opts String
f = Text
"\n\n![](" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
opts' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"
  where
    opts' :: Text
opts'
      | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Text -> Bool
T.null [Text
loop, Text
autoplay] =
        Text
forall a. Monoid a => a
mempty
      | Bool
otherwise =
        Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords [Text
loop, Text
autoplay] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
    boolOpt :: a -> (AnimParams -> Maybe Bool) -> a
boolOpt a
s AnimParams -> Maybe Bool
prop
      | Just Bool
b <- AnimParams -> Maybe Bool
prop AnimParams
opts =
        if Bool
b then a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"=\"true\"" else a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"=\"false\""
      | Bool
otherwise =
        a
forall a. Monoid a => a
mempty
    loop :: Text
loop = Text -> (AnimParams -> Maybe Bool) -> Text
forall a.
(IsString a, Monoid a) =>
a -> (AnimParams -> Maybe Bool) -> a
boolOpt Text
"loop" AnimParams -> Maybe Bool
animLoop
    autoplay :: Text
autoplay = Text -> (AnimParams -> Maybe Bool) -> Text
forall a.
(IsString a, Monoid a) =>
a -> (AnimParams -> Maybe Bool) -> a
boolOpt Text
"autoplay" AnimParams -> Maybe Bool
animAutoplay

plottable :: CompoundValue -> Maybe [Value]
plottable :: CompoundValue -> Maybe [Value]
plottable (ValueTuple [CompoundValue]
vs) = do
  ([Value]
vs', [Int]
ns') <- [(Value, Int)] -> ([Value], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Value, Int)] -> ([Value], [Int]))
-> Maybe [(Value, Int)] -> Maybe ([Value], [Int])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CompoundValue -> Maybe (Value, Int))
-> [CompoundValue] -> Maybe [(Value, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CompoundValue -> Maybe (Value, Int)
inspect [CompoundValue]
vs
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> [Int]
forall a. Ord a => [a] -> [a]
nubOrd [Int]
ns') Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
vs'
  where
    inspect :: CompoundValue -> Maybe (Value, Int)
inspect (ValueAtom Value
v)
      | [Int
n] <- Value -> [Int]
valueShape Value
v = (Value, Int) -> Maybe (Value, Int)
forall a. a -> Maybe a
Just (Value
v, Int
n)
    inspect CompoundValue
_ = Maybe (Value, Int)
forall a. Maybe a
Nothing
plottable CompoundValue
_ = Maybe [Value]
forall a. Maybe a
Nothing

withGnuplotData ::
  [(T.Text, T.Text)] ->
  [(T.Text, [Value])] ->
  ([T.Text] -> [T.Text] -> ScriptM a) ->
  ScriptM a
withGnuplotData :: [(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM a)
-> ScriptM a
withGnuplotData [(Text, Text)]
sets [] [Text] -> [Text] -> ScriptM a
cont = ([Text] -> [Text] -> ScriptM a) -> ([Text], [Text]) -> ScriptM a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Text] -> [Text] -> ScriptM a
cont (([Text], [Text]) -> ScriptM a) -> ([Text], [Text]) -> ScriptM a
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> ([Text], [Text])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Text, Text)] -> ([Text], [Text]))
-> [(Text, Text)] -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a]
reverse [(Text, Text)]
sets
withGnuplotData [(Text, Text)]
sets ((Text
f, [Value]
vs) : [(Text, [Value])]
xys) [Text] -> [Text] -> ScriptM a
cont =
  (String -> ScriptM a) -> ScriptM a
forall a. (String -> ScriptM a) -> ScriptM a
withTempFile ((String -> ScriptM a) -> ScriptM a)
-> (String -> ScriptM a) -> ScriptM a
forall a b. (a -> b) -> a -> b
$ \String
fname -> do
    IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
fname (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Value] -> Text
formatDataForGnuplot [Value]
vs
    [(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM a)
-> ScriptM a
forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM a)
-> ScriptM a
withGnuplotData ((Text
f, Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"='" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
fname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'") (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
sets) [(Text, [Value])]
xys [Text] -> [Text] -> ScriptM a
cont

processDirective :: FilePath -> ScriptServer -> Int -> Directive -> ScriptM T.Text
processDirective :: String -> ScriptServer -> Int -> Directive -> ScriptM Text
processDirective String
imgdir ScriptServer
server Int
i (DirectiveBrief Directive
d) =
  String -> ScriptServer -> Int -> Directive -> ScriptM Text
processDirective String
imgdir ScriptServer
server Int
i Directive
d
processDirective String
imgdir ScriptServer
server Int
i (DirectiveCovert Directive
d) =
  String -> ScriptServer -> Int -> Directive -> ScriptM Text
processDirective String
imgdir ScriptServer
server Int
i Directive
d
processDirective String
_ ScriptServer
server Int
_ (DirectiveRes Exp
e) = do
  CompoundValue
vs <- ScriptServer -> Exp -> ExceptT Text IO CompoundValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> Exp -> m CompoundValue
evalExpToGround ScriptServer
server Exp
e
  Text -> ScriptM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$
    [Text] -> Text
T.unlines
      [ Text
"",
        Text
"```",
        CompoundValue -> Text
forall a. Pretty a => a -> Text
prettyText CompoundValue
vs,
        Text
"```",
        Text
""
      ]
--
processDirective String
imgdir ScriptServer
server Int
i (DirectiveImg Exp
e) = do
  CompoundValue
vs <- ScriptServer -> Exp -> ExceptT Text IO CompoundValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> Exp -> m CompoundValue
evalExpToGround ScriptServer
server Exp
e
  case CompoundValue
vs of
    ValueAtom Value
v
      | Just ByteString
ppm <- Value -> Maybe ByteString
valueToPPM Value
v -> do
        let ppmfile :: String
ppmfile = String
imgdir String -> ShowS
</> String
"img" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
<.> String
".ppm"
        IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
imgdir
        IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
ppmfile ByteString
ppm
        String
pngfile <- String -> ScriptM String
ppmToPNG String
ppmfile
        IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
ppmfile
        Text -> ScriptM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ String -> Text
imgBlock String
pngfile
    CompoundValue
_ ->
      Text -> ScriptM Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$
        Text
"Cannot create image from value of type "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ValueType -> Text
forall a. Pretty a => a -> Text
prettyText ((Value -> ValueType) -> CompoundValue -> Compound ValueType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType CompoundValue
vs)
--
processDirective String
imgdir ScriptServer
server Int
i (DirectivePlot Exp
e Maybe (Int, Int)
size) = do
  CompoundValue
v <- ScriptServer -> Exp -> ExceptT Text IO CompoundValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> Exp -> m CompoundValue
evalExpToGround ScriptServer
server Exp
e
  case CompoundValue
v of
    CompoundValue
_
      | Just [Value]
vs <- CompoundValue -> Maybe [Value]
plottable2d CompoundValue
v ->
        [(Maybe Text, [Value])] -> ScriptM Text
plotWith [(Maybe Text
forall a. Maybe a
Nothing, [Value]
vs)]
    ValueRecord Map Text CompoundValue
m
      | Just Map Text [Value]
m' <- (CompoundValue -> Maybe [Value])
-> Map Text CompoundValue -> Maybe (Map Text [Value])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CompoundValue -> Maybe [Value]
plottable2d Map Text CompoundValue
m ->
        [(Maybe Text, [Value])] -> ScriptM Text
plotWith ([(Maybe Text, [Value])] -> ScriptM Text)
-> [(Maybe Text, [Value])] -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ ((Text, [Value]) -> (Maybe Text, [Value]))
-> [(Text, [Value])] -> [(Maybe Text, [Value])]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Maybe Text) -> (Text, [Value]) -> (Maybe Text, [Value])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Maybe Text
forall a. a -> Maybe a
Just) ([(Text, [Value])] -> [(Maybe Text, [Value])])
-> [(Text, [Value])] -> [(Maybe Text, [Value])]
forall a b. (a -> b) -> a -> b
$ Map Text [Value] -> [(Text, [Value])]
forall k a. Map k a -> [(k, a)]
M.toList Map Text [Value]
m'
    CompoundValue
_ ->
      Text -> ScriptM Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$
        Text
"Cannot plot value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ValueType -> Text
forall a. Pretty a => a -> Text
prettyText ((Value -> ValueType) -> CompoundValue -> Compound ValueType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType CompoundValue
v)
  where
    plottable2d :: CompoundValue -> Maybe [Value]
plottable2d CompoundValue
v = do
      [Value
x, Value
y] <- CompoundValue -> Maybe [Value]
plottable CompoundValue
v
      [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value
x, Value
y]

    pngfile :: String
pngfile = String
imgdir String -> ShowS
</> String
"plot" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
<.> String
".png"

    tag :: (Maybe Text, b) -> Int -> (Text, b)
tag (Maybe Text
Nothing, b
xys) Int
j = (Text
"data" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int
j :: Int)), b
xys)
    tag (Just Text
f, b
xys) Int
_ = (Text
f, b
xys)

    plotWith :: [(Maybe Text, [Value])] -> ScriptM Text
plotWith [(Maybe Text, [Value])]
xys = [(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM Text)
-> ScriptM Text
forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM a)
-> ScriptM a
withGnuplotData [] (((Maybe Text, [Value]) -> Int -> (Text, [Value]))
-> [(Maybe Text, [Value])] -> [Int] -> [(Text, [Value])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Text, [Value]) -> Int -> (Text, [Value])
forall b. (Maybe Text, b) -> Int -> (Text, b)
tag [(Maybe Text, [Value])]
xys [Int
0 ..]) (([Text] -> [Text] -> ScriptM Text) -> ScriptM Text)
-> ([Text] -> [Text] -> ScriptM Text) -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ \[Text]
fs [Text]
sets -> do
      IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
imgdir
      let size' :: Text
size' = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
            case Maybe (Int, Int)
size of
              Maybe (Int, Int)
Nothing -> String
"500,500"
              Just (Int
w, Int
h) -> Int -> String
forall a. Show a => a -> String
show Int
w String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
h
          plotCmd :: a -> Maybe a -> a
plotCmd a
f Maybe a
title =
            let title' :: a
title' = case Maybe a
title of
                  Maybe a
Nothing -> a
"notitle"
                  Just x -> a
"title '" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"'"
             in a
f a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
title' a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" with lines"
          cmds :: Text
cmds = Text -> [Text] -> Text
T.intercalate Text
", " ((Text -> Maybe Text -> Text) -> [Text] -> [Maybe Text] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Maybe Text -> Text
forall a. (IsString a, Semigroup a) => a -> Maybe a -> a
plotCmd [Text]
fs (((Maybe Text, [Value]) -> Maybe Text)
-> [(Maybe Text, [Value])] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Text, [Value]) -> Maybe Text
forall a b. (a, b) -> a
fst [(Maybe Text, [Value])]
xys))
          script :: Text
script =
            [Text] -> Text
T.unlines
              [ Text
"set terminal png size " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
size' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" enhanced",
                Text
"set output '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
pngfile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'",
                Text
"set key outside",
                [Text] -> Text
T.unlines [Text]
sets,
                Text
"plot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmds
              ]
      ScriptM Text -> ExceptT Text IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ExceptT Text IO ())
-> ScriptM Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Text -> ScriptM Text
system String
"gnuplot" [] Text
script
      Text -> ScriptM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ String -> Text
imgBlock String
pngfile
--
processDirective String
imgdir ScriptServer
server Int
i (DirectiveGnuplot Exp
e Text
script) = do
  CompoundValue
vs <- ScriptServer -> Exp -> ExceptT Text IO CompoundValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> Exp -> m CompoundValue
evalExpToGround ScriptServer
server Exp
e
  case CompoundValue
vs of
    ValueRecord Map Text CompoundValue
m
      | Just Map Text [Value]
m' <- (CompoundValue -> Maybe [Value])
-> Map Text CompoundValue -> Maybe (Map Text [Value])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CompoundValue -> Maybe [Value]
plottable Map Text CompoundValue
m ->
        [(Text, [Value])] -> ScriptM Text
plotWith ([(Text, [Value])] -> ScriptM Text)
-> [(Text, [Value])] -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ Map Text [Value] -> [(Text, [Value])]
forall k a. Map k a -> [(k, a)]
M.toList Map Text [Value]
m'
    CompoundValue
_ ->
      Text -> ScriptM Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$
        Text
"Cannot plot value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ValueType -> Text
forall a. Pretty a => a -> Text
prettyText ((Value -> ValueType) -> CompoundValue -> Compound ValueType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType CompoundValue
vs)
  where
    pngfile :: String
pngfile = String
imgdir String -> ShowS
</> String
"plot" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
<.> String
".png"

    plotWith :: [(Text, [Value])] -> ScriptM Text
plotWith [(Text, [Value])]
xys = [(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM Text)
-> ScriptM Text
forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM a)
-> ScriptM a
withGnuplotData [] [(Text, [Value])]
xys (([Text] -> [Text] -> ScriptM Text) -> ScriptM Text)
-> ([Text] -> [Text] -> ScriptM Text) -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ \[Text]
_ [Text]
sets -> do
      IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
imgdir
      let script' :: Text
script' =
            [Text] -> Text
T.unlines
              [ Text
"set terminal png enhanced",
                Text
"set output '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
pngfile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'",
                [Text] -> Text
T.unlines [Text]
sets,
                Text
script
              ]
      ScriptM Text -> ExceptT Text IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ExceptT Text IO ())
-> ScriptM Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Text -> ScriptM Text
system String
"gnuplot" [] Text
script'
      Text -> ScriptM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ String -> Text
imgBlock String
pngfile
--
processDirective String
imgdir ScriptServer
server Int
i (DirectiveAnim Exp
e AnimParams
params) = do
  Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
format Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"webm", Text
"gif"]) (ExceptT Text IO () -> ExceptT Text IO ())
-> ExceptT Text IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
    Text -> ExceptT Text IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Unknown animation format: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
format

  ExpValue
v <- ScriptServer -> Exp -> ExceptT Text IO ExpValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> Exp -> m ExpValue
evalExp ScriptServer
server Exp
e
  let nope :: ExceptT Text IO a
nope =
        Text -> ExceptT Text IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text IO a) -> Text -> ExceptT Text IO a
forall a b. (a -> b) -> a -> b
$
          Text
"Cannot animate value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> Text
forall a. Pretty a => a -> Text
prettyText ((ScriptValue Text -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue Text -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
v)
  case ExpValue
v of
    ValueAtom SValue {} -> do
      ValueAtom Value
arr <- ScriptServer -> ExpValue -> ExceptT Text IO CompoundValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue ScriptServer
server ExpValue
v
      case Value -> Maybe [ByteString]
valueToPPMs Value
arr of
        Maybe [ByteString]
Nothing -> ExceptT Text IO ()
forall a. ExceptT Text IO a
nope
        Just [ByteString]
ppms ->
          (String -> ExceptT Text IO ()) -> ExceptT Text IO ()
forall a. (String -> ScriptM a) -> ScriptM a
withTempDir ((String -> ExceptT Text IO ()) -> ExceptT Text IO ())
-> (String -> ExceptT Text IO ()) -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
            (Int -> ByteString -> ExceptT Text IO ())
-> [Int] -> [ByteString] -> ExceptT Text IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (String -> Int -> ByteString -> ExceptT Text IO ()
forall (m :: * -> *).
MonadIO m =>
String -> Int -> ByteString -> m ()
writePPMFile String
dir) [Int
0 ..] [ByteString]
ppms
            String -> ExceptT Text IO ()
ppmsToVideo String
dir
    ValueTuple [ExpValue
stepfun, ExpValue
initial, ExpValue
num_frames]
      | ValueAtom (SFun Text
stepfun' [Text]
_ [Text
_, Text
_] [ScriptValue Text]
closure) <- ExpValue
stepfun,
        ValueAtom (SValue Text
_ Text
_) <- ExpValue
initial,
        ValueAtom (SValue Text
"i64" Text
_) <- ExpValue
num_frames -> do
        Just (ValueAtom Int64
num_frames') <-
          (Value -> Maybe Int64) -> CompoundValue -> Maybe (Compound Int64)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Maybe Int64
forall t. GetValue t => Value -> Maybe t
getValue (CompoundValue -> Maybe (Compound Int64))
-> ExceptT Text IO CompoundValue
-> ExceptT Text IO (Maybe (Compound Int64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptServer -> ExpValue -> ExceptT Text IO CompoundValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue ScriptServer
server ExpValue
num_frames
        (String -> ExceptT Text IO ()) -> ExceptT Text IO ()
forall a. (String -> ScriptM a) -> ScriptM a
withTempDir ((String -> ExceptT Text IO ()) -> ExceptT Text IO ())
-> (String -> ExceptT Text IO ()) -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
          let num_frames_int :: Int
num_frames_int = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
num_frames' :: Int64)
          String
-> (Text, [ExpValue]) -> ExpValue -> Int -> ExceptT Text IO ()
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadError Text m) =>
String -> (Text, [ExpValue]) -> ExpValue -> Int -> m ()
renderFrames String
dir (Text
stepfun', (ScriptValue Text -> ExpValue) -> [ScriptValue Text] -> [ExpValue]
forall a b. (a -> b) -> [a] -> [b]
map ScriptValue Text -> ExpValue
forall v. v -> Compound v
ValueAtom [ScriptValue Text]
closure) ExpValue
initial Int
num_frames_int
          String -> ExceptT Text IO ()
ppmsToVideo String
dir
    ExpValue
_ ->
      ExceptT Text IO ()
forall a. ExceptT Text IO a
nope

  Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AnimParams -> Maybe Text
animFormat AnimParams
params Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"gif") (ExceptT Text IO () -> ExceptT Text IO ())
-> ExceptT Text IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ do
    ScriptM Text -> ExceptT Text IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ExceptT Text IO ())
-> ScriptM Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Text -> ScriptM Text
system String
"ffmpeg" [String
"-i", String
webmfile, String
giffile] Text
forall a. Monoid a => a
mempty
    IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
webmfile

  Text -> ScriptM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ AnimParams -> String -> Text
videoBlock AnimParams
params String
animfile
  where
    framerate :: Int
framerate = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
30 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ AnimParams -> Maybe Int
animFPS AnimParams
params
    format :: Text
format = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"webm" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ AnimParams -> Maybe Text
animFormat AnimParams
params
    webmfile :: String
webmfile = String
imgdir String -> ShowS
</> String
"anim" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
<.> String
"webm"
    giffile :: String
giffile = String
imgdir String -> ShowS
</> String
"anim" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
<.> String
"gif"
    ppmfile :: String -> Int -> String
ppmfile String
dir Int
j = String
dir String -> ShowS
</> String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"frame%010d.ppm" (Int
j :: Int)
    animfile :: String
animfile = String
imgdir String -> ShowS
</> String
"anim" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
<.> Text -> String
T.unpack Text
format

    renderFrames :: String -> (Text, [ExpValue]) -> ExpValue -> Int -> m ()
renderFrames String
dir (Text
stepfun, [ExpValue]
closure) ExpValue
initial Int
num_frames =
      (ExpValue -> Int -> m ExpValue) -> ExpValue -> [Int] -> m ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ ExpValue -> Int -> m ExpValue
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadError Text m) =>
ExpValue -> Int -> m ExpValue
frame ExpValue
initial [Int
0 .. Int
num_frames Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
      where
        frame :: ExpValue -> Int -> m ExpValue
frame ExpValue
old_state Int
j = do
          ExpValue
v <- ScriptServer -> Exp -> m ExpValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> Exp -> m ExpValue
evalExp ScriptServer
server (Exp -> m ExpValue)
-> ([ExpValue] -> Exp) -> [ExpValue] -> m ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Exp] -> Exp
Call Text
stepfun ([Exp] -> Exp) -> ([ExpValue] -> [Exp]) -> [ExpValue] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExpValue -> Exp) -> [ExpValue] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map ExpValue -> Exp
valueToExp ([ExpValue] -> m ExpValue) -> [ExpValue] -> m ExpValue
forall a b. (a -> b) -> a -> b
$ [ExpValue]
closure [ExpValue] -> [ExpValue] -> [ExpValue]
forall a. [a] -> [a] -> [a]
++ [ExpValue
old_state]
          ScriptServer -> ExpValue -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m ()
freeValue ScriptServer
server ExpValue
old_state

          let nope :: m a
nope =
                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
"Cannot handle step function return type: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> Text
forall a. Pretty a => a -> Text
prettyText ((ScriptValue Text -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue Text -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
v)

          case ExpValue
v of
            ValueTuple [arr_v :: ExpValue
arr_v@(ValueAtom SValue {}), ExpValue
new_state] -> do
              ValueAtom Value
arr <- ScriptServer -> ExpValue -> m CompoundValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue ScriptServer
server ExpValue
arr_v
              ScriptServer -> ExpValue -> m ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m ()
freeValue ScriptServer
server ExpValue
arr_v
              case Value -> Maybe ByteString
valueToPPM Value
arr of
                Maybe ByteString
Nothing -> m ExpValue
forall a. m a
nope
                Just ByteString
ppm -> do
                  String -> Int -> ByteString -> m ()
forall (m :: * -> *).
MonadIO m =>
String -> Int -> ByteString -> m ()
writePPMFile String
dir Int
j ByteString
ppm
                  ExpValue -> m ExpValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpValue
new_state
            ExpValue
_ -> m ExpValue
forall a. m a
nope

    ppmsToVideo :: String -> ExceptT Text IO ()
ppmsToVideo String
dir = do
      IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
imgdir
      ScriptM Text -> ExceptT Text IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ExceptT Text IO ())
-> ScriptM Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
        String -> [String] -> Text -> ScriptM Text
system
          String
"ffmpeg"
          [ String
"-y",
            String
"-r",
            Int -> String
forall a. Show a => a -> String
show Int
framerate,
            String
"-i",
            String
dir String -> ShowS
</> String
"frame%010d.ppm",
            String
"-c:v",
            String
"libvpx-vp9",
            String
"-pix_fmt",
            String
"yuv420p",
            String
"-b:v",
            String
"2M",
            String
webmfile
          ]
          Text
forall a. Monoid a => a
mempty

    writePPMFile :: String -> Int -> ByteString -> m ()
writePPMFile String
dir Int
j ByteString
ppm = do
      let fname :: String
fname = String -> Int -> String
ppmfile String
dir Int
j
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
fname ByteString
ppm

-- Did this script block succeed or fail?
data Failure = Failure | Success
  deriving (Failure -> Failure -> Bool
(Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool) -> Eq Failure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Failure -> Failure -> Bool
$c/= :: Failure -> Failure -> Bool
== :: Failure -> Failure -> Bool
$c== :: Failure -> Failure -> Bool
Eq, Eq Failure
Eq Failure
-> (Failure -> Failure -> Ordering)
-> (Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool)
-> (Failure -> Failure -> Failure)
-> (Failure -> Failure -> Failure)
-> Ord Failure
Failure -> Failure -> Bool
Failure -> Failure -> Ordering
Failure -> Failure -> Failure
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Failure -> Failure -> Failure
$cmin :: Failure -> Failure -> Failure
max :: Failure -> Failure -> Failure
$cmax :: Failure -> Failure -> Failure
>= :: Failure -> Failure -> Bool
$c>= :: Failure -> Failure -> Bool
> :: Failure -> Failure -> Bool
$c> :: Failure -> Failure -> Bool
<= :: Failure -> Failure -> Bool
$c<= :: Failure -> Failure -> Bool
< :: Failure -> Failure -> Bool
$c< :: Failure -> Failure -> Bool
compare :: Failure -> Failure -> Ordering
$ccompare :: Failure -> Failure -> Ordering
$cp1Ord :: Eq Failure
Ord, Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> String
(Int -> Failure -> ShowS)
-> (Failure -> String) -> ([Failure] -> ShowS) -> Show Failure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Failure] -> ShowS
$cshowList :: [Failure] -> ShowS
show :: Failure -> String
$cshow :: Failure -> String
showsPrec :: Int -> Failure -> ShowS
$cshowsPrec :: Int -> Failure -> ShowS
Show)

data Options = Options
  { Options -> String
scriptBackend :: String,
    Options -> Maybe String
scriptFuthark :: Maybe FilePath,
    Options -> [String]
scriptExtraOptions :: [String],
    Options -> [String]
scriptCompilerOptions :: [String],
    Options -> Bool
scriptSkipCompilation :: Bool,
    Options -> Maybe String
scriptOutput :: Maybe FilePath,
    Options -> Int
scriptVerbose :: Int,
    Options -> Bool
scriptStopOnError :: Bool
  }

initialOptions :: Options
initialOptions :: Options
initialOptions =
  Options :: String
-> Maybe String
-> [String]
-> [String]
-> Bool
-> Maybe String
-> Int
-> Bool
-> Options
Options
    { scriptBackend :: String
scriptBackend = String
"c",
      scriptFuthark :: Maybe String
scriptFuthark = Maybe String
forall a. Maybe a
Nothing,
      scriptExtraOptions :: [String]
scriptExtraOptions = [],
      scriptCompilerOptions :: [String]
scriptCompilerOptions = [],
      scriptSkipCompilation :: Bool
scriptSkipCompilation = Bool
False,
      scriptOutput :: Maybe String
scriptOutput = Maybe String
forall a. Maybe a
Nothing,
      scriptVerbose :: Int
scriptVerbose = Int
0,
      scriptStopOnError :: Bool
scriptStopOnError = Bool
False
    }

processBlock :: Options -> FilePath -> ScriptServer -> Int -> Block -> IO (Failure, T.Text)
processBlock :: Options
-> String -> ScriptServer -> Int -> Block -> IO (Failure, Text)
processBlock Options
_ String
_ ScriptServer
_ Int
_ (BlockCode Text
code)
  | Text -> Bool
T.null Text
code = (Failure, Text) -> IO (Failure, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
"\n")
  | Bool
otherwise = (Failure, Text) -> IO (Failure, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
"\n```futhark\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
code Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"```\n\n")
processBlock Options
_ String
_ ScriptServer
_ Int
_ (BlockComment Text
text) =
  (Failure, Text) -> IO (Failure, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
text)
processBlock Options
opts String
imgdir ScriptServer
server Int
i (BlockDirective Directive
directive) = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose Options
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> (Doc -> Text) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Text
forall a. Pretty a => a -> Text
prettyText (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
      Doc
"Processing " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
PP.align (Directive -> Doc
forall a. Pretty a => a -> Doc
PP.ppr Directive
directive) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"..."
  let prompt :: Text
prompt = case Directive
directive of
        DirectiveCovert Directive
_ -> Text
forall a. Monoid a => a
mempty
        DirectiveBrief Directive
_ ->
          Text
"```\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc -> Text
forall a. Pretty a => a -> Text
prettyText (Bool -> Directive -> Doc
pprDirective Bool
False Directive
directive) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n```\n"
        Directive
_ ->
          Text
"```\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc -> Text
forall a. Pretty a => a -> Text
prettyText (Bool -> Directive -> Doc
pprDirective Bool
True Directive
directive) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n```\n"
  Either Text Text
r <- ScriptM Text -> IO (Either Text Text)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ScriptM Text -> IO (Either Text Text))
-> ScriptM Text -> IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$ String -> ScriptServer -> Int -> Directive -> ScriptM Text
processDirective String
imgdir ScriptServer
server Int
i Directive
directive
  (Text -> Text) -> (Failure, Text) -> (Failure, Text)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Text
prompt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ((Failure, Text) -> (Failure, Text))
-> IO (Failure, Text) -> IO (Failure, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Either Text Text
r of
    Left Text
err -> Text -> IO (Failure, Text)
failed Text
err
    Right Text
t -> (Failure, Text) -> IO (Failure, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
t)
  where
    failed :: Text -> IO (Failure, Text)
failed Text
err = do
      let message :: Text
message = Directive -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine Directive
directive Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
      IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStr Handle
stderr Text
message
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Bool
scriptStopOnError Options
opts) IO ()
forall a. IO a
exitFailure
      (Failure, Text) -> IO (Failure, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Failure
Failure,
          [Text] -> Text
T.unlines [Text
"**FAILED**", Text
"```", Text
err, Text
"```"]
        )

processScript :: Options -> FilePath -> ScriptServer -> [Block] -> IO (Failure, T.Text)
processScript :: Options -> String -> ScriptServer -> [Block] -> IO (Failure, Text)
processScript Options
opts String
imgdir ScriptServer
server [Block]
script =
  ([Failure] -> Failure)
-> ([Text] -> Text) -> ([Failure], [Text]) -> (Failure, Text)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Failure -> Failure -> Failure) -> Failure -> [Failure] -> Failure
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Failure -> Failure -> Failure
forall a. Ord a => a -> a -> a
min Failure
Success) [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (([Failure], [Text]) -> (Failure, Text))
-> ([(Failure, Text)] -> ([Failure], [Text]))
-> [(Failure, Text)]
-> (Failure, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Failure, Text)] -> ([Failure], [Text])
forall a b. [(a, b)] -> ([a], [b])
unzip
    ([(Failure, Text)] -> (Failure, Text))
-> IO [(Failure, Text)] -> IO (Failure, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Block -> IO (Failure, Text))
-> [Int] -> [Block] -> IO [(Failure, Text)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Options
-> String -> ScriptServer -> Int -> Block -> IO (Failure, Text)
processBlock Options
opts String
imgdir ScriptServer
server) [Int
0 ..] [Block]
script

commandLineOptions :: [FunOptDescr Options]
commandLineOptions :: [FunOptDescr Options]
commandLineOptions =
  [ String
-> [String]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> String
-> FunOptDescr Options
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"backend"]
      ( (String -> Either (IO ()) (Options -> Options))
-> String -> ArgDescr (Either (IO ()) (Options -> Options))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          (\String
backend -> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptBackend :: String
scriptBackend = String
backend})
          String
"PROGRAM"
      )
      String
"The compiler used (defaults to 'c').",
    String
-> [String]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> String
-> FunOptDescr Options
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"futhark"]
      ( (String -> Either (IO ()) (Options -> Options))
-> String -> ArgDescr (Either (IO ()) (Options -> Options))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          (\String
prog -> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptFuthark :: Maybe String
scriptFuthark = String -> Maybe String
forall a. a -> Maybe a
Just String
prog})
          String
"PROGRAM"
      )
      String
"The binary used for operations (defaults to same binary as 'futhark script').",
    String
-> [String]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> String
-> FunOptDescr Options
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"p"
      [String
"pass-option"]
      ( (String -> Either (IO ()) (Options -> Options))
-> String -> ArgDescr (Either (IO ()) (Options -> Options))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
opt ->
              (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config ->
                Options
config {scriptExtraOptions :: [String]
scriptExtraOptions = String
opt String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Options -> [String]
scriptExtraOptions Options
config}
          )
          String
"OPT"
      )
      String
"Pass this option to programs being run.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> String
-> FunOptDescr Options
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"pass-compiler-option"]
      ( (String -> Either (IO ()) (Options -> Options))
-> String -> ArgDescr (Either (IO ()) (Options -> Options))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
opt ->
              (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config ->
                Options
config {scriptCompilerOptions :: [String]
scriptCompilerOptions = String
opt String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Options -> [String]
scriptCompilerOptions Options
config}
          )
          String
"OPT"
      )
      String
"Pass this option to the compiler.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> String
-> FunOptDescr Options
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"skip-compilation"]
      (Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (Options -> Options)
 -> ArgDescr (Either (IO ()) (Options -> Options)))
-> Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a b. (a -> b) -> a -> b
$ (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptSkipCompilation :: Bool
scriptSkipCompilation = Bool
True})
      String
"Use already compiled program.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> String
-> FunOptDescr Options
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"v"
      [String
"verbose"]
      (Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (Options -> Options)
 -> ArgDescr (Either (IO ()) (Options -> Options)))
-> Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a b. (a -> b) -> a -> b
$ (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptVerbose :: Int
scriptVerbose = Options -> Int
scriptVerbose Options
config Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1})
      String
"Enable logging.  Pass multiple times for more.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> String
-> FunOptDescr Options
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"o"
      [String
"output"]
      ((String -> Either (IO ()) (Options -> Options))
-> String -> ArgDescr (Either (IO ()) (Options -> Options))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
opt -> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptOutput :: Maybe String
scriptOutput = String -> Maybe String
forall a. a -> Maybe a
Just String
opt}) String
"FILE")
      String
"Enable logging.  Pass multiple times for more.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> String
-> FunOptDescr Options
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"stop-on-error"]
      (Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (Options -> Options)
 -> ArgDescr (Either (IO ()) (Options -> Options)))
-> Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a b. (a -> b) -> a -> b
$ (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptStopOnError :: Bool
scriptStopOnError = Bool
True})
      String
"Stop and do not produce output file if any directive fails."
  ]

-- | Run @futhark script@.
main :: String -> [String] -> IO ()
main :: String -> [String] -> IO ()
main = Options
-> [FunOptDescr Options]
-> String
-> ([String] -> Options -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions Options
initialOptions [FunOptDescr Options]
commandLineOptions String
"program" (([String] -> Options -> Maybe (IO ()))
 -> String -> [String] -> IO ())
-> ([String] -> Options -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
args Options
opts ->
  case [String]
args of
    [String
prog] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ do
      String
futhark <- IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getExecutablePath String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO String) -> Maybe String -> IO String
forall a b. (a -> b) -> a -> b
$ Options -> Maybe String
scriptFuthark Options
opts

      [Block]
script <- String -> IO [Block]
parseProgFile String
prog

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Options -> Bool
scriptSkipCompilation Options
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let entryOpt :: Text -> String
entryOpt Text
v = String
"--entry=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
v
            compile_options :: [String]
compile_options =
              String
"--server" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
              (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
entryOpt (Set Text -> [Text]
forall a. Set a -> [a]
S.toList ([Block] -> Set Text
varsInScripts [Block]
script))
                [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Options -> [String]
scriptCompilerOptions Options
opts
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose Options
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Compiling " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
prog Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."
        Either [Text] (ByteString, ByteString)
cres <-
          ExceptT [Text] IO (ByteString, ByteString)
-> IO (Either [Text] (ByteString, ByteString))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT [Text] IO (ByteString, ByteString)
 -> IO (Either [Text] (ByteString, ByteString)))
-> ExceptT [Text] IO (ByteString, ByteString)
-> IO (Either [Text] (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$
            [String]
-> FutharkExe
-> String
-> String
-> ExceptT [Text] IO (ByteString, ByteString)
forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
[String]
-> FutharkExe -> String -> String -> m (ByteString, ByteString)
compileProgram [String]
compile_options (String -> FutharkExe
FutharkExe String
futhark) (Options -> String
scriptBackend Options
opts) String
prog
        case Either [Text] (ByteString, ByteString)
cres of
          Left [Text]
err -> do
            (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr) [Text]
err
            IO ()
forall a. IO a
exitFailure
          Right (ByteString, ByteString)
_ ->
            () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      let mdfile :: String
mdfile = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String
prog String -> ShowS
`replaceExtension` String
"md") (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Options -> Maybe String
scriptOutput Options
opts
          imgdir :: String
imgdir = ShowS
dropExtension String
mdfile String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-img"
          run_options :: [String]
run_options = Options -> [String]
scriptExtraOptions Options
opts

      String -> IO ()
removePathForcibly String
imgdir

      String -> [String] -> (ScriptServer -> IO ()) -> IO ()
forall a. String -> [String] -> (ScriptServer -> IO a) -> IO a
withScriptServer (String
"." String -> ShowS
</> ShowS
dropExtension String
prog) [String]
run_options ((ScriptServer -> IO ()) -> IO ())
-> (ScriptServer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScriptServer
server -> do
        (Failure
failure, Text
md) <- Options -> String -> ScriptServer -> [Block] -> IO (Failure, Text)
processScript Options
opts String
imgdir ScriptServer
server [Block]
script
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Failure
failure Failure -> Failure -> Bool
forall a. Eq a => a -> a -> Bool
== Failure
Failure) IO ()
forall a. IO a
exitFailure
        String -> Text -> IO ()
T.writeFile String
mdfile Text
md
    [String]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing