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

import Codec.BMP qualified as BMP
import Control.Monad
import Control.Monad.Except
import Control.Monad.Free.Church (F)
import Control.Monad.State hiding (State)
import Control.Monad.Trans.Maybe (MaybeT (..), hoistMaybe)
import Data.Array qualified as A
import Data.Bifunctor (first, second)
import Data.Bits
import Data.ByteString.Lazy qualified as LBS
import Data.Char
import Data.Functor (($>))
import Data.List qualified as L
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.Vector.Storable qualified as SVec
import Data.Vector.Storable.ByteString qualified as SVec
import Data.Void
import Data.Word (Word32, Word8)
import Futhark.Compiler (readProgramFilesExceptKnown)
import Futhark.Data
import Futhark.Error (prettyCompilerError)
import Futhark.Eval
  ( EvalConfig (..),
    evalConfig,
    forceValue,
    initialiseInterpreter,
    runInterpreterWith,
  )
import Futhark.FreshNames (VNameSource)
import Futhark.Server
import Futhark.Test
import Futhark.Util
  ( directoryContents,
    ensureCacheDirectory,
    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 Language.Futhark.Interpreter qualified as I
import Language.Futhark.Interpreter.FFI.ServerM qualified as FFI
import Language.Futhark.Interpreter.Values qualified as IV
import Language.Futhark.Pretty ()
import Language.Futhark.Primitive qualified as P
import Language.Futhark.Prop (UncheckedExp, typeOf)
import Language.Futhark.Semantic qualified as T
import Language.Futhark.Syntax qualified as F
import Language.Futhark.Tuple (areTupleFields)
import Language.Futhark.TypeChecker qualified as T
import System.Directory
  ( copyFile,
    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 UncheckedExp
  | DirectiveBrief Directive
  | DirectiveCovert Directive
  | DirectiveImg UncheckedExp ImgParams
  | DirectivePlot UncheckedExp (Maybe (Int, Int))
  | DirectiveGnuplot UncheckedExp T.Text
  | DirectiveVideo UncheckedExp VideoParams
  | DirectiveAudio UncheckedExp 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)

pprDirective :: Bool -> Directive -> PP.Doc a
pprDirective :: forall a. Bool -> Directive -> Doc a
pprDirective Bool
_ (DirectiveRes UncheckedExp
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 (UncheckedExp -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. UncheckedExp -> Doc ann
PP.pretty UncheckedExp
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 UncheckedExp
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 (UncheckedExp -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. UncheckedExp -> Doc ann
PP.pretty UncheckedExp
e))
    Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> if [Doc (ZonkAny 2)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc (ZonkAny 2)]
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
      x <- ImgParams -> Maybe t
f ImgParams
params
      Just $ s <> ": " <> pretty x
pprDirective Bool
True (DirectivePlot UncheckedExp
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
<> UncheckedExp -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. UncheckedExp -> Doc ann
PP.pretty UncheckedExp
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 UncheckedExp
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 (UncheckedExp -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. UncheckedExp -> Doc ann
PP.pretty UncheckedExp
e)
pprDirective Bool
True (DirectiveGnuplot UncheckedExp
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 (UncheckedExp -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. UncheckedExp -> Doc ann
PP.pretty UncheckedExp
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 UncheckedExp
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 (UncheckedExp -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. UncheckedExp -> Doc ann
PP.pretty UncheckedExp
e)
pprDirective Bool
False (DirectiveVideo UncheckedExp
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 (UncheckedExp -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. UncheckedExp -> Doc ann
PP.pretty UncheckedExp
e)
pprDirective Bool
True (DirectiveVideo UncheckedExp
e VideoParams
params) =
  (Doc a
"> :video " Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> UncheckedExp -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. UncheckedExp -> Doc ann
PP.pretty UncheckedExp
e)
    Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> if [Doc (ZonkAny 3)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc (ZonkAny 3)]
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
      x <- VideoParams -> Maybe t
f VideoParams
params
      Just $ s <> ": " <> pretty x
pprDirective Bool
_ (DirectiveAudio UncheckedExp
e AudioParams
params) =
  (Doc a
"> :audio " Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> UncheckedExp -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. UncheckedExp -> Doc ann
PP.pretty UncheckedExp
e)
    Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> if [Doc (ZonkAny 4)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc (ZonkAny 4)]
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
      x <- AudioParams -> Maybe t
f AudioParams
params
      Just $ s <> ": " <> pretty 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)

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
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)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
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 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
-> 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
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> [Text])
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseBlockComment

parseBlockCode :: Parser T.Text
parseBlockCode :: ParsecT Void Text Identity Text
parseBlockCode = [Text] -> Text
T.unlines ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
noblanks ([Text] -> Text)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity Text
line
  where
    noblanks :: [Text] -> [Text]
noblanks = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
T.null ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Text -> Bool
T.null
    line :: ParsecT Void Text Identity Text
line = Parser () -> Parser ()
forall 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 (Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace Parser ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall 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
"--")) 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
  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 f r then p else fail 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:"
      b <- ParsecT Void Text Identity FilePath
parseFilePath
      pure params {imgFile = Just 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:"
      b <- ParsecT Void Text Identity Bool
parseBool
      pure params {videoLoop = Just b}
    pFPS :: VideoParams -> Parser VideoParams
pFPS VideoParams
params = do
      Text -> Parser ()
token Text
"fps:"
      fps <- Parser Int
parseInt
      pure params {videoFPS = Just fps}
    pAutoplay :: VideoParams -> Parser VideoParams
pAutoplay VideoParams
params = do
      Text -> Parser ()
token Text
"autoplay:"
      b <- ParsecT Void Text Identity Bool
parseBool
      pure params {videoAutoplay = Just b}
    pFormat :: VideoParams -> Parser VideoParams
pFormat VideoParams
params = do
      Text -> Parser ()
token Text
"format:"
      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)
      pure params {videoFormat = Just 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:"
      hz <- Parser Int
parseInt
      pure params {audioSamplingFrequency = Just hz}
    pCodec :: AudioParams -> Parser AudioParams
pCodec AudioParams
params = do
      Text -> Parser ()
token Text
"codec:"
      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)
      pure params {audioCodec = Just s}

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

-- | A directive expression extends to the end of the enclosing comment block,
-- or to the ';' that introduces directive parameters.
parseDirectiveExp :: Parser UncheckedExp
parseDirectiveExp :: Parser UncheckedExp
parseDirectiveExp = Parser () -> Parser UncheckedExp
parseEmbeddedExp Parser ()
expText
  where
    expText :: Parser ()
expText = do
      more <- ParsecT Void Text Identity Bool
expLine
      -- A line that starts a new directive does not continue this one. The line
      -- break is consumed only if the expression does continue, as the
      -- directive parsers expect to find it.
      cont <- optional $ try $ eol *> notFollowedBy "-- >" *> lookAhead "--"
      when (more && isJust cont) expText

    -- Consume the expression text on this line (but not the line
    -- break), returning whether it may continue on the next one.
    expLine :: ParsecT Void Text Identity Bool
expLine = do
      l <- 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
lookAhead (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 (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'\n')
      case paramsIn l of
        Just Int
n -> Bool
False Bool
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Bool
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe FilePath -> Int -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> Int -> m (Tokens s)
takeP Maybe FilePath
forall a. Maybe a
Nothing Int
n
        Maybe Int
Nothing -> Bool
True Bool
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Bool
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe FilePath -> Int -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> Int -> m (Tokens s)
takeP Maybe FilePath
forall a. Maybe a
Nothing (Text -> Int
T.length Text
l)

    -- Parameters are introduced by a ';' at the end of a line.  If
    -- this line has one, how much of it belongs to the expression?
    paramsIn :: Text -> Maybe Int
paramsIn Text
l =
      case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
";" Text
l of
        (Text
before, Text
after)
          | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
before,
            (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isSpace Text
after ->
              Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
before Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        (Text, Text)
_ -> Maybe Int
forall a. Maybe a
Nothing

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
        [ 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 ()
-> (UncheckedExp -> ImgParams -> Directive)
-> ParsecT
     Void Text Identity (UncheckedExp -> ImgParams -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> UncheckedExp -> ImgParams -> Directive
DirectiveImg
            ParsecT Void Text Identity (UncheckedExp -> ImgParams -> Directive)
-> Parser UncheckedExp
-> 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 UncheckedExp
parseDirectiveExp
            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 ()
-> (UncheckedExp -> Maybe (Int, Int) -> Directive)
-> ParsecT
     Void Text Identity (UncheckedExp -> Maybe (Int, Int) -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> UncheckedExp -> Maybe (Int, Int) -> Directive
DirectivePlot
            ParsecT
  Void Text Identity (UncheckedExp -> Maybe (Int, Int) -> Directive)
-> Parser UncheckedExp
-> 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 UncheckedExp
parseDirectiveExp
            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 ()
-> (UncheckedExp -> Text -> Directive)
-> ParsecT Void Text Identity (UncheckedExp -> Text -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> UncheckedExp -> Text -> Directive
DirectiveGnuplot
            ParsecT Void Text Identity (UncheckedExp -> Text -> Directive)
-> Parser UncheckedExp
-> 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 UncheckedExp
parseDirectiveExp
            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 ()
-> (UncheckedExp -> VideoParams -> Directive)
-> ParsecT
     Void Text Identity (UncheckedExp -> VideoParams -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> UncheckedExp -> VideoParams -> Directive
DirectiveVideo
            ParsecT
  Void Text Identity (UncheckedExp -> VideoParams -> Directive)
-> Parser UncheckedExp
-> 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 UncheckedExp
parseDirectiveExp
            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 ()
-> (UncheckedExp -> AudioParams -> Directive)
-> ParsecT
     Void Text Identity (UncheckedExp -> AudioParams -> Directive)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> UncheckedExp -> AudioParams -> Directive
DirectiveAudio
            ParsecT
  Void Text Identity (UncheckedExp -> AudioParams -> Directive)
-> Parser UncheckedExp
-> 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 UncheckedExp
parseDirectiveExp
            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],
          UncheckedExp -> Directive
DirectiveRes (UncheckedExp -> Directive)
-> Parser UncheckedExp -> Parser Directive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser UncheckedExp
parseDirectiveExp 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
  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 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}

-- | The monad in which 'futhark literate' runs. Just does error propagation and
-- state management on top of IO.
newtype LiterateM a = LiterateM (ExceptT T.Text (StateT State IO) a)
  deriving
    ( (forall a b. (a -> b) -> LiterateM a -> LiterateM b)
-> (forall a b. a -> LiterateM b -> LiterateM a)
-> Functor LiterateM
forall a b. a -> LiterateM b -> LiterateM a
forall a b. (a -> b) -> LiterateM a -> LiterateM 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) -> LiterateM a -> LiterateM b
fmap :: forall a b. (a -> b) -> LiterateM a -> LiterateM b
$c<$ :: forall a b. a -> LiterateM b -> LiterateM a
<$ :: forall a b. a -> LiterateM b -> LiterateM a
Functor,
      Functor LiterateM
Functor LiterateM =>
(forall a. a -> LiterateM a)
-> (forall a b. LiterateM (a -> b) -> LiterateM a -> LiterateM b)
-> (forall a b c.
    (a -> b -> c) -> LiterateM a -> LiterateM b -> LiterateM c)
-> (forall a b. LiterateM a -> LiterateM b -> LiterateM b)
-> (forall a b. LiterateM a -> LiterateM b -> LiterateM a)
-> Applicative LiterateM
forall a. a -> LiterateM a
forall a b. LiterateM a -> LiterateM b -> LiterateM a
forall a b. LiterateM a -> LiterateM b -> LiterateM b
forall a b. LiterateM (a -> b) -> LiterateM a -> LiterateM b
forall a b c.
(a -> b -> c) -> LiterateM a -> LiterateM b -> LiterateM 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 -> LiterateM a
pure :: forall a. a -> LiterateM a
$c<*> :: forall a b. LiterateM (a -> b) -> LiterateM a -> LiterateM b
<*> :: forall a b. LiterateM (a -> b) -> LiterateM a -> LiterateM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> LiterateM a -> LiterateM b -> LiterateM c
liftA2 :: forall a b c.
(a -> b -> c) -> LiterateM a -> LiterateM b -> LiterateM c
$c*> :: forall a b. LiterateM a -> LiterateM b -> LiterateM b
*> :: forall a b. LiterateM a -> LiterateM b -> LiterateM b
$c<* :: forall a b. LiterateM a -> LiterateM b -> LiterateM a
<* :: forall a b. LiterateM a -> LiterateM b -> LiterateM a
Applicative,
      Applicative LiterateM
Applicative LiterateM =>
(forall a b. LiterateM a -> (a -> LiterateM b) -> LiterateM b)
-> (forall a b. LiterateM a -> LiterateM b -> LiterateM b)
-> (forall a. a -> LiterateM a)
-> Monad LiterateM
forall a. a -> LiterateM a
forall a b. LiterateM a -> LiterateM b -> LiterateM b
forall a b. LiterateM a -> (a -> LiterateM b) -> LiterateM 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. LiterateM a -> (a -> LiterateM b) -> LiterateM b
>>= :: forall a b. LiterateM a -> (a -> LiterateM b) -> LiterateM b
$c>> :: forall a b. LiterateM a -> LiterateM b -> LiterateM b
>> :: forall a b. LiterateM a -> LiterateM b -> LiterateM b
$creturn :: forall a. a -> LiterateM a
return :: forall a. a -> LiterateM a
Monad,
      MonadError T.Text,
      Monad LiterateM
Monad LiterateM =>
(forall a. FilePath -> LiterateM a) -> MonadFail LiterateM
forall a. FilePath -> LiterateM a
forall (m :: * -> *).
Monad m =>
(forall a. FilePath -> m a) -> MonadFail m
$cfail :: forall a. FilePath -> LiterateM a
fail :: forall a. FilePath -> LiterateM a
MonadFail,
      Monad LiterateM
Monad LiterateM =>
(forall a. IO a -> LiterateM a) -> MonadIO LiterateM
forall a. IO a -> LiterateM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> LiterateM a
liftIO :: forall a. IO a -> LiterateM a
MonadIO,
      MonadState State
    )

runLiterateM :: LiterateM a -> IO (Either T.Text a, Files)
runLiterateM :: forall a. LiterateM a -> IO (Either Text a, Files)
runLiterateM (LiterateM 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 -> LiterateM a) -> LiterateM a
withTempFile :: forall a. (FilePath -> LiterateM a) -> LiterateM a
withTempFile FilePath -> LiterateM a
f =
  LiterateM (LiterateM a) -> LiterateM a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (LiterateM (LiterateM a) -> LiterateM a)
-> ((FilePath -> Handle -> IO (LiterateM a))
    -> LiterateM (LiterateM a))
-> (FilePath -> Handle -> IO (LiterateM a))
-> LiterateM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (LiterateM a) -> LiterateM (LiterateM a)
forall a. IO a -> LiterateM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LiterateM a) -> LiterateM (LiterateM a))
-> ((FilePath -> Handle -> IO (LiterateM a)) -> IO (LiterateM a))
-> (FilePath -> Handle -> IO (LiterateM a))
-> LiterateM (LiterateM a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath
-> (FilePath -> Handle -> IO (LiterateM a)) -> IO (LiterateM a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> Handle -> m a) -> m a
withSystemTempFile FilePath
"futhark-literate" ((FilePath -> Handle -> IO (LiterateM a)) -> LiterateM a)
-> (FilePath -> Handle -> IO (LiterateM a)) -> LiterateM a
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpf Handle
tmpf_h -> do
    Handle -> IO ()
hClose Handle
tmpf_h
    (res, files) <- LiterateM a -> IO (Either Text a, Files)
forall a. LiterateM a -> IO (Either Text a, Files)
runLiterateM (FilePath -> LiterateM a
f FilePath
tmpf)
    pure $ do
      modify $ \State
s -> State
s {stateFiles = files <> stateFiles s}
      either throwError pure res

withTempDir :: (FilePath -> LiterateM a) -> LiterateM a
withTempDir :: forall a. (FilePath -> LiterateM a) -> LiterateM a
withTempDir FilePath -> LiterateM a
f =
  LiterateM (LiterateM a) -> LiterateM a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (LiterateM (LiterateM a) -> LiterateM a)
-> ((FilePath -> IO (LiterateM a)) -> LiterateM (LiterateM a))
-> (FilePath -> IO (LiterateM a))
-> LiterateM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (LiterateM a) -> LiterateM (LiterateM a)
forall a. IO a -> LiterateM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LiterateM a) -> LiterateM (LiterateM a))
-> ((FilePath -> IO (LiterateM a)) -> IO (LiterateM a))
-> (FilePath -> IO (LiterateM a))
-> LiterateM (LiterateM a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> (FilePath -> IO (LiterateM a)) -> IO (LiterateM a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"futhark-literate" ((FilePath -> IO (LiterateM a)) -> LiterateM a)
-> (FilePath -> IO (LiterateM a)) -> LiterateM a
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
    (res, files) <- LiterateM a -> IO (Either Text a, Files)
forall a. LiterateM a -> IO (Either Text a, Files)
runLiterateM (FilePath -> LiterateM a
f FilePath
dir)
    pure $ do
      modify $ \State
s -> State
s {stateFiles = files <> stateFiles s}
      either throwError pure 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
  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 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]]
L.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

-- | A tuple of one-dimensional arrays of the same length, which is what the
-- plotting directives expect.
plottable :: Env -> I.Value -> LiterateM (Maybe [Value])
plottable :: Env -> Value -> LiterateM (Maybe [Value])
plottable Env
env (IV.ValueRecord Map Name Value
fs) = MaybeT LiterateM [Value] -> LiterateM (Maybe [Value])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT LiterateM [Value] -> LiterateM (Maybe [Value]))
-> MaybeT LiterateM [Value] -> LiterateM (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ do
  vs <- Maybe [Value] -> MaybeT LiterateM [Value]
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Maybe [Value] -> MaybeT LiterateM [Value])
-> Maybe [Value] -> MaybeT LiterateM [Value]
forall a b. (a -> b) -> a -> b
$ Map Name Value -> Maybe [Value]
forall a. Map Name a -> Maybe [a]
areTupleFields Map Name Value
fs
  (vs', ns') <- mapAndUnzipM inspect vs
  guard $ length (nubOrd ns') == 1
  pure vs'
  where
    inspect :: Value -> MaybeT LiterateM (Value, Int)
inspect Value
v = do
      v' <- LiterateM (Maybe Value) -> MaybeT LiterateM Value
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (LiterateM (Maybe Value) -> MaybeT LiterateM Value)
-> LiterateM (Maybe Value) -> MaybeT LiterateM Value
forall a b. (a -> b) -> a -> b
$ Env -> Value -> LiterateM (Maybe Value)
dataValue Env
env Value
v
      case valueShape v' of
        [Int
n] -> (Value, Int) -> MaybeT LiterateM (Value, Int)
forall a. a -> MaybeT LiterateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
v', Int
n)
        [Int]
_ -> Maybe (Value, Int) -> MaybeT LiterateM (Value, Int)
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe Maybe (Value, Int)
forall a. Maybe a
Nothing
plottable Env
_ Value
_ = Maybe [Value] -> LiterateM (Maybe [Value])
forall a. a -> LiterateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Value]
forall a. Maybe a
Nothing

-- | As 'plottable', but for exactly two arrays, interpreted as x and y values.
plottable2d :: Env -> I.Value -> LiterateM (Maybe [Value])
plottable2d :: Env -> Value -> LiterateM (Maybe [Value])
plottable2d Env
env Value
v = do
  vs <- Env -> Value -> LiterateM (Maybe [Value])
plottable Env
env Value
v
  pure $ case vs of
    Just [Value
x, Value
y] -> [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value
x, Value
y]
    Maybe [Value]
_ -> Maybe [Value]
forall a. Maybe a
Nothing

-- | The fields of a record, as expected by the plotting directives. Note that a
-- tuple is also a record, so this must be tried only after 'plottable'.
plottableFields ::
  (I.Value -> LiterateM (Maybe [Value])) ->
  I.Value ->
  LiterateM (Maybe [(T.Text, [Value])])
plottableFields :: (Value -> LiterateM (Maybe [Value]))
-> Value -> LiterateM (Maybe [(Text, [Value])])
plottableFields Value -> LiterateM (Maybe [Value])
f (IV.ValueRecord Map Name Value
fs)
  | Maybe [Value]
Nothing <- Map Name Value -> Maybe [Value]
forall a. Map Name a -> Maybe [a]
areTupleFields Map Name Value
fs =
      MaybeT LiterateM [(Text, [Value])]
-> LiterateM (Maybe [(Text, [Value])])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT LiterateM [(Text, [Value])]
 -> LiterateM (Maybe [(Text, [Value])]))
