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

import Codec.BMP qualified as BMP
import Control.Monad.Except
import Control.Monad.State hiding (State)
import Data.Bifunctor (first, second)
import Data.Bits
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Char
import Data.Functor
import Data.Int (Int64)
import Data.List (foldl', transpose)
import Data.Map qualified as M
import Data.Maybe
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
import Data.Text.Read qualified as T
import Data.Vector.Storable qualified as SVec
import Data.Vector.Storable.ByteString qualified as SVec
import Data.Void
import Data.Word (Word32, Word8)
import Futhark.Data
import Futhark.Script
import Futhark.Server
import Futhark.Test
import Futhark.Test.Values
import Futhark.Util
  ( directoryContents,
    fancyTerminal,
    hashText,
    nubOrd,
    runProgramWithExitCode,
    showText,
  )
import Futhark.Util.Options
import Futhark.Util.Pretty (prettyText, prettyTextOneLine)
import Futhark.Util.Pretty qualified as PP
import Futhark.Util.ProgressBar
import System.Directory
  ( copyFile,
    createDirectoryIfMissing,
    doesFileExist,
    removePathForcibly,
  )
import System.Environment (getExecutablePath)
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error (isDoesNotExistError)
import System.IO.Temp (withSystemTempDirectory, withSystemTempFile)
import Text.Megaparsec hiding (State, failure, token)
import Text.Megaparsec.Char
import Text.Printf

newtype ImgParams = ImgParams
  { ImgParams -> Maybe FilePath
imgFile :: Maybe FilePath
  }
  deriving (Int -> ImgParams -> ShowS
[ImgParams] -> ShowS
ImgParams -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ImgParams] -> ShowS
$cshowList :: [ImgParams] -> ShowS
show :: ImgParams -> FilePath
$cshow :: ImgParams -> FilePath
showsPrec :: Int -> ImgParams -> ShowS
$cshowsPrec :: Int -> ImgParams -> ShowS
Show)

defaultImgParams :: ImgParams
defaultImgParams :: ImgParams
defaultImgParams =
  ImgParams {imgFile :: Maybe FilePath
imgFile = forall a. Maybe a
Nothing}

data VideoParams = VideoParams
  { VideoParams -> Maybe Int
videoFPS :: Maybe Int,
    VideoParams -> Maybe Bool
videoLoop :: Maybe Bool,
    VideoParams -> Maybe Bool
videoAutoplay :: Maybe Bool,
    VideoParams -> Maybe Text
videoFormat :: Maybe T.Text,
    VideoParams -> Maybe FilePath
videoFile :: Maybe FilePath
  }
  deriving (Int -> VideoParams -> ShowS
[VideoParams] -> ShowS
VideoParams -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [VideoParams] -> ShowS
$cshowList :: [VideoParams] -> ShowS
show :: VideoParams -> FilePath
$cshow :: VideoParams -> FilePath
showsPrec :: Int -> VideoParams -> ShowS
$cshowsPrec :: Int -> VideoParams -> ShowS
Show)

defaultVideoParams :: VideoParams
defaultVideoParams :: VideoParams
defaultVideoParams =
  VideoParams
    { videoFPS :: Maybe Int
videoFPS = forall a. Maybe a
Nothing,
      videoLoop :: Maybe Bool
videoLoop = forall a. Maybe a
Nothing,
      videoAutoplay :: Maybe Bool
videoAutoplay = forall a. Maybe a
Nothing,
      videoFormat :: Maybe Text
videoFormat = forall a. Maybe a
Nothing,
      videoFile :: Maybe FilePath
videoFile = forall a. Maybe a
Nothing
    }

data AudioParams = AudioParams
  { AudioParams -> Maybe Int
audioSamplingFrequency :: Maybe Int,
    AudioParams -> Maybe Text
audioCodec :: Maybe T.Text
  }
  deriving (Int -> AudioParams -> ShowS
[AudioParams] -> ShowS
AudioParams -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [AudioParams] -> ShowS
$cshowList :: [AudioParams] -> ShowS
show :: AudioParams -> FilePath
$cshow :: AudioParams -> FilePath
showsPrec :: Int -> AudioParams -> ShowS
$cshowsPrec :: Int -> AudioParams -> ShowS
Show)

defaultAudioParams :: AudioParams
defaultAudioParams :: AudioParams
defaultAudioParams =
  AudioParams
    { audioSamplingFrequency :: Maybe Int
audioSamplingFrequency = forall a. Maybe a
Nothing,
      audioCodec :: Maybe Text
audioCodec = forall a. Maybe a
Nothing
    }

data Directive
  = DirectiveRes Exp
  | DirectiveBrief Directive
  | DirectiveCovert Directive
  | DirectiveImg Exp ImgParams
  | DirectivePlot Exp (Maybe (Int, Int))
  | DirectiveGnuplot Exp T.Text
  | DirectiveVideo Exp VideoParams
  | DirectiveAudio Exp AudioParams
  deriving (Int -> Directive -> ShowS
[Directive] -> ShowS
Directive -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Directive] -> ShowS
$cshowList :: [Directive] -> ShowS
show :: Directive -> FilePath
$cshow :: Directive -> FilePath
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 ImgParams
_) = 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 (DirectiveVideo Exp
e VideoParams
_) = Exp -> Set Text
varsInExp Exp
e
varsInDirective (DirectiveAudio Exp
e AudioParams
_) = Exp -> Set Text
varsInExp Exp
e

pprDirective :: Bool -> Directive -> PP.Doc a
pprDirective :: forall a. Bool -> Directive -> Doc a
pprDirective Bool
_ (DirectiveRes Exp
e) =
  Doc a
"> " forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
PP.align (forall a ann. Pretty a => a -> Doc ann
PP.pretty Exp
e)
pprDirective Bool
_ (DirectiveBrief Directive
f) =
  forall a. Bool -> Directive -> Doc a
pprDirective Bool
False Directive
f
pprDirective Bool
_ (DirectiveCovert Directive
f) =
  forall a. Bool -> Directive -> Doc a
pprDirective Bool
False Directive
f
pprDirective Bool
_ (DirectiveImg Exp
e ImgParams
params) =
  (Doc a
"> :img " forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
PP.align (forall a ann. Pretty a => a -> Doc ann
PP.pretty Exp
e))
    forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall {ann}. [Doc ann]
params' then forall a. Monoid a => a
mempty else Doc a
";" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
PP.hardline forall a. Semigroup a => a -> a -> a
<> forall a. [Doc a] -> Doc a
PP.stack forall {ann}. [Doc ann]
params'
  where
    params' :: [Doc ann]
params' = forall a. [Maybe a] -> [a]
catMaybes [forall {b} {t}.
(Semigroup b, IsString b) =>
b -> (ImgParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc ann
"file" ImgParams -> Maybe FilePath
imgFile forall a ann. Pretty a => a -> Doc ann
PP.pretty]
    p :: b -> (ImgParams -> Maybe t) -> (t -> b) -> Maybe b
p b
s ImgParams -> Maybe t
f t -> b
pretty = do
      t
x <- ImgParams -> Maybe t
f ImgParams
params
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ b
s forall a. Semigroup a => a -> a -> a
<> b
": " forall a. Semigroup a => a -> a -> a
<> t -> b
pretty t
x
pprDirective Bool
True (DirectivePlot Exp
e (Just (Int
h, Int
w))) =
  forall a. [Doc a] -> Doc a
PP.stack
    [ Doc a
"> :plot2d " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
PP.pretty Exp
e forall a. Semigroup a => a -> a -> a
<> Doc a
";",
      Doc a
"size: (" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
PP.pretty Int
w forall a. Semigroup a => a -> a -> a
<> Doc a
"," forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
PP.pretty Int
h forall a. Semigroup a => a -> a -> a
<> Doc a
")"
    ]
pprDirective Bool
_ (DirectivePlot Exp
e Maybe (Int, Int)
_) =
  Doc a
"> :plot2d " forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
PP.align (forall a ann. Pretty a => a -> Doc ann
PP.pretty Exp
e)
pprDirective Bool
True (DirectiveGnuplot Exp
e Text
script) =
  forall a. [Doc a] -> Doc a
PP.stack forall a b. (a -> b) -> a -> b
$
    Doc a
"> :gnuplot " forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
PP.align (forall a ann. Pretty a => a -> Doc ann
PP.pretty Exp
e) forall a. Semigroup a => a -> a -> a
<> Doc a
";"
      forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text -> [Text]
T.lines Text
script)
pprDirective Bool
False (DirectiveGnuplot Exp
e Text
_) =
  Doc a
"> :gnuplot " forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
PP.align (forall a ann. Pretty a => a -> Doc ann
PP.pretty Exp
e)
pprDirective Bool
False (DirectiveVideo Exp
e VideoParams
_) =
  Doc a
"> :video " forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
PP.align (forall a ann. Pretty a => a -> Doc ann
PP.pretty Exp
e)
pprDirective Bool
True (DirectiveVideo Exp
e VideoParams
params) =
  (Doc a
"> :video " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
PP.pretty Exp
e)
    forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall {ann}. [Doc ann]
params' then forall a. Monoid a => a
mempty else Doc a
";" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
PP.hardline forall a. Semigroup a => a -> a -> a
<> forall a. [Doc a] -> Doc a
PP.stack forall {ann}. [Doc ann]
params'
  where
    params' :: [Doc ann]
params' =
      forall a. [Maybe a] -> [a]
