-- | @futhark literate@
--
-- Also contains various utility definitions used by "Futhark.CLI.Script".
module Futhark.CLI.Literate
  ( main,
    Options (..),
    initialOptions,
    scriptCommandLineOptions,
    prepareServer,
  )
where

import Codec.BMP qualified as BMP
import Control.Monad
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,
    getCurrentDirectory,
    removePathForcibly,
    setCurrentDirectory,
  )
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
(Int -> ImgParams -> ShowS)
-> (ImgParams -> FilePath)
-> ([ImgParams] -> ShowS)
-> Show ImgParams
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ImgParams -> ShowS
showsPrec :: Int -> ImgParams -> ShowS
$cshow :: ImgParams -> FilePath
show :: ImgParams -> FilePath
$cshowList :: [ImgParams] -> ShowS
showList :: [ImgParams] -> ShowS
Show)

defaultImgParams :: ImgParams
defaultImgParams :: ImgParams
defaultImgParams =
  ImgParams {imgFile :: Maybe FilePath
imgFile = Maybe FilePath
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
(Int -> VideoParams -> ShowS)
-> (VideoParams -> FilePath)
-> ([VideoParams] -> ShowS)
-> Show VideoParams
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VideoParams -> ShowS
showsPrec :: Int -> VideoParams -> ShowS
$cshow :: VideoParams -> FilePath
show :: VideoParams -> FilePath
$cshowList :: [VideoParams] -> ShowS
showList :: [VideoParams] -> ShowS
Show)

defaultVideoParams :: VideoParams
defaultVideoParams :: VideoParams
defaultVideoParams =
  VideoParams
    { videoFPS :: Maybe Int
videoFPS = Maybe Int
forall a. Maybe a
Nothing,
      videoLoop :: Maybe Bool
videoLoop = Maybe Bool
forall a. Maybe a
Nothing,
      videoAutoplay :: Maybe Bool
videoAutoplay = Maybe Bool
forall a. Maybe a
Nothing,
      videoFormat :: Maybe Text
videoFormat = Maybe Text
forall a. Maybe a
Nothing,
      videoFile :: Maybe FilePath
videoFile = Maybe FilePath
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
(Int -> AudioParams -> ShowS)
-> (AudioParams -> FilePath)
-> ([AudioParams] -> ShowS)
-> Show AudioParams
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AudioParams -> ShowS
showsPrec :: Int -> AudioParams -> ShowS
$cshow :: AudioParams -> FilePath
show :: AudioParams -> FilePath
$cshowList :: [AudioParams] -> ShowS
showList :: [AudioParams] -> ShowS
Show)

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

instance PP.Pretty Directive where
  pretty :: forall ann. Directive -> Doc ann
pretty = Bool -> Directive -> Doc ann
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
(Int -> Block -> ShowS)
-> (Block -> FilePath) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Block -> ShowS
showsPrec :: Int -> Block -> ShowS
$cshow :: Block -> FilePath
show :: Block -> FilePath
$cshowList :: [Block] -> ShowS
showList :: [Block] -> ShowS
Show)

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

type Parser = Parsec Void T.Text

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

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

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

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

restOfLine :: Parser T.Text
restOfLine :: ParsecT Void Text Identity Text
restOfLine = Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe FilePath
forall a. Maybe a
Nothing (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'\n') ParsecT Void Text Identity Text
-> Parser () -> ParsecT Void Text Identity Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol Parser () -> Parser () -> Parser ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
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 ([Text] -> Text)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity Text
line
  where
    line :: ParsecT Void Text Identity Text
line = ParsecT Void Text Identity Text
"--" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity (Maybe Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Text
" " ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
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 ([Text] -> Text)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((:) (Text -> [Text] -> [Text])
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity ([Text] -> [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
header ParsecT Void Text Identity ([Text] -> [Text])
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity [Text]
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity [Text]
remainder)
  where
    header :: ParsecT Void Text Identity Text
header = ParsecT Void Text Identity Text
"-- ==" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
    remainder :: ParsecT Void Text Identity [Text]
remainder = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"-- " <>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> [Text])
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseBlockComment

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

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

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

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

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

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

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

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

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 <- ParsecT Void Text Identity Text
forall e s (m :: * -> *). MonadParsec e s m => m s
getInput
  Int
bef <- Parser Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  a
x <- Parser a
p
  Int
aft <- Parser Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  b -> Parser b
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Parser b) -> b -> Parser b
forall a b. (a -> b) -> a -> b
$ a -> Text -> b
f a
x (Text -> b) -> Text -> b
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take (Int
aft Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bef) Text
s

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

parseProg :: FilePath -> T.Text -> Either T.Text [Block]
parseProg :: FilePath -> Text -> Either Text [Block]
parseProg FilePath
fname Text
s =
  (ParseErrorBundle Text Void -> Either Text [Block])
-> ([Block] -> Either Text [Block])
-> Either (ParseErrorBundle Text Void) [Block]
-> Either Text [Block]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Either Text [Block]
forall a b. a -> Either a b
Left (Text -> Either Text [Block])
-> (ParseErrorBundle Text Void -> Text)
-> ParseErrorBundle Text Void
-> Either Text [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text)
-> (ParseErrorBundle Text Void -> FilePath)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> FilePath
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
errorBundlePretty) [Block] -> Either Text [Block]
forall a b. b -> Either a b
Right (Either (ParseErrorBundle Text Void) [Block]
 -> Either Text [Block])
-> Either (ParseErrorBundle Text Void) [Block]
-> Either Text [Block]
forall a b. (a -> b) -> a -> b
$
    Parsec Void Text [Block]
-> FilePath -> Text -> Either (ParseErrorBundle Text Void) [Block]
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
parse (Parser Block -> Parsec Void Text [Block]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Block
parseBlock Parsec Void Text [Block] -> Parser () -> Parsec Void Text [Block]
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
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 (Text -> Either Text [Block])
-> IO Text -> IO (Either Text [Block])
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
      IO [Block]
forall a. IO a
exitFailure
    Right [Block]
script ->
      [Block] -> IO [Block]
forall a. a -> IO a
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 -> b) -> ScriptM a -> ScriptM b)
-> (forall a b. a -> ScriptM b -> ScriptM a) -> Functor ScriptM
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
$cfmap :: forall a b. (a -> b) -> ScriptM a -> ScriptM b
fmap :: forall a b. (a -> b) -> ScriptM a -> ScriptM b
$c<$ :: forall a b. a -> ScriptM b -> ScriptM a
<$ :: forall a b. a -> ScriptM b -> ScriptM a
Functor,
      Functor ScriptM
Functor ScriptM
-> (forall a. a -> ScriptM a)
-> (forall a b. ScriptM (a -> b) -> ScriptM a -> ScriptM b)
-> (forall a b c.
    (a -> b -> c) -> ScriptM a -> ScriptM b -> ScriptM c)
-> (forall a b. ScriptM a -> ScriptM b -> ScriptM b)
-> (forall a b. ScriptM a -> ScriptM b -> ScriptM a)
-> Applicative 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
$cpure :: forall a. a -> ScriptM a
pure :: forall a. a -> ScriptM a
$c<*> :: forall a b. ScriptM (a -> b) -> ScriptM a -> ScriptM b
<*> :: forall a b. ScriptM (a -> b) -> ScriptM a -> ScriptM b
$cliftA2 :: forall a b c. (a -> b -> c) -> ScriptM a -> ScriptM b -> ScriptM c
liftA2 :: forall a b c. (a -> b -> c) -> ScriptM a -> ScriptM b -> ScriptM c
$c*> :: forall a b. ScriptM a -> ScriptM b -> ScriptM b
*> :: forall a b. ScriptM a -> ScriptM b -> ScriptM b
$c<* :: forall a b. ScriptM a -> ScriptM b -> ScriptM a
<* :: forall a b. ScriptM a -> ScriptM b -> ScriptM a
Applicative,
      Applicative ScriptM
Applicative ScriptM
-> (forall a b. ScriptM a -> (a -> ScriptM b) -> ScriptM b)
-> (forall a b. ScriptM a -> ScriptM b -> ScriptM b)
-> (forall a. a -> ScriptM a)
-> Monad 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
$c>>= :: forall a b. ScriptM a -> (a -> ScriptM b) -> ScriptM b
>>= :: forall a b. ScriptM a -> (a -> ScriptM b) -> ScriptM b
$c>> :: forall a b. ScriptM a -> ScriptM b -> ScriptM b
>> :: forall a b. ScriptM a -> ScriptM b -> ScriptM b
$creturn :: forall a. a -> ScriptM a
return :: forall a. a -> ScriptM a
Monad,
      MonadError T.Text,
      Monad ScriptM
Monad ScriptM
-> (forall a. FilePath -> ScriptM a) -> MonadFail ScriptM
forall a. FilePath -> ScriptM a
forall (m :: * -> *).
Monad m -> (forall a. FilePath -> m a) -> MonadFail m
$cfail :: forall a. FilePath -> ScriptM a
fail :: forall a. FilePath -> ScriptM a
MonadFail,
      Monad ScriptM