-> MaybeT LiterateM [(Text, [Value])]
-> LiterateM (Maybe [(Text, [Value])])
forall a b. (a -> b) -> a -> b
$ ((Name, Value) -> MaybeT LiterateM (Text, [Value]))
-> [(Name, Value)] -> MaybeT LiterateM [(Text, [Value])]
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 (Name, Value) -> MaybeT LiterateM (Text, [Value])
onField ([(Name, Value)] -> MaybeT LiterateM [(Text, [Value])])
-> [(Name, Value)] -> MaybeT LiterateM [(Text, [Value])]
forall a b. (a -> b) -> a -> b
$ Map Name Value -> [(Name, Value)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name Value
fs
  where
    onField :: (Name, Value) -> MaybeT LiterateM (Text, [Value])
onField (Name
k, Value
v) = (Name -> Text
F.nameToText Name
k,) ([Value] -> (Text, [Value]))
-> MaybeT LiterateM [Value] -> MaybeT LiterateM (Text, [Value])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LiterateM (Maybe [Value]) -> MaybeT LiterateM [Value]
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Value -> LiterateM (Maybe [Value])
f Value
v)
plottableFields Value -> LiterateM (Maybe [Value])
_ Value
_ = Maybe [(Text, [Value])] -> LiterateM (Maybe [(Text, [Value])])
forall a. a -> LiterateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(Text, [Value])]
forall a. Maybe a
Nothing