catMaybes
        [ forall {b} {t}.
(Semigroup b, IsString b) =>
b -> (VideoParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc ann
"fps" VideoParams -> Maybe Int
videoFPS forall a ann. Pretty a => a -> Doc ann
PP.pretty,
          forall {b} {t}.
(Semigroup b, IsString b) =>
b -> (VideoParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc ann
"loop" VideoParams -> Maybe Bool
videoLoop forall {a}. IsString a => Bool -> a
ppBool,
          forall {b} {t}.
(Semigroup b, IsString b) =>
b -> (VideoParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc ann
"autoplay" VideoParams -> Maybe Bool
videoAutoplay forall {a}. IsString a => Bool -> a
ppBool,
          forall {b} {t}.
(Semigroup b, IsString b) =>
b -> (VideoParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc ann
"format" VideoParams -> Maybe Text
videoFormat forall a ann. Pretty a => a -> Doc ann
PP.pretty,
          forall {b} {t}.
(Semigroup b, IsString b) =>
b -> (VideoParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc ann
"file" VideoParams -> Maybe FilePath
videoFile forall a ann. Pretty a => a -> Doc ann
PP.pretty
        ]
    ppBool :: Bool -> a
ppBool Bool
b = if Bool
b then a
"true" else a
"false"
    p :: b -> (VideoParams -> Maybe t) -> (t -> b) -> Maybe b
p b
s VideoParams -> Maybe t
f t -> b
pretty = do
      t
x <- VideoParams -> Maybe t
f VideoParams
params
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ b
s forall a. Semigroup a => a -> a -> a
<> b
": " forall a. Semigroup a => a -> a -> a
<> t -> b
pretty t
x
pprDirective Bool
_ (DirectiveAudio Exp
e AudioParams
params) =
  (Doc a
"> :audio " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
PP.pretty Exp
e)
    forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall {ann}. [Doc ann]
params' then forall a. Monoid a => a
mempty else Doc a
";" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
PP.hardline forall a. Semigroup a => a -> a -> a
<> forall a. [Doc a] -> Doc a
PP.stack forall {ann}. [Doc ann]
params'
  where
    params' :: [Doc ann]
params' =
      forall a. [Maybe a] -> [a]
catMaybes
        [ forall {b} {t}.
(Semigroup b, IsString b) =>
b -> (AudioParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc ann
"sampling_frequency" AudioParams -> Maybe Int
audioSamplingFrequency forall a ann. Pretty a => a -> Doc ann
PP.pretty,
          forall {b} {t}.
(Semigroup b, IsString b) =>
b -> (AudioParams -> Maybe t) -> (t -> b) -> Maybe b
p Doc ann
"codec" AudioParams -> Maybe Text
audioCodec forall a ann. Pretty a => a -> Doc ann
PP.pretty
        ]
    p :: b -> (AudioParams -> Maybe t) -> (t -> b) -> Maybe b
p b
s AudioParams -> Maybe t
f t -> b
pretty = do
      t
x <- AudioParams -> Maybe t
f AudioParams
params
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ b
s forall a. Semigroup a => a -> a -> a
<> b
": " forall a. Semigroup a => a -> a -> a
<> t -> b
pretty t
x

instance PP.Pretty Directive where
  pretty :: forall ann. Directive -> Doc ann
pretty = forall a. Bool -> Directive -> Doc a
pprDirective Bool
True

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

varsInScripts :: [Block] -> S.Set EntryName
varsInScripts :: [Block] -> Set Text
varsInScripts = 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 Text
_) = Directive -> Set Text
varsInDirective Directive
d
    varsInBlock BlockCode {} = forall a. Monoid a => a
mempty
    varsInBlock BlockComment {} = forall a. Monoid a => a
mempty

type Parser = Parsec Void T.Text

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

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

token :: T.Text -> Parser ()
token :: Text -> Parser ()
token = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Parser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string

parseInt :: Parser Int
parseInt :: Parser Int
parseInt = forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ forall a. Read a => FilePath -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isDigit)

restOfLine :: Parser T.Text
restOfLine :: ParsecT Void Text Identity Text
restOfLine = forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing (forall a. Eq a => a -> a -> Bool
/= Char
'\n') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)

parseBlockComment :: Parser T.Text
parseBlockComment :: ParsecT Void Text Identity Text
parseBlockComment = [Text] -> Text
T.unlines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
"--" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Text
" " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
restOfLine

parseTestBlock :: Parser T.Text
parseTestBlock :: ParsecT Void Text Identity Text
parseTestBlock =
  [Text] -> Text
T.unlines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
header 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
"-- ==" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
    remainder :: ParsecT Void Text Identity [Text]
remainder = forall a b. (a -> b) -> [a] -> [b]
map (Text
"-- " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
noblanks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity Text
line
  where
    noblanks :: [Text] -> [Text]
noblanks = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
T.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
T.null
    line :: ParsecT Void Text Identity Text
line = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT Void Text Identity Text
"--") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall e s (m :: * -> *). MonadParsec e s m => m ()
eof 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 =
  forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$
    ParsecT Void Text Identity Text
";"
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser ()
token Text
"-- size:"
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser ()
token Text
"("
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
parseInt forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser ()
token Text
"," forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
parseInt)
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser ()
token Text
")"

withPredicate :: (a -> Bool) -> String -> Parser a -> Parser a
withPredicate :: forall a. (a -> Bool) -> FilePath -> Parser a -> Parser a
withPredicate a -> Bool
f FilePath
msg Parser a
p = do
  a
r <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead Parser a
p
  if a -> Bool
f a
r then Parser a
p else forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
msg

parseFilePath :: Parser FilePath
parseFilePath :: Parser FilePath
parseFilePath =
  forall a. (a -> Bool) -> FilePath -> Parser a -> Parser a
withPredicate FilePath -> Bool
ok FilePath
"filename must not have directory component" Parser FilePath
p
  where
    p :: Parser FilePath
p = Text -> FilePath
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser a
lexeme (forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace))
    ok :: FilePath -> Bool
ok FilePath
f = ShowS
takeFileName FilePath
f forall a. Eq a => a -> a -> Bool
== FilePath
f

parseImgParams :: Parser ImgParams
parseImgParams :: Parser ImgParams
parseImgParams =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe ImgParams
defaultImgParams) forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$
      ParsecT Void Text Identity Text
";" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
"-- " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ImgParams -> Parser ImgParams
parseParams ImgParams
defaultImgParams
  where
    parseParams :: ImgParams -> Parser ImgParams
parseParams ImgParams
params =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
            [ImgParams -> Parser ImgParams
pFile ImgParams
params]
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ImgParams -> Parser ImgParams
parseParams,
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ImgParams
params
        ]
    pFile :: ImgParams -> Parser ImgParams
pFile ImgParams
params = do
      Text -> Parser ()
token Text
"file:"
      FilePath
b <- Parser FilePath
parseFilePath
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ImgParams
params {imgFile :: Maybe FilePath
imgFile = forall a. a -> Maybe a
Just FilePath
b}

parseVideoParams :: Parser VideoParams
parseVideoParams :: Parser VideoParams
parseVideoParams =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe VideoParams
defaultVideoParams) forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$
      ParsecT Void Text Identity Text
";" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
"-- " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> VideoParams -> Parser VideoParams
parseParams VideoParams
defaultVideoParams
  where
    parseParams :: VideoParams -> Parser VideoParams
parseParams VideoParams
params =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
            [VideoParams -> Parser VideoParams
pLoop VideoParams
params, VideoParams -> Parser VideoParams
pFPS VideoParams
params, VideoParams -> Parser VideoParams
pAutoplay VideoParams
params, VideoParams -> Parser VideoParams
pFormat VideoParams
params]
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VideoParams -> Parser VideoParams
parseParams,
          forall (f :: * -> *) a. Applicative f => a -> f a
pure VideoParams
params
        ]
    parseBool :: ParsecT Void Text Identity Bool
parseBool = Text -> Parser ()
token Text
"true" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
token Text
"false" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
    pLoop :: VideoParams -> Parser VideoParams
pLoop VideoParams
params = do
      Text -> Parser ()
token Text
"loop:"
      Bool
b <- ParsecT Void Text Identity Bool
parseBool
      forall (f :: * -> *) a. Applicative f => a -> f a
pure VideoParams
params {videoLoop :: Maybe Bool
videoLoop = forall a. a -> Maybe a
Just Bool
b}
    pFPS :: VideoParams -> Parser VideoParams
pFPS VideoParams
params = do
      Text -> Parser ()
token Text
"fps:"
      Int
fps <- Parser Int
parseInt
      forall (f :: * -> *) a. Applicative f => a -> f a
pure VideoParams
params {videoFPS :: Maybe Int
videoFPS = forall a. a -> Maybe a
Just Int
fps}
    pAutoplay :: VideoParams -> Parser VideoParams
pAutoplay VideoParams
params = do
      Text -> Parser ()
token Text
"autoplay:"
      Bool
b <- ParsecT Void Text Identity Bool
parseBool
      forall (f :: * -> *) a. Applicative f => a -> f a
pure VideoParams
params {videoAutoplay :: Maybe Bool
videoAutoplay = forall a. a -> Maybe a
Just Bool
b}
    pFormat :: VideoParams -> Parser VideoParams
pFormat VideoParams
params = do
      Text -> Parser ()
token Text
"format:"
      Text
s <- forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure VideoParams
params {videoFormat :: Maybe Text
videoFormat = forall a. a -> Maybe a
Just Text
s}

parseAudioParams :: Parser AudioParams
parseAudioParams :: Parser AudioParams
parseAudioParams =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe AudioParams
defaultAudioParams) forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$
      ParsecT Void Text Identity Text
";" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
"-- " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> AudioParams -> Parser AudioParams
parseParams AudioParams
defaultAudioParams
  where
    parseParams :: AudioParams -> Parser AudioParams
parseParams AudioParams
params =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
            [AudioParams -> Parser AudioParams
pSamplingFrequency AudioParams
params, AudioParams -> Parser AudioParams
pCodec AudioParams
params]
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AudioParams -> Parser AudioParams
parseParams,
          forall (f :: * -> *) a. Applicative f => a -> f a