Monad ScriptM -> (forall a. IO a -> ScriptM a) -> MonadIO ScriptM
forall a. IO a -> ScriptM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> ScriptM a
liftIO :: 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) = (State -> Files)
-> (Either Text a, State) -> (Either Text a, Files)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second State -> Files
stateFiles ((Either Text a, State) -> (Either Text a, Files))
-> IO (Either Text a, State) -> IO (Either Text a, Files)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT State IO (Either Text a)
-> State -> IO (Either Text a, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ExceptT Text (StateT State IO) a -> StateT State IO (Either Text a)
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 Files
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 =
  ScriptM (ScriptM a) -> ScriptM a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ScriptM (ScriptM a) -> ScriptM a)
-> ((FilePath -> Handle -> IO (ScriptM a)) -> ScriptM (ScriptM a))
-> (FilePath -> Handle -> IO (ScriptM a))
-> ScriptM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (ScriptM a) -> ScriptM (ScriptM a)
forall a. IO a -> ScriptM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ScriptM a) -> ScriptM (ScriptM a))
-> ((FilePath -> Handle -> IO (ScriptM a)) -> IO (ScriptM a))
-> (FilePath -> Handle -> IO (ScriptM a))
-> ScriptM (ScriptM a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> (FilePath -> Handle -> IO (ScriptM a)) -> IO (ScriptM a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"futhark-literate" ((FilePath -> Handle -> IO (ScriptM a)) -> ScriptM a)
-> (FilePath -> Handle -> IO (ScriptM a)) -> ScriptM a
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) <- ScriptM a -> IO (Either Text a, Files)
forall a. ScriptM a -> IO (Either Text a, Files)
runScriptM (FilePath -> ScriptM a
f FilePath
tmpf)
    ScriptM a -> IO (ScriptM a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptM a -> IO (ScriptM a)) -> ScriptM a -> IO (ScriptM a)
forall a b. (a -> b) -> a -> b
$ do
      (State -> State) -> ScriptM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State -> State) -> ScriptM ()) -> (State -> State) -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ \State
s -> State
s {stateFiles :: Files
stateFiles = Files
files Files -> Files -> Files
forall a. Semigroup a => a -> a -> a
<> State -> Files
stateFiles State
s}
      (Text -> ScriptM a)
-> (a -> ScriptM a) -> Either Text a -> ScriptM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> ScriptM a
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> ScriptM a
forall a. a -> ScriptM a
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 =
  ScriptM (ScriptM a) -> ScriptM a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ScriptM (ScriptM a) -> ScriptM a)
-> ((FilePath -> IO (ScriptM a)) -> ScriptM (ScriptM a))
-> (FilePath -> IO (ScriptM a))
-> ScriptM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (ScriptM a) -> ScriptM (ScriptM a)
forall a. IO a -> ScriptM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ScriptM a) -> ScriptM (ScriptM a))
-> ((FilePath -> IO (ScriptM a)) -> IO (ScriptM a))
-> (FilePath -> IO (ScriptM a))
-> ScriptM (ScriptM a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> (FilePath -> IO (ScriptM a)) -> IO (ScriptM a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"futhark-literate" ((FilePath -> IO (ScriptM a)) -> ScriptM a)
-> (FilePath -> IO (ScriptM a)) -> ScriptM a
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
    (Either Text a
res, Files
files) <- ScriptM a -> IO (Either Text a, Files)
forall a. ScriptM a -> IO (Either Text a, Files)
runScriptM (FilePath -> ScriptM a
f FilePath
dir)
    ScriptM a -> IO (ScriptM a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptM a -> IO (ScriptM a)) -> ScriptM a -> IO (ScriptM a)
forall a b. (a -> b) -> a -> b
$ do
      (State -> State) -> ScriptM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State -> State) -> ScriptM ()) -> (State -> State) -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ \State
s -> State
s {stateFiles :: Files
stateFiles = Files
files Files -> Files -> Files
forall a. Semigroup a => a -> a -> a
<> State -> Files
stateFiles State
s}
      (Text -> ScriptM a)
-> (a -> ScriptM a) -> Either Text a -> ScriptM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> ScriptM a
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> ScriptM a
forall a. a -> ScriptM a
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 = (a -> Word32) -> Vector a -> Vector Word32
forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
SVec.map a -> Word32
forall {a} {p}. (Bits a, RealFrac p, Integral a) => p -> a
grey
  where
    grey :: p -> a
grey p
i =
      let i' :: a