withGnuplotData ::
  [(T.Text, T.Text)] ->
  [(T.Text, [Value])] ->
  ([T.Text] -> [T.Text] -> LiterateM a) ->
  LiterateM a
withGnuplotData :: forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> LiterateM a)
-> LiterateM a
withGnuplotData [(Text, Text)]
sets [] [Text] -> [Text] -> LiterateM a
cont = ([Text] -> [Text] -> LiterateM a)
-> ([Text], [Text]) -> LiterateM a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Text] -> [Text] -> LiterateM a
cont (([Text], [Text]) -> LiterateM a)
-> ([Text], [Text]) -> LiterateM 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] -> LiterateM a
cont =
  (FilePath -> LiterateM a) -> LiterateM a
forall a. (FilePath -> LiterateM a) -> LiterateM a
withTempFile ((FilePath -> LiterateM a) -> LiterateM a)
-> (FilePath -> LiterateM a) -> LiterateM a
forall a b. (a -> b) -> a -> b
$ \FilePath
fname -> do
    IO () -> LiterateM ()
forall a. IO a -> LiterateM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LiterateM ()) -> IO () -> LiterateM ()
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] -> LiterateM a)
-> LiterateM a
forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> LiterateM a)
-> LiterateM 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] -> LiterateM a
cont

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,
    -- | Entry points are not interpreted, but run on this server.
    Env -> Server
envServer :: FFI.Server,
    Env -> VNameSource
envSrc :: VNameSource,
    Env -> Env
envTypeEnv :: T.Env,
    Env -> Ctx
envCtx :: I.Ctx,
    Env -> Text
envHash :: T.Text
  }

-- | Run an interpreter action. Traces are shown when verbose, external calls
-- are dispatched to the server, and breakpoints are ignored.
runInterpreter :: Env -> F I.ExtOp a -> LiterateM a
runInterpreter :: forall a. Env -> F ExtOp a -> LiterateM a
runInterpreter Env
env =
  (InterpreterError -> LiterateM a)
-> (a -> LiterateM a) -> Either InterpreterError a -> LiterateM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> LiterateM a
forall a. Text -> LiterateM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> LiterateM a)
-> (InterpreterError -> Text) -> InterpreterError -> LiterateM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Text
forall a. Doc a -> Text
PP.docText (Doc AnsiStyle -> Text)
-> (InterpreterError -> Doc AnsiStyle) -> InterpreterError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterError -> Doc AnsiStyle
I.prettyInterpreterError) a -> LiterateM a
forall a. a -> LiterateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either InterpreterError a -> LiterateM a)
-> (F ExtOp a -> LiterateM (Either InterpreterError a))
-> F ExtOp a
-> LiterateM a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Doc AnsiStyle -> LiterateM ())
-> Maybe Server
-> Maybe FilePath
-> F ExtOp a
-> LiterateM (Either InterpreterError a)
forall (m :: * -> *) a.
MonadIO m =>
(Doc AnsiStyle -> m ())
-> Maybe Server
-> Maybe FilePath
-> F ExtOp a
-> m (Either InterpreterError a)
runInterpreterWith Doc AnsiStyle -> LiterateM ()
forall {f :: * -> *} {a}. MonadIO f => Doc a -> f ()
report (Server -> Maybe Server
forall a. a -> Maybe a
Just (Env -> Server
envServer Env
env)) Maybe FilePath
forall a. Maybe a
Nothing
  where
    report :: Doc a -> f ()
