-- Copyright 2014 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Transformers that evaluate their deriver conditionally.
module Derive.C.Prelude.Conditional where
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty

import qualified Derive.Args as Args
import qualified Derive.Call.Module as Module
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.Library as Library
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Signal as Signal

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers [(Symbol
"solo", Transformer Note
c_solo)]
    , (forall d. CallableExpr d => [(Symbol, Generator d)]) -> Library
Library.poly_generators
        [ (Symbol
"if-e", forall d. CallableExpr d => Generator d
c_if_e)
        , (Symbol
"if-c<", forall d. CallableExpr d => (Y -> Y -> Bool) -> Generator d
c_if_c forall a. Ord a => a -> a -> Bool
(<))
        , (Symbol
"if-c>", forall d. CallableExpr d => (Y -> Y -> Bool) -> Generator d
c_if_c forall a. Ord a => a -> a -> Bool
(>))
        , (Symbol
"on-repeat", forall d. CallableExpr d => Generator d
c_on_repeat)
        ]
    , (forall d. CallableExpr d => [(Symbol, Transformer d)]) -> Library
Library.poly_transformers
        [ (Symbol
"when-c", forall d. Taggable d => Bool -> Transformer d
c_when_c Bool
False)
        , (Symbol
"unless-c", forall d. Taggable d => Bool -> Transformer d
c_when_c Bool
True)
        , (Symbol
"when-e", forall d. Taggable d => Bool -> Transformer d
c_when_e Bool
False)
        , (Symbol
"unless-e", forall d. Taggable d => Bool -> Transformer d
c_when_e Bool
True)
        ]
    ]

-- * generator

c_if_e :: Derive.CallableExpr d => Derive.Generator d
c_if_e :: forall d. CallableExpr d => Generator d
c_if_e = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"if-e" forall a. Monoid a => a
mempty
    Doc
"Derive based on the value of an environment variable."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"name" Doc
"Environ key."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"value" (forall a. Maybe a
Nothing :: Maybe DeriveT.Val)
        Doc
"Environ value. If not given, require\
        \ only that the environ key is set."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"true" Doc
"Eval if true."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"false" Doc
"Eval if false."
    ) forall a b. (a -> b) -> a -> b
$ \(Text
name, Maybe Val
maybe_value, Quoted
true, Quoted
false) PassedArgs d
args ->
        forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Text -> Maybe Val -> Deriver Bool
has_environ Text
name Maybe Val
maybe_value)
            (forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall a. PassedArgs a -> Context a
Args.context PassedArgs d
args) Quoted
true)
            (forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall a. PassedArgs a -> Context a
Args.context PassedArgs d
args) Quoted
false)

c_if_c :: Derive.CallableExpr d => (Signal.Y -> Signal.Y -> Bool)
    -> Derive.Generator d
c_if_c :: forall d. CallableExpr d => (Y -> Y -> Bool) -> Generator d
c_if_c Y -> Y -> Bool
cmp = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"if-c<" forall a. Monoid a => a
mempty
    Doc
"Derive based on the value of a control."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"control" Doc
"Test this control."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"tests" Doc
"(value, expr) pairs."
    ) forall a b. (a -> b) -> a -> b
$ \(Control
control, NonEmpty Val
tests) PassedArgs d
args -> do
        Y
val <- forall a. a -> Maybe a -> a
fromMaybe Y
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (Control -> RealTime -> Deriver State Error (Maybe Y)
Derive.untyped_control_at Control
control forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs d
args)
        ([(Y, Quoted)]
tests, Quoted
final) <- ScoreTime -> [Val] -> Deriver ([(Y, Quoted)], Quoted)
typecheck_tests (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs d
args)
            (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Val
tests)
        forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall a. PassedArgs a -> Context a
Args.context PassedArgs d
args) forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Quoted
final forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Y -> Y -> Bool
cmp Y
val forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Y, Quoted)]
tests

typecheck_tests :: ScoreTime -> [DeriveT.Val]
    -> Derive.Deriver ([(Signal.Y, DeriveT.Quoted)], DeriveT.Quoted)
typecheck_tests :: ScoreTime -> [Val] -> Deriver ([(Y, Quoted)], Quoted)
typecheck_tests ScoreTime
start = forall {b} {a} {a}.
(Typecheck b, Typecheck a, Typecheck a) =>
[Val] -> Deriver State Error ([(a, a)], b)
go
    where
    go :: [Val] -> Deriver State Error ([(a, a)], b)
go [] = forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"not enough values"
    go [Val
x] = do
        b
final <- forall a. Typecheck a => Val -> Deriver a
typecheck Val
x
        forall (m :: * -> *) a. Monad m => a -> m a
return ([], b
final)
    go (Val
val : Val
result : [Val]
rest) = do
        (a, a)