i' = p -> a
forall b. Integral b => p -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (p
i p -> p -> p
forall a. Num a => a -> a -> a
* p
255) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFF
       in (a
i' a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) a -> a -> a
forall a. Bits a => a -> a -> a
.|. (a
i' a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) a -> a -> a
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 = (a -> Word32) -> Vector a -> Vector Word32
forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
SVec.map a -> Word32
forall {a} {a}. (Bits a, Integral a, Num a) => a -> a
grey
  where
    grey :: a -> a
grey a
i =
      (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) a -> a -> a
forall a. Bits a => a -> a -> a
.|. (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) a -> a -> a
forall a. Bits a => a -> 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 (BMP -> ByteString)
-> (Vector Word32 -> BMP) -> Vector Word32 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ByteString -> BMP
BMP.packRGBA32ToBMP24 Int
w Int
h (ByteString -> BMP)
-> (Vector Word32 -> ByteString) -> Vector Word32 -> BMP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word8 -> ByteString
forall a. Storable a => Vector a -> ByteString
SVec.vectorToByteString (Vector Word8 -> ByteString)
-> (Vector Word32 -> Vector Word8) -> Vector Word32 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word32 -> Vector Word8
forall {a}.
(Integral a, Storable a, Bits a) =>
Vector a -> Vector Word8
frobVec
  where
    frobVec :: Vector a -> Vector Word8
frobVec Vector a
vec = Int -> (Int -> Word8) -> Vector Word8
forall a. Storable a => Int -> (Int -> a) -> Vector a
SVec.generate (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) (Vector a -> Int -> Word8
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 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
w
          argb :: a
argb = Vector a
vec Vector a -> Int -> a
forall a. Storable a => Vector a -> Int -> a
SVec.! ((Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j)
          c :: a
c = (a
argb a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` (Int
24 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ((Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8)) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFF
       in a -> Word8
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 =
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
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 =
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w (Vector Word32 -> ByteString) -> Vector Word32 -> ByteString
forall a b. (a -> b) -> a -> b
$ (Int32 -> Word32) -> Vector Int32 -> Vector Word32
forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
SVec.map Int32 -> Word32
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 =
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w (Vector Word32 -> ByteString) -> Vector Word32 -> ByteString
forall a b. (a -> b) -> a -> b
$ Vector Float -> Vector Word32
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 =
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w (Vector Word32 -> ByteString) -> Vector Word32 -> ByteString
forall a b. (a -> b) -> a -> b
$ Vector Word8 -> Vector Word32
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 =
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w (Vector Word32 -> ByteString) -> Vector Word32 -> ByteString
forall a b. (a -> b) -> a -> b
$ Vector Double -> Vector Word32
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 =
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Word32 -> ByteString
vecToBMP Int
h Int
w (Vector Word32 -> ByteString) -> Vector Word32 -> ByteString
forall a b. (a -> b) -> a -> b
$ Vector Int -> Vector Word32
forall a. (Integral a, Storable a) => Vector a -> Vector Word32
greyByteToImg (Vector Int -> Vector Word32) -> Vector Int -> Vector Word32
forall a b. (a -> b) -> a -> b
$ (Bool -> Int) -> Vector Bool -> Vector Int
forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
SVec.map (Int -> Int -> Int
forall a. Num a => a -> a -> a
(*) Int
255 (Int -> Int) -> (Bool -> Int) -> Bool -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum) Vector Bool
bytes
valueToBMP Value
_ = Maybe ByteString
forall a. Maybe a
Nothing

valueToBMPs :: Value -> Maybe [LBS.ByteString]
valueToBMPs :: Value -> Maybe [ByteString]
valueToBMPs = (Value -> Maybe ByteString) -> [Value] -> Maybe [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Maybe ByteString
valueToBMP ([Value] -> Maybe [ByteString])
-> (Value -> [Value]) -> Value -> Maybe [ByteString]
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 <- IO (Either IOError (ExitCode, FilePath, FilePath))
-> m (Either IOError (ExitCode, FilePath, FilePath))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError (ExitCode, FilePath, FilePath))
 -> m (Either IOError (ExitCode, FilePath, FilePath)))
-> IO (Either IOError (ExitCode, FilePath, FilePath))
-> m (Either IOError (ExitCode, FilePath, FilePath))
forall a b. (a -> b) -> a -> b
$ FilePath
-> [FilePath]
-> ByteString
-> IO (Either IOError (ExitCode, FilePath, FilePath))
runProgramWithExitCode FilePath
prog [FilePath]
options (ByteString -> IO (Either IOError (ExitCode, FilePath, FilePath)))
-> ByteString -> IO (Either IOError (ExitCode, FilePath, FilePath))
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
input
  case Either IOError (ExitCode, FilePath, FilePath)
res of
    Left IOError
err ->
      Text -> m Text
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text
prog' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOError -> Text
forall a. Show a => a -> Text
showText IOError
err
    Right (ExitCode
ExitSuccess, FilePath
stdout_t, FilePath
_) ->
      Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
stdout_t
    Right (ExitFailure Int
code', FilePath
_, FilePath
stderr_t) ->
      Text -> m Text
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$
        Text
prog'
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed with exit code "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showText Int
code'
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and stderr:\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
stderr_t
  where
    prog' :: Text
prog' = Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
prog Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"

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

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

videoBlock :: VideoParams -> FilePath -> T.Text
videoBlock :: VideoParams -> FilePath -> Text
videoBlock VideoParams
opts FilePath
f = Text
"![](" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
opts' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
  where
    opts' :: Text
opts'
      | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Text -> Bool
T.null [Text
loop, Text
autoplay] =
          Text
forall a. Monoid a => a
mempty
      | Bool
otherwise =
          Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords [Text
loop, Text
autoplay] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
    boolOpt :: a -> (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 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"=\"true\"" else a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"=\"false\""
      | Bool
otherwise =
          a
forall a. Monoid a => a
mempty
    loop :: Text
loop = Text -> (VideoParams -> Maybe Bool) -> Text
forall {a}.
(IsString a, Monoid a) =>
a -> (VideoParams -> Maybe Bool) -> a
boolOpt Text
"loop" VideoParams -> Maybe Bool
videoLoop
    autoplay :: Text
autoplay = Text -> (VideoParams -> Maybe Bool) -> Text
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') <- (CompoundValue -> Maybe (Value, Int))
-> [CompoundValue] -> Maybe ([Value], [Int])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CompoundValue -> Maybe (Value, Int)
inspect [CompoundValue]
vs
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> [Int]
forall a. Ord a => [a] -> [a]
nubOrd [Int]
ns') Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
vs'
  where
    inspect :: CompoundValue -> Maybe (Value, Int)
inspect (ValueAtom Value
v)
      | [Int
n] <- Value -> [Int]
valueShape Value
v = (Value, Int) -> Maybe (Value, Int)
forall a. a -> Maybe a
Just (Value
v, Int
n)
    inspect CompoundValue
_ = Maybe (Value, Int)
forall a. Maybe a
Nothing
plottable CompoundValue
_ = Maybe [Value]
forall a. Maybe a
Nothing

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

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

loadImage :: FilePath -> ScriptM (Compound Value)
loadImage :: FilePath -> ScriptM CompoundValue
loadImage FilePath
imgfile =
  (FilePath -> ScriptM CompoundValue) -> ScriptM CompoundValue
forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir ((FilePath -> ScriptM CompoundValue) -> ScriptM CompoundValue)
-> (FilePath -> ScriptM CompoundValue) -> ScriptM CompoundValue
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"
    ScriptM Text -> ScriptM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ScriptM ()) -> ScriptM Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Text -> ScriptM Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"convert" [FilePath
imgfile, FilePath
"-type", FilePath
"TrueColorAlpha", FilePath
bmpfile] Text
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 <- IO ByteString -> ScriptM ByteString
forall a. IO a -> ScriptM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ScriptM ByteString)
-> IO ByteString -> ScriptM ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
LBS.readFile FilePath
pcmfile
  let v :: Vector Double
v = ByteString -> Vector Double
forall a. Storable a => ByteString -> Vector a
SVec.byteStringToVector (ByteString -> Vector Double) -> ByteString -> Vector Double
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
contents
      channel_length :: Int
channel_length = Vector Double -> Int
forall a. Storable a => Vector a -> Int
SVec.length Vector Double
v Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
num_channels
      shape :: Vector Int
shape =
        [Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList
          [ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num_channels,
            Int -> Int
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 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
channel_length) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
num_channels Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
channel_length
      perm :: Vector Int
perm = Int -> (Int -> Int) -> Vector Int
forall a. Storable a => Int -> (Int -> a) -> Vector a
SVec.generate (Vector Double -> Int
forall a. Storable a => Vector a -> Int
SVec.length Vector Double
v) Int -> Int
backPermuter
  CompoundValue -> ScriptM CompoundValue
forall a. a -> ScriptM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompoundValue -> ScriptM CompoundValue)
-> CompoundValue -> ScriptM CompoundValue
forall a b. (a -> b) -> a -> b
$ Value -> CompoundValue
forall v. v -> Compound v
ValueAtom (Value -> CompoundValue) -> Value -> CompoundValue
forall a b. (a -> b) -> a -> b
$ Vector Int -> Vector Double -> Value
F64Value Vector Int
shape (Vector Double -> Value) -> Vector Double -> Value
forall a b. (a -> b) -> a -> b
$ Vector Double -> Vector Int -> Vector Double
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 <- FilePath -> [FilePath] -> Text -> ScriptM Text
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"] Text
forall a. Monoid a => a
mempty
  case Reader Int
forall a. Integral a => Reader a
T.decimal Text
s of
    Right (Int
num_channels, Text
_) -> do
      (FilePath -> ScriptM CompoundValue) -> ScriptM CompoundValue
forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir ((FilePath -> ScriptM CompoundValue) -> ScriptM CompoundValue)
-> (FilePath -> ScriptM CompoundValue) -> ScriptM CompoundValue
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"
        ScriptM Text -> ScriptM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ScriptM ()) -> ScriptM Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Text -> ScriptM Text
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] Text
forall a. Monoid a => a
mempty
        Int -> FilePath -> ScriptM CompoundValue
loadPCM Int
num_channels FilePath
pcmfile
    Either FilePath (Int, Text)
_ -> Text -> ScriptM CompoundValue
forall a. Text -> ScriptM a
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 <- Value -> Maybe [Word8]
forall t. GetValue t => Value -> Maybe t
getValue Value
v -> do
          let path' :: FilePath
path' = (Word8 -> Char) -> [Word8] -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8]
path :: [Word8])
          FilePath -> ScriptM CompoundValue
loadImage FilePath
path'
    [CompoundValue]
_ ->
      Text -> ScriptM CompoundValue
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM CompoundValue) -> Text -> ScriptM CompoundValue
forall a b. (a -> b) -> a -> b
$
        Text
"$loadimg does not accept arguments of types: "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((CompoundValue -> Text) -> [CompoundValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Compound ValueType -> Text
forall a. Pretty a => a -> Text
prettyText (Compound ValueType -> Text)
-> (CompoundValue -> Compound ValueType) -> CompoundValue -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> ValueType) -> CompoundValue -> Compound ValueType
forall a b. (a -> b) -> Compound a -> Compound b
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 <- Value -> Maybe [Word8]
forall t. GetValue t => Value -> Maybe t
getValue Value
v -> do
          let path' :: FilePath
path' = (Word8 -> Char) -> [Word8] -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8]
path :: [Word8])
          FilePath -> ScriptM CompoundValue
loadAudio FilePath
path'
    [CompoundValue]
_ ->
      Text -> ScriptM CompoundValue
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM CompoundValue) -> Text -> ScriptM CompoundValue
forall a b. (a -> b) -> a -> b
$
        Text
"$loadaudio does not accept arguments of types: "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((CompoundValue -> Text) -> [CompoundValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Compound ValueType -> Text
forall a. Pretty a => a -> Text
prettyText (Compound ValueType -> Text)
-> (CompoundValue -> Compound ValueType) -> CompoundValue -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> ValueType) -> CompoundValue -> Compound ValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType) [CompoundValue]
vs)
literateBuiltin Text
f [CompoundValue]
vs =
  FilePath -> EvalBuiltin ScriptM
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> EvalBuiltin m
scriptBuiltin FilePath
"." Text
f [CompoundValue]
vs

-- | Some of these only make sense for @futhark literate@, but enough
-- are also sensible for @futhark script@ that we can share them.
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 = Maybe FilePath
forall a. Maybe a
Nothing,
      scriptExtraOptions :: [FilePath]
scriptExtraOptions = [],
      scriptCompilerOptions :: [FilePath]
scriptCompilerOptions = [],
      scriptSkipCompilation :: Bool
scriptSkipCompilation = Bool
False,
      scriptOutput :: Maybe FilePath
scriptOutput = Maybe FilePath
forall a. Maybe a
Nothing,
      scriptVerbose :: Int
scriptVerbose = Int
0,
      scriptStopOnError :: Bool
scriptStopOnError = Bool
False
    }

data Env = Env
  { Env -> FilePath
envImgDir :: FilePath,
    Env -> Options
envOpts :: Options,
    Env -> ScriptServer
envServer :: ScriptServer,
    Env -> Text
envHash :: T.Text
  }

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

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 =
  IO Text -> ScriptM Text
forall a. IO a -> ScriptM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ScriptM Text)
-> (FilePath -> IO Text) -> FilePath -> ScriptM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Text
T.readFile (FilePath -> ScriptM Text) -> ScriptM FilePath -> ScriptM Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM FilePath
newFile 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 (Maybe FilePath
forall a. Maybe a
Nothing, FilePath
"eval.txt") ((FilePath -> ScriptM ()) -> ScriptM Text)
-> (FilePath -> ScriptM ()) -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ \FilePath
resultf -> do
      CompoundValue
v <- (Compound ScriptValueType -> ScriptM CompoundValue)
-> (CompoundValue -> ScriptM CompoundValue)
-> Either (Compound ScriptValueType) CompoundValue
-> ScriptM CompoundValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Compound ScriptValueType -> ScriptM CompoundValue
forall {m :: * -> *} {a} {a}.
(MonadError Text m, Pretty a) =>
a -> m a
nope CompoundValue -> ScriptM CompoundValue
forall a. a -> ScriptM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Compound ScriptValueType) CompoundValue
 -> ScriptM CompoundValue)
-> ScriptM (Either (Compound ScriptValueType) CompoundValue)
-> ScriptM CompoundValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EvalBuiltin ScriptM
-> ScriptServer
-> Exp
-> ScriptM (Either (Compound ScriptValueType) CompoundValue)
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
      IO () -> ScriptM ()
forall a. IO a -> ScriptM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ScriptM ()) -> IO () -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
T.writeFile FilePath
resultf (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ CompoundValue -> Text
forall a. Pretty a => a -> Text
prettyText CompoundValue
v
  Text -> ScriptM Text
forall a. a -> ScriptM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ScriptM Text) -> Text -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text
"```", Text
result, Text
"```"]
  where
    nope :: a -> m a
nope a
t =
      Text -> m a
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ Text
"Cannot show value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Pretty a => a -> Text
prettyText a
t
--
processDirective Env
env (DirectiveImg Exp
e ImgParams
params) = do
  (FilePath -> Text) -> ScriptM FilePath -> ScriptM Text
forall a b. (a -> b) -> ScriptM a -> ScriptM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock (ScriptM FilePath -> ScriptM Text)
-> ((FilePath -> ScriptM ()) -> ScriptM FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM Text
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") ((FilePath -> ScriptM ()) -> ScriptM Text)
-> (FilePath -> ScriptM ()) -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ \FilePath
pngfile -> do
    Either (Compound ScriptValueType) CompoundValue
maybe_v <- EvalBuiltin ScriptM
-> ScriptServer
-> Exp
-> ScriptM (Either (Compound ScriptValueType) CompoundValue)
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
            (FilePath -> ScriptM ()) -> ScriptM ()
forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir ((FilePath -> ScriptM ()) -> ScriptM ())
-> (FilePath -> ScriptM ()) -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
              let bmpfile :: FilePath
bmpfile = FilePath
dir FilePath -> ShowS
</> FilePath
"img.bmp"
              IO () -> ScriptM ()
forall a. IO a -> ScriptM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ScriptM ()) -> IO () -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
bmpfile ByteString
bmp
              ScriptM Text -> ScriptM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ScriptM ()) -> ScriptM Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Text -> ScriptM Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"convert" [FilePath
bmpfile, FilePath
pngfile] Text
forall a. Monoid a => a
mempty
      Right CompoundValue
v ->
        Compound ValueType -> ScriptM ()
forall {m :: * -> *} {a} {a}.
(MonadError Text m, Pretty a) =>
a -> m a
nope (Compound ValueType -> ScriptM ())
-> Compound ValueType -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ (Value -> ValueType) -> CompoundValue -> Compound ValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType CompoundValue
v
      Left Compound ScriptValueType
t ->
        Compound ScriptValueType -> ScriptM ()
forall {m :: * -> *} {a} {a}.
(MonadError Text m, Pretty a) =>
a -> m a
nope Compound ScriptValueType
t
  where
    nope :: a -> m a
nope a
t =
      Text -> m a
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$
        Text
"Cannot create image from value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Pretty a => a -> Text
prettyText a
t
--
processDirective Env
env (DirectivePlot Exp
e Maybe (Int, Int)
size) = do
  (FilePath -> Text) -> ScriptM FilePath -> ScriptM Text
forall a b. (a -> b) -> ScriptM a -> ScriptM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock (ScriptM FilePath -> ScriptM Text)
-> ((FilePath -> ScriptM ()) -> ScriptM FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM FilePath
newFile Env
env (Maybe FilePath
forall a. Maybe a
Nothing, FilePath
"plot.png") ((FilePath -> ScriptM ()) -> ScriptM Text)
-> (FilePath -> ScriptM ()) -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ \FilePath
pngfile -> do
    Either (Compound ScriptValueType) CompoundValue
maybe_v <- EvalBuiltin ScriptM
-> ScriptServer
-> Exp
-> ScriptM (Either (Compound ScriptValueType) CompoundValue)
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 [(Maybe Text
forall a. Maybe a
Nothing, [Value]
vs)] FilePath
pngfile
      Right (ValueRecord Map Text CompoundValue
m)
        | Just Map Text [Value]
m' <- (CompoundValue -> Maybe [Value])
-> Map Text CompoundValue -> Maybe (Map Text [Value])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map Text a -> f (Map Text b)
traverse CompoundValue -> Maybe [Value]
plottable2d Map Text CompoundValue
m -> do
            [(Maybe Text, [Value])] -> FilePath -> ScriptM ()
plotWith (((Text, [Value]) -> (Maybe Text, [Value]))
-> [(Text, [Value])] -> [(Maybe Text, [Value])]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Maybe Text) -> (Text, [Value]) -> (Maybe Text, [Value])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Maybe Text
forall a. a -> Maybe a
Just) ([(Text, [Value])] -> [(Maybe Text, [Value])])
-> [(Text, [Value])] -> [(Maybe Text, [Value])]
forall a b. (a -> b) -> a -> b
$ Map Text [Value] -> [(Text, [Value])]
forall k a. Map k a -> [(k, a)]
M.toList Map Text [Value]
m') FilePath
pngfile
      Right CompoundValue
v ->
        Text -> ScriptM ()
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM ()) -> Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ Text
"Cannot plot value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ValueType -> Text
forall a. Pretty a => a -> Text
prettyText ((Value -> ValueType) -> CompoundValue -> Compound ValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType CompoundValue
v)
      Left Compound ScriptValueType
t ->
        Text -> ScriptM ()
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM ()) -> Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ Text
"Cannot plot opaque value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> Text
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
      [Value] -> Maybe [Value]
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" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
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 =
      [(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM ())
-> ScriptM ()
forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM a)
-> ScriptM a
withGnuplotData [] (((Maybe Text, [Value]) -> Int -> (Text, [Value]))
-> [(Maybe Text, [Value])] -> [Int] -> [(Text, [Value])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Text, [Value]) -> Int -> (Text, [Value])
forall {b}. (Maybe Text, b) -> Int -> (Text, b)
tag [(Maybe Text, [Value])]
xys [Int
0 ..]) (([Text] -> [Text] -> ScriptM ()) -> ScriptM ())
-> ([Text] -> [Text] -> ScriptM ()) -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ \[Text]
fs [Text]
sets -> do
        let size' :: Text
size' = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
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) -> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
w FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"," FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
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 '" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"'"
               in a