report Doc a
d =
      Bool -> f () -> f ()
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) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
        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
$
          Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Doc a -> Text
forall a. Doc a -> Text
PP.docText Doc a
d

-- | Type check and evaluate an expression, returning its type (which is useful
-- for error messages) and the value in full.
evalExp :: Env -> UncheckedExp -> LiterateM (F.StructType, I.Value)
evalExp :: Env -> UncheckedExp -> LiterateM (StructType, Value)
evalExp Env
env UncheckedExp
e = do
  fexp <- case Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], ExpBase Info VName))
T.checkExp [] (Env -> VNameSource
envSrc Env
env) (Env -> Env
envTypeEnv Env
env) UncheckedExp
e of
    (Warnings
_, Left TypeError
terr) -> Text -> LiterateM (ExpBase Info VName)
forall a. Text -> LiterateM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> LiterateM (ExpBase Info VName))
-> Text -> LiterateM (ExpBase Info VName)
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Text
forall a. Doc a -> Text
PP.docText (Doc AnsiStyle -> Text) -> Doc AnsiStyle -> Text
forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeError TypeError
terr
    (Warnings
_, Right ([], ExpBase Info VName
fexp)) -> ExpBase Info VName -> LiterateM (ExpBase Info VName)
forall a. a -> LiterateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExpBase Info VName
fexp
    (Warnings
_, Right ([TypeParam]
_, ExpBase Info VName
fexp)) ->
      Text -> LiterateM (ExpBase Info VName)
forall a. Text -> LiterateM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> LiterateM (ExpBase Info VName))
-> Text -> LiterateM (ExpBase Info VName)
forall a b. (a -> b) -> a -> b
$ Text
"Ambiguous type of expression: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StructType -> Text
forall a. Pretty a => a -> Text
prettyText (ExpBase Info VName -> StructType
typeOf ExpBase Info VName
fexp)
  (typeOf fexp,) <$> runInterpreter env (I.interpretExp (envCtx env) fexp)

-- | As 'evalExp', but also fetch any parts of the value that reside on
-- the server.
evalExpForced :: Env -> UncheckedExp -> LiterateM (F.StructType, I.Value)
evalExpForced :: Env -> UncheckedExp -> LiterateM (StructType, Value)
evalExpForced Env
env UncheckedExp
e = do
  (t, v) <- Env -> UncheckedExp -> LiterateM (StructType, Value)
evalExp Env
env UncheckedExp
e
  (t,) <$> force env v

-- | Fetch a value that resides on the server. Anything we do with a
-- value, except passing it back to the server, needs it in full.
force :: Env -> I.Value -> LiterateM I.Value
force :: Env -> Value -> LiterateM Value
force Env
env Value
v = do
  v' <- IO (Either InterpreterError Value)
-> LiterateM (Either InterpreterError Value)
forall a. IO a -> LiterateM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either InterpreterError Value)
 -> LiterateM (Either InterpreterError Value))
-> IO (Either InterpreterError Value)
-> LiterateM (Either InterpreterError Value)
forall a b. (a -> b) -> a -> b
$ Maybe Server -> Value -> IO (Either InterpreterError Value)
forceValue (Server -> Maybe Server
forall a. a -> Maybe a
Just (Env -> Server
envServer Env
env)) Value
v
  either (throwError . PP.docText . I.prettyInterpreterError) pure v'

-- | As 'evalExp', but convert the value to the flat representation expected by
-- the external programs we use. The description is used in the error message if
-- the value has no such representation.
evalExpToData :: Env -> T.Text -> UncheckedExp -> LiterateM Value
evalExpToData :: Env -> Text -> UncheckedExp -> LiterateM Value
evalExpToData Env
env Text
what UncheckedExp
e = do
  (t, v) <- Env -> UncheckedExp -> LiterateM (StructType, Value)
evalExp Env
env UncheckedExp
e
  let nope = Text
"Cannot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StructType -> Text
forall a. Pretty a => a -> Text
prettyText StructType
t
  maybe (throwError nope) pure =<< dataValue env v

-- | As 'dataValue', but for a value that is already present in full. Only
-- primitives and arrays of primitives have a flat representation, and not even
-- all of those: the element type of an empty array cannot be recovered from the
-- value alone.
localDataValue :: I.Value -> Maybe Value
localDataValue :: Value -> Maybe Value
localDataValue (IV.ValuePrim PrimValue
v) = Vector Int -> [PrimValue] -> Maybe Value
primsToValue Vector Int
forall a. Monoid a => a
mempty [PrimValue
v]
localDataValue v :: Value
v@IV.ValueArray {} =
  Vector Int -> [PrimValue] -> Maybe Value
primsToValue ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList ((Int64 -> Int) -> [Int64] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Shape Int64 -> [Int64]
forall {a}. Shape a -> [a]
dims (Value -> Shape Int64
forall (m :: * -> *). Value m -> Shape Int64
IV.valueShape Value
v))))
    ([PrimValue] -> Maybe Value) -> Maybe [PrimValue] -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> Maybe [PrimValue]
forall {m :: * -> *}. Value m -> Maybe [PrimValue]
prims Value
v
  where
    prims :: Value m -> Maybe [PrimValue]
prims (IV.ValueArray Shape Int64
_ Array Int (Value m)
arr) = [[PrimValue]] -> [PrimValue]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PrimValue]] -> [PrimValue])
-> Maybe [[PrimValue]] -> Maybe [PrimValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value m -> Maybe [PrimValue]) -> [Value m] -> Maybe [[PrimValue]]
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 m -> Maybe [PrimValue]
prims (Array Int (Value m) -> [Value m]
forall i e. Array i e -> [e]
A.elems Array Int (Value m)
arr)
    prims (IV.ValuePrim PrimValue
x) = [PrimValue] -> Maybe [PrimValue]
forall a. a -> Maybe a
Just [PrimValue
x]
    prims Value m
_ = Maybe [PrimValue]
forall a. Maybe a
Nothing
    dims :: Shape a -> [a]
dims (IV.ShapeDim a
n Shape a
shape) = a
n a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Shape a -> [a]
dims Shape a
shape
    dims Shape a
_ = []
localDataValue Value
_ = Maybe Value
forall a. Maybe a
Nothing

-- | Convert an interpreter value to the flat representation of the Futhark data
-- format, if it has one. A value that resides on the server is retrieved in its
-- entirety, which is far faster than forcing it, as that fetches an array one
-- element at a time.
dataValue :: Env -> I.Value -> LiterateM (Maybe Value)
dataValue :: Env -> Value -> LiterateM (Maybe Value)
dataValue Env
env v :: Value
v@(IV.ValueLazyFFI Shape Int64
_ ValueRef
vr []) = do
  r <- IO (Either FilePath (Maybe Value))
-> LiterateM (Either FilePath (Maybe Value))
forall a. IO a -> LiterateM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FilePath (Maybe Value))
 -> LiterateM (Either FilePath (Maybe Value)))
-> IO (Either FilePath (Maybe Value))
-> LiterateM (Either FilePath (Maybe Value))
forall a b. (a -> b) -> a -> b
$ Server
-> ServerM (Maybe Value) -> IO (Either FilePath (Maybe Value))
forall a. Server -> ServerM a -> IO (Either FilePath a)
FFI.runServerM (Env -> Server
envServer Env
env) (ServerM (Maybe Value) -> IO (Either FilePath (Maybe Value)))
-> ServerM (Maybe Value) -> IO (Either FilePath (Maybe Value))
forall a b. (a -> b) -> a -> b
$ ValueRef -> ServerM (Maybe Value)
FFI.getData ValueRef
vr
  case r of
    Right (Just Value
v') -> Maybe Value -> LiterateM (Maybe Value)
forall a. a -> LiterateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> LiterateM (Maybe Value))
-> Maybe Value -> LiterateM (Maybe Value)
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v'
    -- The value is opaque, or something went wrong; fall back to
    -- fetching it piecemeal, which may still work.
    Either FilePath (Maybe Value)