pure AudioParams
params
        ]
    pSamplingFrequency :: AudioParams -> Parser AudioParams
pSamplingFrequency AudioParams
params = do
      Text -> Parser ()
token Text
"sampling_frequency:"
      Int
hz <- Parser Int
parseInt
      forall (f :: * -> *) a. Applicative f => a -> f a
pure AudioParams
params {audioSamplingFrequency :: Maybe Int
audioSamplingFrequency = forall a. a -> Maybe a
Just Int
hz}
    pCodec :: AudioParams -> Parser AudioParams
pCodec AudioParams
params = do
      Text -> Parser ()
token Text
"codec:"
      Text
s <- forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure AudioParams
params {audioCodec :: Maybe Text
audioCodec = forall a. a -> Maybe a
Just Text
s}

atStartOfLine :: Parser ()
atStartOfLine :: Parser ()
atStartOfLine = do
  Pos
col <- SourcePos -> Pos
sourceColumn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Pos
col forall a. Eq a => a -> a -> Bool
/= Pos
pos1) forall (f :: * -> *) a. Alternative f => f a
empty

afterExp :: Parser ()
afterExp :: Parser ()
afterExp = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Parser ()
atStartOfLine, forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol]

withParsedSource :: Parser a -> (a -> T.Text -> b) -> Parser b
withParsedSource :: forall a b. Parser a -> (a -> Text -> b) -> Parser b
withParsedSource Parser a
p a -> Text -> b
f = do
  Text
s <- forall e s (m :: * -> *). MonadParsec e s m => m s
getInput
  Int
bef <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  a
x <- Parser a
p
  Int
aft <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ a -> Text -> b
f a
x forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take (Int
aft forall a. Num a => a -> a -> a
- Int
bef) Text
s

stripCommentPrefix :: T.Text -> T.Text
stripCommentPrefix :: Text -> Text
stripCommentPrefix = [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
onLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
  where
    onLine :: Text -> Text
onLine Text
s
      | Text
"-- " Text -> Text -> Bool
`T.isPrefixOf` Text
s = Int -> Text -> Text
T.drop Int
3 Text
s
      | Bool
otherwise = Int -> Text -> Text
T.drop Int
2 Text
s

parseBlock :: Parser Block
parseBlock :: Parser Block
parseBlock =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ forall a b. Parser a -> (a -> Text -> b) -> Parser b
withParsedSource (Text -> Parser ()
token Text
"-- >" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Directive
parseDirective) forall a b. (a -> b) -> a -> b
$ \Directive
d Text
s ->
        Directive -> Text -> Block
BlockDirective Directive
d forall a b. (a -> b) -> a -> b
$ Text -> Text
stripCommentPrefix Text
s,
      Text -> Block
BlockCode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseTestBlock,
      Text -> Block
BlockCode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseBlockCode,
      Text -> Block
BlockComment 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 =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Exp -> Directive
DirectiveRes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parsec Void Text Exp
parseExp Parser ()
postlexeme forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
afterExp,
          Text -> Parser ()
directiveName Text
"covert"
            forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Directive -> Directive
DirectiveCovert
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Directive
parseDirective,
          Text -> Parser ()
directiveName Text
"brief"
            forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Directive -> Directive
DirectiveBrief
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Directive
parseDirective,
          Text -> Parser ()
directiveName Text
"img"
            forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp -> ImgParams -> Directive
DirectiveImg
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void Text Exp
parseExp Parser ()
postlexeme
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ImgParams
parseImgParams
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol,
          Text -> Parser ()
directiveName Text
"plot2d"
            forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp -> Maybe (Int, Int) -> Directive
DirectivePlot
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void Text Exp
parseExp Parser ()
postlexeme
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe (Int, Int))
parsePlotParams
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol,
          Text -> Parser ()
directiveName Text
"gnuplot"
            forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp -> Text -> Directive
DirectiveGnuplot
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void Text Exp
parseExp Parser ()
postlexeme
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParsecT Void Text Identity Text
";" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
parseBlockComment),
          (Text -> Parser ()
directiveName Text
"video" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
directiveName Text
"video")
            forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp -> VideoParams -> Directive
DirectiveVideo
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void Text Exp
parseExp Parser ()
postlexeme
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser VideoParams
parseVideoParams
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol,
          Text -> Parser ()
directiveName Text
"audio"
            forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Exp -> AudioParams -> Directive
DirectiveAudio
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser () -> Parsec Void Text Exp
parseExp Parser ()
postlexeme
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser AudioParams
parseAudioParams
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
        ]
    directiveName :: Text -> Parser ()
directiveName Text
s = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ Text -> Parser ()
token (Text
":" forall a. Semigroup a => a -> a -> a
<> Text
s)

parseProg :: FilePath -> T.Text -> Either T.Text [Block]
parseProg :: FilePath -> Text -> Either Text [Block]
parseProg FilePath
fname Text
s =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
errorBundlePretty) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
    forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
parse (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Block
parseBlock forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) FilePath
fname Text
s

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

-- | The collection of file paths (all inside the image directory)
-- produced during directive execution.
type Files = S.Set FilePath

newtype State = State {State -> Files
stateFiles :: Files}

newtype ScriptM a = ScriptM (ExceptT T.Text (StateT State IO) a)
  deriving
    ( forall a b. a -> ScriptM b -> ScriptM a
forall a b. (a -> b) -> ScriptM a -> ScriptM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ScriptM b -> ScriptM a
$c<$ :: forall a b. a -> ScriptM b -> ScriptM a
fmap :: forall a b. (a -> b) -> ScriptM a -> ScriptM b
$cfmap :: forall a b. (a -> b) -> ScriptM a -> ScriptM b
Functor,
      Functor ScriptM
forall a. a -> ScriptM a
forall a b. ScriptM a -> ScriptM b -> ScriptM a
forall a b. ScriptM a -> ScriptM b -> ScriptM b
forall a b. ScriptM (a -> b) -> ScriptM a -> ScriptM b
forall a b c. (a -> b -> c) -> ScriptM a -> ScriptM b -> ScriptM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. ScriptM a -> ScriptM b -> ScriptM a
$c<* :: forall a b. ScriptM a -> ScriptM b -> ScriptM a
*> :: forall a b. ScriptM a -> ScriptM b -> ScriptM b
$c*> :: forall a b. ScriptM a -> ScriptM b -> ScriptM b
liftA2 :: forall a b c. (a -> b -> c) -> ScriptM a -> ScriptM b -> ScriptM c
$cliftA2 :: forall a b c. (a -> b -> c) -> ScriptM a -> ScriptM b -> ScriptM c
<*> :: forall a b. ScriptM (a -> b) -> ScriptM a -> ScriptM b
$c<*> :: forall a b. ScriptM (a -> b) -> ScriptM a -> ScriptM b
pure :: forall a. a -> ScriptM a
$cpure :: forall a. a -> ScriptM a
Applicative,
      Applicative ScriptM
forall a. a -> ScriptM a
forall a b. ScriptM a -> ScriptM b -> ScriptM b
forall a b. ScriptM a -> (a -> ScriptM b) -> ScriptM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ScriptM a
$creturn :: forall a. a -> ScriptM a
>> :: forall a b. ScriptM a -> ScriptM b -> ScriptM b
$c>> :: forall a b. ScriptM a -> ScriptM b -> ScriptM b
>>= :: forall a b. ScriptM a -> (a -> ScriptM b) -> ScriptM b
$c>>= :: forall a b. ScriptM a -> (a -> ScriptM b) -> ScriptM b
Monad,
      MonadError T.Text,
      Monad ScriptM
forall a. FilePath -> ScriptM a
forall (m :: * -> *).
Monad m -> (forall a. FilePath -> m a) -> MonadFail m
fail :: forall a. FilePath -> ScriptM a
$cfail :: forall a. FilePath -> ScriptM a
MonadFail,
      Monad ScriptM
forall a. IO a -> ScriptM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> ScriptM a
$cliftIO :: forall a. IO a -> ScriptM a
MonadIO,
      MonadState State
    )

runScriptM :: ScriptM a -> IO (Either T.Text a, Files)
runScriptM :: forall a. ScriptM a -> IO (Either Text a, Files)
runScriptM (ScriptM ExceptT Text (StateT State IO) a
m) = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second State -> Files
stateFiles forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Text (StateT State IO) a
m) State
s
  where
    s :: State
s = Files -> State
State forall a. Monoid a => a
mempty

withTempFile :: (FilePath -> ScriptM a) -> ScriptM a
withTempFile :: forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempFile FilePath -> ScriptM a
f =
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"futhark-literate" forall a b. (a -> b) -> a -> b
$ \FilePath
tmpf Handle
tmpf_h -> do
    Handle -> IO ()
hClose Handle
tmpf_h
    (Either Text a
res, Files
files) <- forall a. ScriptM a -> IO (Either Text a, Files)
runScriptM (FilePath -> ScriptM a
f FilePath
tmpf)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \State
s -> State
s {stateFiles :: Files
stateFiles = Files
files forall a. Semigroup a => a -> a -> a
<> State -> Files
stateFiles State
s}
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Text a
res

withTempDir :: (FilePath -> ScriptM a) -> ScriptM a
withTempDir :: forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir FilePath -> ScriptM a
f =
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"futhark-literate" forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
    (Either Text a
res, Files
files) <- forall a. ScriptM a -> IO (Either Text a, Files)
runScriptM (FilePath -> ScriptM a
f FilePath
dir)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \State
s -> State
s {stateFiles :: Files
stateFiles = Files
files forall a. Semigroup a => a -> a -> a
<> State -> Files
stateFiles State
s}
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Text a
res

greyFloatToImg ::
  (RealFrac a, SVec.Storable a) =>
  SVec.Vector a ->
  SVec.Vector Word32