f a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
title' a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" with lines"
            cmds :: Text
cmds = Text -> [Text] -> Text
T.intercalate Text
", " ((Text -> Maybe Text -> Text) -> [Text] -> [Maybe Text] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Maybe Text -> Text
forall {a}. (IsString a, Semigroup a) => a -> Maybe a -> a
plotCmd [Text]
fs (((Maybe Text, [Value]) -> Maybe Text)
-> [(Maybe Text, [Value])] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Text, [Value]) -> Maybe Text
forall a b. (a, b) -> a
fst [(Maybe Text, [Value])]
xys))
            script :: Text
script =
              [Text] -> Text
T.unlines
                [ Text
"set terminal png size " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
size' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" enhanced",
                  Text
"set output '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
pngfile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'",
                  Text
"set key outside",
                  [Text] -> Text
T.unlines [Text]
sets,
                  Text
"plot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmds
                ]
        ScriptM Text -> ScriptM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ScriptM ()) -> ScriptM Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Text -> ScriptM Text
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
  (FilePath -> Text) -> ScriptM FilePath -> ScriptM Text
forall a b. (a -> b) -> ScriptM a -> ScriptM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock (ScriptM FilePath -> ScriptM Text)
-> ((FilePath -> ScriptM ()) -> ScriptM FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM FilePath
newFile Env
env (Maybe FilePath
forall a. Maybe a
Nothing, FilePath
"plot.png") ((FilePath -> ScriptM ()) -> ScriptM Text)
-> (FilePath -> ScriptM ()) -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ \FilePath
pngfile -> do
    Either (Compound ScriptValueType) CompoundValue
maybe_v <- EvalBuiltin ScriptM
-> ScriptServer
-> Exp
-> ScriptM (Either (Compound ScriptValueType) CompoundValue)
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' <- (CompoundValue -> Maybe [Value])
-> Map Text CompoundValue -> Maybe (Map Text [Value])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map Text a -> f (Map Text b)
traverse CompoundValue -> Maybe [Value]
plottable Map Text CompoundValue
m ->
            [(Text, [Value])] -> FilePath -> ScriptM ()
plotWith (Map Text [Value] -> [(Text, [Value])]
forall k a. Map k a -> [(k, a)]
M.toList Map Text [Value]
m') FilePath
pngfile
      Right CompoundValue
v ->
        Text -> ScriptM ()
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM ()) -> Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ Text
"Cannot plot value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ValueType -> Text
forall a. Pretty a => a -> Text
prettyText ((Value -> ValueType) -> CompoundValue -> Compound ValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> ValueType
valueType CompoundValue
v)
      Left Compound ScriptValueType
t ->
        Text -> ScriptM ()
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM ()) -> Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ Text
"Cannot plot opaque value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> Text
forall a. Pretty a => a -> Text
prettyText Compound ScriptValueType
t
  where
    plotWith :: [(Text, [Value])] -> FilePath -> ScriptM ()