_ -> Env -> Value -> LiterateM (Maybe Value)
dataValue Env
env (Value -> LiterateM (Maybe Value))
-> LiterateM Value -> LiterateM (Maybe Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> Value -> LiterateM Value
force Env
env Value
v
dataValue Env
env v :: Value
v@IV.ValueLazyFFI {} =
  -- A partially indexed array cannot be retrieved directly.
  Env -> Value -> LiterateM (Maybe Value)
dataValue Env
env (Value -> LiterateM (Maybe Value))
-> LiterateM Value -> LiterateM (Maybe Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> Value -> LiterateM Value
force Env
env Value
v
dataValue Env
_ Value
v = Maybe Value -> LiterateM (Maybe Value)
forall a. a -> LiterateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> LiterateM (Maybe Value))
-> Maybe Value -> LiterateM (Maybe Value)
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value
localDataValue Value
v

-- | The elements must all be of the same type, which is that of the
-- first one.
primsToValue :: SVec.Vector Int -> [F.PrimValue] -> Maybe Value
primsToValue :: Vector Int -> [PrimValue] -> Maybe Value
primsToValue Vector Int
shape [PrimValue]
vs =
  case [PrimValue]
vs of
    [] -> Maybe Value
forall a. Maybe a
Nothing
    F.SignedValue (P.Int8Value Int8
_) : [PrimValue]
_ -> Vector Int -> Vector Int8 -> Value
I8Value Vector Int
shape (Vector Int8 -> Value) -> Maybe (Vector Int8) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Int8) -> Maybe (Vector Int8)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec PrimValue -> Maybe Int8
asI8
    F.SignedValue (P.Int16Value Int16
_) : [PrimValue]
_ -> Vector Int -> Vector Int16 -> Value
I16Value Vector Int
shape (Vector Int16 -> Value) -> Maybe (Vector Int16) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Int16) -> Maybe (Vector Int16)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec PrimValue -> Maybe Int16
asI16
    F.SignedValue (P.Int32Value Int32
_) : [PrimValue]
_ -> Vector Int -> Vector Int32 -> Value
I32Value Vector Int
shape (Vector Int32 -> Value) -> Maybe (Vector Int32) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Int32) -> Maybe (Vector Int32)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec PrimValue -> Maybe Int32
asI32
    F.SignedValue (P.Int64Value Int64
_) : [PrimValue]
_ -> Vector Int -> Vector Int64 -> Value
I64Value Vector Int
shape (Vector Int64 -> Value) -> Maybe (Vector Int64) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Int64) -> Maybe (Vector Int64)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec PrimValue -> Maybe Int64
asI64
    F.UnsignedValue (P.Int8Value Int8
_) : [PrimValue]
_ -> Vector Int -> Vector Word8 -> Value
U8Value Vector Int
shape (Vector Word8 -> Value) -> Maybe (Vector Word8) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Word8) -> Maybe (Vector Word8)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec ((Int8 -> Word8) -> Maybe Int8 -> Maybe Word8
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Maybe Int8 -> Maybe Word8)
-> (PrimValue -> Maybe Int8) -> PrimValue -> Maybe Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimValue -> Maybe Int8
asI8)
    F.UnsignedValue (P.Int16Value Int16
_) : [PrimValue]
_ -> Vector Int -> Vector Word16 -> Value
U16Value Vector Int
shape (Vector Word16 -> Value) -> Maybe (Vector Word16) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Word16) -> Maybe (Vector Word16)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec ((Int16 -> Word16) -> Maybe Int16 -> Maybe Word16
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Maybe Int16 -> Maybe Word16)
-> (PrimValue -> Maybe Int16) -> PrimValue -> Maybe Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimValue -> Maybe Int16
asI16)
    F.UnsignedValue (P.Int32Value Int32
_) : [PrimValue]
_ -> Vector Int -> Vector Word32 -> Value
U32Value Vector Int
shape (Vector Word32 -> Value) -> Maybe (Vector Word32) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Word32) -> Maybe (Vector Word32)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec ((Int32 -> Word32) -> Maybe Int32 -> Maybe Word32
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Maybe Int32 -> Maybe Word32)
-> (PrimValue -> Maybe Int32) -> PrimValue -> Maybe Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimValue -> Maybe Int32
asI32)
    F.UnsignedValue (P.Int64Value Int64
_) : [PrimValue]
_ -> Vector Int -> Vector Word64 -> Value
U64Value Vector Int
shape (Vector Word64 -> Value) -> Maybe (Vector Word64) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Word64) -> Maybe (Vector Word64)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec ((Int64 -> Word64) -> Maybe Int64 -> Maybe Word64
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Maybe Int64 -> Maybe Word64)
-> (PrimValue -> Maybe Int64) -> PrimValue -> Maybe Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimValue -> Maybe Int64
asI64)
    F.FloatValue (P.Float16Value Half
_) : [PrimValue]
_ -> Vector Int -> Vector Half -> Value
F16Value Vector Int
shape (Vector Half -> Value) -> Maybe (Vector Half) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Half) -> Maybe (Vector Half)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec PrimValue -> Maybe Half
asF16
    F.FloatValue (P.Float32Value Float
_) : [PrimValue]
_ -> Vector Int -> Vector Float -> Value
F32Value Vector Int
shape (Vector Float -> Value) -> Maybe (Vector Float) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Float) -> Maybe (Vector Float)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec PrimValue -> Maybe Float
asF32
    F.FloatValue (P.Float64Value Double
_) : [PrimValue]
_ -> Vector Int -> Vector Double -> Value
F64Value Vector Int
shape (Vector Double -> Value) -> Maybe (Vector Double) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Double) -> Maybe (Vector Double)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec PrimValue -> Maybe Double
asF64
    F.BoolValue Bool
_ : [PrimValue]
_ -> Vector Int -> Vector Bool -> Value
BoolValue Vector Int
shape (Vector Bool -> Value) -> Maybe (Vector Bool) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe Bool) -> Maybe (Vector Bool)
forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec PrimValue -> Maybe Bool
asBool
  where
    vec :: (SVec.Storable a) => (F.PrimValue -> Maybe a) -> Maybe (SVec.Vector a)
    vec :: forall a. Storable a => (PrimValue -> Maybe a) -> Maybe (Vector a)
vec PrimValue -> Maybe a
f = [a] -> Vector a
forall a. Storable a => [a] -> Vector a
SVec.fromList ([a] -> Vector a) -> Maybe [a] -> Maybe (Vector a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PrimValue -> Maybe a) -> [PrimValue] -> Maybe [a]
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 PrimValue -> Maybe a
f [PrimValue]
vs
    asI8 :: PrimValue -> Maybe Int8
asI8 (F.SignedValue (P.Int8Value Int8
x)) = Int8 -> Maybe Int8
forall a. a -> Maybe a
Just Int8
x
    asI8 (F.UnsignedValue (P.Int8Value Int8
x)) = Int8 -> Maybe Int8
forall a. a -> Maybe a
Just Int8
x
    asI8 PrimValue
_ = Maybe Int8
forall a. Maybe a
Nothing
    asI16 :: PrimValue -> Maybe Int16
asI16 (F.SignedValue (P.Int16Value Int16
x)) = Int16 -> Maybe Int16
forall a. a -> Maybe a
Just Int16
x
    asI16 (F.UnsignedValue (P.Int16Value Int16
x)) = Int16 -> Maybe Int16
forall a. a -> Maybe a
Just Int16
x
    asI16 PrimValue
_ = Maybe Int16
forall a. Maybe a
Nothing
    asI32 :: PrimValue -> Maybe Int32
asI32 (F.SignedValue (P.Int32Value Int32
x)) = Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
x
    asI32 (F.UnsignedValue (P.Int32Value Int32
x)) = Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
x
    asI32 PrimValue
_ = Maybe Int32
forall a. Maybe a
Nothing
    asI64 :: PrimValue -> Maybe Int64
asI64 (F.SignedValue (P.Int64Value Int64
x)) = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
x
    asI64 (F.UnsignedValue (P.Int64Value Int64
x)) = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
x
    asI64 PrimValue