greyFloatToImg :: forall a. (RealFrac a, Storable a) => Vector a -> Vector Word32
greyFloatToImg = forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
SVec.map forall {a} {p}. (Bits a, RealFrac p, Integral a) => p -> a
grey
  where
    grey :: p -> a
grey p
i =
      let i' :: a
i' = forall a b. (RealFrac a, Integral b) => a -> b
round (p
i forall a. Num a => a -> a -> a
* p
255) forall a. Bits a => a -> a -> a
.&. a
0xFF
       in (a
i' forall a. Bits a => a -> Int -> a
`shiftL` Int
16) forall a. Bits a => a -> a -> a
.|. (a
i' forall a. Bits a => a -> Int -> a
`shiftL` Int
8) forall a. Bits a => a -> a -> a
.|. a
i'

greyByteToImg ::
  (Integral a, SVec.Storable a) =>
  SVec.Vector a ->
  SVec.Vector Word32
greyByteToImg :: forall a. (Integral a, Storable a) => Vector a -> Vector Word32
greyByteToImg = forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
SVec.map forall {a} {a}. (Bits a, Integral a, Num a) => a -> a
grey
  where
    grey :: a -> a
grey a
i =
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i forall a. Bits a => a -> Int -> a
`shiftL` Int
16) forall a. Bits a => a -> a -> a
.|. (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i forall a. Bits a => a -> Int -> a
`shiftL` Int
8) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i

-- BMPs are RGBA and bottom-up where we assumes images are top-down
-- and ARGB.  We fix this up before encoding the BMP.  This is
-- probably a little slower than it has to be.
vecToBMP :: Int -> Int -> SVec.Vector Word32 -> LBS.ByteString
vecToBMP :: Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w = BMP -> ByteString
BMP.renderBMP forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ByteString -> BMP
BMP.packRGBA32ToBMP24 Int
w Int
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Vector a -> ByteString
SVec.vectorToByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
(Integral a, Storable a, Bits a) =>
Vector a -> Vector Word8
frobVec
  where
    frobVec :: Vector a -> Vector Word8
frobVec Vector a
vec = forall a. Storable a => Int -> (Int -> a) -> Vector a
SVec.generate (Int
h forall a. Num a => a -> a -> a
* Int
w forall a. Num a => a -> a -> a
* Int
4) (forall {a}.
(Integral a, Storable a, Bits a) =>
Vector a -> Int -> Word8
pix Vector a
vec)
    pix :: Vector a -> Int -> Word8
pix Vector a
vec Int
l =
      let (Int
i, Int
j) = (Int
l forall a. Integral a => a -> a -> a
`div` Int
4) forall a. Integral a => a -> a -> (a, a)
`divMod` Int
w
          argb :: a
argb = Vector a
vec forall a. Storable a => Vector a -> Int -> a
SVec.! ((Int
h forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
i) forall a. Num a => a -> a -> a
* Int
w forall a. Num a => a -> a -> a
+ Int
j)
          c :: a
c = (a
argb forall a. Bits a => a -> Int -> a
`shiftR` (Int
24 forall a. Num a => a -> a -> a
- ((Int
l forall a. Num a => a -> a -> a
+ Int
1) forall a. Integral a => a -> a -> a
`mod` Int
4) forall a. Num a => a -> a -> a
* Int
8)) forall a. Bits a => a -> a -> a
.&. a
0xFF
       in forall a b. (Integral a, Num b) => a -> b
fromIntegral a
c :: Word8

valueToBMP :: Value -> Maybe LBS.ByteString
valueToBMP :: Value -> Maybe ByteString
valueToBMP v :: Value
v@(U32Value Vector Int
_ Vector Word32
bytes)
  | [Int
h, Int
w] <- Value -> [Int]
valueShape Value
v =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w Vector Word32
bytes
valueToBMP v :: Value
v@(I32Value Vector Int
_ Vector Int32
bytes)
  | [Int
h, Int
w] <- Value -> [Int]
valueShape Value
v =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w forall a b. (a -> b) -> a -> b
$ forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
SVec.map forall a b. (Integral a, Num b) => a -> b
fromIntegral Vector Int32
bytes
valueToBMP v :: Value
v@(F32Value Vector Int
_ Vector Float
bytes)
  | [Int
h, Int
w] <- Value -> [Int]
valueShape Value
v =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w forall a b. (a -> b) -> a -> b
$ forall a. (RealFrac a, Storable a) => Vector a -> Vector Word32
greyFloatToImg Vector Float
bytes
valueToBMP v :: Value
v@(U8Value Vector Int
_ Vector Word8
bytes)
  | [Int
h, Int
w] <- Value -> [Int]
valueShape Value
v =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Storable a) => Vector a -> Vector Word32
greyByteToImg Vector Word8
bytes
valueToBMP v :: Value
v@(F64Value Vector Int
_ Vector Double
bytes)
  | [Int
h, Int
w] <- Value -> [Int]
valueShape Value
v =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w forall a b. (a -> b) -> a -> b
$ forall a. (RealFrac a, Storable a) => Vector a -> Vector Word32
greyFloatToImg Vector Double
bytes
valueToBMP v :: Value
v@(BoolValue Vector Int
_ Vector Bool
bytes)
  | [Int
h, Int
w] <- Value -> [Int]
valueShape Value
v =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Storable a) => Vector a -> Vector Word32
greyByteToImg forall a b. (a -> b) -> a -> b
$ forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
SVec.map (forall a. Num a => a -> a -> a
(*) Int
255 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) Vector Bool
bytes
valueToBMP Value
_ = forall a. Maybe a
Nothing

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

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

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

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

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

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

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

loadBMP :: FilePath -> ScriptM (Compound Value)
loadBMP :: FilePath -> ScriptM CompoundValue
loadBMP FilePath
bmpfile = do
  Either Error BMP
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Either Error BMP)
BMP.readBMP FilePath
bmpfile
  case Either Error BMP
res of
    Left Error
err ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Failed to read BMP:\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText Error
err
    Right BMP
bmp -> do
      let bmp_bs :: ByteString
bmp_bs = BMP -> ByteString
BMP.unpackBMPToRGBA32 BMP
bmp
          (Int
w, Int
h) = BMP -> (Int, Int)
BMP.bmpDimensions BMP
bmp
          shape :: Vector Int
shape = forall a. Storable a => [a] -> Vector a
SVec.fromList [forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w]
          pix :: Int -> a
pix Int
l =
            let (Int
i, Int
j) = Int
l forall a. Integral a => a -> a -> (a, a)
`divMod` Int
w
                l' :: Int
l' = (Int
h forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
i) forall a. Num a => a -> a -> a
* Int
w forall a. Num a => a -> a -> a
+ Int
j
                r :: a
r = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString
bmp_bs HasCallStack => ByteString -> Int -> Word8
`BS.index` (Int
l' forall a. Num a => a -> a -> a
* Int
4)
                g :: a
g = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString
bmp_bs HasCallStack => ByteString -> Int -> Word8
`BS.index` (Int
l' forall a. Num a => a -> a -> a
* Int
4 forall a. Num a => a -> a -> a
+ Int
1)
                b :: a
b = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString
bmp_bs HasCallStack => ByteString -> Int -> Word8
`BS.index` (Int
l' forall a. Num a => a -> a -> a
* Int
4 forall a. Num a => a -> a -> a
+ Int
2)
                a :: a
a = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString
bmp_bs HasCallStack => ByteString -> Int -> Word8
`BS.index` (Int
l' forall a. Num a => a -> a -> a
* Int
4 forall a. Num a => a -> a -> a
+ Int
3)
             in (a
a forall a. Bits a => a -> Int -> a
`shiftL` Int
24) forall a. Bits a => a -> a -> a
.|. (a
r forall a. Bits a => a -> Int -> a
`shiftL` Int
16) forall a. Bits a => a -> a -> a
.|. (a
g forall a. Bits a => a -> Int -> a
`shiftL` Int
8) forall a. Bits a => a -> a -> a
.|. a
b
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. v -> Compound v
ValueAtom forall a b. (a -> b) -> a -> b
$ Vector Int -> Vector Word32 -> Value
U32Value Vector Int
shape forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Int -> (Int -> a) -> Vector a
SVec.generate (Int
w forall a. Num a => a -> a -> a
* Int
h) forall {a}. (Bits a, Num a) => Int -> a
pix

loadImage :: FilePath -> ScriptM (Compound Value)
loadImage :: FilePath -> ScriptM CompoundValue
loadImage FilePath
imgfile =
  forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
    let bmpfile :: FilePath
bmpfile = FilePath
dir FilePath -> ShowS
</> ShowS
takeBaseName FilePath
imgfile FilePath -> ShowS
`replaceExtension` FilePath
"bmp"
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"convert" [FilePath
imgfile, FilePath
"-type", FilePath
"TrueColorAlpha", FilePath
bmpfile] forall a. Monoid a => a
mempty
    FilePath -> ScriptM CompoundValue
loadBMP FilePath
bmpfile

loadPCM :: Int -> FilePath -> ScriptM (Compound Value)
loadPCM :: Int -> FilePath -> ScriptM CompoundValue
loadPCM Int
num_channels FilePath
pcmfile = do
  ByteString
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
LBS.readFile FilePath
pcmfile
  let v :: Vector Double
v = forall a. Storable a => ByteString -> Vector a
SVec.byteStringToVector forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
contents
      channel_length :: Int
channel_length = forall a. Storable a => Vector a -> Int
SVec.length Vector Double
v forall a. Integral a => a -> a -> a
`div` Int
num_channels
      shape :: Vector Int
shape =
        forall a. Storable a => [a] -> Vector a
SVec.fromList
          [ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num_channels,
            forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
channel_length
          ]
      -- ffmpeg outputs audio data in column-major format. `backPermuter` computes the
      -- tranposed indexes for a backpermutation.
      backPermuter :: Int -> Int
