-- Copyright 2013 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

-- | Block call and support.
module Derive.C.Prelude.Block (
    library
    , eval_root_block, global_transform
) where
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map

import qualified Derive.Args as Args
import qualified Derive.Cache as Cache
import qualified Derive.Call.BlockUtil as BlockUtil
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Score as Score
import qualified Derive.Sig as Sig
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream

import qualified Perform.Signal as Signal
import qualified Ui.Block as Block
import qualified Ui.Event as Event
import qualified Ui.Id as Id
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [(Symbol
BlockUtil.capture_null_control, Generator Note
c_capture_null_control)]
    , forall call. ToLibrary call => PatternCall call -> Library
Library.pattern PatternCall (Generator Note)
pattern_note_block
    , forall call. ToLibrary call => PatternCall call -> Library
Library.pattern PatternCall (Generator Control)
pattern_control_block
    ]

-- * root block

-- | Evaluate the root block in a performance.  Making this an ordinary call
-- means it participates in the derive cache just like all other calls.
--
-- Tempo.with_tempo does a bit of magic to stretch all blocks to length 1,
-- except the root one.  The root block should operate in real time, so no
-- stretching here.  Otherwise, a tempo of 2 would be the same as 1.
{-# SCC eval_root_block #-}
eval_root_block :: BlockId -> Derive.NoteDeriver
eval_root_block :: BlockId -> NoteDeriver
eval_root_block BlockId
block_id =
    NoteDeriver -> NoteDeriver
global_transform forall a b. (a -> b) -> a -> b
$ forall d. CallableExpr d => Bool -> Call -> Deriver (Stream d)
Eval.eval_one_call Bool
True forall a b. (a -> b) -> a -> b
$ BlockId -> Call
call_from_block_id BlockId
block_id

{-# SCC global_transform #-}
global_transform :: Derive.NoteDeriver -> Derive.NoteDeriver
global_transform :: NoteDeriver -> NoteDeriver
global_transform = forall a.
Callable (Transformer a) =>
Context a -> Symbol -> Deriver (Stream a) -> Deriver (Stream a)
transform_if_present forall {a}. Context a
ctx Symbol
"GLOBAL"
    where ctx :: Context a
ctx = forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
0 ScoreTime
1 Text
"<GLOBAL transform>"

transform_if_present :: Derive.Callable (Derive.Transformer a)
    => Derive.Context a
    -> Expr.Symbol -> Derive.Deriver (Stream.Stream a)
    -> Derive.Deriver (Stream.Stream a)
transform_if_present :: forall a.
Callable (Transformer a) =>
Context a -> Symbol -> Deriver (Stream a) -> Deriver (Stream a)
transform_if_present Context a
ctx Symbol
sym Deriver (Stream a)
deriver = forall call. Callable call => Symbol -> Deriver (Maybe call)
Derive.lookup_call Symbol
sym forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Transformer a)
Nothing -> Deriver (Stream a)
deriver
    Just Transformer a
call -> forall d.
Context d
-> Transformer d
-> [Val]
-> Deriver (Stream d)
-> Deriver (Stream d)
Eval.apply_transformer Context a
ctx Transformer a
call [] Deriver (Stream a)
deriver

-- * note calls

pattern_note_block :: Derive.PatternCall (Derive.Generator Derive.Note)
pattern_note_block :: PatternCall (Generator Note)
pattern_note_block = Derive.PatternCall
    { pat_description :: Text
pat_description = Text
"block name"
    , pat_doc :: DocumentedCall
pat_doc = forall d. Call d -> DocumentedCall
Derive.extract_doc Generator Note
fake_call
    , pat_function :: Symbol -> Deriver (Maybe (Generator Note))
pat_function = \Symbol
sym -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockId -> Generator Note
c_block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbol -> Deriver (Maybe BlockId)
call_to_block_id Symbol
sym
    }
    where
    -- Not evaluated, so it doesn't matter if the BlockId is invalid.
    fake_call :: Generator Note
fake_call = BlockId -> Generator Note
c_block (Id -> BlockId
Id.BlockId (Text -> Id
Id.read_id Text
"example/block"))

{-# SCC c_block #-}
c_block :: BlockId -> Derive.Generator Derive.Note
c_block :: BlockId -> Generator Note
c_block BlockId
block_id = forall d.
(PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
Derive.with_score_duration forall a. a -> Deriver (CallDuration ScoreTime)
get_score_duration forall a b. (a -> b) -> a -> b
$
    forall d.
(PassedArgs d -> Deriver (CallDuration RealTime))
-> Generator d -> Generator d
Derive.with_real_duration (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ BlockId -> Deriver (CallDuration RealTime)
get_real_duration BlockId
block_id) forall a b. (a -> b) -> a -> b
$
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude
        (Text -> CallName
Derive.CallName forall a b. (a -> b) -> a -> b
$ Text
"block " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt BlockId
block_id) Tags
Tags.prio_block
    Doc
"Substitute the named block into the score. If the symbol doesn't contain\
    \ a `/`, the default namespace is applied. If it starts with a `-`, this\
    \ is a relative call and the calling block's namespace and name are\
    \ prepended."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Stack
stack <- Deriver Stack
Internal.get_stack
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockId -> Frame
Stack.Block BlockId
block_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Stack -> [Frame]
Stack.innermost Stack
stack) forall a b. (a -> b) -> a -> b
$
            forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"recursive call to " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id
        -- This ensures that each block call from the same event sees a new
        -- serial number, as documented in 'Derive.CacheKey'.
        Deriver State Error ()
Internal.increment_event_serial
        -- I have to put the block on the stack before calling 'd_block'
        -- because 'Cache.block' relies on on the block id already being
        -- on the stack.
        forall a. BlockId -> Deriver a -> Deriver a
Internal.with_stack_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ forall d.
BlockId
-> (PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Cache.block BlockId
block_id forall {a}. PassedArgs a -> NoteDeriver
run PassedArgs Note
args
    where
    run :: PassedArgs a -> NoteDeriver
run PassedArgs a
args = forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start (ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
start) forall a b. (a -> b) -> a -> b
$ forall {a} {b}. PassedArgs a -> Deriver b -> Deriver b
trim PassedArgs a
args forall a b. (a -> b) -> a -> b
$ BlockId -> NoteDeriver
d_block BlockId
block_id
        where (ScoreTime
start, ScoreTime
end) = forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs a
args
    trim :: PassedArgs a -> Deriver b -> Deriver b
trim PassedArgs a
args Deriver b
deriver = do
        RealTime
end <- forall a. Time a => a -> Deriver RealTime
Derive.real (ScoreTime
1 :: ScoreTime)
        if Event -> Bool
Event.is_positive (forall a. PassedArgs a -> Event
Args.event PassedArgs a
args)
            then forall a. RealTime -> Deriver a -> Deriver a
trim_controls RealTime
end Deriver b
deriver
            else Deriver b
deriver
    get_score_duration :: a -> Derive.Deriver (Derive.CallDuration ScoreTime)
    get_score_duration :: forall a. a -> Deriver (CallDuration ScoreTime)
get_score_duration a
_ = forall a. a -> CallDuration a
Derive.CallDuration forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(ScoreTime
s, ScoreTime
e) -> ScoreTime
eforall a. Num a => a -> a -> a
-ScoreTime
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        BlockId -> Deriver (ScoreTime, ScoreTime)
Derive.block_logical_range BlockId
block_id
    get_real_duration :: BlockId
        -> Derive.Deriver (Derive.CallDuration RealTime)
    get_real_duration :: BlockId -> Deriver (CallDuration RealTime)
get_real_duration BlockId
block_id = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. CallDuration a
Derive.Unknown) forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
        forall a.
Deriver a -> Deriver (Either Error (CallDuration RealTime))
Derive.get_real_duration forall a b. (a -> b) -> a -> b
$ forall a. BlockId -> Deriver a -> Deriver a
Internal.with_stack_block BlockId
block_id forall a b. (a -> b) -> a -> b
$
            BlockId -> NoteDeriver
d_block BlockId
block_id

-- | Remove samples at the given RealTime.  This is to support final block
-- notes and 'Derive.Flags.infer_duration'.  Otherwise, an event at the end of
-- a block will pick up controls (e.g. a transposition change) that is meant to
-- start at the beginning of the next block.
--
-- However, I can't trim the signal entirely because I still want the control
-- signals past the end of the block to be visible to non-final events.  The
-- problem is that I do want control samples at the end time to be visible
-- if they are interior to the block.  So I need a way to tell the difference
-- between controls from the caller and local ones, so a final event can
-- exclude the former and include the latter.
--
-- TODO this is unsatisfying because it feels ad-hoc and clunky.  In addition,
-- it drops a sample that I don't actually want to drop for non-final events.
-- Not to mention it's inefficient.
trim_controls :: RealTime -> Derive.Deriver a -> Derive.Deriver a
trim_controls :: forall a. RealTime -> Deriver a -> Deriver a
trim_controls RealTime
end =
    forall a.
(Control -> Control) -> (Pitch -> Pitch) -> Deriver a -> Deriver a
Derive.modify_signals (RealTime -> Control -> Control
Signal.drop_discontinuity_at RealTime
end)
        (RealTime -> Pitch -> Pitch
PSignal.drop_discontinuity_at RealTime
end)

d_block :: BlockId -> Derive.NoteDeriver
d_block :: BlockId -> NoteDeriver
d_block BlockId
block_id = do
    Map BlockId Block
blocks <- forall a. (State -> a) -> Deriver a
Derive.get_ui_state State -> Map BlockId Block
Ui.state_blocks
    -- Do some error checking.  These are all caught later, but if I throw here
    -- I can give more specific error msgs.
    Text
title <- case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId Block
blocks of
        Maybe Block
Nothing -> forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"block_id not found"
        Just Block
block -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Block -> Text
Block.block_title Block
block
    -- Record a dependency on this block.  This should happen even if the
    -- derivation throws, because a dependency on a block with an error is
    -- still a dependency.
    BlockId -> Deriver State Error ()
Internal.add_block_dep BlockId
block_id
    let deriver :: NoteDeriver
deriver = BlockId -> NoteDeriver
BlockUtil.note_deriver BlockId
block_id
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe forall a. Stream a
Stream.empty) forall a b. (a -> b) -> a -> b
$ forall a. Bool -> Deriver a -> Deriver (Maybe a)
Derive.catch Bool
True forall a b. (a -> b) -> a -> b
$
        case Text -> Either Text Expr
ParseTitle.parse_block Text
title of
            Left Text
err -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"block title: " forall a. Semigroup a => a -> a -> a
<> Text
err
            -- An empty title means no transformation.
            Right (Expr.Call Symbol
call [] :| []) | Symbol
call forall a. Eq a => a -> a -> Bool
== Symbol
"" -> NoteDeriver
deriver
            Right Expr
expr ->
                forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> [Call] -> Deriver (Stream d) -> Deriver (Stream d)
Eval.eval_transformers forall {a}. Context a
ctx (forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
expr) NoteDeriver
deriver
                where ctx :: Context a
ctx = forall a. ScoreTime -> ScoreTime -> Text -> Context a
Derive.dummy_context ScoreTime
0 ScoreTime
1 Text
"block title"

-- | Given a block id, produce a call expression that will call that block.
call_from_block_id :: BlockId -> DeriveT.Call
call_from_block_id :: BlockId -> Call
call_from_block_id BlockId
block_id =
    forall val. Symbol -> Call val
Expr.call0 (Text -> Symbol
Expr.Symbol forall a b. (a -> b) -> a -> b
$ Id -> Text
Id.show_id forall a b. (a -> b) -> a -> b
$ forall a. Ident a => a -> Id
Id.unpack_id BlockId
block_id)

-- | Like 'Eval.call_to_block_id' but make sure the block exists.
call_to_block_id :: Expr.Symbol -> Derive.Deriver (Maybe BlockId)
call_to_block_id :: Symbol -> Deriver (Maybe BlockId)
call_to_block_id Symbol
sym = do
    Maybe BlockId
caller <- Deriver (Maybe BlockId)
Internal.lookup_current_block_id
    Namespace
ns <- forall a. (State -> a) -> Deriver a
Derive.get_ui_state forall a b. (a -> b) -> a -> b
$ Config -> Namespace
UiConfig.config_namespace forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
Ui.state_config
    case Namespace -> Maybe BlockId -> Symbol -> Maybe BlockId
Eval.call_to_block_id Namespace
ns Maybe BlockId
caller Symbol
sym of
        Maybe BlockId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just BlockId
block_id -> do
            Map BlockId Block
blocks <- forall a. (State -> a) -> Deriver a
Derive.get_ui_state State -> Map BlockId Block
Ui.state_blocks
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall k a. Ord k => k -> Map k a -> Bool
Map.member BlockId
block_id Map BlockId Block
blocks then forall a. a -> Maybe a
Just BlockId
block_id
                else forall a. Maybe a
Nothing

-- * control calls

pattern_control_block :: Derive.PatternCall (Derive.Generator Derive.Control)
pattern_control_block :: PatternCall (Generator Control)
pattern_control_block = Derive.PatternCall
    { pat_description :: Text
pat_description = Text
"block name"
    , pat_doc :: DocumentedCall
pat_doc = forall d. Call d -> DocumentedCall
Derive.extract_doc Generator Control
fake_call
    , pat_function :: Symbol -> Deriver (Maybe (Generator Control))
pat_function = \Symbol
sym -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockId -> Generator Control
c_control_block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbol -> Deriver (Maybe BlockId)
call_to_block_id Symbol
sym
    }
    where
    -- Not evaluated, so it doesn't matter if the BlockId is invalid.
    fake_call :: Generator Control
fake_call = BlockId -> Generator Control
c_control_block (Id -> BlockId
Id.BlockId (Text -> Id
Id.read_id Text
"example/block"))

c_control_block :: BlockId -> Derive.Generator Derive.Control
c_control_block :: BlockId -> Generator Control
c_control_block BlockId
block_id = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"control-block"
    forall a. Monoid a => a
mempty (Doc
"Substitute the control signal from the named control block.\
    \ A control block should consist of a single branch ending in\
    \ a track named `%`.  The signal from that track will be\
    \ substituted."
    ) forall a b. (a -> b) -> a -> b
$
    forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ \PassedArgs Control
args -> do
        let (ScoreTime
start, ScoreTime
end) = forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Control
args
        forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start (ScoreTime
endforall a. Num a => a -> a -> a
-ScoreTime
start) (BlockId -> Deriver (Stream Control)
d_control_block BlockId
block_id)

d_control_block :: BlockId -> Derive.ControlDeriver
d_control_block :: BlockId -> Deriver (Stream Control)
d_control_block BlockId
block_id = forall a. BlockId -> Deriver a -> Deriver a
Internal.with_stack_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ do
    -- Control calls aren't cached, so I can put the block stack in the
    -- convenient place.
    Map BlockId Block
blocks <- forall a. (State -> a) -> Deriver a
Derive.get_ui_state State -> Map BlockId Block
Ui.state_blocks
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId Block
blocks forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
        forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"block_id not found"
    BlockId -> Deriver State Error ()
Internal.add_block_dep BlockId
block_id
    Deriver (Stream Control)
deriver <- forall a. HasCallStack => StateId a -> Deriver a
Derive.eval_ui forall a b. (a -> b) -> a -> b
$ BlockId -> StateId (Deriver (Stream Control))
BlockUtil.control_deriver BlockId
block_id
    Deriver (Stream Control)
deriver

c_capture_null_control :: Derive.Generator Derive.Note
c_capture_null_control :: Generator Note
c_capture_null_control = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.internal
    (Symbol -> CallName
Derive.sym_to_call_name Symbol
BlockUtil.capture_null_control) forall a. Monoid a => a
mempty
    (Doc
"This is an internal call used to capture the control signal at the\
    \ bottom of a control block."
    ) forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_ -> do
        Typed Control
sig <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"no null control to capture"
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Control -> Deriver (Maybe (Typed Control))
Derive.lookup_signal Control
Controls.null
        Stack
stack <- Deriver Stack
Derive.get_stack
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Control -> Typed Control -> Note -> Note
Score.set_control Control
Controls.null Typed Control
sig Note
Score.empty_event
            { event_stack :: Stack
Score.event_stack = Stack
stack }