_ = Maybe Int64
forall a. Maybe a
Nothing
    asF16 :: PrimValue -> Maybe Half
asF16 (F.FloatValue (P.Float16Value Half
x)) = Half -> Maybe Half
forall a. a -> Maybe a
Just Half
x
    asF16 PrimValue
_ = Maybe Half
forall a. Maybe a
Nothing
    asF32 :: PrimValue -> Maybe Float
asF32 (F.FloatValue (P.Float32Value Float
x)) = Float -> Maybe Float
forall a. a -> Maybe a
Just Float
x
    asF32 PrimValue
_ = Maybe Float
forall a. Maybe a
Nothing
    asF64 :: PrimValue -> Maybe Double
asF64 (F.FloatValue (P.Float64Value Double
x)) = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x
    asF64 PrimValue
_ = Maybe Double
forall a. Maybe a
Nothing
    asBool :: PrimValue -> Maybe Bool
asBool (F.BoolValue Bool
x) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x
    asBool PrimValue
_ = Maybe Bool
forall a. Maybe a
Nothing

newFile :: Env -> (Maybe FilePath, FilePath) -> (FilePath -> LiterateM ()) -> LiterateM FilePath
newFile :: Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM FilePath
newFile Env
env (Maybe FilePath
fname_desired, FilePath
template) FilePath -> LiterateM ()
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
  exists <- IO Bool -> LiterateM Bool
forall a. IO a -> LiterateM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> LiterateM Bool) -> IO Bool -> LiterateM Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
fname
  liftIO $ ensureCacheDirectory $ envImgDir env
  when (exists && scriptVerbose (envOpts env) > 0) $
    liftIO . T.hPutStrLn stderr $
      "Using existing file: " <> T.pack fname
  unless exists $ do
    when (scriptVerbose (envOpts env) > 0) $
      liftIO . T.hPutStrLn stderr $
        "Generating new file: " <> T.pack fname
    m fname
  modify $ \State
s -> State
s {stateFiles = S.insert fname $ stateFiles s}
  pure fname

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

processDirective :: Env -> Directive -> LiterateM T.Text
processDirective :: Env -> Directive -> LiterateM Text
processDirective Env
env (DirectiveBrief Directive
d) =
  Env -> Directive -> LiterateM Text
processDirective Env
env Directive
d
processDirective Env
env (DirectiveCovert Directive
d) =
  Env -> Directive -> LiterateM Text
processDirective Env
env Directive
d
processDirective Env
env (DirectiveRes UncheckedExp
e) = do
  result <-
    Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM Text
newFileContents Env
env (Maybe FilePath
forall a. Maybe a
Nothing, FilePath
"eval.txt") ((FilePath -> LiterateM ()) -> LiterateM Text)
-> (FilePath -> LiterateM ()) -> LiterateM Text
forall a b. (a -> b) -> a -> b
$ \FilePath
resultf -> do
      v <- (StructType, Value) -> Value
forall a b. (a, b) -> b
snd ((StructType, Value) -> Value)
-> LiterateM (StructType, Value) -> LiterateM Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> UncheckedExp -> LiterateM (StructType, Value)
evalExpForced Env
env UncheckedExp
e
      liftIO $ T.writeFile resultf $ PP.docText $ I.prettyValue v
  pure $ T.unlines ["```", result, "```"]
--
processDirective Env
env (DirectiveImg UncheckedExp
e ImgParams
params) = do
  (FilePath -> Text) -> LiterateM FilePath -> LiterateM Text
forall a b. (a -> b) -> LiterateM a -> LiterateM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock (LiterateM FilePath -> LiterateM Text)
-> ((FilePath -> LiterateM ()) -> LiterateM FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM FilePath
newFile Env
env (ImgParams -> Maybe FilePath
imgFile ImgParams
params, FilePath
"img.png") ((FilePath -> LiterateM ()) -> LiterateM Text)
-> (FilePath -> LiterateM ()) -> LiterateM Text
forall a b. (a -> b) -> a -> b
$ \FilePath
pngfile -> do
    (t, v) <- Env -> UncheckedExp -> LiterateM (StructType, Value)
evalExp Env
env UncheckedExp
e
    bmp <- (valueToBMP =<<) <$> dataValue env v
    case bmp of
      Just ByteString
bmp' ->
        (FilePath -> LiterateM ()) -> LiterateM ()
forall a. (FilePath -> LiterateM a) -> LiterateM a
withTempDir ((FilePath -> LiterateM ()) -> LiterateM ())
-> (FilePath -> LiterateM ()) -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
          let bmpfile :: FilePath
bmpfile = FilePath
dir FilePath -> ShowS
</> FilePath
"img.bmp"
          IO () -> LiterateM ()
forall a. IO a -> LiterateM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LiterateM ()) -> IO () -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
bmpfile ByteString
bmp'
          LiterateM Text -> LiterateM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LiterateM Text -> LiterateM ()) -> LiterateM Text -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Text -> LiterateM 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
      Maybe ByteString
Nothing ->
        Text -> LiterateM ()
forall a. Text -> LiterateM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> LiterateM ()) -> Text -> LiterateM ()
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
<> StructType -> Text
forall a. Pretty a => a -> Text
prettyText StructType
t
--
processDirective Env
env (DirectivePlot UncheckedExp
e Maybe (Int, Int)
size) = do
  (FilePath -> Text) -> LiterateM FilePath -> LiterateM Text
forall a b. (a -> b) -> LiterateM a -> LiterateM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock (LiterateM FilePath -> LiterateM Text)
-> ((FilePath -> LiterateM ()) -> LiterateM FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM FilePath
newFile Env
env (Maybe FilePath
forall a. Maybe a
Nothing, FilePath
"plot.png") ((FilePath -> LiterateM ()) -> LiterateM Text)
-> (FilePath -> LiterateM ()) -> LiterateM Text
forall a b. (a -> b) -> a -> b
$ \FilePath
pngfile -> do
    (t, v) <- Env -> UncheckedExp -> LiterateM (StructType, Value)
evalExp Env
env UncheckedExp
e
    one <- plottable2d env v
    fields <- plottableFields (plottable2d env) v
    case (one, fields) of
      (Just [Value]
vs, Maybe [(Text, [Value])]
_) ->
        [(Maybe Text, [Value])] -> FilePath -> LiterateM ()
plotWith [(Maybe Text
forall a. Maybe a
Nothing, [Value]
vs)] FilePath
pngfile
      (Maybe [Value]
_, Just [(Text, [Value])]
fs) ->
        [(Maybe Text, [Value])] -> FilePath -> LiterateM ()
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])]
fs) FilePath
pngfile
      (Maybe [Value], Maybe [(Text, [Value])])
_ ->
        Text -> LiterateM ()
forall a. Text -> LiterateM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> LiterateM ()) -> Text -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ Text
"Cannot plot value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StructType -> Text
forall a. Pretty a => a -> Text
prettyText StructType
t
  where
    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 -> LiterateM ()
plotWith [(Maybe Text, [Value])]
xys FilePath
pngfile =
      [(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> LiterateM ())
-> LiterateM ()
forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> LiterateM a)
-> LiterateM 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] -> LiterateM ()) -> LiterateM ())
-> ([Text] -> [Text] -> LiterateM ()) -> LiterateM ()
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
                ]
        LiterateM Text -> LiterateM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LiterateM Text -> LiterateM ()) -> LiterateM Text -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Text -> LiterateM Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"gnuplot" [] Text
script
--
processDirective Env
env (DirectiveGnuplot UncheckedExp
e Text
script) = do
  (FilePath -> Text) -> LiterateM FilePath -> LiterateM Text
forall a b. (a -> b) -> LiterateM a -> LiterateM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock (LiterateM FilePath -> LiterateM Text)
-> ((FilePath -> LiterateM ()) -> LiterateM FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM FilePath
newFile Env
env (Maybe FilePath
forall a. Maybe a
Nothing, FilePath
"plot.png") ((FilePath -> LiterateM ()) -> LiterateM Text)
-> (FilePath -> LiterateM ()) -> LiterateM Text
forall a b. (a -> b) -> a -> b
$ \FilePath
pngfile -> do
    (t, v) <- Env -> UncheckedExp -> LiterateM (StructType, Value)
evalExp Env
env UncheckedExp
e
    fields <- plottableFields (plottable env) v
    case fields of
      Just [(Text, [Value])]
fs ->
        [(Text, [Value])] -> FilePath -> LiterateM ()
plotWith [(Text, [Value])]
fs FilePath
pngfile
      Maybe [(Text, [Value])]
Nothing ->
        Text -> LiterateM ()
forall a. Text -> LiterateM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> LiterateM ()) -> Text -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ Text
"Cannot plot value of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StructType -> Text
forall a. Pretty a => a -> Text
prettyText StructType
t
  where
    plotWith :: [(Text, [Value])] -> FilePath -> LiterateM ()
plotWith [(Text, [Value])]
xys FilePath
pngfile = [(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> LiterateM ())
-> LiterateM ()
forall a.
[(Text, Text)]
-> [(Text, [Value])]
-> ([Text] -> [Text] -> LiterateM a)
-> LiterateM a
withGnuplotData [] [(Text, [Value])]
xys (([Text] -> [Text] -> LiterateM ()) -> LiterateM ())
-> ([Text] -> [Text] -> LiterateM ()) -> LiterateM ()
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
              ]
      LiterateM Text -> LiterateM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LiterateM Text -> LiterateM ()) -> LiterateM Text -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> Text -> LiterateM Text
forall (m :: * -> *).
(MonadIO m, MonadError Text m) =>
FilePath -> [FilePath] -> Text -> m Text
system FilePath
"gnuplot" [] Text
script'
--
processDirective Env
env (DirectiveVideo UncheckedExp
e VideoParams
params) = do
  Bool -> LiterateM () -> LiterateM ()
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"]) (LiterateM () -> LiterateM ()) -> LiterateM () -> LiterateM ()
forall a b. (a -> b) -> a -> b
$
    Text -> LiterateM ()
forall a. Text -> LiterateM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> LiterateM ()) -> Text -> LiterateM ()
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) -> LiterateM FilePath -> LiterateM Text
forall a b. (a -> b) -> LiterateM a -> LiterateM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VideoParams -> FilePath -> Text
videoBlock VideoParams
params) (LiterateM FilePath -> LiterateM Text)
-> ((FilePath -> LiterateM ()) -> LiterateM FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM FilePath
newFile Env
env (Maybe FilePath, FilePath)
file ((FilePath -> LiterateM ()) -> LiterateM Text)
-> (FilePath -> LiterateM ()) -> LiterateM Text
forall a b. (a -> b) -> a -> b
$ \FilePath
videofile -> do
    (t, v) <- Env -> UncheckedExp -> LiterateM (StructType, Value)
evalExp Env
env UncheckedExp
e
    let nope =
          Text -> LiterateM a
forall a. Text -> LiterateM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> LiterateM a) -> Text -> LiterateM 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
<> StructType -> Text
forall a. Pretty a => a -> Text
prettyText StructType
t
    case v of
      IV.ValueRecord Map Name Value
fs
        | Just [stepfun :: Value
stepfun@IV.ValueFun {}, Value
initial, Value
num_frames] <- Map Name Value -> Maybe [Value]
forall a. Map Name a -> Maybe [a]
areTupleFields Map Name Value
fs,
          IV.ValuePrim (F.SignedValue (P.Int64Value Int64
num_frames')) <- Value
num_frames ->
            (FilePath -> LiterateM ()) -> LiterateM ()
forall a. (FilePath -> LiterateM a) -> LiterateM a
withTempDir ((FilePath -> LiterateM ()) -> LiterateM ())
-> (FilePath -> LiterateM ()) -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
              FilePath -> Value -> Value -> Int -> LiterateM ()
renderFrames FilePath
dir Value
stepfun Value
initial (Int -> LiterateM ()) -> Int -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
num_frames'
              FilePath -> FilePath -> LiterateM ()
forall {f :: * -> *}.
(MonadIO f, MonadError Text f) =>
FilePath -> FilePath -> f ()
onWebM FilePath
videofile (FilePath -> LiterateM ()) -> LiterateM FilePath -> LiterateM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> LiterateM FilePath
forall {m :: * -> *}.
(MonadIO m, MonadError Text m) =>
FilePath -> m FilePath
bmpsToVideo FilePath
dir
      Value
_ -> do
        bmps <- (Value -> Maybe [ByteString]
valueToBMPs (Value -> Maybe [ByteString]) -> Maybe Value -> Maybe [ByteString]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe Value -> Maybe [ByteString])
-> LiterateM (Maybe Value) -> LiterateM (Maybe [ByteString])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Value -> LiterateM (Maybe Value)
dataValue Env
env Value
v
        case bmps of
          Just [ByteString]
bmps' ->
            (FilePath -> LiterateM ()) -> LiterateM ()
forall a. (FilePath -> LiterateM a) -> LiterateM a
withTempDir ((FilePath -> LiterateM ()) -> LiterateM ())
-> (FilePath -> LiterateM ()) -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
              (Int -> ByteString -> LiterateM ())
-> [Int] -> [ByteString] -> LiterateM ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (FilePath -> Int -> ByteString -> LiterateM ()
forall {m :: * -> *}.
MonadIO m =>
FilePath -> Int -> ByteString -> m ()
writeBMPFile FilePath
dir) [Int
0 ..] [ByteString]
bmps'
              FilePath -> FilePath -> LiterateM ()
forall {f :: * -> *}.
(MonadIO f, MonadError Text f) =>
FilePath -> FilePath -> f ()
onWebM FilePath
videofile (FilePath -> LiterateM ()) -> LiterateM FilePath -> LiterateM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> LiterateM FilePath
forall {m :: * -> *}.
(MonadIO m, MonadError Text m) =>
FilePath -> m FilePath
bmpsToVideo FilePath
dir
          Maybe [ByteString]
Nothing -> LiterateM ()
forall {a}. LiterateM 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 -> LiterateM ()
progressStep, LiterateM ()
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 () -> LiterateM ()
forall a. IO a -> LiterateM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LiterateM ()) -> IO () -> LiterateM ()
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 () -> LiterateM ()
forall a. IO a -> LiterateM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LiterateM ()) -> IO () -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
""
          )
      | Bool
otherwise =
          (\Int
_ Int
_ -> () -> LiterateM ()
forall a. a -> LiterateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), () -> LiterateM ()
forall a. a -> LiterateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

    -- Only the image of each frame is fetched from the server; the
    -- state is passed straight back to the step function, so all the
    -- frames need not exist at once.
    renderFrames :: FilePath -> Value -> Value -> Int -> LiterateM ()
renderFrames FilePath
dir Value
stepfun Value
initial Int
num_frames = do
      (Value -> Int -> LiterateM Value) -> Value -> [Int] -> LiterateM ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ Value -> Int -> LiterateM Value
frame Value
initial [Int
0 .. Int
num_frames Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      LiterateM ()
progressDone
      where
        frame :: Value -> Int -> LiterateM Value
frame Value
old_state Int
j = do
          Int -> Int -> LiterateM ()
progressStep Int
j Int
num_frames
          v <- Env -> F ExtOp Value -> LiterateM Value
forall a. Env -> F ExtOp a -> LiterateM a
runInterpreter Env
env (F ExtOp Value -> LiterateM Value)
-> F ExtOp Value -> LiterateM Value
forall a b. (a -> b) -> a -> b
$ Ctx -> Value -> Value -> F ExtOp Value
I.interpretApply (Env -> Ctx
envCtx Env
env) Value
stepfun Value
old_state
          case v of
            IV.ValueRecord Map Name Value
fs
              | Just [Value
arr, Value
new_state] <- Map Name Value -> Maybe [Value]
forall a. Map Name a -> Maybe [a]
areTupleFields Map Name Value
fs -> do
                  bmp <-
                    LiterateM ByteString
-> (ByteString -> LiterateM ByteString)
-> Maybe ByteString
-> LiterateM ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LiterateM ByteString
forall {a}. LiterateM a
badFrame ByteString -> LiterateM ByteString
forall a. a -> LiterateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> LiterateM ByteString)
-> (Maybe Value -> Maybe ByteString)
-> Maybe Value
-> LiterateM ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Maybe ByteString
valueToBMP (Value -> Maybe ByteString) -> Maybe Value -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe Value -> LiterateM ByteString)
-> LiterateM (Maybe Value) -> LiterateM ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> Value -> LiterateM (Maybe Value)
dataValue Env
env Value
arr
                  writeBMPFile dir j bmp
                  pure new_state
            Value
_ -> LiterateM Value
forall {a}. LiterateM a
badFrame
        badFrame :: LiterateM a
badFrame =
          Text -> LiterateM a
forall a. Text -> LiterateM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Cannot handle step function return value."

    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 UncheckedExp
e AudioParams
params) = do
  (FilePath -> Text) -> LiterateM FilePath -> LiterateM Text
forall a b. (a -> b) -> LiterateM a -> LiterateM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
imgBlock (LiterateM FilePath -> LiterateM Text)
-> ((FilePath -> LiterateM ()) -> LiterateM FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env
-> (Maybe FilePath, FilePath)
-> (FilePath -> LiterateM ())
-> LiterateM 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 -> LiterateM ()) -> LiterateM Text)
-> (FilePath -> LiterateM ()) -> LiterateM Text
forall a b. (a -> b) -> a -> b
$
    \FilePath
audiofile -> do
      (FilePath -> LiterateM ()) -> LiterateM ()
forall a. (FilePath -> LiterateM a) -> LiterateM a
withTempDir ((FilePath -> LiterateM ()) -> LiterateM ())
-> (FilePath -> LiterateM ()) -> LiterateM ()
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
        v <- Env -> Text -> UncheckedExp -> LiterateM Value
evalExpToData Env
env Text
"create audio from" UncheckedExp
e
        maybe_raw_files <- toRawFiles dir v
        case maybe_raw_files of
          (FilePath
input_format, [FilePath]
raw_files) -> do
            LiterateM Text -> LiterateM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LiterateM Text -> LiterateM ()) -> LiterateM Text -> LiterateM ()
forall a b. (a -> b) -> a -> b
$
              FilePath -> [FilePath] -> Text -> LiterateM 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 -> Value -> m (a, [FilePath])
toRawFiles FilePath
dir 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
_ Value
v = Text -> m (a, [FilePath])
forall {a} {m :: * -> *} {a}.
(MonadError a m, Semigroup a, IsString a) =>
a -> m a
nope (Text -> m (a, [FilePath])) -> Text -> m (a, [FilePath])
forall a b. (a -> b) -> a -> b
$ ValueType -> Text
valueTypeText (ValueType -> Text) -> ValueType -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ValueType
valueType Value
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 :: a -> m a
nope a
t = a -> m a
forall a. a -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ a
"Cannot create audio from value of type " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
t

-- 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 (ZonkAny 0) -> Text) -> Doc (ZonkAny 0) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc (ZonkAny 0) -> Text
forall a. Doc a -> Text
PP.docText (Doc (ZonkAny 0) -> IO ()) -> Doc (ZonkAny 0) -> IO ()
forall a b. (a -> b) -> a -> b
$
      Doc (ZonkAny 0)
"Processing " Doc (ZonkAny 0) -> Doc (ZonkAny 0) -> Doc (ZonkAny 0)
forall a. Semigroup a => a -> a -> a
<> Doc (ZonkAny 0) -> Doc (ZonkAny 0)
forall ann. Doc ann -> Doc ann
PP.align (Directive -> Doc (ZonkAny 0)
forall a ann. Pretty a => a -> Doc ann
forall ann. Directive -> Doc ann
PP.pretty Directive
directive) Doc (ZonkAny 0) -> Doc (ZonkAny 0) -> Doc (ZonkAny 0)
forall a. Semigroup a => a -> a -> a
<> Doc (ZonkAny 0)
"..."
  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 (ZonkAny 5) -> Text
forall a. Doc a -> Text
PP.docText (Bool -> Directive -> Doc (ZonkAny 5)
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 = hashText (envHash env <> prettyText directive)}
  (r, files) <- LiterateM Text -> IO (Either Text Text, Files)
forall a. LiterateM a -> IO (Either Text a, Files)
runLiterateM (LiterateM Text -> IO (Either Text Text, Files))
-> LiterateM Text -> IO (Either Text Text, Files)
forall a b. (a -> b) -> a -> b
$ Env -> Directive -> LiterateM Text
processDirective Env
env' Directive
directive
  case 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
  (failures, outputs, 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
  cleanupImgDir env $
    (envImgDir env </> "CACHEDIR.TAG") `S.insert` mconcat files
  pure (L.foldl' min Success failures, T.intercalate "\n" 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 = 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 = Just prog})
          FilePath
"PROGRAM"
      )
      FilePath
"The binary used for operations (defaults to same binary as 'futhark literate').",
    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 = opt : scriptExtraOptions 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 = opt : scriptCompilerOptions 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 = 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 = scriptVerbose config + 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 = Just 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 = True})
           FilePath
"Stop and do not produce output file if any directive fails."
       ]

-- Start up (and eventually shut down) a Futhark server corresponding
-- to the provided program. If the program has a @.fut@ extension, it
-- will be compiled automatically.
prepareServer :: FilePath -> Options -> (Server -> IO a) -> IO a
prepareServer :: forall a. FilePath -> Options -> (Server -> IO a) -> IO a
prepareServer FilePath
prog Options
opts Server -> IO a
f = do
  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 = ShowS
takeExtension FilePath
prog FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".fut"

  unless (scriptSkipCompilation opts || not is_fut) $ do
    let compile_options = FilePath
"--server" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Options -> [FilePath]
scriptCompilerOptions Options
opts
    when (scriptVerbose opts > 0) $
      T.hPutStrLn stderr $
        "Compiling " <> T.pack prog <> "..."
    when (scriptVerbose opts > 1) $
      T.hPutStrLn stderr $
        T.pack $
          unwords compile_options

    let onError Text
err = do
          Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
err
          IO b
forall a. IO a
exitFailure

    void $
      either onError pure <=< runExceptT $
        compileProgram compile_options (FutharkExe futhark) (scriptBackend opts) prog

  let run_options = Options -> [FilePath]
scriptExtraOptions Options
opts
      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' = if Bool
is_fut then ShowS
dropExtension FilePath
prog else FilePath
prog
      cfg =
        (FilePath -> [FilePath] -> ServerCfg
futharkServerCfg (FilePath
"." FilePath -> ShowS
</> FilePath
prog') [FilePath]
run_options)
          { cfgOnLine =
              if scriptVerbose opts > 0
                then onLine
                else const . const $ pure ()
          }

  withServer cfg 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
      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
err = do
            Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
err
            IO b
forall a. IO a
exitFailure
          onDocError Doc AnsiStyle
err = do
            Handle -> Doc AnsiStyle -> IO ()
PP.hPutDocLn Handle
stderr Doc AnsiStyle
err
            IO b
forall a. IO a
exitFailure
      proghash <-
        either onError pure <=< runExceptT $
          system futhark ["hash", prog] mempty
      script <- parseProgFile prog

      orig_dir <- getCurrentDirectory
      -- Every directive is interpreted, and may call any entry point of
      -- the program, so we cannot compile just a subset of them.
      prepareServer prog opts $ \Server
server -> do
        -- The interpreter uses the server for entry point calls, and
        -- does not shut it down.
        ffi_server <- Server -> IO Server
FFI.newServer Server
server
        (_, imports, src) <-
          either (onDocError . prettyCompilerError) pure
            =<< runExceptT (readProgramFilesExceptKnown [] mempty [prog])
        let eval_cfg =
              EvalConfig
evalConfig
                { evalPrintWarnings = False,
                  evalFile = Just prog,
                  evalBackend = Just $ scriptBackend opts
                }
        (_, tenv, ictx) <-
          either onDocError pure
            =<< initialiseInterpreter eval_cfg (Just prog) (Just ffi_server) imports

        let 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 = ShowS
takeDirectory FilePath
prog
            imgdir = ShowS
dropExtension (ShowS
takeFileName FilePath
mdfile) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"-img"
            env =
              Env
                { envServer :: Server
envServer = Server
ffi_server,
                  envSrc :: VNameSource
envSrc = VNameSource
src,
                  envTypeEnv :: Env
envTypeEnv = Env
tenv,
                  envCtx :: Ctx
envCtx = Ctx
ictx,
                  envOpts :: Options
envOpts = Options
opts,
                  envHash :: Text
envHash = Text
proghash,
                  envImgDir :: FilePath
envImgDir = FilePath
imgdir
                }

        when (scriptVerbose opts > 0) $ do
          T.hPutStrLn stderr $ "Executing from " <> T.pack prog_dir
        setCurrentDirectory prog_dir

        (failure, md) <- processScript env script
        T.writeFile (orig_dir </> mdfile) md
        when (failure == Failure) exitFailure
    [FilePath]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing