packages feed

csound-expression-typed 0.0.7.9.1 → 0.0.8

raw patch · 15 files changed

+432/−72 lines, 15 filesdep +hashabledep ~basedep ~csound-expression-dynamicdep ~temporal-mediaPVP ok

version bump matches the API change (PVP)

Dependencies added: hashable

Dependency ranges changed: base, csound-expression-dynamic, temporal-media

API changes (from Hackage documentation)

Files

csound-expression-typed.cabal view
@@ -1,5 +1,5 @@ Name:          csound-expression-typed-Version:       0.0.7.9.1+Version:       0.0.8 Cabal-Version: >= 1.22 License:       BSD3 License-file:  LICENSE@@ -24,8 +24,8 @@ Library   Ghc-Options:    -Wall   Build-Depends:-        base >= 4.8, base < 5, ghc-prim, containers, transformers >= 0.3, Boolean >= 0.1.0, colour >= 2.0, data-default, deepseq,-        wl-pprint, csound-expression-dynamic >= 0.1.4.3, temporal-media >= 0.6.1+        base >= 4, base < 5, ghc-prim, containers, transformers >= 0.3, Boolean >= 0.1.0, colour >= 2.0, data-default, deepseq,+        wl-pprint, csound-expression-dynamic >= 0.1.5, temporal-media >= 0.6.0, hashable   Hs-Source-Dirs:      src/   Exposed-Modules:     Csound.Typed@@ -46,7 +46,8 @@     Csound.Typed.GlobalState.Options     Csound.Typed.GlobalState.GE     Csound.Typed.GlobalState.SE-    Csound.Typed.GlobalState.Instr    +    Csound.Typed.GlobalState.Instr+    Csound.Typed.GlobalState.Cache     Csound.Typed.GlobalState.Elements     Csound.Typed.GlobalState.Opcodes @@ -68,4 +69,8 @@     Csound.Typed.Gui.BoxModel      Csound.Typed.Constants++    Csound.Typed.Lib.StableMaps.Dynamic+    Csound.Typed.Lib.StableMaps.Dynamic.Map+   Default-Language: Haskell2010
src/Csound/Typed/Control/Evt.hs view
@@ -4,6 +4,8 @@     retrigs, evtLoop, evtLoopOnce     ) where +import System.Mem.StableName+ import Data.Boolean  import Control.Applicative@@ -28,21 +30,21 @@     where unEvt e = (T.eventStart e, T.eventDur e, T.eventContent e)  sched :: (Arg a, Sigs b) => (a -> SE b) -> Evt (Sco a) -> b-sched instr evts = apInstr0 $ do        -    instrId <- saveSourceInstrWithLivenessWatch (funArity instr) (insExp instr)+sched instr evts = apInstr0 $ do    +    instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp instr)     saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts evts)     where unEvt e = (T.eventStart e, T.eventDur e, T.eventContent e)  -- | Triggers a procedure on the event stream. sched_ :: (Arg a) => (a -> SE ()) -> Evt (Sco a) -> SE () sched_ instr evts = fromDep_ $ hideGEinDep $ do-    instrId <- saveSourceInstr_  (unitExp $ fmap (const unit) $ instr toArg)+    instrId <- saveSourceInstrCached_ (unitExp $ fmap (const unit) $ instr toArg)     return $ saveEvtInstr_ instrId (renderEvts evts)  -- | A closure to trigger an instrument inside the body of another instrument. schedBy :: (Arg a, Sigs b, Arg c) => (a -> SE b) -> (c -> Evt (Sco a)) -> (c -> b) schedBy instr evts args = flip apInstr args $ do-    instrId <- saveSourceInstrWithLivenessWatch (funArity instr) (insExp instr)+    instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp instr)     saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts $ evts toArg)    -------------------------------------------------@@ -75,8 +77,8 @@ -- | Retriggers an instrument every time an event happens. The note -- is held until the next event happens. retrigs :: (Arg a, Sigs b) => (a -> SE b) -> Evt [a] -> b-retrigs instr evts = apInstr0 $ do       -    instrId <- saveSourceInstrWithLivenessWatchAndRetrig (funArity instr) (insExp instr)+retrigs instr evts = apInstr0 $ do+    instrId <- saveSourceInstrCachedWithLivenessWatchAndRetrig (funArity instr) (insExp instr)     saveRetrigEvtInstr (arityOuts $ funArity instr) instrId evts     saveRetrigEvtInstr :: Arg a => Int -> C.InstrId -> Evt [a] -> GE C.InstrId@@ -116,7 +118,7 @@  evtLoopGen :: (Num a, Tuple a, Sigs a) => Bool -> Maybe (Evt Unit) -> [SE a] -> [Evt Unit] -> a evtLoopGen mustLoop maybeOffEvt instrs evts = apInstr0 $ do-    (instrId, evtInstrId) <- saveSourceInstrWithLivenessWatchAndRetrigAndEvtLoop (constArity instr) (insExp $ toInstrExp instr) (toSingleEvt evts)+    (instrId, evtInstrId) <- saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop (constArity instr) (insExp $ toInstrExp instr) (toSingleEvt evts)     saveEvtLoopInstr mustLoop loopLength maybeOffEvt (arityOuts $ constArity instr) instrId evtInstrId     where                  loopLength = int $ lcm (length instrs) (length evts)@@ -125,7 +127,7 @@         toInstrExp :: a -> (Unit -> a)         toInstrExp = const -        toSingleInstr :: (Sigs a, Num a, Tuple a) => [SE a] -> SE a+        toSingleInstr :: (Num a, Tuple a) => [SE a] -> SE a         toSingleInstr as = do             let n = mod' (fromE $ getRetrigVal 4) (sig $ int $ length as)             ref <- newRef 0@@ -138,7 +140,7 @@         toSingleEvt :: [Evt Unit] -> SE ()         toSingleEvt evts = do             let n = mod' (fromE $ getRetrigVal 4) (sig $ int $ length evts)-            zipWithM_ (f n) (fmap (sig . int) [0 .. ]) evts            +            zipWithM_ (f n) (fmap (sig . int) [0 .. ]) evts             where                  f :: Sig -> Sig -> Evt Unit -> SE ()                 f n ix evt = when1 (n ==* ix) $ evtLoopInstr evt@@ -226,14 +228,14 @@ -- for some seconds (specified in the first argument) then it's turned off. schedHarp :: (Arg a, Sigs b) => D -> (a -> SE b) -> Evt [a] -> b schedHarp turnOffTime instr evts = apInstr0 $ do-    instrId <- saveSourceInstrWithLivenessWatch (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr)+    instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr)     saveEvtInstr (arityOuts $ funArity instr) instrId (fmap (fmap phi) evts)     where phi a = (0, infiniteDur, a)  -- | A closure to trigger an instrument inside the body of another instrument. schedHarpBy :: (Arg a, Sigs b, Arg c) => D -> (a -> SE b) -> (c -> Evt [a]) -> (c -> b) schedHarpBy turnOffTime instr evts args = flip apInstr args $ do-    instrId <- saveSourceInstrWithLivenessWatch (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr)+    instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp $ (autoOff turnOffTime =<< ) . instr)     saveEvtInstr (arityOuts $ funArity instr) instrId (fmap (fmap phi) $ evts toArg)     where phi a = (0, infiniteDur, a) @@ -248,6 +250,13 @@ saveEvtInstr_ :: Arg a => C.InstrId -> Evt [(D, D, a)] -> Dep () saveEvtInstr_ instrId evts = unSE $ runEvt evts $ \es -> fromDep_ $ mapM_ event es     where event (start, dur, args) = hideGEinDep $ fmap C.event $ C.Event instrId <$> toGE start <*> toGE dur <*> toNote args++-------------------------------------------------------------------++evtKey :: a -> b -> GE EvtKey+evtKey a b = liftIO $ EvtKey <$> hash a <*> hash b+    where hash x = hashStableName <$> makeStableName x+  ------------------------------------------------------------------- -- sample level triggering
src/Csound/Typed/Control/Midi.hs view
@@ -34,10 +34,10 @@ pgmidi :: (Num a, Sigs a) => Maybe Int -> Channel -> (Msg -> SE a) -> SE a pgmidi mchn n = fromProcMidi (pgmidiWithInstrId_ mchn n) -fromProcMidi :: (Num a, Sigs a) => ((InstrId -> Msg -> SE ()) -> SE ()) -> (Msg -> SE a) -> SE a+fromProcMidi :: (Num a, Sigs a) => ((Msg -> SE ()) -> SE ()) -> (Msg -> SE a) -> SE a fromProcMidi procMidi f = do     ref <- newGlobalRef 0-    procMidi (\instrId -> mixRef ref . scaleMidiVolumeFactor instrId <=< f)+    procMidi (mixRef ref . scaleMidiVolumeFactor <=< f)     res <- readRef ref     writeRef ref 0     return res@@ -45,15 +45,15 @@ -----------------------------------------------------------------  -- | Triggers a midi-procedure (aka Csound's massign) for all channels. -midiWithInstrId_ :: (InstrId -> Msg -> SE ()) -> SE ()+midiWithInstrId_ :: (Msg -> SE ()) -> SE () midiWithInstrId_ = midinWithInstrId_ 0  -- | Triggers a midi-procedure (aka Csound's pgmassign) on the given channel. -midinWithInstrId_ :: Channel -> (InstrId -> Msg -> SE ()) -> SE ()+midinWithInstrId_ :: Channel -> (Msg -> SE ()) -> SE () midinWithInstrId_ chn instr = genMidi_ Massign chn instr  -- | Triggers a midi-procedure (aka Csound's pgmassign) on the given programm bank. -pgmidiWithInstrId_ :: Maybe Int -> Channel -> (InstrId -> Msg -> SE ()) -> SE ()+pgmidiWithInstrId_ :: Maybe Int -> Channel -> (Msg -> SE ()) -> SE () pgmidiWithInstrId_ mchn chn instr = genMidi_ (Pgmassign mchn) chn instr  -----------------------------------------------------------------@@ -64,14 +64,14 @@  -- | Triggers a midi-procedure (aka Csound's pgmassign) on the given channel.  midin_ :: Channel -> (Msg -> SE ()) -> SE ()-midin_ chn instr = genMidi_ Massign chn (const instr)+midin_ chn instr = genMidi_ Massign chn instr  -- | Triggers a midi-procedure (aka Csound's pgmassign) on the given programm bank.  pgmidi_ :: Maybe Int -> Channel -> (Msg -> SE ()) -> SE ()-pgmidi_ mchn chn instr = genMidi_ (Pgmassign mchn) chn (const instr)+pgmidi_ mchn chn instr = genMidi_ (Pgmassign mchn) chn instr -genMidi_ :: MidiType -> Channel -> (InstrId -> Msg -> SE ()) -> SE ()-genMidi_ midiType chn instr = geToSe $ saveToMidiInstr midiType chn (\instrId -> unSE $ instr instrId Msg)+genMidi_ :: MidiType -> Channel -> (Msg -> SE ()) -> SE ()+genMidi_ midiType chn instr = geToSe $ saveToMidiInstr midiType chn (unSE $ instr Msg)  ----------------------------------------------------------------- -- midi ctrls@@ -84,5 +84,5 @@ ----------------------------------------------------------------- -- midi volume factor -scaleMidiVolumeFactor :: Sigs a => InstrId -> a -> a-scaleMidiVolumeFactor instrId = mapTuple (C.midiVolumeFactor instrId * )+scaleMidiVolumeFactor :: Sigs a => a -> a+scaleMidiVolumeFactor = mapTuple (C.midiVolumeFactor (pn 1) * )
src/Csound/Typed/Control/Mix.hs view
@@ -9,6 +9,8 @@ import Control.Applicative import Control.Monad.IO.Class import Data.Traversable+import System.Mem.StableName+ import Temporal.Media  import Csound.Dynamic hiding (Instr, Sco, str)@@ -42,14 +44,14 @@ sco :: (Arg a, Sigs b) => (a -> SE b) -> Sco a -> Sco (Mix b) sco instr notes = wrapSco notes $ \events -> do     events' <- traverse toNote events    -    instrId <- saveSourceInstrWithLivenessWatch (funArity instr) (insExp instr)+    instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp instr)     return $ Snd instrId events'  -- | Invokes a procedure for the given bunch of events. sco_ :: (Arg a) => (a -> SE ()) -> Sco a -> Sco (Mix Unit) sco_ instr notes = wrapSco notes $ \events -> do     events' <- traverse toNote events    -    instrId <- saveSourceInstr_ (unitExp $ fmap (const unit) $ instr toArg)+    instrId <- saveSourceInstrCached_ (unitExp $ fmap (const unit) $ instr toArg)     return $ Snd instrId events'  -- | Applies an effect to the sound. Effect is applied to the sound on the give track. @@ -75,23 +77,29 @@  -- | Renders a scores to the sound signals. we can use it inside the other instruments. mix :: (Sigs a) => Sco (Mix a) -> a-mix a = flip apInstr unit $ do    -    setDuration =<< (toGE $ dur a)-    saveMixInstr (mixArity a) =<< toEventList a'+mix a = flip apInstr unit $ do+    key <- mixKey a+    durE <- toGE $ dur a+    withCache (ExpDur durE) getMixKey saveMixKey key $ +        saveMixInstr (mixArity a) =<< toEventList a'     where a' = toCsdEventList a  -- | Imitates a closure for a bunch of notes to be played within another instrument.  mixBy :: (Arg a, Sigs b) => (a -> Sco (Mix b)) -> (a -> b)-mixBy evts args = flip apInstr args $ do    -    setDuration =<< (toGE $ dur evts')-    saveMixInstr (mixArityFun evts) =<< (toEventList evts')+mixBy evts args = flip apInstr args $ do+    key <- mixKey evts+    durE <- toGE $ dur evts'+    withCache (ExpDur durE) getMixKey saveMixKey key $ +        saveMixInstr (mixArityFun evts) =<< (toEventList evts')     where evts' = toCsdEventList $ evts toArg  -- | Converts a bunch of procedures scheduled with scores to a single procedure. mix_ :: Sco (Mix Unit) -> SE ()-mix_ a = fromDep_ $ hideGEinDep $ do    -    setDuration =<< (toGE $ dur a)-    saveMixInstr_ =<< toEventList a'+mix_ a = fromDep_ $ hideGEinDep $ do+    key <- mixKey a+    durE <- toGE $ dur a+    withCache (ExpDur durE) getMixProcKey saveMixProcKey key $+        saveMixInstr_ =<< toEventList a'     where a' = toCsdEventList a  -- | Imitates a closure for a bunch of procedures to be played within another instrument. @@ -99,6 +107,9 @@ mixBy_ evts args = mix_ $ evts args  ----------------------------------------------------------++mixKey :: a -> GE MixKey+mixKey = liftIO . fmap (MixKey . hashStableName) . makeStableName  toEventList :: Sco (Mix a) -> GE (CsdEventList M) toEventList evts = fmap delayAndRescaleCsdEventListM $ traverse unMix $ evts
src/Csound/Typed/Control/Ref.hs view
@@ -10,6 +10,10 @@  -- | It describes a reference to mutable values. newtype Ref a = Ref [Var]+{-+    { writeRef :: a -> SE ()+    , readRef  :: SE a }+-}  writeRef :: Tuple a => Ref a -> a -> SE () writeRef (Ref vars) a = fromDep_ $ hideGEinDep $ do
src/Csound/Typed/GlobalState.hs view
@@ -2,7 +2,8 @@     module Csound.Typed.GlobalState.Options,     module Csound.Typed.GlobalState.GE,     module Csound.Typed.GlobalState.SE,-    module Csound.Typed.GlobalState.Instr,    +    module Csound.Typed.GlobalState.Instr,+    module Csound.Typed.GlobalState.Cache,         -- * Reexports dynamic         BandLimited(..), readBandLimited, renderBandLimited,     Instrs(..), IdMap(..), getInstrIds,@@ -26,5 +27,6 @@ import Csound.Typed.GlobalState.GE import Csound.Typed.GlobalState.SE import Csound.Typed.GlobalState.Instr+import Csound.Typed.GlobalState.Cache import Csound.Typed.GlobalState.Elements import Csound.Typed.GlobalState.Opcodes
+ src/Csound/Typed/GlobalState/Cache.hs view
@@ -0,0 +1,99 @@+module Csound.Typed.GlobalState.Cache(+    Cache(..), HashKey,    +    -- * Mix+    -- ** Functions+    CacheMix, MixKey(..),+    saveMixKey, getMixKey,+    -- ** Procedures+    CacheMixProc, +    saveMixProcKey, getMixProcKey,+    -- * Evt+    -- ** Functions+    CacheEvt, EvtKey(..),+    saveEvtKey, getEvtKey,+    -- ** Procedures+    CacheEvtProc, +    saveEvtProcKey, getEvtProcKey+) where++import qualified Data.Map as M+import Data.Default++import Csound.Dynamic++data Cache m = Cache +    { cacheMix      :: CacheMix+    , cacheMixProc  :: CacheMixProc m+    , cacheEvt      :: CacheEvt+    , cacheEvtProc  :: CacheEvtProc m }++instance Default (Cache m) where+    def = Cache def def def def++type HashKey = Int++type GetKey  m a b = a -> Cache m -> Maybe b+type SaveKey m a b = a -> b -> Cache m -> Cache m++getKeyMap :: (Ord key) => (Cache m -> M.Map key val) -> GetKey m key val+getKeyMap f key x = M.lookup key $ f x++saveKeyMap :: (Ord key) => (Cache m -> M.Map key val) -> (M.Map key val -> Cache m -> Cache m) -> SaveKey m key val+saveKeyMap getter setter key val cache = setter (M.insert key val $ getter cache) cache++----------------------------------------------------------+-- Mix++-- Mix functions++newtype MixKey = MixKey HashKey+    deriving (Eq, Ord)++type    MixVal = InstrId++type CacheMix = M.Map MixKey MixVal++getMixKey :: GetKey m MixKey MixVal+getMixKey = getKeyMap cacheMix++saveMixKey :: SaveKey m MixKey MixVal+saveMixKey = saveKeyMap cacheMix (\a x -> x { cacheMix = a })++-- Mix procedures++type CacheMixProc m = M.Map MixKey (DepT m ())++getMixProcKey :: GetKey m MixKey (DepT m ())+getMixProcKey = getKeyMap cacheMixProc++saveMixProcKey :: SaveKey m MixKey (DepT m ())+saveMixProcKey = saveKeyMap cacheMixProc (\a x -> x { cacheMixProc = a })++----------------------------------------------------------+-- Evt++-- Evt functions++data EvtKey = EvtKey HashKey HashKey+    deriving (Eq, Ord)++type    EvtVal = InstrId++type CacheEvt = M.Map EvtKey EvtVal++getEvtKey :: GetKey m EvtKey EvtVal+getEvtKey = getKeyMap cacheEvt++saveEvtKey :: SaveKey m EvtKey EvtVal+saveEvtKey = saveKeyMap cacheEvt (\a x -> x { cacheEvt = a })++-- Evt procedures++type CacheEvtProc m = M.Map EvtKey (DepT m ())++getEvtProcKey :: GetKey m EvtKey (DepT m ())+getEvtProcKey = getKeyMap cacheEvtProc++saveEvtProcKey :: SaveKey m EvtKey (DepT m ())+saveEvtProcKey = saveKeyMap cacheEvtProc (\a x -> x { cacheEvtProc = a })+
src/Csound/Typed/GlobalState/Elements.hs view
@@ -18,7 +18,7 @@     Globals(..), newPersistentGlobalVar, newClearableGlobalVar,      renderGlobals,     -- * Instruments-    Instrs(..), newInstrId, saveInstrById, saveInstr, getInstrIds,+    Instrs(..), saveInstr, getInstrIds, -- newInstrId, saveInstrById, saveInstr, CacheName, makeCacheName, saveCachedInstr, getInstrIds,     -- * Src     InstrBody, getIn, sendOut, sendChn, sendGlobal, chnPargId,     Event(..),@@ -26,13 +26,16 @@     subinstr, subinstr_, event_i, event, safeOut, autoOff, changed ) where +import Data.Hashable  import Control.Monad.Trans.State.Strict import Control.Monad(zipWithM_) import Control.Applicative(liftA2) import Data.Default import qualified Data.Map as M+import qualified Data.IntMap as IM + import Csound.Dynamic.Types import Csound.Dynamic.Build import Csound.Dynamic.Build.Numeric()@@ -199,10 +202,10 @@ data MidiKey = MidiKey MidiType Channel     deriving (Show, Eq, Ord) -type MidiMap m = M.Map MidiKey (InstrId -> DepT m ())+type MidiMap m = M.Map MidiKey (DepT m ()) -saveMidiInstr :: Monad m => MidiType -> Channel -> (InstrId -> DepT m ()) -> MidiMap m -> MidiMap m-saveMidiInstr ty chn body = M.insertWith (liftA2 $ flip (>>)) (MidiKey ty chn) body+saveMidiInstr :: Monad m => MidiType -> Channel -> DepT m () -> MidiMap m -> MidiMap m+saveMidiInstr ty chn body = M.insertWith (flip (>>)) (MidiKey ty chn) body  -- global variables @@ -248,19 +251,50 @@ -- instrs  data Instrs = Instrs-    { instrsNewId   :: Int+    { instrsCache   :: IM.IntMap InstrId+    , instrsNewId   :: Int     , instrsContent :: [(InstrId, InstrBody)]     }  instance Default Instrs where-    def = Instrs 18 []+    def = Instrs IM.empty 18 [] +type CacheName = Int++makeCacheName :: Hashable a => a -> CacheName+makeCacheName = hash+ getInstrIds :: Instrs -> [InstrId] getInstrIds = fmap fst . instrsContent  ----------------------------------------------------------------- -- ++saveInstr :: InstrBody -> State Instrs InstrId+saveInstr body = state $ \s -> +    let h = hash body+    in  case IM.lookup h $ instrsCache s of+            Just  n -> (n, s)+            Nothing -> +                let newId = instrsNewId s+                    s1    = s { instrsCache   = IM.insert h (intInstrId newId) $ instrsCache s+                              , instrsNewId   = succ newId+                              , instrsContent = (intInstrId newId, body) : instrsContent s }+                in  (intInstrId newId, s1)++{-+saveCachedInstr :: InstrBody -> State Instrs InstrId +saveCachedInstr name body = state $ \s -> +    case IM.lookup name $ instrsCache s of+        Just n  -> (n, s)+        Nothing -> +            let newId   = instrsNewId s+                s1      = s { instrsCache   = IM.insert name (intInstrId newId) $ instrsCache s+                            , instrsNewId   = succ newId+                            , instrsContent = (intInstrId newId, body) : instrsContent s }+            in  (intInstrId newId, s1)+ newInstrId :: State Instrs InstrId newInstrId = state $ \s ->     let newId   = instrsNewId s@@ -277,6 +311,7 @@     newId <- newInstrId     saveInstrById newId body     return newId+-}  ----------------------------------------------------------------- -- sound sources
src/Csound/Typed/GlobalState/GE.hs view
@@ -10,7 +10,7 @@     saveAlwaysOnInstr, onInstr, saveUserInstr0, getSysExpr,     -- * Total duration     TotalDur(..), pureGetTotalDurForF0, getTotalDurForTerminator, -    setDurationForce, setDuration, setDurationToInfinite,+    setDurationForce, setDuration, setDurationToInfinite,         -- * Notes     addNote,     -- * GEN routines@@ -21,6 +21,8 @@     saveBandLimitedWave,     -- * Strings     saveStr,+    -- * Cache+    GetCache, SetCache, withCache,     -- * Guis     newGuiHandle, saveGuiRoot, saveDefKeybdPanel, appendToGui,      newGuiVar, getPanels, guiHandleToVar,@@ -44,6 +46,7 @@ import Csound.Dynamic   import Csound.Typed.GlobalState.Options+import Csound.Typed.GlobalState.Cache import Csound.Typed.GlobalState.Elements import Csound.Typed.Constants(infiniteDur) @@ -91,11 +94,12 @@     , alwaysOnInstrs    :: [InstrId]     , notes             :: [(InstrId, CsdEvent)]     , userInstr0        :: Dep ()-    , bandLimitedMap    :: BandLimitedMap    +    , bandLimitedMap    :: BandLimitedMap+    , cache             :: Cache GE     , guis              :: Guis }  instance Default History where-    def = History def def def def def def def def def def def def (return ()) def def+    def = History def def def def def def def def def def def def (return ()) def def def  data Msg = Msg data MidiAssign = MidiAssign MidiType Channel InstrId@@ -175,7 +179,7 @@ saveMidi ma = onMidis $ modify (ma: )     where onMidis = onHistory midis (\a h -> h { midis = a }) -saveToMidiInstr :: MidiType -> Channel -> (InstrId -> Dep ()) -> GE ()+saveToMidiInstr :: MidiType -> Channel -> Dep () -> GE () saveToMidiInstr ty chn expr = onMidiMap (saveMidiInstr ty chn expr)     where onMidiMap = modifyHistoryField midiMap (\a h -> h { midiMap = a }) @@ -251,6 +255,33 @@  onGlobals :: UpdField Globals a onGlobals = onHistory globals (\a h -> h { globals = a })++----------------------------------------------------------------------+-- cache++-- midi functions++type GetCache a b = a -> Cache GE -> Maybe b++fromCache :: GetCache a b -> a -> GE (Maybe b)+fromCache f key = withHistory $ f key . cache++type SetCache a b = a -> b -> Cache GE -> Cache GE++toCache :: SetCache a b -> a -> b -> GE () +toCache f key val = modifyHistory $ \h -> h { cache = f key val (cache h) }++withCache :: TotalDur -> GetCache key val -> SetCache key val -> key -> GE val -> GE val+withCache dur lookupResult saveResult key getResult = do    +    ma <- fromCache lookupResult key+    res <- case ma of+        Just a      -> return a+        Nothing     -> do+            r <- getResult+            toCache saveResult key r+            return r+    setTotalDur dur+    return res  -------------------------------------------------------- -- guis
src/Csound/Typed/GlobalState/Instr.hs view
@@ -11,6 +11,7 @@ import Csound.Typed.GlobalState.GE import Csound.Typed.GlobalState.SE import Csound.Typed.GlobalState.Options+import Csound.Typed.GlobalState.Cache import Csound.Typed.GlobalState.Opcodes(turnoff2, exitnow, servantUpdateChnAlive, servantUpdateChnRetrig) import Csound.Typed.GlobalState.Elements(getInstrIds) @@ -31,36 +32,36 @@ retrigWatch :: Arity -> SE () retrigWatch arity = fromDep_ $ servantUpdateChnRetrig (C.chnPargId $ arityIns arity) -saveSourceInstrWithLivenessWatch :: Arity -> InsExp -> GE InstrId-saveSourceInstrWithLivenessWatch arity instr = saveInstr $ do+saveSourceInstrCachedWithLivenessWatch :: Arity -> InsExp -> GE InstrId+saveSourceInstrCachedWithLivenessWatch arity instr = saveInstr $ do     toOut =<< instr     livenessWatch arity      where toOut = SE . C.sendChn (arityIns arity) (arityOuts arity) -saveSourceInstrWithLivenessWatchAndRetrig :: Arity -> InsExp -> GE InstrId-saveSourceInstrWithLivenessWatchAndRetrig arity instr = saveInstr $ do+saveSourceInstrCachedWithLivenessWatchAndRetrig :: Arity -> InsExp -> GE InstrId+saveSourceInstrCachedWithLivenessWatchAndRetrig arity instr = saveInstr $ do     toOut =<< instr     retrigWatch arity     livenessWatch arity         where toOut = SE . C.sendChn (arityIns arity) (arityOuts arity) -saveSourceInstrWithLivenessWatchAndRetrigAndEvtLoop :: Arity -> InsExp -> UnitExp -> GE (InstrId, InstrId)-saveSourceInstrWithLivenessWatchAndRetrigAndEvtLoop arity instr evtInstr = do -    instrId <- saveSourceInstrWithLivenessWatchAndRetrig  arity instr+saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop :: Arity -> InsExp -> UnitExp -> GE (InstrId, InstrId)+saveSourceInstrCachedWithLivenessWatchAndRetrigAndEvtLoop arity instr evtInstr = do +    instrId <- saveSourceInstrCachedWithLivenessWatchAndRetrig arity instr     evtInstrId <- saveInstr (evtInstr >> retrigWatch evtInstrArity >> livenessWatch evtInstrArity)     return (instrId, evtInstrId)     where          evtInstrArity = Arity 0 0         -saveSourceInstr :: Arity -> InsExp -> GE InstrId-saveSourceInstr arity instr = saveInstr $ toOut =<< instr+saveSourceInstrCached :: Arity -> InsExp -> GE InstrId+saveSourceInstrCached arity instr = saveInstr $ toOut =<< instr     where toOut = SE . C.sendChn (arityIns arity) (arityOuts arity) -saveSourceInstr_ :: UnitExp -> GE InstrId-saveSourceInstr_ instr = saveInstr instr+saveSourceInstrCached_ :: UnitExp -> GE InstrId+saveSourceInstrCached_ instr = saveInstr instr -saveSourceInstrWithLivenessWatch_ :: Arity -> UnitExp -> GE InstrId-saveSourceInstrWithLivenessWatch_ arity instr = saveInstr $ +saveSourceInstrCachedWithLivenessWatch_ :: Arity -> UnitExp -> GE InstrId+saveSourceInstrCachedWithLivenessWatch_ arity instr = saveInstr $      instr >> livenessWatch arity  saveEffectInstr :: Arity -> EffExp -> GE InstrId@@ -96,13 +97,11 @@ saveMidiMap :: GE () saveMidiMap = do     m <- fmap midiMap getHistory-    mapM_ (\(C.MidiKey midiType channel, instrExpr) -> saveMidiInstr_ midiType channel (SE . instrExpr)) $ toList m+    mapM_ (\(C.MidiKey midiType channel, instrExpr) -> saveMidiInstr_ midiType channel (SE instrExpr)) $ toList m -saveMidiInstr_ :: C.MidiType -> C.Channel -> (InstrId -> UnitExp) -> GE ()-saveMidiInstr_ midiType channel instr = do-    instrId <- onInstr C.newInstrId-    onInstr . C.saveInstrById instrId =<< execSE (instr instrId)-    -- instrId <- onInstr . C.saveInstr =<< execSE instr+saveMidiInstr_ :: C.MidiType -> C.Channel -> UnitExp -> GE ()+saveMidiInstr_ midiType channel instr = do    +    instrId <- saveInstr instr     saveMidi $ MidiAssign midiType channel instrId     saveIns0 :: Int -> [Rate] -> SE [E] -> GE [E]
src/Csound/Typed/GlobalState/Opcodes.hs view
@@ -28,9 +28,7 @@     midiVolumeFactor ) where - import Prelude hiding ((<*))- import Control.Monad(zipWithM_, forM_) import Data.Boolean @@ -349,12 +347,12 @@ ----------------------------------------------------------- -- midi volume factor (normalize by number of notes) -midiVolumeFactor :: InstrId -> E+midiVolumeFactor :: E -> E midiVolumeFactor idx = flip port 0.0015 $ ifB (n ==* 0) 1 (recip n)     where n = sqrt (active idx) -active :: InstrId -> E    -active instrId = opcs "active" [(Kr, [Ir])] [instrIdE instrId]+active :: E -> E    +active instrId = opcs "active" [(Kr, [Ir])] [instrId]  port :: E -> E -> E port a b = opcs "port" [(Kr, [Kr, Ir])] [a, b]
src/Csound/Typed/GlobalState/Options.hs view
@@ -11,6 +11,7 @@ ) where  import Control.Applicative+import Data.Monoid import Data.Default import qualified Data.IntMap as IM
src/Csound/Typed/Gui/BoxModel.hs view
@@ -9,6 +9,7 @@ import Control.Monad import Control.Monad.Trans.State.Strict import Data.Default+import Data.Monoid  data Interval = Interval      { start :: Int
+ src/Csound/Typed/Lib/StableMaps/Dynamic.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TypeFamilies, Rank2Types #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Mem.StableName.Dynamic+-- Copyright   :  (c) Edward Kmett 2010+-- License     :  BSD3+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  GHC only+--+-- Dynamic stable names are a way of performing fast (O(1)), not-quite-exact comparison between objects.+--+-- Dynamic stable names solve the following problem: suppose you want to build a hash table with Haskell objects as keys, but you want to use pointer equality for comparison; maybe because the keys are large and hashing would be slow, or perhaps because the keys are infinite in size. We can't build a hash table using the address of the object as the key, because objects get moved around by the garbage collector, meaning a re-hash would be necessary after every garbage collection.+-----------------------------------------------------------------------------++module Csound.Typed.Lib.StableMaps.Dynamic +    ( DynamicStableName(..)+    , hashDynamicStableName+    , makeDynamicStableName+    , wrapStableName+    ) where++import GHC.Prim++import System.Mem.StableName (StableName, makeStableName, hashStableName)+import Unsafe.Coerce (unsafeCoerce)++{-|+  An abstract name for an object, that supports equality and hashing.++  Dynamic stable names have the following property:++  * If @sn1 :: DynamicStableName@ and @sn2 :: DynamicStableName@ and @sn1 == sn2@+   then @sn1@ and @sn2@ were created by calls to @makeStableName@ on +   the same object.++  The reverse is not necessarily true: if two dynamic stable names are not+  equal, then the objects they name may still be equal.  Note in particular+  that `makeDynamicStableName` may return a different `DynamicStableName` +  after an object is evaluated.++  Dynamic Stable Names are similar to Stable Pointers ("Foreign.StablePtr"),+  but differ in the following ways:++  * There is no @freeDynamicStableName@ operation, unlike "Foreign.StablePtr"s.+    Dynamic Stable Names are reclaimed by the runtime system when they are no+    longer needed.++  * There is no @deRefDynamicStableName@ operation.  You can\'t get back from+    a dynamic stable name to the original Haskell object.  The reason for+    this is that the existence of a stable name for an object does not+    guarantee the existence of the object itself; it can still be garbage+    collected.++-}++newtype DynamicStableName = DynamicStableName (StableName Any)++-- | Makes a 'DynamicStableName' for an arbitrary object.  The object passed as+-- the first argument is not evaluated by 'makeDynamicStableName'.+makeDynamicStableName :: t -> IO DynamicStableName+makeDynamicStableName a = do+    s <- makeStableName a+    return (wrapStableName s)++-- | Convert a 'DynamicStableName' to an 'Int'.  The 'Int' returned is not+-- necessarily unique; several 'DynamicStableName's may map to the same 'Int'+-- (in practice however, the chances of this are small, so the result+-- of 'hashDynamicStableName' makes a good hash key).+hashDynamicStableName :: DynamicStableName -> Int+hashDynamicStableName (DynamicStableName sn) = hashStableName sn++instance Eq DynamicStableName where+    DynamicStableName sn1 == DynamicStableName sn2 = sn1 == sn2++wrapStableName :: StableName a -> DynamicStableName+wrapStableName s = DynamicStableName (unsafeCoerce s)
+ src/Csound/Typed/Lib/StableMaps/Dynamic/Map.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Unsafe #-}+#endif+module Csound.Typed.Lib.StableMaps.Dynamic.Map+    ( Map+    , empty+    , null+    , singleton+    , member+    , notMember+    , insert+    , insertWith+    , insertWith'+    , lookup+    , find+    , findWithDefault+    ) where++import qualified Prelude+import Prelude hiding (lookup, null)+import Csound.Typed.Lib.StableMaps.Dynamic+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)++newtype Map a = Map { getMap :: IntMap [(DynamicStableName, a)] } ++empty :: Map a+empty = Map IntMap.empty++null :: Map a -> Bool+null (Map m) = IntMap.null m++singleton :: DynamicStableName -> a -> Map a+singleton k v = Map $ IntMap.singleton (hashDynamicStableName k) [(k,v)]++member :: DynamicStableName -> Map a -> Bool+member k m = case lookup k m of+    Nothing -> False+    Just _ -> True++notMember :: DynamicStableName -> Map a -> Bool+notMember k m = not $ member k m ++insert :: DynamicStableName -> a -> Map a -> Map a+insert k v = Map . IntMap.insertWith (++) (hashDynamicStableName k) [(k,v)] . getMap+    +-- | /O(log n)/. Insert with a function for combining the new value and old value.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if the key does not exist+-- in the map. If the key does exist, the function will insert the pair+-- @(key, f new_value old_value)@+insertWith :: (a -> a -> a) -> DynamicStableName -> a -> Map a -> Map a+insertWith f k v = Map . IntMap.insertWith go (hashDynamicStableName k) [(k,v)] . getMap +    where +        go _ ((k',v'):kvs) +            | k == k' = (k', f v v') : kvs+            | otherwise = (k',v') : go undefined kvs+        go _ [] = []++-- | Same as 'insertWith', but with the combining function applied strictly.+insertWith' :: (a -> a -> a) -> DynamicStableName -> a -> Map a -> Map a+insertWith' f k v = Map . IntMap.insertWith go (hashDynamicStableName k) [(k,v)] . getMap +    where +        go _ ((k',v'):kvs) +            | k == k' = let v'' = f v v' in v'' `seq` (k', v'') : kvs+            | otherwise = (k', v') : go undefined kvs+        go _ [] = []++-- | /O(log n)/. Lookup the value at a key in the map.+-- +-- The function will return the corresponding value as a @('Just' value)@+-- or 'Nothing' if the key isn't in the map.+lookup :: DynamicStableName -> Map v -> Maybe v+lookup k (Map m) = do+    pairs <- IntMap.lookup (hashDynamicStableName k) m+    Prelude.lookup k pairs++find :: DynamicStableName -> Map v -> v+find k m = case lookup k m of+    Nothing -> error "Map.find: element not in the map"+    Just x -> x ++-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns the default value @def@+-- when the key is not in the map.+findWithDefault :: v -> DynamicStableName -> Map v -> v+findWithDefault dflt k m = maybe dflt id $ lookup k m