plotWith [(Text, [Value])]
xys FilePath
pngfile = [(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM ())
-> ScriptM ()
forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> ScriptM a)
-> ScriptM a
withGnuplotData [] [(Text, [Value])]
xys (([Text] -> [Text] -> ScriptM ()) -> ScriptM ())
-> ([Text] -> [Text] -> ScriptM ()) -> ScriptM ()
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 '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
pngfile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'",
                [Text] -> Text
T.unlines [Text]
sets,
                Text
script
              ]
      ScriptM Text -> ScriptM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ScriptM ()) -> ScriptM Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Text -> ScriptM Text
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
  Bool -> ScriptM () -> ScriptM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
format Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"webm", Text
"gif"]) (ScriptM () -> ScriptM ()) -> ScriptM () -> ScriptM ()
forall a b. (a -> b) -> a -> b
$
    Text -> ScriptM ()
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM ()) -> Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$
      Text
"Unknown video format: " Text -> Text -> Text
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)
  (FilePath -> Text) -> ScriptM FilePath -> ScriptM Text
forall a b. (a -> b) -> ScriptM a -> ScriptM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VideoParams -> FilePath -> Text
videoBlock VideoParams
params) (ScriptM FilePath -> ScriptM Text)
-> ((FilePath -> ScriptM ()) -> ScriptM FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM Text
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 ((FilePath -> ScriptM ()) -> ScriptM Text)
-> (FilePath -> ScriptM ()) -> ScriptM Text
forall a b. (a -> b) -> a -> b
$ \FilePath
videofile -> do
    ExpValue
v <- EvalBuiltin ScriptM -> ScriptServer -> Exp -> ScriptM ExpValue
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 =
          Text -> ScriptM a
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM a) -> Text -> ScriptM a
forall a b. (a -> b) -> a -> b
$
            Text
"Cannot produce video from value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> Text
forall a. Pretty a => a -> Text
prettyText ((ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
v)
    case ExpValue
v of
      ValueAtom SValue {} -> do
        ValueAtom Value
arr <- ScriptServer -> ExpValue -> ScriptM CompoundValue
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 -> ScriptM ()
forall {a}. ScriptM a
nope
          Just [ByteString]
bmps ->
            (FilePath -> ScriptM ()) -> ScriptM ()
forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir ((FilePath -> ScriptM ()) -> ScriptM ())
-> (FilePath -> ScriptM ()) -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
              (Int -> ByteString -> ScriptM ())
-> [Int] -> [ByteString] -> ScriptM ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (FilePath -> Int -> ByteString -> ScriptM ()
forall {m :: * -> *}.
MonadIO m =>
FilePath -> Int -> ByteString -> m ()
writeBMPFile FilePath
dir) [Int
0 ..] [ByteString]
bmps
              FilePath -> FilePath -> ScriptM ()
forall {f :: * -> *}.
(MonadIO f, MonadError Text f) =>
FilePath -> FilePath -> f ()
onWebM FilePath
videofile (FilePath -> ScriptM ()) -> ScriptM FilePath -> ScriptM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> ScriptM FilePath
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') <-
              (Value -> Maybe Int64) -> CompoundValue -> Maybe (Compound Int64)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Compound a -> m (Compound b)
mapM Value -> Maybe Int64
forall t. GetValue t => Value -> Maybe t
getValue (CompoundValue -> Maybe (Compound Int64))
-> ScriptM CompoundValue -> ScriptM (Maybe (Compound Int64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptServer -> ExpValue -> ScriptM CompoundValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue (Env -> ScriptServer
envServer Env
env) ExpValue
num_frames
            (FilePath -> ScriptM ()) -> ScriptM ()
forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir ((FilePath -> ScriptM ()) -> ScriptM ())
-> (FilePath -> ScriptM ()) -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
              let num_frames_int :: Int
num_frames_int = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
num_frames' :: Int64)
              FilePath -> (Text, [ExpValue]) -> ExpValue -> Int -> ScriptM ()
renderFrames FilePath
dir (Text
stepfun', (ScriptValue ValOrVar -> ExpValue)
-> [ScriptValue ValOrVar] -> [ExpValue]
forall a b. (a -> b) -> [a] -> [b]
map ScriptValue ValOrVar -> ExpValue
forall v. v -> Compound v
ValueAtom [ScriptValue ValOrVar]
closure) ExpValue
initial Int
num_frames_int
              FilePath -> FilePath -> ScriptM ()
forall {f :: * -> *}.
(MonadIO f, MonadError Text f) =>
FilePath -> FilePath -> f ()
onWebM FilePath
videofile (FilePath -> ScriptM ()) -> ScriptM FilePath -> ScriptM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> ScriptM FilePath
forall {m :: * -> *}.
(MonadIO m, MonadError Text m) =>
FilePath -> m FilePath
bmpsToVideo FilePath
dir
      ExpValue
_ ->
        ScriptM ()
forall {a}. ScriptM a
nope
  where
    framerate :: Int
framerate = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
30 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ VideoParams -> Maybe Int
videoFPS VideoParams
params
    format :: Text
format = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"webm" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ VideoParams -> Maybe Text
videoFormat VideoParams
params
    bmpfile :: FilePath -> Int -> FilePath
bmpfile FilePath
dir Int
j = FilePath
dir FilePath -> ShowS
</> FilePath -> Int -> FilePath
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) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 =
          ( \Int
j Int
num_frames -> IO () -> ScriptM ()
forall a. IO a -> ScriptM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ScriptM ()) -> IO () -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ do
              Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
                Text
"\r"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ProgressBar -> Text
progressBar
                    (Int -> Double -> Double -> ProgressBar
ProgressBar Int
40 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num_frames Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j))
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"generating frame "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Pretty a => a -> Text
prettyText (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Pretty a => a -> Text
prettyText Int
num_frames
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
              Handle -> IO ()
hFlush Handle
stdout,
            IO () -> ScriptM ()
forall a. IO a -> ScriptM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ScriptM ()) -> IO () -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
""
          )
      | Bool
otherwise =
          (\Int
_ Int
_ -> () -> ScriptM ()
forall a. a -> ScriptM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), () -> ScriptM ()
forall a. a -> ScriptM a
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
      (ExpValue -> Int -> ScriptM ExpValue)
-> ExpValue -> [Int] -> ScriptM ()
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 Int -> Int -> Int
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 <-
            EvalBuiltin ScriptM -> ScriptServer -> Exp -> ScriptM ExpValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
EvalBuiltin m -> ScriptServer -> Exp -> m ExpValue
evalExp EvalBuiltin ScriptM
literateBuiltin (Env -> ScriptServer
envServer Env
env)
              (Exp -> ScriptM ExpValue)
-> ([ExpValue] -> Exp) -> [ExpValue] -> ScriptM ExpValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Func -> [Exp] -> Exp
Call (Text -> Func
FuncFut Text
stepfun)
              ([Exp] -> Exp) -> ([ExpValue] -> [Exp]) -> [ExpValue] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExpValue -> Exp) -> [ExpValue] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map ExpValue -> Exp
valueToExp
              ([ExpValue] -> ScriptM ExpValue) -> [ExpValue] -> ScriptM ExpValue
forall a b. (a -> b) -> a -> b
$ [ExpValue]
closure [ExpValue] -> [ExpValue] -> [ExpValue]
forall a. [a] -> [a] -> [a]
++ [ExpValue
old_state]
          ScriptServer -> ExpValue -> ScriptM ()
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m ()
freeValue (Env -> ScriptServer
envServer Env
env) ExpValue
old_state

          let nope :: ScriptM a
nope =
                Text -> ScriptM a
forall a. Text -> ScriptM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ScriptM a) -> Text -> ScriptM a
forall a b. (a -> b) -> a -> b
$
                  Text
"Cannot handle step function return type: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Compound ScriptValueType -> Text
forall a. Pretty a => a -> Text
prettyText ((ScriptValue ValOrVar -> ScriptValueType)
-> ExpValue -> Compound ScriptValueType
forall a b. (a -> b) -> Compound a -> Compound b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptValue ValOrVar -> ScriptValueType
forall v. ScriptValue v -> ScriptValueType
scriptValueType ExpValue
v)

          case ExpValue