checked <- (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => Val -> Deriver a
typecheck Val
val forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => Val -> Deriver a
typecheck Val
result
        ([(a, a)]
rest, b
final) <- [Val] -> Deriver State Error ([(a, a)], b)
go [Val]
rest
        forall (m :: * -> *) a. Monad m => a -> m a
return ((a, a)
checked forall a. a -> [a] -> [a]
: [(a, a)]
rest, b
final)
    typecheck :: Typecheck.Typecheck a => DeriveT.Val -> Derive.Deriver a
    typecheck :: forall a. Typecheck a => Val -> Deriver a
typecheck = forall a. Typecheck a => Text -> ScoreTime -> Val -> Deriver a
Typecheck.typecheck Text
"" ScoreTime
start

c_on_repeat :: Derive.CallableExpr d => Derive.Generator d
c_on_repeat :: forall d. CallableExpr d => Generator d
c_on_repeat = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"on-repeat" forall a. Monoid a => a
mempty
    Doc
"Derive the argument indexed by the `repeat` variable, where an out of\
    \ range index is clamped to be in range."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"repeat" Doc
"Eval on nth repeat.") forall a b. (a -> b) -> a -> b
$ \NonEmpty Quoted
repeats PassedArgs d
args -> do
        Maybe Int
repeat <- forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
"repeat"
        forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall a. PassedArgs a -> Context a
Args.context PassedArgs d
args) (forall a. NonEmpty a -> Int -> a
at NonEmpty Quoted
repeats (forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
repeat))

at :: NonEmpty a -> Int -> a
at :: forall a. NonEmpty a -> Int -> a
at (a
x0 :| a
x1: [a]
xs) Int
i
    | Int
i forall a. Ord a => a -> a -> Bool
<= Int
0 = a
x0
    | Bool
otherwise = forall a. NonEmpty a -> Int -> a
at (a
x1 forall a. a -> [a] -> NonEmpty a
:| [a]
xs) (Int
iforall a. Num a => a -> a -> a
-Int
1)
at (a
x0 :| []) Int
_ = a
x0

-- * transformer

c_solo :: Derive.Transformer Derive.Note
c_solo :: Transformer Note
c_solo = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"solo" forall a. Monoid a => a
mempty
    Doc
"Only derive if `inst` is set to the given value. This is a specialized\
    \ version of `when-e`."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"inst" Doc
"Instrument.")
    forall a b. (a -> b) -> a -> b
$ \Instrument
inst PassedArgs Note
_args Deriver State Error (Stream Note)
deriver ->
        forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Text -> Maybe Val -> Deriver Bool
has_environ Text
EnvKey.instrument
                (forall a. a -> Maybe a
Just (forall a. ToVal a => a -> Val
Typecheck.to_val (Instrument
inst :: ScoreT.Instrument))))
            Deriver State Error (Stream Note)
deriver forall a. Monoid a => a
mempty

c_when_c :: Derive.Taggable d => Bool -> Derive.Transformer d
c_when_c :: forall d. Taggable d => Bool -> Transformer d
c_when_c Bool
inverted = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"when-c" forall a. Monoid a => a
mempty
    Doc
"Only derive if the control has the given value. E.g., you can use a\
    \ `%var` control to select among different variations."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"val" Doc
"Value."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"control" (Y
0 :: Double) Doc
"Control."
    ) forall a b. (a -> b) -> a -> b
$ \(Int
val :: Int, Y
control :: Double) PassedArgs d
_args Deriver (Stream d)
deriver ->
        if Bool -> Bool
invert (forall a b. (RealFrac a, Integral b) => a -> b
round Y
control forall a. Eq a => a -> a -> Bool
== Int
val)
            then Deriver (Stream d)
deriver else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty
    where invert :: Bool -> Bool
invert = if Bool
inverted then Bool -> Bool
not else forall a. a -> a
id

c_when_e :: Derive.Taggable d => Bool -> Derive.Transformer d
c_when_e :: forall d. Taggable d => Bool -> Transformer d
c_when_e Bool
inverted = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"when-e" forall a. Monoid a => a
mempty
    Doc
"Only derive if environ value is set to the given value. In a block\
    \ derived multiple times by different instruments, this can be used to\
    \ solo a bit of score to one particular instrument."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"name" Doc
"Environ key."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"value" (forall a. Maybe a
Nothing :: Maybe DeriveT.Val)
        Doc
"Environ value. If not given, require\
        \ only that the environ key is set."
    ) forall a b. (a -> b) -> a -> b
$ \(Text
name, Maybe Val
maybe_value) PassedArgs d
_args Deriver (Stream d)
deriver ->
        forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Deriver Bool -> Deriver Bool
invert forall a b. (a -> b) -> a -> b
$ Text -> Maybe Val -> Deriver Bool
has_environ Text
name Maybe Val
maybe_value) Deriver (Stream d)
deriver
            (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty)
    where invert :: Deriver Bool -> Deriver Bool
invert = if Bool
inverted then (Bool -> Bool
not <$>) else forall a. a -> a
id

has_environ :: Env.Key -> Maybe DeriveT.Val -> Derive.Deriver Bool
has_environ :: Text -> Maybe Val -> Deriver Bool
has_environ Text
name Maybe Val
maybe_val = forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Val
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Just Val
env_val -> case Maybe Val
maybe_val of
        Maybe Val
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Just Val
val -> case Val -> Val -> Maybe Bool
DeriveT.vals_equal Val
val Val
env_val of
            Maybe Bool
Nothing -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"vals can't be compared: "
                forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Val
val forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Val
env_val
            Just Bool
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
t