backPermuter Int
i = (Int
i forall a. Integral a => a -> a -> a
`mod` Int
channel_length) forall a. Num a => a -> a -> a
* Int
num_channels forall a. Num a => a -> a -> a
+ Int
i forall a. Integral a => a -> a -> a
`div` Int
channel_length
      perm :: Vector Int
perm = forall a. Storable a => Int -> (Int -> a) -> Vector a
SVec.generate (forall a. Storable a => Vector a -> Int
SVec.length Vector Double
v) Int -> Int
backPermuter
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. v -> Compound v
ValueAtom forall a b. (a -> b) -> a -> b
$ Vector Int -> Vector Double -> Value
F64Value Vector Int
shape forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> Vector Int -> Vector a
SVec.backpermute Vector Double
v Vector Int
perm

loadAudio :: FilePath -> ScriptM (Compound Value)
loadAudio :: FilePath -> ScriptM CompoundValue
loadAudio FilePath
audiofile = do
  Text
s <- forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"ffprobe" [FilePath
audiofile, FilePath
"-show_entries", FilePath
"stream=channels", FilePath
"-select_streams", FilePath
"a", FilePath
"-of", FilePath
"compact=p=0:nk=1", FilePath
"-v", FilePath
"0"] forall a. Monoid a => a
mempty
  case forall a. Integral a => Reader a
T.decimal Text
s of
    Right (Int
num_channels, Text
_) -> do
      forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
        let pcmfile :: FilePath
pcmfile = FilePath
dir FilePath -> ShowS
</> ShowS
takeBaseName FilePath
audiofile FilePath -> ShowS
`replaceExtension` FilePath
"pcm"
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"ffmpeg" [FilePath
"-i", FilePath
audiofile, FilePath
"-c:a", FilePath
"pcm_f64le", FilePath
"-map", FilePath
"0", FilePath
"-f", FilePath
"data", FilePath
pcmfile] forall a. Monoid a => a
mempty
        Int -> FilePath -> ScriptM CompoundValue
loadPCM Int
num_channels FilePath
pcmfile
    Either FilePath (Int, Text)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"$loadImg failed to detect the number of channels in the audio input"

literateBuiltin :: EvalBuiltin ScriptM
literateBuiltin :: EvalBuiltin ScriptM
literateBuiltin Text
"loadimg" [CompoundValue]
vs =
  case [CompoundValue]
vs of
    [ValueAtom Value
v]
      | Just [Word8]
path <- forall t. GetValue t => Value -> Maybe t
getValue Value
v -> do
          let path' :: FilePath
path' = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8]
path :: [Word8])
          FilePath -> ScriptM CompoundValue
loadImage FilePath
path'
    [CompoundValue]
_ ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
        Text
"$loadimg does not accept arguments of types: "
          forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> Text
prettyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType) [CompoundValue]
vs)
literateBuiltin Text
"loadaudio" [CompoundValue]
vs =
  case [CompoundValue]
vs of
    [ValueAtom Value
v]
      | Just [Word8]
path <- forall t. GetValue t => Value -> Maybe t
getValue Value
v -> do
          let path' :: FilePath
path' = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8]
path :: [Word8])
          FilePath -> ScriptM CompoundValue
loadAudio FilePath
path'
    [CompoundValue]
_ ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
        Text
"$loadaudio does not accept arguments of types: "
          forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> Text
prettyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType) [CompoundValue]
vs)
literateBuiltin Text
f [CompoundValue]
vs =
  forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> EvalBuiltin m
scriptBuiltin FilePath
"." Text
f [CompoundValue]
vs

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

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

data Env = Env
  { Env -> FilePath
envImgDir :: FilePath,
    -- | Image dir relative to program.
    Env -> FilePath
envRelImgDir :: FilePath,
    Env -> Options
envOpts :: Options,
    Env -> ScriptServer
envServer :: ScriptServer,
    Env -> Text
envHash :: T.Text
  }

newFileWorker :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> ScriptM ()) -> ScriptM (FilePath, FilePath)
newFileWorker :: Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM (FilePath, FilePath)
newFileWorker Env
env (Maybe FilePath
fname_desired, FilePath
template) FilePath -> ScriptM ()
m = do
  let fname_base :: FilePath
fname_base = forall a. a -> Maybe a -> a
fromMaybe (Text -> FilePath
T.unpack (Env -> Text
envHash Env
env) forall a. Semigroup a => a -> a -> a
<> FilePath
"-" forall a. Semigroup a => a -> a -> a
<> FilePath
template) Maybe FilePath
fname_desired
      fname :: FilePath
fname = Env -> FilePath
envImgDir Env
env FilePath -> ShowS
</> FilePath
fname_base
      fname_rel :: FilePath
fname_rel = Env -> FilePath
envRelImgDir Env
env FilePath -> ShowS
</> FilePath
fname_base
  Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
fname
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ Env -> FilePath
envImgDir Env
env
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exists Bool -> Bool -> Bool
&& Options -> Int
scriptVerbose (Env -> Options
envOpts Env
env) forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
        Text
"Using existing file: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fname
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose (Env -> Options
envOpts Env
env) forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
          Text
"Generating new file: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fname
    FilePath -> ScriptM ()
m FilePath
fname
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \State
s -> State
s {stateFiles :: Files
stateFiles = forall a. Ord a => a -> Set a -> Set a
S.insert FilePath
fname forall a b. (a -> b) -> a -> b
$ State -> Files
stateFiles State
s}
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
fname, FilePath
fname_rel)

newFile :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> ScriptM ()) -> ScriptM FilePath
newFile :: Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM FilePath
newFile Env
env (Maybe FilePath, FilePath)
f FilePath -> ScriptM ()
m = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM (FilePath, FilePath)
newFileWorker Env
env (Maybe FilePath, FilePath)
f FilePath -> ScriptM ()
m

newFileContents :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> ScriptM ()) -> ScriptM T.Text
newFileContents :: Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM Text
newFileContents Env
env (Maybe FilePath, FilePath)
f FilePath -> ScriptM ()
m =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Text
T.readFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM (FilePath, FilePath)
newFileWorker Env
env (Maybe FilePath, FilePath)
f FilePath -> ScriptM ()
m

processDirective :: Env -> Directive -> ScriptM T.Text
processDirective :: Env -> Directive -> ScriptM Text
processDirective Env
env (DirectiveBrief Directive
d) =
  Env -> Directive -> ScriptM Text
processDirective Env
env Directive
d
processDirective Env
env (DirectiveCovert Directive
d) =
  Env -> Directive -> ScriptM Text
processDirective Env
env Directive
d
processDirective Env
env (DirectiveRes Exp
e) = do
  Text
result <-
    Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM Text
newFileContents Env
env (forall a. Maybe a
Nothing, FilePath
"eval.txt") forall a b. (a -> b) -> a -> b
$ \FilePath
resultf -> do
      CompoundValue
v <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {m :: * -> *} {a} {a}.
(MonadError Text m, Pretty a) =>
a -> m a
nope forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m
-> ScriptServer
-> Exp
-> m (Either (Compound ScriptValueType) CompoundValue)
evalExpToGround EvalBuiltin ScriptM
literateBuiltin (Env -> ScriptServer
envServer Env
env) Exp
e
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
T.writeFile FilePath
resultf forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
prettyText CompoundValue
v
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    [Text] -> Text
T.unlines
      [ Text
"",
        Text
"```",
        Text
result,
        Text
"```",
        Text
""
      ]
  where
    nope :: a -> m a
nope a
t =
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Cannot show value of type " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText a
t
--
processDirective Env
env (DirectiveImg Exp
e ImgParams
params) = do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM FilePath
newFile Env
env (ImgParams -> Maybe FilePath
imgFile ImgParams
params, FilePath
"img.png") forall a b. (a -> b) -> a -> b
$ \FilePath
pngfile -> do
    Either (Compound ScriptValueType) CompoundValue
maybe_v <- forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m
-> ScriptServer
-> Exp
-> m (Either (Compound ScriptValueType) CompoundValue)
evalExpToGround EvalBuiltin ScriptM
literateBuiltin (Env -> ScriptServer
envServer Env
env) Exp
e
    case Either (Compound ScriptValueType) CompoundValue
maybe_v of
      Right (ValueAtom Value
v)
        | Just ByteString
bmp <- Value -> Maybe ByteString
valueToBMP Value
v -> do
            forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
              let bmpfile :: FilePath
bmpfile = FilePath
dir FilePath -> ShowS
</> FilePath
"img.bmp"
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
bmpfile ByteString
bmp
              forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"convert" [FilePath
bmpfile, FilePath
pngfile] forall a. Monoid a => a
mempty
      Right CompoundValue
v ->
        forall {m :: * -> *} {a} {a}.
(MonadError Text m, Pretty a) =>
a -> m a
nope forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType CompoundValue
v
      Left Compound ScriptValueType
t ->
        forall {m :: * -> *} {a} {a}.
(MonadError Text m, Pretty a) =>
a -> m a
nope Compound ScriptValueType
t
  where
    nope :: a -> m a
nope a
t =
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
        Text
"Cannot create image from value of type " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText a
t
--
processDirective Env
env (DirectivePlot Exp
e Maybe (Int, Int)
size) = do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM FilePath
newFile Env
env (forall a. Maybe a
Nothing, FilePath
"plot.png") forall a b. (a -> b) -> a -> b
$ \FilePath
pngfile -> do
    Either (Compound ScriptValueType) CompoundValue
maybe_v <- forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m
-> ScriptServer
-> Exp
-> m (Either (Compound ScriptValueType) CompoundValue)
evalExpToGround EvalBuiltin ScriptM
literateBuiltin (Env -> ScriptServer
envServer Env
env) Exp
e
    case Either (Compound ScriptValueType) CompoundValue
maybe_v of
      Right CompoundValue
v
        | Just [Value]
vs <- CompoundValue -> Maybe [Value]
plottable2d CompoundValue
v ->
            [(Maybe Text, [Value])] -> FilePath -> ScriptM ()
plotWith [(forall a. Maybe a
Nothing, [Value]
vs)] FilePath
pngfile
      Right (ValueRecord Map Text CompoundValue
m)
        | Just Map Text [Value]
m' <- 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 -> do
            [(Maybe Text, [Value])] -> FilePath -> ScriptM ()
plotWith (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map Text [Value]
m') FilePath
pngfile
      Right CompoundValue
v ->
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Cannot plot value of type " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType CompoundValue
v)
      Left Compound ScriptValueType
t ->
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Cannot plot opaque value of type " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText Compound ScriptValueType
t
  where
    plottable2d :: CompoundValue -> Maybe [Value]
plottable2d CompoundValue
v = do
      [Value
x, Value
y] <- CompoundValue -> Maybe [Value]
plottable CompoundValue
v
      forall a. a -> Maybe a
Just [Value
x, Value
y]

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

    plotWith :: [(Maybe Text, [Value])] -> FilePath -> ScriptM ()
plotWith [(Maybe Text, [Value])]
xys FilePath
pngfile =
      forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM a)
-> ScriptM a
withGnuplotData [] (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {b}. (Maybe Text, b) -> Int -> (Text, b)
tag [(Maybe Text, [Value])]
xys [Int
0 ..]) forall a b. (a -> b) -> a -> b
$ \[Text]
fs [Text]
sets -> do
        let size' :: Text
size' = FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$
              case Maybe (Int, Int)
size of
                Maybe (Int, Int)
Nothing -> FilePath
"500,500"
                Just (Int
w, Int
h) -> forall a. Show a => a -> FilePath
show Int
w forall a. [a] -> [a] -> [a]
++ FilePath
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
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 a
x -> a
"title '" forall a. Semigroup a => a -> a -> a
<> a
x forall a. Semigroup a => a -> a -> a
<> a
"'"
               in a
f forall a. Semigroup a => a -> a -> a
<> a
" " forall a. Semigroup a => a -> a -> a
<> a
title' forall a. Semigroup a => a -> a -> a
<> a
" with lines"
            cmds :: Text
cmds = Text -> [Text] -> Text
T.intercalate Text
", " (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. (IsString a, Semigroup a) => a -> Maybe a -> a
plotCmd [Text]
fs (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Maybe Text, [Value])]
xys))
            script :: Text
script =
              [Text] -> Text
T.unlines
                [ Text
"set terminal png size " forall a. Semigroup a => a -> a -> a
<> Text
size' forall a. Semigroup a => a -> a -> a
<> Text
" enhanced",
                  Text
"set output '" forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
pngfile forall a. Semigroup a => a -> a -> a
<> Text
"'",
                  Text
"set key outside",
                  [Text] -> Text
T.unlines [Text]
sets,
                  Text
"plot " forall a. Semigroup a => a -> a -> a
<> Text
cmds
                ]
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"gnuplot" [] Text
script
--
processDirective Env
env (DirectiveGnuplot Exp
e Text
script) = do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM FilePath
newFile Env
env (forall a. Maybe a
Nothing, FilePath
"plot.png") forall a b. (a -> b) -> a -> b
$ \FilePath
pngfile -> do
    Either (Compound ScriptValueType) CompoundValue
maybe_v <- forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m
-> ScriptServer
-> Exp
-> m (Either (Compound ScriptValueType) CompoundValue)
evalExpToGround EvalBuiltin ScriptM
literateBuiltin (Env -> ScriptServer
envServer Env
env) Exp
e
    case Either (Compound ScriptValueType) CompoundValue
maybe_v of
      Right (ValueRecord Map Text CompoundValue
m)
        | Just Map Text [Value]
m' <- 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])] -> FilePath -> ScriptM ()
plotWith (forall k a. Map k a -> [(k, a)]
M.toList Map Text [Value]
m') FilePath
pngfile
      Right CompoundValue
v ->
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Cannot plot value of type " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType CompoundValue
v)
      Left Compound ScriptValueType
t ->
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Cannot plot opaque value of type " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText Compound ScriptValueType
t
  where
    plotWith :: [(Text, [Value])] -> FilePath -> ScriptM ()
plotWith [(Text, [Value])]
xys FilePath
pngfile = forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM a)
-> ScriptM a
withGnuplotData [] [(Text, [Value])]
xys forall a b. (a -> b) -> a -> b
$ \[Text]
_ [Text]
sets -> do
      let script' :: Text
script' =
            [Text] -> Text
T.unlines
              [ Text
"set terminal png enhanced",
                Text
"set output '" forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
pngfile forall a. Semigroup a => a -> a -> a
<> Text
"'",
                [Text] -> Text
T.unlines [Text]
sets,
                Text
script
              ]
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"gnuplot" [] Text
script'
--
processDirective Env
env (DirectiveVideo Exp
e VideoParams
params) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
format forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"webm", Text
"gif"]) forall a b. (a -> b) -> a -> b
$
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
      Text
"Unknown video format: " forall a. Semigroup a => a -> a -> a
<> Text
format

  let file :: (Maybe FilePath, FilePath)
file = (VideoParams -> Maybe FilePath
videoFile VideoParams
params, FilePath
"video" FilePath -> ShowS
<.> Text -> FilePath
T.unpack Text
format)
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VideoParams -> FilePath -> Text
videoBlock VideoParams
params) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM FilePath
newFile Env
env (Maybe FilePath, FilePath)
file forall a b. (a -> b) -> a -> b
$ \FilePath
videofile -> do
    ExpValue
v <- forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
evalExp EvalBuiltin ScriptM
literateBuiltin (Env -> ScriptServer
envServer Env
env) Exp
e
    let nope :: ScriptM a
nope =
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
            Text
"Cannot produce video from value of type " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
v)
    case ExpValue
v of
      ValueAtom SValue {} -> do
        ValueAtom Value
arr <- forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue (Env -> ScriptServer
envServer Env
env) ExpValue
v
        case Value -> Maybe [ByteString]
valueToBMPs Value
arr of
          Maybe [ByteString]
Nothing -> forall {a}. ScriptM a
nope
          Just [ByteString]
bmps ->
            forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
              forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (forall {m :: * -> *}.
MonadIO m =>
FilePath -> Int -> ByteString -> m ()
writeBMPFile FilePath
dir) [Int
0 ..] [ByteString]
bmps
              forall {f :: * -> *}.
(MonadIO f, MonadError Text f) =>
FilePath -> FilePath -> f ()
onWebM FilePath
videofile forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {m :: * -> *}.
(MonadIO m, MonadError Text m) =>
FilePath -> m FilePath
bmpsToVideo FilePath
dir
      ValueTuple [ExpValue
stepfun, ExpValue
initial, ExpValue
num_frames]
        | ValueAtom (SFun Text
stepfun' [Text]
_ [Text
_, Text
_] [ScriptValue ValOrVar]
closure) <- ExpValue
stepfun,
          ValueAtom (SValue Text
"i64" ValOrVar
_) <- ExpValue
num_frames -> do
            Just (ValueAtom Int64
num_frames') <-
              forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall t. GetValue t => Value -> Maybe t
getValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue (Env -> ScriptServer
envServer Env
env) ExpValue
num_frames
            forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
              let num_frames_int :: Int
num_frames_int = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
num_frames' :: Int64)
              FilePath -> (Text, [ExpValue]) -> ExpValue -> Int -> ScriptM ()
renderFrames FilePath
dir (Text
stepfun', forall a b. (a -> b) -> [a] -> [b]
map forall v. v -> Compound v
ValueAtom [ScriptValue ValOrVar]
closure) ExpValue
initial Int
num_frames_int
              forall {f :: * -> *}.
(MonadIO f, MonadError Text f) =>
FilePath -> FilePath -> f ()
onWebM FilePath
videofile forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {m :: * -> *}.
(MonadIO m, MonadError Text m) =>
FilePath -> m FilePath
bmpsToVideo FilePath
dir
      ExpValue
_ ->
        forall {a}. ScriptM a
nope
  where
    framerate :: Int
framerate = forall a. a -> Maybe a -> a
fromMaybe Int
30 forall a b. (a -> b) -> a -> b
$ VideoParams -> Maybe Int
videoFPS VideoParams
params
    format :: Text
format = forall a. a -> Maybe a -> a
fromMaybe Text
"webm" forall a b. (a -> b) -> a -> b
$ VideoParams -> Maybe Text
videoFormat VideoParams
params
    bmpfile :: FilePath -> Int -> FilePath
bmpfile FilePath
dir Int
j = FilePath
dir FilePath -> ShowS
</> forall r. PrintfType r => FilePath -> r
printf FilePath
"frame%010d.bmp" (Int
j :: Int)

    (Int -> Int -> ScriptM ()
progressStep, ScriptM ()
progressDone)
      | Bool
fancyTerminal,
        Options -> Int
scriptVerbose (Env -> Options
envOpts Env
env) forall a. Ord a => a -> a -> Bool
> Int
0 =
          ( \Int
j Int
num_frames -> do
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$
                Text
"\r"
                  forall a. Semigroup a => a -> a -> a
<> ProgressBar -> Text
progressBar
                    (Int -> Double -> Double -> ProgressBar
ProgressBar Int
40 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num_frames forall a. Num a => a -> a -> a
- Double
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j))
                  forall a. Semigroup a => a -> a -> a
<> Text
"generating frame "
                  forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText (Int
j forall a. Num a => a -> a -> a
+ Int
1)
                  forall a. Semigroup a => a -> a -> a
<> Text
"/"
                  forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText Int
num_frames
                  forall a. Semigroup a => a -> a -> a
<> Text
" "
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
stdout,
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
              Text -> IO ()
T.putStrLn Text
""
          )
      | Bool
otherwise =
          (\Int
_ Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (), forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

    renderFrames :: FilePath -> (Text, [ExpValue]) -> ExpValue -> Int -> ScriptM ()
renderFrames FilePath
dir (Text
stepfun, [ExpValue]
closure) ExpValue
initial Int
num_frames = do
      forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ ExpValue -> Int -> ScriptM ExpValue
frame ExpValue
initial [Int
0 .. Int
num_frames forall a. Num a => a -> a -> a
- Int
1]
      ScriptM ()
progressDone
      where
        frame :: ExpValue -> Int -> ScriptM ExpValue
frame ExpValue
old_state Int
j = do
          Int -> Int -> ScriptM ()
progressStep Int
j Int
num_frames
          ExpValue
v <-
            forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
evalExp EvalBuiltin ScriptM
literateBuiltin (Env -> ScriptServer
envServer Env
env)
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. Func -> [Exp] -> Exp
Call (Text -> Func
FuncFut Text
stepfun)
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ExpValue -> Exp
valueToExp
              forall a b. (a -> b) -> a -> b
$ [ExpValue]
closure forall a. [a] -> [a] -> [a]
++ [ExpValue
old_state]
          forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m ()
freeValue (Env -> ScriptServer
envServer Env
env) ExpValue
old_state

          let nope :: ScriptM a
nope =
                forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
                  Text
"Cannot handle step function return type: "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 <- forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue (Env -> ScriptServer
envServer Env
env) ExpValue
arr_v
              forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m ()
freeValue (Env -> ScriptServer
envServer Env
env) ExpValue
arr_v
              case Value -> Maybe ByteString
valueToBMP Value
arr of
                Maybe ByteString
Nothing -> forall {a}. ScriptM a
nope
                Just ByteString
bmp -> do
                  forall {m :: * -> *}.
MonadIO m =>
FilePath -> Int -> ByteString -> m ()
writeBMPFile FilePath
dir Int
j ByteString
bmp
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpValue
new_state
            ExpValue
_ -> forall {a}. ScriptM a
nope

    writeBMPFile :: FilePath -> Int -> ByteString -> m ()
writeBMPFile FilePath
dir Int
j ByteString
bmp =
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
LBS.writeFile (FilePath -> Int -> FilePath
bmpfile FilePath
dir Int
j) ByteString
bmp

    bmpsToVideo :: FilePath -> m FilePath
bmpsToVideo FilePath
dir = do
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system
          FilePath
"ffmpeg"
          [ FilePath
"-y",
            FilePath
"-r",
            forall a. Show a => a -> FilePath
show Int
framerate,
            FilePath
"-i",
            FilePath
dir FilePath -> ShowS
</> FilePath
"frame%010d.bmp",
            FilePath
"-c:v",
            FilePath
"libvpx-vp9",
            FilePath
"-pix_fmt",
            FilePath
"yuv420p",
            FilePath
"-b:v",
            FilePath
"2M",
            FilePath
dir FilePath -> ShowS
</> FilePath
"video.webm"
          ]
          forall a. Monoid a => a
mempty
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> ShowS
</> FilePath
"video.webm"

    onWebM :: FilePath -> FilePath -> f ()
onWebM FilePath
videofile FilePath
webmfile
      | Text
format forall a. Eq a => a -> a -> Bool
== Text
"gif" =
          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"ffmpeg" [FilePath
"-i", FilePath
webmfile, FilePath
videofile] forall a. Monoid a => a
mempty
      | Bool
otherwise =
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
copyFile FilePath
webmfile FilePath
videofile

--
processDirective Env
env (DirectiveAudio Exp
e AudioParams
params) = do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM FilePath
newFile Env
env (forall a. Maybe a
Nothing, FilePath
"output." forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
output_format) forall a b. (a -> b) -> a -> b
$
    \FilePath
audiofile -> do
      forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
        Either (Compound ScriptValueType) CompoundValue
maybe_v <- forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m
-> ScriptServer
-> Exp
-> m (Either (Compound ScriptValueType) CompoundValue)
evalExpToGround EvalBuiltin ScriptM
literateBuiltin (Env -> ScriptServer
envServer Env
env) Exp
e
        (FilePath, [FilePath])
maybe_raw_files <- forall {m :: * -> *} {e} {a} {a}.
(MonadIO m, MonadError e m, IsString a, IsString e) =>
FilePath -> Either a CompoundValue -> m (a, [FilePath])
toRawFiles FilePath
dir Either (Compound ScriptValueType) CompoundValue
maybe_v
        case (FilePath, [FilePath])
maybe_raw_files of
          (FilePath
input_format, [FilePath]
raw_files) -> do
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
              forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system
                FilePath
"ffmpeg"
                ( forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                    ( \FilePath
raw_file ->
                        [ FilePath
"-f",
                          FilePath
input_format,
                          FilePath
"-ar",
                          forall a. Show a => a -> FilePath
show Int
sampling_frequency,
                          FilePath
"-i",
                          FilePath
raw_file
                        ]
                    )
                    [FilePath]
raw_files
                    forall a. [a] -> [a] -> [a]
++ [ FilePath
"-f",
                         Text -> FilePath
T.unpack Text
output_format,
                         FilePath
"-filter_complex",
                         forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                           (\Int
i -> FilePath
"[" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Int
i forall a. Semigroup a => a -> a -> a
<> FilePath
":a]")
                           [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
raw_files forall a. Num a => a -> a -> a
- Int
1]
                           forall a. Semigroup a => a -> a -> a
<> FilePath
"amerge=inputs="
                           forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
raw_files)
                           forall a. Semigroup a => a -> a -> a
<> FilePath
"[a]",
                         FilePath
"-map",
                         FilePath
"[a]",
                         FilePath
audiofile
                       ]
                )
                forall a. Monoid a => a
mempty
  where
    writeRaw :: FilePath -> FilePath -> Value -> m ()
writeRaw FilePath
dir FilePath
name Value
v = do
      let rawfile :: FilePath
rawfile = FilePath
dir FilePath -> ShowS
</> FilePath
name
      let Just ByteString
bytes = Value -> Maybe ByteString
toBytes Value
v
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
rawfile forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bytes

    toRawFiles :: FilePath -> Either a CompoundValue -> m (a, [FilePath])
toRawFiles FilePath
dir (Right (ValueAtom Value
v))
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length (Value -> [Int]
valueShape Value
v) forall a. Eq a => a -> a -> Bool
== Int
1,
        Just a
input_format <- forall {a}. IsString a => Value -> Maybe a
toFfmpegFormat Value
v = do
          forall {m :: * -> *}.
MonadIO m =>
FilePath -> FilePath -> Value -> m ()
writeRaw FilePath
dir FilePath
"raw.pcm" Value
v
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
input_format, [FilePath
dir FilePath -> ShowS
</> FilePath
"raw.pcm"])
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length (Value -> [Int]
valueShape Value
v) forall a. Eq a => a -> a -> Bool
== Int
2,
        Just a
input_format <- forall {a}. IsString a => Value -> Maybe a
toFfmpegFormat Value
v = do
          (a
input_format,)
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM
              ( \Value
v' Int
i -> do
                  let file_name :: FilePath
file_name = FilePath
"raw-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Int
i forall a. Semigroup a => a -> a -> a
<> FilePath
".pcm"
                  forall {m :: * -> *}.
MonadIO m =>
FilePath -> FilePath -> Value -> m ()
writeRaw FilePath
dir FilePath
file_name Value
v'
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> ShowS
</> FilePath
file_name
              )
              (Value -> [Value]
valueElems Value
v)
              [Int
0 :: Int ..]
    toRawFiles FilePath
_ Either a CompoundValue
v = forall {e} {m :: * -> *} {p} {a}.
(MonadError e m, IsString e) =>
p -> m a
nope forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType) Either a CompoundValue
v

    toFfmpegFormat :: Value -> Maybe a
toFfmpegFormat I8Value {} = forall a. a -> Maybe a
Just a
"s8"
    toFfmpegFormat U8Value {} = forall a. a -> Maybe a
Just a
"u8"
    toFfmpegFormat I16Value {} = forall a. a -> Maybe a
Just a
"s16le"
    toFfmpegFormat U16Value {} = forall a. a -> Maybe a
Just a
"u16le"
    toFfmpegFormat I32Value {} = forall a. a -> Maybe a
Just a
"s32le"
    toFfmpegFormat U32Value {} = forall a. a -> Maybe a
Just a
"u32le"
    toFfmpegFormat F32Value {} = forall a. a -> Maybe a
Just a
"f32le"
    toFfmpegFormat F64Value {} = forall a. a -> Maybe a
Just a
"f64le"
    toFfmpegFormat Value
_ = forall a. Maybe a
Nothing

    toBytes :: Value -> Maybe ByteString
toBytes (I8Value Vector Int
_ Vector Int8
bytes) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> ByteString
SVec.vectorToByteString Vector Int8
bytes
    toBytes (U8Value Vector Int
_ Vector Word8
bytes) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> ByteString
SVec.vectorToByteString Vector Word8
bytes
    toBytes (I16Value Vector Int
_ Vector Int16
bytes) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> ByteString
SVec.vectorToByteString Vector Int16
bytes
    toBytes (U16Value Vector Int
_ Vector Word16
bytes) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> ByteString
SVec.vectorToByteString Vector Word16
bytes
    toBytes (I32Value Vector Int
_ Vector Int32
bytes) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> ByteString
SVec.vectorToByteString Vector Int32
bytes
    toBytes (U32Value Vector Int
_ Vector Word32
bytes) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> ByteString
SVec.vectorToByteString Vector Word32
bytes
    toBytes (F32Value Vector Int
_ Vector Float
bytes) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> ByteString
SVec.vectorToByteString Vector Float
bytes
    toBytes (F64Value Vector Int
_ Vector Double
bytes) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> ByteString
SVec.vectorToByteString Vector Double
bytes
    toBytes Value
_ = forall a. Maybe a
Nothing

    output_format :: Text
output_format = forall a. a -> Maybe a -> a
fromMaybe Text
"wav" forall a b. (a -> b) -> a -> b
$ AudioParams -> Maybe Text
audioCodec AudioParams
params
    sampling_frequency :: Int
sampling_frequency = forall a. a -> Maybe a -> a
fromMaybe Int
44100 forall a b. (a -> b) -> a -> b
$ AudioParams -> Maybe Int
audioSamplingFrequency AudioParams
params
    nope :: p -> m a
nope p
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
"Cannot create audio from value"

-- Did this script block succeed or fail?
data Failure = Failure | Success
  deriving (Failure -> Failure -> Bool
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
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
Ord, Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Failure] -> ShowS
$cshowList :: [Failure] -> ShowS
show :: Failure -> FilePath
$cshow :: Failure -> FilePath
showsPrec :: Int -> Failure -> ShowS
$cshowsPrec :: Int -> Failure -> ShowS
Show)

processBlock :: Env -> Block -> IO (Failure, T.Text, Files)
processBlock :: Env -> Block -> IO (Failure, Text, Files)
processBlock Env
_ (BlockCode Text
code)
  | Text -> Bool
T.null Text
code = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
"\n", forall a. Monoid a => a
mempty)
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
"\n```futhark\n" forall a. Semigroup a => a -> a -> a
<> Text
code forall a. Semigroup a => a -> a -> a
<> Text
"```\n\n", forall a. Monoid a => a
mempty)
processBlock Env
_ (BlockComment Text
pretty) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
pretty, forall a. Monoid a => a
mempty)
processBlock Env
env (BlockDirective Directive
directive Text
text) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose (Env -> Options
envOpts Env
env) forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
    Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Text
PP.docText forall a b. (a -> b) -> a -> b
$
      Doc Any
"Processing " forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
PP.align (forall a ann. Pretty a => a -> Doc ann
PP.pretty Directive
directive) forall a. Semigroup a => a -> a -> a
<> Doc Any
"..."
  let prompt :: Text
prompt = case Directive
directive of
        DirectiveCovert Directive
_ -> forall a. Monoid a => a
mempty
        DirectiveBrief Directive
_ ->
          Text
"```\n" forall a. Semigroup a => a -> a -> a
<> forall a. Doc a -> Text
PP.docText (forall a. Bool -> Directive -> Doc a
pprDirective Bool
False Directive
directive) forall a. Semigroup a => a -> a -> a
<> Text
"\n```\n"
        Directive
_ ->
          Text
"```\n" forall a. Semigroup a => a -> a -> a
<> Text
text forall a. Semigroup a => a -> a -> a
<> Text
"```\n"
      env' :: Env
env' = Env
env {envHash :: Text
envHash = Text -> Text
hashText (Env -> Text
envHash Env
env forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText Directive
directive)}
  (Either Text Text
r, Files
files) <- forall a. ScriptM a -> IO (Either Text a, Files)
runScriptM forall a b. (a -> b) -> a -> b
$ Env -> Directive -> ScriptM Text
processDirective Env
env' Directive
directive
  case Either Text Text
r of
    Left Text
err -> forall {c}. Text -> Text -> c -> IO (Failure, Text, c)
failed Text
prompt Text
err Files
files
    Right Text
t -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
prompt forall a. Semigroup a => a -> a -> a
<> Text
t, Files
files)
  where
    failed :: Text -> Text -> c -> IO (Failure, Text, c)
failed Text
prompt Text
err c
files = do
      let message :: Text
message = forall a. Pretty a => a -> Text
prettyTextOneLine Directive
directive forall a. Semigroup a => a -> a -> a
<> Text
" failed:\n" forall a. Semigroup a => a -> a -> a
<> Text
err forall a. Semigroup a => a -> a -> a
<> Text
"\n"
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStr Handle
stderr Text
message
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Bool
scriptStopOnError (Env -> Options
envOpts Env
env)) forall a. IO a
exitFailure
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Failure
Failure,
          [Text] -> Text
T.unlines [Text
prompt, Text
"**FAILED**", Text
"```", Text
err, Text
"```"],
          c
files
        )

-- Delete all files in the given directory that are not contained in
-- 'files'.
cleanupImgDir :: Env -> Files -> IO ()
cleanupImgDir :: Env -> Files -> IO ()
cleanupImgDir Env
env Files
keep_files =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
toRemove forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => a -> Set a -> Bool
`S.member` Files
keep_files))
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FilePath -> IO [FilePath]
directoryContents (Env -> FilePath
envImgDir Env
env) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` forall {f :: * -> *} {a}. MonadError IOError f => IOError -> f [a]
onError)
  where
    onError :: IOError -> f [a]
onError IOError
e
      | IOError -> Bool
isDoesNotExistError IOError
e = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Bool
otherwise = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError IOError
e
    toRemove :: FilePath -> IO ()
toRemove FilePath
f = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose (Env -> Options
envOpts Env
env) forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
          Text
"Deleting unused file: " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
f
      FilePath -> IO ()
removePathForcibly FilePath
f

processScript :: Env -> [Block] -> IO (Failure, T.Text)
processScript :: Env -> [Block] -> IO (Failure, Text)
processScript Env
env [Block]
script = do
  ([Failure]
failures, [Text]
outputs, [Files]
files) <-
    forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> Block -> IO (Failure, Text, Files)
processBlock Env
env) [Block]
script
  Env -> Files -> IO ()
cleanupImgDir Env
env forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Files]
files
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Ord a => a -> a -> a
min Failure
Success [Failure]
failures, forall a. Monoid a => [a] -> a
mconcat [Text]
outputs)

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

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

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

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Options -> Bool
scriptSkipCompilation Options
opts) forall a b. (a -> b) -> a -> b
$ do
        let entryOpt :: Text -> FilePath
entryOpt Text
v = FilePath
"--entry-point=" forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
v
            compile_options :: [FilePath]
compile_options =
              FilePath
"--server"
                forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
entryOpt (forall a. Set a -> [a]
S.toList ([Block] -> Set Text
varsInScripts [Block]
script))
                forall a. [a] -> [a] -> [a]
++ Options -> [FilePath]
scriptCompilerOptions Options
opts
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose Options
opts forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
          Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
            Text
"Compiling " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
prog forall a. Semigroup a => a -> a -> a
<> Text
"..."
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose Options
opts forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$
          Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
            FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$
              [FilePath] -> FilePath
unwords [FilePath]
compile_options

        let onError :: t Text -> IO b
onError t Text
err = do
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr) t Text
err
              forall a. IO a
exitFailure
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {t :: * -> *} {b}. Foldable t => t Text -> IO b
onError forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *).
(MonadIO m, MonadError [Text] m) =>
[FilePath]
-> FutharkExe -> FilePath -> FilePath -> m (ByteString, ByteString)
compileProgram [FilePath]
compile_options (FilePath -> FutharkExe
FutharkExe FilePath
futhark) (Options -> FilePath
scriptBackend Options
opts) FilePath
prog

      let onError :: Text -> IO b
onError Text
err = do
            Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
err
            forall a. IO a
exitFailure
      Text
proghash <-
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {b}. Text -> IO b
onError forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
futhark [FilePath
"hash", FilePath
prog] forall a. Monoid a => a
mempty

      let mdfile :: FilePath
mdfile = forall a. a -> Maybe a -> a
fromMaybe (FilePath
prog FilePath -> ShowS
`replaceExtension` FilePath
"md") forall a b. (a -> b) -> a -> b
$ Options -> Maybe FilePath
scriptOutput Options
opts
          imgdir_rel :: FilePath
imgdir_rel = ShowS
dropExtension (ShowS
takeFileName FilePath
mdfile) forall a. Semigroup a => a -> a -> a
<> FilePath
"-img"
          imgdir :: FilePath
imgdir = ShowS
takeDirectory FilePath
mdfile FilePath -> ShowS
</> FilePath
imgdir_rel
          run_options :: [FilePath]
run_options = Options -> [FilePath]
scriptExtraOptions Options
opts
          onLine :: a -> Text -> IO ()
onLine a
"call" Text
l = Text -> IO ()
T.putStrLn Text
l
          onLine a
_ Text
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          cfg :: ServerCfg
cfg =
            (FilePath -> [FilePath] -> ServerCfg
futharkServerCfg (FilePath
"." FilePath -> ShowS
</> ShowS
dropExtension FilePath
prog) [FilePath]
run_options)
              { cfgOnLine :: Text -> Text -> IO ()
cfgOnLine =
                  if Options -> Int
scriptVerbose Options
opts forall a. Ord a => a -> a -> Bool
> Int
0
                    then forall {a}. (Eq a, IsString a) => a -> Text -> IO ()
onLine
                    else forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              }

      forall a. ServerCfg -> (ScriptServer -> IO a) -> IO a
withScriptServer ServerCfg
cfg forall a b. (a -> b) -> a -> b
$ \ScriptServer
server -> do
        let env :: Env
env =
              Env
                { envServer :: ScriptServer
envServer = ScriptServer
server,
                  envOpts :: Options
envOpts = Options
opts,
                  envHash :: Text
envHash = Text
proghash,
                  envImgDir :: FilePath
envImgDir = FilePath
imgdir,
                  envRelImgDir :: FilePath
envRelImgDir = FilePath
imgdir_rel
                }
        (Failure
failure, Text
md) <- Env -> [Block] -> IO (Failure, Text)
processScript Env
env [Block]
script
        FilePath -> Text -> IO ()
T.writeFile FilePath
mdfile Text
md
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Failure
failure forall a. Eq a => a -> a -> Bool
== Failure
Failure) forall a. IO a
exitFailure
    [FilePath]
_ -> forall a. Maybe a
Nothing