v of
            ValueTuple [arr_v :: ExpValue
arr_v@(ValueAtom SValue {}), ExpValue
new_state] -> do
              ValueAtom Value
arr <- ScriptServer -> ExpValue -> ScriptM CompoundValue
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
ScriptServer -> ExpValue -> m CompoundValue
getExpValue (Env -> ScriptServer
envServer Env
env) ExpValue
arr_v
              ScriptServer -> ExpValue -> ScriptM ()
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 -> ScriptM ExpValue
forall {a}. ScriptM a
nope
                Just ByteString
bmp -> do
                  FilePath -> Int -> ByteString -> ScriptM ()
forall {m :: * -> *}.
MonadIO m =>
FilePath -> Int -> ByteString -> m ()
writeBMPFile FilePath
dir Int
j ByteString
bmp
                  ExpValue -> ScriptM ExpValue
forall a. a -> ScriptM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpValue
new_state
            ExpValue
_ -> ScriptM ExpValue
forall {a}. ScriptM a
nope

    writeBMPFile :: FilePath -> Int -> ByteString -> m ()
writeBMPFile FilePath
dir Int
j ByteString
bmp =
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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
      m Text -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Text -> m ()) -> m Text -> m ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> [FilePath] -> Text -> m Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system
          FilePath
"ffmpeg"
          [ FilePath
"-y",
            FilePath
"-r",
            Int -> FilePath
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"
          ]
          Text
forall a. Monoid a => a
mempty
      FilePath -> m FilePath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> m FilePath) -> FilePath -> m FilePath
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"gif" =
          f Text -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f Text -> f ()) -> f Text -> f ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Text -> f Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"ffmpeg" [FilePath
"-i", FilePath
webmfile, FilePath
videofile] Text
forall a. Monoid a => a
mempty
      | Bool
otherwise =
          IO () -> f ()
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
copyFile FilePath
webmfile FilePath
videofile

--
processDirective Env
env (DirectiveAudio Exp
e AudioParams
params) = do
  (FilePath -> Text) -> ScriptM FilePath -> ScriptM Text
forall a b. (a -> b) -> ScriptM a -> ScriptM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock (ScriptM FilePath -> ScriptM Text)
-> ((FilePath -> ScriptM ()) -> ScriptM FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> ScriptM ())
-> ScriptM FilePath
newFile Env
env (Maybe FilePath
forall a. Maybe a
Nothing, FilePath
"output." FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
output_format) ((FilePath -> ScriptM ()) -> ScriptM Text)
-> (FilePath -> ScriptM ()) -> ScriptM Text
forall a b. (a -> b) -> a -> b
$
    \FilePath
audiofile -> do
      (FilePath -> ScriptM ()) -> ScriptM ()
forall a. (FilePath -> ScriptM a) -> ScriptM a
withTempDir ((FilePath -> ScriptM ()) -> ScriptM ())
-> (FilePath -> ScriptM ()) -> ScriptM ()
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
        Either (Compound ScriptValueType) CompoundValue
maybe_v <- EvalBuiltin ScriptM
-> ScriptServer
-> Exp
-> ScriptM (Either (Compound ScriptValueType) CompoundValue)
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 <- FilePath
-> Either (Compound ScriptValueType) CompoundValue
-> ScriptM (FilePath, [FilePath])
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
            ScriptM Text -> ScriptM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ScriptM Text -> ScriptM ()) -> ScriptM Text -> ScriptM ()
forall a b. (a -> b) -> a -> b
$
              FilePath -> [FilePath] -> Text -> ScriptM Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system
                FilePath
"ffmpeg"
                ( (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                    ( \FilePath
raw_file ->
                        [ FilePath
"-f",
                          FilePath
input_format,
                          FilePath
"-ar",
                          Int -> FilePath
forall a. Show a => a -> FilePath
show Int
sampling_frequency,
                          FilePath
"-i",
                          FilePath
raw_file
                        ]
                    )
                    [FilePath]
raw_files
                    [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [ FilePath
"-f",
                         Text -> FilePath
T.unpack Text
output_format,
                         FilePath
"-filter_complex",
                         (Int -> FilePath) -> [Int] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                           (\Int
i -> FilePath
"[" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
":a]")
                           [Int
0 .. [FilePath] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
raw_files Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                           FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"amerge=inputs="
                           FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show ([FilePath] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
raw_files)
                           FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"[a]",
                         FilePath
"-map",
                         FilePath
"[a]",
                         FilePath
audiofile
                       ]
                )
                Text
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
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
rawfile (ByteString -> IO ()) -> ByteString -> IO ()
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))
      | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Value -> [Int]
valueShape Value
v) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1,
        Just a
input_format <- Value -> Maybe a
forall {a}. IsString a => Value -> Maybe a
toFfmpegFormat Value
v = do
          FilePath -> FilePath -> Value -> m ()
forall {m :: * -> *}.
MonadIO m =>
FilePath -> FilePath -> Value -> m ()
writeRaw FilePath
dir FilePath
"raw.pcm" Value
v
          (a, [FilePath]) -> m (a, [FilePath])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
input_format, [FilePath
dir FilePath -> ShowS
</> FilePath
"raw.pcm"])
      | [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Value -> [Int]
valueShape Value
v) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2,
        Just a
input_format <- Value -> Maybe a
forall {a}. IsString a => Value -> Maybe a
toFfmpegFormat Value
v = do
          (a
input_format,)
            ([FilePath] -> (a, [FilePath]))
-> m [FilePath] -> m (a, [FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Int -> m FilePath) -> [Value] -> [Int] -> m [FilePath]
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-" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
".pcm"
                  FilePath -> FilePath -> Value -> m ()
forall {m :: * -> *}.
MonadIO m =>
FilePath -> FilePath -> Value -> m ()
writeRaw FilePath
dir FilePath
file_name Value
v'
                  FilePath -> m FilePath
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> m FilePath) -> FilePath -> m FilePath
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 = Either a (Compound ValueType) -> m (a, [FilePath])
forall {e} {m :: * -> *} {p} {a}.
(MonadError e m, IsString e) =>
p -> m a
nope (Either a (Compound ValueType) -> m (a, [FilePath]))
-> Either a (Compound ValueType) -> m (a, [FilePath])
forall a b. (a -> b) -> a -> b
$ (CompoundValue -> Compound ValueType)
-> Either a CompoundValue -> Either a (Compound ValueType)
forall a b. (a -> b) -> Either a a -> Either a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> ValueType) -> CompoundValue -> Compound ValueType
forall a b. (a -> b) -> Compound a -> Compound b
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 {} = a -> Maybe a
forall a. a -> Maybe a
Just a
"s8"
    toFfmpegFormat U8Value {} = a -> Maybe a
forall a. a -> Maybe a
Just a
"u8"
    toFfmpegFormat I16Value {} = a -> Maybe a
forall a. a -> Maybe a
Just a
"s16le"
    toFfmpegFormat U16Value {} = a -> Maybe a
forall a. a -> Maybe a
Just a
"u16le"
    toFfmpegFormat I32Value {} = a -> Maybe a
forall a. a -> Maybe a
Just a
"s32le"
    toFfmpegFormat U32Value {} = a -> Maybe a
forall a. a -> Maybe a
Just a
"u32le"
    toFfmpegFormat F32Value {} = a -> Maybe a
forall a. a -> Maybe a
Just a
"f32le"
    toFfmpegFormat F64Value {} = a -> Maybe a
forall a. a -> Maybe a
Just a
"f64le"
    toFfmpegFormat Value
_ = Maybe a
forall a. Maybe a
Nothing

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

    output_format :: Text
output_format = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"wav" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ AudioParams -> Maybe Text
audioCodec AudioParams
params
    sampling_frequency :: Int
sampling_frequency = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
44100 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ AudioParams -> Maybe Int
audioSamplingFrequency AudioParams
params
    nope :: p -> m a
nope p
_ = e -> m a
forall a. e -> m a
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
(Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool) -> Eq Failure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Failure -> Failure -> Bool
== :: Failure -> Failure -> Bool
$c/= :: Failure -> Failure -> Bool
/= :: Failure -> Failure -> Bool
Eq, Eq Failure
Eq Failure
-> (Failure -> Failure -> Ordering)
-> (Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool)
-> (Failure -> Failure -> Failure)
-> (Failure -> Failure -> Failure)
-> Ord Failure
Failure -> Failure -> Bool
Failure -> Failure -> Ordering
Failure -> Failure -> Failure
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Failure -> Failure -> Ordering
compare :: Failure -> Failure -> Ordering
$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
>= :: Failure -> Failure -> Bool
$cmax :: Failure -> Failure -> Failure
max :: Failure -> Failure -> Failure
$cmin :: Failure -> Failure -> Failure
min :: Failure -> Failure -> Failure
Ord, Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> FilePath
(Int -> Failure -> ShowS)
-> (Failure -> FilePath) -> ([Failure] -> ShowS) -> Show Failure
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Failure -> ShowS
showsPrec :: Int -> Failure -> ShowS
$cshow :: Failure -> FilePath
show :: Failure -> FilePath
$cshowList :: [Failure] -> ShowS
showList :: [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 = (Failure, Text, Files) -> IO (Failure, Text, Files)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
forall a. Monoid a => a
mempty, Files
forall a. Monoid a => a
mempty)
  | Bool
otherwise = (Failure, Text, Files) -> IO (Failure, Text, Files)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
"```futhark\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
code Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"```\n", Files
forall a. Monoid a => a
mempty)
processBlock Env
_ (BlockComment Text
pretty) =
  (Failure, Text, Files) -> IO (Failure, Text, Files)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
pretty, Files
forall a. Monoid a => a
mempty)
processBlock Env
env (BlockDirective Directive
directive Text
text) = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose (Env -> Options
envOpts Env
env) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> (Doc Any -> Text) -> Doc Any -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> Text
forall a. Doc a -> Text
PP.docText (Doc Any -> IO ()) -> Doc Any -> IO ()
forall a b. (a -> b) -> a -> b
$
      Doc Any
"Processing " Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann
PP.align (Directive -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Directive -> Doc ann
PP.pretty Directive
directive) Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
"..."
  let prompt :: Text
prompt = case Directive
directive of
        DirectiveCovert Directive
_ -> Text
forall a. Monoid a => a
mempty
        DirectiveBrief Directive
_ ->
          Text
"```\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc Any -> Text
forall a. Doc a -> Text
PP.docText (Bool -> Directive -> Doc Any
forall a. Bool -> Directive -> Doc a
pprDirective Bool
False Directive
directive) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n```\n"
        Directive
_ ->
          Text
"```\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> 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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Directive -> Text
forall a. Pretty a => a -> Text
prettyText Directive
directive)}
  (Either Text Text
r, Files
files) <- ScriptM Text -> IO (Either Text Text, Files)
forall a. ScriptM a -> IO (Either Text a, Files)
runScriptM (ScriptM Text -> IO (Either Text Text, Files))
-> ScriptM Text -> IO (Either Text Text, Files)
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 -> Text -> Text -> Files -> IO (Failure, Text, Files)
forall {c}. Text -> Text -> c -> IO (Failure, Text, c)
failed Text
prompt Text
err Files
files
    Right Text
t -> (Failure, Text, Files) -> IO (Failure, Text, Files)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Failure
Success, Text
prompt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
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 = Directive -> Text
forall a. Pretty a => a -> Text
prettyTextOneLine Directive
directive Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStr Handle
stderr Text
message
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Bool
scriptStopOnError (Env -> Options
envOpts Env
env)) IO ()
forall a. IO a
exitFailure
      (Failure, Text, c) -> IO (Failure, Text, c)
forall a. a -> IO a
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 =
  (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
toRemove ([FilePath] -> IO ())
-> ([FilePath] -> [FilePath]) -> [FilePath] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Files -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Files
keep_files))
    ([FilePath] -> IO ()) -> IO [FilePath] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FilePath -> IO [FilePath]
directoryContents (Env -> FilePath
envImgDir Env
env) IO [FilePath] -> (IOError -> IO [FilePath]) -> IO [FilePath]
forall a. IO a -> (IOError -> IO a) -> IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` IOError -> IO [FilePath]
forall {f :: * -> *} {a}. MonadError IOError f => IOError -> f [a]
onError)
  where
    onError :: IOError -> f [a]
onError IOError
e
      | IOError -> Bool
isDoesNotExistError IOError
e = [a] -> f [a]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Bool
otherwise = IOError -> f [a]
forall a. IOError -> f a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError IOError
e
    toRemove :: FilePath -> IO ()
toRemove FilePath
f = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose (Env -> Options
envOpts Env
env) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text
"Deleting unused file: " Text -> Text -> Text
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) <-
    [(Failure, Text, Files)] -> ([Failure], [Text], [Files])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Failure, Text, Files)] -> ([Failure], [Text], [Files]))
-> IO [(Failure, Text, Files)] -> IO ([Failure], [Text], [Files])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> IO (Failure, Text, Files))
-> [Block] -> IO [(Failure, Text, Files)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Env -> Block -> IO (Failure, Text, Files)
processBlock Env
env) [Block]
script
  Env -> Files -> IO ()
cleanupImgDir Env
env (Files -> IO ()) -> Files -> IO ()
forall a b. (a -> b) -> a -> b
$ [Files] -> Files
forall a. Monoid a => [a] -> a
mconcat [Files]
files
  (Failure, Text) -> IO (Failure, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Failure -> Failure -> Failure) -> Failure -> [Failure] -> Failure
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Failure -> Failure -> Failure
forall a. Ord a => a -> a -> a
min Failure
Success [Failure]
failures, Text -> [Text] -> Text
T.intercalate Text
"\n" [Text]
outputs)

scriptCommandLineOptions :: [FunOptDescr Options]
scriptCommandLineOptions :: [FunOptDescr Options]
scriptCommandLineOptions =
  [ FilePath
-> [FilePath]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> FilePath
-> FunOptDescr Options
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      []
      [FilePath
"backend"]
      ( (FilePath -> Either (IO ()) (Options -> Options))
-> FilePath -> ArgDescr (Either (IO ()) (Options -> Options))
forall a. (FilePath -> a) -> FilePath -> ArgDescr a
ReqArg
          (\FilePath
backend -> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptBackend :: FilePath
scriptBackend = FilePath
backend})
          FilePath
"PROGRAM"
      )
      FilePath
"The compiler used (defaults to 'c').",
    FilePath
-> [FilePath]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> FilePath
-> FunOptDescr Options
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      []
      [FilePath
"futhark"]
      ( (FilePath -> Either (IO ()) (Options -> Options))
-> FilePath -> ArgDescr (Either (IO ()) (Options -> Options))
forall a. (FilePath -> a) -> FilePath -> ArgDescr a
ReqArg
          (\FilePath
prog -> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptFuthark :: Maybe FilePath
scriptFuthark = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
prog})
          FilePath
"PROGRAM"
      )
      FilePath
"The binary used for operations (defaults to same binary as 'futhark script').",
    FilePath
-> [FilePath]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> FilePath
-> FunOptDescr Options
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      FilePath
"p"
      [FilePath
"pass-option"]
      ( (FilePath -> Either (IO ()) (Options -> Options))
-> FilePath -> ArgDescr (Either (IO ()) (Options -> Options))
forall a. (FilePath -> a) -> FilePath -> ArgDescr a
ReqArg
          ( \FilePath
opt ->
              (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config ->
                Options
config {scriptExtraOptions :: [FilePath]
scriptExtraOptions = FilePath
opt FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Options -> [FilePath]
scriptExtraOptions Options
config}
          )
          FilePath
"OPT"
      )
      FilePath
"Pass this option to programs being run.",
    FilePath
-> [FilePath]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> FilePath
-> FunOptDescr Options
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      []
      [FilePath
"pass-compiler-option"]
      ( (FilePath -> Either (IO ()) (Options -> Options))
-> FilePath -> ArgDescr (Either (IO ()) (Options -> Options))
forall a. (FilePath -> a) -> FilePath -> ArgDescr a
ReqArg
          ( \FilePath
opt ->
              (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config ->
                Options
config {scriptCompilerOptions :: [FilePath]
scriptCompilerOptions = FilePath
opt FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Options -> [FilePath]
scriptCompilerOptions Options
config}
          )
          FilePath
"OPT"
      )
      FilePath
"Pass this option to the compiler.",
    FilePath
-> [FilePath]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> FilePath
-> FunOptDescr Options
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      []
      [FilePath
"skip-compilation"]
      (Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (Options -> Options)
 -> ArgDescr (Either (IO ()) (Options -> Options)))
-> Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a b. (a -> b) -> a -> b
$ (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptSkipCompilation :: Bool
scriptSkipCompilation = Bool
True})
      FilePath
"Use already compiled program.",
    FilePath
-> [FilePath]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> FilePath
-> FunOptDescr Options
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
      FilePath
"v"
      [FilePath
"verbose"]
      (Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (Options -> Options)
 -> ArgDescr (Either (IO ()) (Options -> Options)))
-> Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a b. (a -> b) -> a -> b
$ (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptVerbose :: Int
scriptVerbose = Options -> Int
scriptVerbose Options
config Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1})
      FilePath
"Enable logging. Pass multiple times for more."
  ]

commandLineOptions :: [FunOptDescr Options]
commandLineOptions :: [FunOptDescr Options]
commandLineOptions =
  [FunOptDescr Options]
scriptCommandLineOptions
    [FunOptDescr Options]
-> [FunOptDescr Options] -> [FunOptDescr Options]
forall a. Semigroup a => a -> a -> a
<> [ FilePath
-> [FilePath]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> FilePath
-> FunOptDescr Options
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
           FilePath
"o"
           [FilePath
"output"]
           ((FilePath -> Either (IO ()) (Options -> Options))
-> FilePath -> ArgDescr (Either (IO ()) (Options -> Options))
forall a. (FilePath -> a) -> FilePath -> ArgDescr a
ReqArg (\FilePath
opt -> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptOutput :: Maybe FilePath
scriptOutput = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
opt}) FilePath
"FILE")
           FilePath
"Override output file. Image directory is set to basename appended with -img/.",
         FilePath
-> [FilePath]
-> ArgDescr (Either (IO ()) (Options -> Options))
-> FilePath
-> FunOptDescr Options
forall a.
FilePath -> [FilePath] -> ArgDescr a -> FilePath -> OptDescr a
Option
           []
           [FilePath
"stop-on-error"]
           (Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (Options -> Options)
 -> ArgDescr (Either (IO ()) (Options -> Options)))
-> Either (IO ()) (Options -> Options)
-> ArgDescr (Either (IO ()) (Options -> Options))
forall a b. (a -> b) -> a -> b
$ (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. b -> Either a b
Right ((Options -> Options) -> Either (IO ()) (Options -> Options))
-> (Options -> Options) -> Either (IO ()) (Options -> Options)
forall a b. (a -> b) -> a -> b
$ \Options
config -> Options
config {scriptStopOnError :: Bool
scriptStopOnError = Bool
True})
           FilePath
"Stop and do not produce output file if any directive fails."
       ]

prepareServer :: FilePath -> Options -> (ScriptServer -> IO a) -> IO a
prepareServer :: forall a. FilePath -> Options -> (ScriptServer -> IO a) -> IO a
prepareServer FilePath
prog Options
opts ScriptServer -> IO a
f = do
  FilePath
futhark <- IO FilePath
-> (FilePath -> IO FilePath) -> Maybe FilePath -> IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO FilePath
getExecutablePath FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO FilePath) -> Maybe FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Options -> Maybe FilePath
scriptFuthark Options
opts

  let is_fut :: Bool
is_fut = ShowS
takeExtension FilePath
prog FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".fut"

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Options -> Bool
scriptSkipCompilation Options
opts Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
is_fut) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let compile_options :: [FilePath]
compile_options = FilePath
"--server" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Options -> [FilePath]
scriptCompilerOptions Options
opts
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose Options
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text
"Compiling " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
prog Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose Options
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$
          [FilePath] -> FilePath
unwords [FilePath]
compile_options

    let onError :: t Text -> IO b
onError t Text
err = do
          (Text -> IO ()) -> t Text -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr) t Text
err
          IO b
forall a. IO a
exitFailure

    IO (ByteString, ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ByteString, ByteString) -> IO ())
-> IO (ByteString, ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$
      ([Text] -> IO (ByteString, ByteString))
-> ((ByteString, ByteString) -> IO (ByteString, ByteString))
-> Either [Text] (ByteString, ByteString)
-> IO (ByteString, ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Text] -> IO (ByteString, ByteString)
forall {t :: * -> *} {b}. Foldable t => t Text -> IO b
onError (ByteString, ByteString) -> IO (ByteString, ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Text] (ByteString, ByteString)
 -> IO (ByteString, ByteString))
-> (ExceptT [Text] IO (ByteString, ByteString)
    -> IO (Either [Text] (ByteString, ByteString)))
-> ExceptT [Text] IO (ByteString, ByteString)
-> IO (ByteString, ByteString)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ExceptT [Text] IO (ByteString, ByteString)
-> IO (Either [Text] (ByteString, ByteString))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT [Text] IO (ByteString, ByteString)
 -> IO (ByteString, ByteString))
-> ExceptT [Text] IO (ByteString, ByteString)
-> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$
        [FilePath]
-> FutharkExe
-> FilePath
-> FilePath
-> ExceptT [Text] IO (ByteString, ByteString)
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 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
"startup" Text
l = Text -> IO ()
T.putStrLn Text
l
      onLine a
_ Text
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      prog' :: FilePath
prog' = if Bool
is_fut then ShowS
dropExtension FilePath
prog else FilePath
prog
      cfg :: ServerCfg
cfg =
        (FilePath -> [FilePath] -> ServerCfg
futharkServerCfg (FilePath
"." FilePath -> ShowS
</> FilePath
prog') [FilePath]
run_options)
          { cfgOnLine :: Text -> Text -> IO ()
cfgOnLine =
              if Options -> Int
scriptVerbose Options
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then Text -> Text -> IO ()
forall {a}. (Eq a, IsString a) => a -> Text -> IO ()
onLine
                else (Text -> IO ()) -> Text -> Text -> IO ()
forall a b. a -> b -> a
const ((Text -> IO ()) -> Text -> Text -> IO ())
-> (IO () -> Text -> IO ()) -> IO () -> Text -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Text -> IO ()
forall a b. a -> b -> a
const (IO () -> Text -> Text -> IO ()) -> IO () -> Text -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          }

  ServerCfg -> (ScriptServer -> IO a) -> IO a
forall a. ServerCfg -> (ScriptServer -> IO a) -> IO a
withScriptServer ServerCfg
cfg ScriptServer -> IO a
f

-- | Run @futhark literate@.
main :: String -> [String] -> IO ()
main :: FilePath -> [FilePath] -> IO ()
main = Options
-> [FunOptDescr Options]
-> FilePath
-> ([FilePath] -> Options -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> FilePath
-> ([FilePath] -> cfg -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
mainWithOptions Options
initialOptions [FunOptDescr Options]
commandLineOptions FilePath
"program" (([FilePath] -> Options -> Maybe (IO ()))
 -> FilePath -> [FilePath] -> IO ())
-> ([FilePath] -> Options -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[FilePath]
args Options
opts ->
  case [FilePath]
args of
    [FilePath
prog] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ do
      FilePath
futhark <- IO FilePath
-> (FilePath -> IO FilePath) -> Maybe FilePath -> IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO FilePath
getExecutablePath FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO FilePath) -> Maybe FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Options -> Maybe FilePath
scriptFuthark Options
opts
      let onError :: Text -> IO b
onError Text
err = do
            Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
err
            IO b
forall a. IO a
exitFailure
      Text
proghash <-
        (Text -> IO Text)
-> (Text -> IO Text) -> Either Text Text -> IO Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> IO Text
forall {b}. Text -> IO b
onError Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Text -> IO Text)
-> (ExceptT Text IO Text -> IO (Either Text Text))
-> ExceptT Text IO Text
-> IO Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ExceptT Text IO Text -> IO (Either Text Text)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO Text -> IO Text)
-> ExceptT Text IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$
          FilePath -> [FilePath] -> Text -> ExceptT Text IO Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
futhark [FilePath
"hash", FilePath
prog] Text
forall a. Monoid a => a
mempty
      [Block]
script <- FilePath -> IO [Block]
parseProgFile FilePath
prog

      FilePath
orig_dir <- IO FilePath
getCurrentDirectory
      let entryOpt :: Text -> FilePath
entryOpt Text
v = FilePath
"--entry-point=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
v
          opts' :: Options
opts' =
            Options
opts
              { scriptCompilerOptions :: [FilePath]
scriptCompilerOptions =
                  (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
entryOpt (Set Text -> [Text]
forall a. Set a -> [a]
S.toList ([Block] -> Set Text
varsInScripts [Block]
script))
                    [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> Options -> [FilePath]
scriptCompilerOptions Options
opts
              }
      FilePath -> Options -> (ScriptServer -> IO ()) -> IO ()
forall a. FilePath -> Options -> (ScriptServer -> IO a) -> IO a
prepareServer FilePath
prog Options
opts' ((ScriptServer -> IO ()) -> IO ())
-> (ScriptServer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScriptServer
server -> do
        let mdfile :: FilePath
mdfile = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath
prog FilePath -> ShowS
`replaceExtension` FilePath
"md") (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Options -> Maybe FilePath
scriptOutput Options
opts
            prog_dir :: FilePath
prog_dir = ShowS
takeDirectory FilePath
prog
            imgdir :: FilePath
imgdir = ShowS
dropExtension (ShowS
takeFileName FilePath
mdfile) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"-img"
            env :: Env
env =
              Env
                { envServer :: ScriptServer
envServer = ScriptServer
server,
                  envOpts :: Options
envOpts = Options
opts,
                  envHash :: Text
envHash = Text
proghash,
                  envImgDir :: FilePath
envImgDir = FilePath
imgdir
                }

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
scriptVerbose Options
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Executing from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
prog_dir
        FilePath -> IO ()
setCurrentDirectory FilePath
prog_dir

        (Failure
failure, Text
md) <- Env -> [Block] -> IO (Failure, Text)
processScript Env
env [Block]
script
        FilePath -> Text -> IO ()
T.writeFile (FilePath
orig_dir FilePath -> ShowS
</> FilePath
mdfile) Text
md
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Failure
failure Failure -> Failure -> Bool
forall a. Eq a => a -> a -> Bool
== Failure
Failure) IO ()
forall a. IO a
exitFailure
    [FilePath]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing