diff --git a/csound-expression-typed.cabal b/csound-expression-typed.cabal --- a/csound-expression-typed.cabal +++ b/csound-expression-typed.cabal @@ -1,6 +1,6 @@ Name: csound-expression-typed -Version: 0.2.7 -Cabal-Version: >= 1.22 +Version: 0.2.7.1 +Cabal-Version: 1.12 License: BSD3 License-file: LICENSE Author: Anton Kholomiov @@ -67,8 +67,9 @@ Library Ghc-Options: -Wall Build-Depends: - base >= 4.6, + base >= 4.10, base < 5, + bytestring, ghc-prim, containers, transformers >= 0.3, @@ -79,10 +80,11 @@ NumInstances, filepath, directory, - wl-pprint >= 1.2.1, - csound-expression-dynamic >= 0.3.8, + wl-pprint-text >= 1.2.0, + csound-expression-dynamic >= 0.3.9.1, temporal-media >= 0.6.3, - hashable + hashable, + text Hs-Source-Dirs: src/ Exposed-Modules: Csound.Typed @@ -99,12 +101,12 @@ Csound.Typed.Types.Tuple Csound.Typed.Types.Lift Csound.Typed.Types.Array + Csound.Typed.Types.PureArray Csound.Typed.Types.MonoArg Csound.Typed.Types.SigSpace Csound.Typed.Plugins - Other-Modules: Csound.Typed.GlobalState Csound.Typed.GlobalState.Options Csound.Typed.GlobalState.GE @@ -163,4 +165,8 @@ Default-Language: Haskell2010 Default-extensions: + ImportQualifiedPost LambdaCase + OverloadedStrings + ScopedTypeVariables + TypeApplications diff --git a/src/Csound/Typed/Control.hs b/src/Csound/Typed/Control.hs --- a/src/Csound/Typed/Control.hs +++ b/src/Csound/Typed/Control.hs @@ -1,3 +1,4 @@ +{-# Language ScopedTypeVariables #-} module Csound.Typed.Control ( -- * SE module Csound.Typed.GlobalState.SE, @@ -25,12 +26,13 @@ module Csound.Typed.Control.Vco, -- * Imperative instruments module Csound.Typed.Control.InstrRef, - -- * Array folding and traversals + -- * Array folding and traversals module Csound.Typed.Control.ArrayTraverse, -- * Reads global config arguments from command line module Csound.Typed.Control.MacrosArgs ) where +import Data.Proxy import Csound.Typed.GlobalState.SE import Csound.Typed.Control.Ref @@ -49,23 +51,14 @@ import Csound.Typed.Types import Csound.Typed.GlobalState -instr0 :: Tuple a => SE a -> SE a -instr0 a = return $ toTuple $ saveIns0 ins0Arity (tupleRates $ proxy a) ins0Exp +instr0 :: forall a. Tuple a => SE a -> SE a +instr0 a = return $ toTuple $ saveIns0 ins0Arity (tupleRates (Proxy :: Proxy a)) ins0Exp where ins0Exp = execGEinSE $ fmap fromTuple a - - ins0Arity = tupleArity $ proxy a - - proxy :: Tuple a => SE a -> a - proxy = const (toTuple $ return $ repeat undefined) - -getIns :: Sigs a => SE a -getIns = res - where - res = fmap toTuple $ fromDep $ getIn (tupleArity $ proxy res) + ins0Arity = tupleArity (Proxy :: Proxy a) - proxy :: SE a -> a - proxy = const undefined +getIns :: forall a. Sigs a => SE a +getIns = fmap toTuple $ fromDep $ getIn (tupleArity (Proxy :: Proxy a)) -- | Sets the global duration of the file or output signal to the given value. -- It should be used only once! The proper place is in the top-most @@ -79,4 +72,4 @@ -- | Gets new id. freshId :: SE D -freshId = SE $ fmap fromE freeChn +freshId = SE $ fmap fromE freeChn diff --git a/src/Csound/Typed/Control/Api.hs b/src/Csound/Typed/Control/Api.hs --- a/src/Csound/Typed/Control/Api.hs +++ b/src/Csound/Typed/Control/Api.hs @@ -14,6 +14,7 @@ import Csound.Typed.GlobalState import Csound.Typed.GlobalState.Opcodes(eventi, Event(..), downsamp) import Csound.Typed.InnerOpcodes +import Data.Text (Text) import Csound.Typed.Plugins.TabQueue @@ -23,7 +24,7 @@ -- With Csound API we can send messages -- -- > i "name" time duration arg1 arg2 arg3 -trigByName_ :: Arg a => String -> (a -> SE ()) -> SE () +trigByName_ :: Arg a => Text -> (a -> SE ()) -> SE () trigByName_ name instr = geToSe $ saveNamedInstr name =<< (execSE $ instr toArg) -- | Creates an instrument that can be triggered by name with Csound API. @@ -33,7 +34,7 @@ -- @p1@ is the name of teh instrument, @p2@ is the start time of the note, -- @p3@ is the duration of the note. Then @p4@ and @p5@ are going to be doubles and @p6@ -- is an integer that denotes a functional table. -trigByName :: (Arg a, Sigs b) => String -> (a -> SE b) -> SE b +trigByName :: (Arg a, Sigs b) => Text -> (a -> SE b) -> SE b trigByName name instr = do ref <- newClearableGlobalRef 0 trigByName_ name (go ref) @@ -43,7 +44,7 @@ -- | It behaves just like the function @trigByNameMidi@. Only it doesn't produce an audio -- signal. It performs some procedure on note on and stops doing the precedure on note off. -trigByNameMidi_ :: forall a . Arg a => String -> ((D, D, a) -> SE ()) -> SE () +trigByNameMidi_ :: forall a . Arg a => Text -> ((D, D, a) -> SE ()) -> SE () trigByNameMidi_ name instr = do instrId <- geToSe $ saveInstr (instr toArg) trigByName_ name (go instrId) @@ -55,10 +56,10 @@ noteFlagExpr <- toGE noteFlag args <- fromTuple (pch, vol, other) return $ do - D.when1 D.Ir (noteFlagExpr ==* 1) $ do - eventi (Event instrIdExpr 0 (-1) args) - D.when1 D.Ir (noteFlagExpr ==* 0) $ do - eventi (Event (negate instrIdExpr) 0 0 args) + D.when1 D.IfIr (noteFlagExpr ==* 1) $ do + D.toBlock $ eventi (Event instrIdExpr 0 (-1) args) + D.when1 D.IfIr (noteFlagExpr ==* 0) $ do + D.toBlock $ eventi (Event (negate instrIdExpr) 0 0 args) turnoff -- | Creates an instrument that can be triggered by name with Csound API. @@ -87,14 +88,14 @@ -- Csound procedure invokes: -- -- > turnoff 18.pitchKey -trigByNameMidi :: (Arg a, Sigs b) => String -> ((D, D, a) -> SE b) -> SE b +trigByNameMidi :: (Arg a, Sigs b) => Text -> ((D, D, a) -> SE b) -> SE b trigByNameMidi name instr = do ref <- newClearableGlobalRef 0 trigByNameMidi_ name (go ref) readRef ref where go ref x = mixRef ref =<< instr x -namedMonoMsg :: String -> SE MonoArg +namedMonoMsg :: Text -> SE MonoArg namedMonoMsg name = do refPch <- newGlobalRef 0 refVol <- newGlobalRef 0 @@ -118,7 +119,7 @@ onNote = tabQueue2_append offNote tab (pch, _vol) = tabQueue2_delete tab pch -trigByNameMidiCbk :: String -> ((D, D) -> SE ()) -> ((D, D) -> SE ()) -> SE () +trigByNameMidiCbk :: Text -> ((D, D) -> SE ()) -> ((D, D) -> SE ()) -> SE () trigByNameMidiCbk name noteOn noteOff = trigByName_ name go where diff --git a/src/Csound/Typed/Control/ArrayTraverse.hs b/src/Csound/Typed/Control/ArrayTraverse.hs --- a/src/Csound/Typed/Control/ArrayTraverse.hs +++ b/src/Csound/Typed/Control/ArrayTraverse.hs @@ -5,6 +5,7 @@ foldArr, foldRowArr, foldColumnArr, foldRowsArrD, foldColumnsArrD ) where +import Data.Proxy import Csound.Typed.Types import Csound.Typed.Control.Ref import Csound.Typed.GlobalState @@ -56,10 +57,7 @@ fromDep_ D.whileEnd - arity = tupleArity $ proxy array - - proxy :: Arr ix a -> ix - proxy = const undefined + arity = tupleArity (Proxy :: Proxy ix) concatRefs :: [Ref b] -> Ref ix concatRefs vs = Ref $ vs >>= \(Ref xs) -> xs diff --git a/src/Csound/Typed/Control/Instr.hs b/src/Csound/Typed/Control/Instr.hs --- a/src/Csound/Typed/Control/Instr.hs +++ b/src/Csound/Typed/Control/Instr.hs @@ -1,3 +1,4 @@ +{-# Language ScopedTypeVariables #-} -- | Converts to low-level instruments module Csound.Typed.Control.Instr( Arity(..), InsExp, EffExp, @@ -6,19 +7,15 @@ apInstr, apInstr0 ) where +import Data.Proxy import Csound.Dynamic(InstrId(..)) import qualified Csound.Typed.GlobalState.Elements as C import Csound.Typed.Types import Csound.Typed.GlobalState -funProxy :: (a -> f b) -> (a, b) -funProxy = const (msg, msg) - where msg = error "I'm a Csound.Typed.Control.Instr.funProxy" - -funArity :: (Tuple a, Tuple b) => (a -> SE b) -> Arity -funArity instr = Arity (tupleArity a) (tupleArity b) - where (a, b) = funProxy instr +funArity :: forall a b. (Tuple a, Tuple b) => (a -> SE b) -> Arity +funArity _instr = Arity (tupleArity (Proxy :: Proxy a)) (tupleArity (Proxy :: Proxy b)) constArity :: (Tuple a) => SE a -> Arity constArity a = Arity 0 (outArity a) @@ -38,13 +35,12 @@ unitExp :: SE Unit -> UnitExp unitExp = execGEinSE . fmap unUnit -apInstr :: (Arg a, Sigs b) => GE InstrId -> a -> b -apInstr instrIdGE args = res - where - res = toTuple $ do - instrId <- instrIdGE - argList <- fromTuple args - return $ C.subinstr (tupleArity res) instrId argList +apInstr :: forall a b. (Arg a, Sigs b) => GE InstrId -> a -> b +apInstr instrIdGE args = + toTuple $ do + instrId <- instrIdGE + argList <- fromTuple args + return $ C.subinstr (tupleArity (Proxy :: Proxy b)) instrId argList apInstr0 :: (Sigs b) => GE InstrId -> b apInstr0 instrId = apInstr instrId unit diff --git a/src/Csound/Typed/Control/MacrosArgs.hs b/src/Csound/Typed/Control/MacrosArgs.hs --- a/src/Csound/Typed/Control/MacrosArgs.hs +++ b/src/Csound/Typed/Control/MacrosArgs.hs @@ -5,12 +5,13 @@ import Csound.Typed.Types import qualified Csound.Typed.GlobalState as G(readMacrosString, readMacrosDouble, readMacrosInt) +import Data.Text (Text) -readMacrosString :: String -> String -> Str +readMacrosString :: Text -> Text -> Str readMacrosString name value = fromGE $ G.readMacrosString name value -readMacrosDouble :: String -> Double -> D +readMacrosDouble :: Text -> Double -> D readMacrosDouble name value = fromGE $ G.readMacrosDouble name value -readMacrosInt :: String -> Int -> D +readMacrosInt :: Text -> Int -> D readMacrosInt name value = fromGE $ G.readMacrosInt name value diff --git a/src/Csound/Typed/Control/Mix.hs b/src/Csound/Typed/Control/Mix.hs --- a/src/Csound/Typed/Control/Mix.hs +++ b/src/Csound/Typed/Control/Mix.hs @@ -13,6 +13,7 @@ Sco, CsdEventList, CsdEvent ) where +import Data.Proxy import Data.Boolean import Control.Monad.IO.Class @@ -158,17 +159,11 @@ toEventList :: Sco (Mix a) -> GE (CsdEventList M) toEventList evts = fmap delayAndRescaleCsdEventListM $ traverse unMix $ evts -mixArity :: Sigs b => f (Mix b) -> Int -mixArity = tupleArity . proxy - where - proxy :: f (Mix b) -> b - proxy = const undefined +mixArity :: forall b f. Sigs b => f (Mix b) -> Int +mixArity _ = tupleArity (Proxy :: Proxy b) -mixArityFun :: Sigs b => (a -> f (Mix b)) -> Int -mixArityFun = tupleArity . proxy - where - proxy :: (a -> f (Mix b)) -> b - proxy = const undefined +mixArityFun :: forall a b f. Sigs b => (a -> f (Mix b)) -> Int +mixArityFun _ = tupleArity (Proxy :: Proxy b) ----------------------------------------------------------- -- instances diff --git a/src/Csound/Typed/Control/Ref.hs b/src/Csound/Typed/Control/Ref.hs --- a/src/Csound/Typed/Control/Ref.hs +++ b/src/Csound/Typed/Control/Ref.hs @@ -9,6 +9,7 @@ ) where import Data.Boolean +import Data.Proxy import Control.Monad import Control.Monad.Trans.Class @@ -42,19 +43,18 @@ -- | Allocates a new local (it is visible within the instrument) mutable value and initializes it with value. -- A reference can contain a tuple of variables. -newRef :: Tuple a => a -> SE (Ref a) -newRef t = fmap Ref $ newLocalVars (tupleRates t) (fromTuple t) +newRef :: forall a. Tuple a => a -> SE (Ref a) +newRef t = fmap Ref $ newLocalVars (tupleRates (Proxy :: Proxy a)) (fromTuple t) -- | Allocates a new local (it is visible within the instrument) mutable value and initializes it with value. -- A reference can contain a tuple of variables. -- It contains control signals (k-rate) and constants for numbers (i-rates). -newCtrlRef :: Tuple a => a -> SE (Ref a) -newCtrlRef t = fmap Ref $ newLocalVars (fmap toCtrlRate $ tupleRates t) (fromTuple t) +newCtrlRef :: forall a. Tuple a => a -> SE (Ref a) +newCtrlRef t = fmap Ref $ newLocalVars (fmap toCtrlRate $ tupleRates (Proxy :: Proxy a)) (fromTuple t) toCtrlRate :: Rate -> Rate toCtrlRate x = case x of Ar -> Kr - Kr -> Ir _ -> x concatRef :: (Tuple a, Tuple b) => Ref a -> Ref b -> Ref (a, b) @@ -85,19 +85,19 @@ -- to mutable value but a pair of reader and writer functions. sensorsSE :: Tuple a => a -> SE (SE a, a -> SE ()) sensorsSE a = do - ref <- newRef a + ref <- newCtrlRef a return $ (readRef ref, writeRef ref) -- | Allocates a new global mutable value and initializes it with value. -- A reference can contain a tuple of variables. -newGlobalRef :: Tuple a => a -> SE (Ref a) -newGlobalRef t = fmap Ref $ newGlobalVars (tupleRates t) (fromTuple t) +newGlobalRef :: forall a. Tuple a => a -> SE (Ref a) +newGlobalRef t = fmap Ref $ newGlobalVars (tupleRates (Proxy :: Proxy a)) (fromTuple t) -- | Allocates a new global mutable value and initializes it with value. -- A reference can contain a tuple of variables. -- It contains control signals (k-rate) and constants for numbers (i-rates). -newGlobalCtrlRef :: Tuple a => a -> SE (Ref a) -newGlobalCtrlRef t = fmap Ref $ newGlobalVars (fmap toCtrlRate $ tupleRates t) (fromTuple t) +newGlobalCtrlRef :: forall a . Tuple a => a -> SE (Ref a) +newGlobalCtrlRef t = fmap Ref $ newGlobalVars (fmap toCtrlRate $ tupleRates (Proxy :: Proxy a)) (fromTuple t) -- | An alias for the function @newRef@. It returns not the reference -- to mutable value but a pair of reader and writer functions. @@ -110,8 +110,8 @@ -- A reference can contain a tuple of variables. -- The variable is set to zero at the end of every iteration. -- It's useful for accumulation of audio values from several instruments. -newClearableGlobalRef :: Tuple a => a -> SE (Ref a) -newClearableGlobalRef t = fmap Ref $ newClearableGlobalVars (tupleRates t) (fromTuple t) +newClearableGlobalRef :: forall a . Tuple a => a -> SE (Ref a) +newClearableGlobalRef t = fmap Ref $ newClearableGlobalVars (tupleRates (Proxy :: Proxy a)) (fromTuple t) ------------------------------------------------------------------------------- -- writable tables diff --git a/src/Csound/Typed/Control/Sf2.hs b/src/Csound/Typed/Control/Sf2.hs --- a/src/Csound/Typed/Control/Sf2.hs +++ b/src/Csound/Typed/Control/Sf2.hs @@ -5,6 +5,7 @@ import Data.Boolean import Data.Default +import Data.Text (Text) import qualified Csound.Dynamic as D @@ -13,12 +14,12 @@ -- | The sf2 sound font preset. It is defined with -- file name, bank and program integers. -data Sf = Sf - { sfName :: String +data Sf = Sf + { sfName :: Text , sfBank :: Int - , sfProg :: Int } + , sfProg :: Int } | SfId (GE E) - + instance Val Sf where fromGE = SfId toGE = unSf @@ -28,9 +29,9 @@ SfId a -> a Sf name bank prog -> fmap D.int $ saveSf (SfSpec name bank prog) -instance Default Sf where +instance Default Sf where def = fromE 0 type instance BooleanOf Sf = BoolD -instance IfB Sf where ifB = on3 ifB +instance IfB Sf where ifB = on3 (D.ifExp D.IfIr) diff --git a/src/Csound/Typed/GlobalState/Elements.hs b/src/Csound/Typed/GlobalState/Elements.hs --- a/src/Csound/Typed/GlobalState/Elements.hs +++ b/src/Csound/Typed/GlobalState/Elements.hs @@ -49,12 +49,12 @@ ) where import Data.List -import Data.Hashable +import Data.ByteString (ByteString) import Control.Monad.Trans.State.Strict import Control.Monad(zipWithM_) import Data.Default -import qualified Data.Map as M +import qualified Data.Map.Strict as M import qualified Data.IntMap as IM import Csound.Dynamic.Types hiding (genId) @@ -62,6 +62,8 @@ import Csound.Dynamic.Build.Numeric() import Csound.Typed.GlobalState.Opcodes +import Data.Text (Text) +import Data.Text qualified as Text -- tables of identifiers @@ -156,9 +158,9 @@ -- strings -type StringMap = IdMap String +type StringMap = IdMap Text -newString :: String -> State StringMap Prim +newString :: Text -> State StringMap Prim newString = fmap PrimInt . saveId -- gen counter @@ -173,7 +175,7 @@ , sfVars :: [Var] } data SfSpec = SfSpec - { sfName :: String + { sfName :: Text , sfBank :: Int , sfProgram :: Int } deriving (Eq, Ord, Show) @@ -186,22 +188,24 @@ sfVar :: Int -> E sfVar n = readOnlyVar (VarVerbatim Ir $ sfEngineName n) -sfEngineName :: Int -> String -sfEngineName n = "gi_Sf_engine_" ++ show n +sfEngineName :: Int -> Text +sfEngineName n = "gi_Sf_engine_" <> Text.pack (show n) -sfInstrName :: Int -> String -sfInstrName n = "i_Sf_instr_" ++ show n +sfInstrName :: Int -> Text +sfInstrName n = "i_Sf_instr_" <> Text.pack (show n) renderSf :: Monad m => SfSpec -> Int -> DepT m () renderSf (SfSpec name bank prog) n = verbatim $ - engineStr ++ "\n" ++ - loadStr ++ "\n" ++ - selectProgStr ++ "\n" + Text.unlines + [ engineStr + , loadStr + , selectProgStr + ] where - engineStr = engineName ++ " fluidEngine" - loadStr = insName ++ " fluidLoad \"" ++ name ++ "\", " ++ engineName ++ ", 1" - selectProgStr = "fluidProgramSelect " ++ engineName ++ ", 1, " ++ insName - ++ ", " ++ show bank ++ ", " ++ show prog + engineStr = engineName <> " fluidEngine" + loadStr = insName <> " fluidLoad \"" <> name <> "\", " <> engineName <> ", 1" + selectProgStr = "fluidProgramSelect " <> engineName <> ", 1, " <> insName + <> ", " <> Text.pack (show bank) <> ", " <> Text.pack (show prog) engineName = sfEngineName n insName = sfInstrName n @@ -220,7 +224,7 @@ UserBandLimitedWave userId -> noRate $ ReadVar $ bandLimitedVar userId bandLimitedVar :: Show a => a -> Var -bandLimitedVar userId = Var GlobalVar Ir ("BandLim" ++ show userId) +bandLimitedVar userId = Var GlobalVar Ir ("BandLim" <> Text.pack (show userId)) data BandLimitedMap = BandLimitedMap { simpleBandLimitedMap :: M.Map BandLimited BandLimitedId @@ -271,7 +275,7 @@ renderVcoVarAssignment genId freeVcoVar = Var GlobalVar Ir "free_vco" - ftVar n = Var GlobalVar Ir $ "vco_table_" ++ show n + ftVar n = Var GlobalVar Ir $ "vco_table_" <> Text.pack (show n) renderFtgen lastGenId (g, n) = writeVar (ftVar n) $ ftgen (int $ lastGenId + n) g @@ -343,13 +347,13 @@ bpmVar :: Var bpmVar = Var GlobalVar Kr bpmVarName -bpmVarName :: String +bpmVarName :: Text bpmVarName = "gBpmVar" newGlobalVar :: GlobalVarType -> Rate -> E -> State Globals Var newGlobalVar ty rate initVal = state $ \s -> let newId = globalsNewId s - var = Var GlobalVar rate ('g' : show newId) + var = Var GlobalVar rate (Text.cons 'g' (Text.pack $ show newId)) s1 = s { globalsNewId = succ newId , globalsVars = AllocVar ty var initVal : globalsVars s } in (var, s1) @@ -363,7 +367,7 @@ newPersistentGloabalArrVar :: Rate -> [E] -> State Globals Var newPersistentGloabalArrVar rate sizes = state $ \s -> let newId = globalsNewId s - var = Var GlobalVar rate ('g' : show newId) + var = Var GlobalVar rate (Text.cons 'g' (Text.pack $ show newId)) s1 = s { globalsNewId = succ newId , globalsVars = AllocArrVar var sizes : globalsVars s } in (var, s1) @@ -392,13 +396,13 @@ -- instrs data Instrs = Instrs - { instrsCache :: IM.IntMap InstrId + { instrsCache :: M.Map ByteString InstrId , instrsNewId :: Int , instrsContent :: [(InstrId, InstrBody)] } instance Default Instrs where - def = Instrs IM.empty 18 [] + def = Instrs M.empty 18 [] getInstrIds :: Instrs -> [InstrId] getInstrIds = fmap fst . instrsContent @@ -406,58 +410,27 @@ ----------------------------------------------------------------- -- - saveInstr :: InstrBody -> State Instrs InstrId saveInstr body = state $ \s -> - let h = hash body - in case IM.lookup h $ instrsCache s of + let h = hashE body + in case M.lookup h $ instrsCache s of Just n -> (n, s) Nothing -> let newId = instrsNewId s - s1 = s { instrsCache = IM.insert h (intInstrId newId) $ instrsCache s + s1 = s { instrsCache = M.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 - s1 = s { instrsNewId = succ newId } - in (intInstrId newId, s1) - -saveInstrById :: InstrId -> InstrBody -> State Instrs () -saveInstrById instrId body = state $ \s -> - let s1 = s { instrsContent = (instrId, body) : instrsContent s } - in ((), s1) - -saveInstr :: InstrBody -> State Instrs InstrId -saveInstr body = do - newId <- newInstrId - saveInstrById newId body - return newId --} - ----------------------------------------------------------------- -- named instrs -newtype NamedInstrs = NamedInstrs { unNamedInstrs :: [(String, InstrBody)] } +newtype NamedInstrs = NamedInstrs { unNamedInstrs :: [(Text, InstrBody)] } instance Default NamedInstrs where def = NamedInstrs [] -saveNamedInstr :: String -> InstrBody -> State NamedInstrs () +saveNamedInstr :: Text -> InstrBody -> State NamedInstrs () saveNamedInstr name body = state $ \(NamedInstrs xs) -> ((), NamedInstrs $ (name, body) : xs) ----------------------------------------------------------------- @@ -528,12 +501,12 @@ ---------------------------------------------------------- -- macros arguments -type MacrosInits = M.Map String MacrosInit +type MacrosInits = M.Map Text MacrosInit data MacrosInit - = MacrosInitDouble { macrosInitName :: String, macrosInitValueDouble :: Double } - | MacrosInitString { macrosInitName :: String, macrosInitValueString :: String } - | MacrosInitInt { macrosInitName :: String, macrosInitValueInt :: Int } + = MacrosInitDouble { macrosInitName :: Text, macrosInitValueDouble :: Double } + | MacrosInitString { macrosInitName :: Text, macrosInitValueString :: Text } + | MacrosInitInt { macrosInitName :: Text, macrosInitValueInt :: Int } deriving (Show, Eq, Ord) initMacros :: MacrosInit -> State MacrosInits () @@ -542,12 +515,12 @@ -------------------------------------------------------- -- Udo plugins -newtype UdoPlugin = UdoPlugin { unUdoPlugin :: String } +newtype UdoPlugin = UdoPlugin { unUdoPlugin :: Text } addUdoPlugin :: UdoPlugin -> State [UdoPlugin] () addUdoPlugin a = modify (a :) -getUdoPluginNames :: [UdoPlugin] -> [String] +getUdoPluginNames :: [UdoPlugin] -> [Text] getUdoPluginNames xs = nub (fmap unUdoPlugin xs) -- tabQueue diff --git a/src/Csound/Typed/GlobalState/GE.hs b/src/Csound/Typed/GlobalState/GE.hs --- a/src/Csound/Typed/GlobalState/GE.hs +++ b/src/Csound/Typed/GlobalState/GE.hs @@ -52,6 +52,8 @@ import Control.Monad import Data.Boolean import Data.Default +import Data.Text (Text) +import Data.Text qualified as Text import qualified Data.IntMap as IM import qualified Data.Map as M @@ -93,39 +95,39 @@ fmap f = GE . fmap f . unGE instance Applicative GE where - pure = return + pure = GE . return (<*>) = ap instance Monad GE where - return = GE . return ma >>= mf = GE $ unGE ma >>= unGE . mf instance MonadIO GE where liftIO = GE . liftIO . liftIO data History = History - { genMap :: GenMap - , writeGenMap :: WriteGenMap - , globalGenCounter :: Int - , stringMap :: StringMap - , sfMap :: SfMap - , midiMap :: MidiMap GE - , globals :: Globals - , instrs :: Instrs - , udoPlugins :: [UdoPlugin] - , namedInstrs :: NamedInstrs - , midis :: [MidiAssign] - , midiCtrls :: [MidiCtrl] - , totalDur :: Maybe TotalDur - , alwaysOnInstrs :: [InstrId] - , notes :: [(InstrId, CsdEvent)] - , userInstr0 :: Dep () - , bandLimitedMap :: BandLimitedMap - , cache :: Cache GE - , guis :: Guis - , oscListenPorts :: OscListenPorts - , cabbageGui :: Maybe Cabbage.Lang - , macrosInits :: MacrosInits } + { genMap :: !GenMap + , writeGenMap :: !WriteGenMap + , globalGenCounter :: !Int + , stringMap :: !StringMap + , sfMap :: !SfMap + , midiMap :: !(MidiMap GE) + , globals :: !Globals + , instrs :: !Instrs + , udoPlugins :: ![UdoPlugin] + , namedInstrs :: !NamedInstrs + , midis :: ![MidiAssign] + , midiCtrls :: ![MidiCtrl] + , totalDur :: !(Maybe TotalDur) + , alwaysOnInstrs :: ![InstrId] + , notes :: ![(InstrId, CsdEvent)] + , userInstr0 :: !(Dep ()) + , bandLimitedMap :: !BandLimitedMap + , cache :: !(Cache GE) + , guis :: !Guis + , oscListenPorts :: !OscListenPorts + , cabbageGui :: !(Maybe Cabbage.Lang) + , macrosInits :: !MacrosInits + } instance Default History where def = History def def def def def def def def def def def def def def def (return ()) def def def def def def @@ -175,7 +177,7 @@ setDurationForce :: E -> GE () setDurationForce = setTotalDur . ExpDur -saveStr :: String -> GE E +saveStr :: Text -> GE E saveStr = fmap prim . onStringMap . newString where onStringMap = onHistory stringMap (\val h -> h{ stringMap = val }) @@ -300,7 +302,7 @@ ---------------------------------------------------------------------- -- named instruments -saveNamedInstr :: String -> InstrBody -> GE () +saveNamedInstr :: Text -> InstrBody -> GE () saveNamedInstr name body = onNamedInstrs $ E.saveNamedInstr name body where onNamedInstrs = onHistory namedInstrs (\a h -> h { namedInstrs = a }) @@ -354,7 +356,7 @@ in (GuiHandle n, h{ guis = g' }) guiHandleToVar :: GuiHandle -> Var -guiHandleToVar (GuiHandle n) = Var GlobalVar Ir ('h' : show n) +guiHandleToVar (GuiHandle n) = Var GlobalVar Ir (Text.cons 'h' $ Text.pack $ show n) newGuiVar :: GE (Var, GuiHandle) newGuiVar = liftA2 (,) (onGlobals $ newPersistentGlobalVar Kr 0) newGuiHandle @@ -507,12 +509,12 @@ keyEventInstrBody keyMap = execDepT $ do let keys = flKeyIn isChange = changed keys ==* 1 - when1 Kr isChange $ do - whens Kr (fmap (uncurry $ listenEvt keys) events) doNothing + when1 IfKr isChange $ do + toBlock $ whens IfKr (fmap (uncurry $ listenEvt keys) events) (toBlock doNothing) where doNothing = return () - listenEvt keySig keyCode var = (keySig ==* int keyCode, writeVar var 1) + listenEvt keySig keyCode var = (keySig ==* int keyCode, toBlock $ writeVar var 1) events = IM.toList keyMap @@ -569,16 +571,16 @@ ----------------------------------------------- -- read macros -readMacrosDouble :: String -> Double -> GE E +readMacrosDouble :: Text -> Double -> GE E readMacrosDouble = readMacrosBy D.readMacrosDouble MacrosInitDouble -readMacrosString :: String -> String -> GE E +readMacrosString :: Text -> Text -> GE E readMacrosString = readMacrosBy D.readMacrosString MacrosInitString -readMacrosInt :: String -> Int -> GE E +readMacrosInt :: Text -> Int -> GE E readMacrosInt = readMacrosBy D.readMacrosInt MacrosInitInt -readMacrosBy :: (String -> E) -> (String -> a -> MacrosInit) -> String -> a -> GE E +readMacrosBy :: (Text -> E) -> (Text -> a -> MacrosInit) -> Text -> a -> GE E readMacrosBy extract allocator name initValue = do onMacrosInits $ initMacros $ allocator name initValue return $ extract name @@ -591,13 +593,9 @@ addUdoPlugin p = onUdo (E.addUdoPlugin p) where onUdo = onHistory udoPlugins (\val h -> h{ udoPlugins = val }) -renderUdoPlugins :: History -> IO String -renderUdoPlugins h = fmap concat $ mapM getUdoPluginBody $ getUdoPluginNames $ udoPlugins h - -getUdoPluginBody :: String -> IO String -getUdoPluginBody name = readFile =<< getDataFileName filename - where filename = concat ["data/opcodes/", name, ".udo"] - - - +renderUdoPlugins :: History -> IO Text +renderUdoPlugins h = fmap mconcat $ mapM getUdoPluginBody $ getUdoPluginNames $ udoPlugins h +getUdoPluginBody :: Text -> IO Text +getUdoPluginBody name = fmap Text.pack $ readFile =<< getDataFileName filename + where filename = concat ["data/opcodes/", Text.unpack name, ".udo"] diff --git a/src/Csound/Typed/GlobalState/Opcodes.hs b/src/Csound/Typed/GlobalState/Opcodes.hs --- a/src/Csound/Typed/GlobalState/Opcodes.hs +++ b/src/Csound/Typed/GlobalState/Opcodes.hs @@ -37,11 +37,14 @@ downsamp ) where +import Control.Monad import Prelude hiding ((<*)) import Control.Monad(zipWithM_, forM_) import Data.Boolean import Csound.Dynamic +import Data.Text (Text) +import Data.Text qualified as Text -- channels @@ -88,8 +91,8 @@ servantUpdateChnAlive pargId = do let sName = chnAliveName (pn pargId) kAlive <- chngetK sName - when1 Kr (kAlive <* -10) $ do - turnoff + when1 IfKr (kAlive <* -10) $ do + toBlock turnoff chnsetK sName (kAlive - 1) getRetrigVal :: Int -> E @@ -100,14 +103,14 @@ let sName = chnRetrigName (pn pargId) let retrigVal = pn $ pargId + 1 kRetrig <- chngetK sName - when1 Kr (kRetrig /=* retrigVal) $ do - turnoff + when1 IfKr (kRetrig /=* retrigVal) $ do + toBlock turnoff servantUpdateChnEvtLoop :: Monad m => Int -> DepT m () servantUpdateChnEvtLoop pargId = do let sName = chnEvtLoopName (pn pargId) kEvtLoop <- chngetK sName - chnsetK sName (ifB (kEvtLoop ==* 0) 1 0) + chnsetK sName (ifExp IfKr (kEvtLoop ==* 0) 1 0) turnoff readChnEvtLoop :: Monad m => ChnRef -> DepT m E @@ -151,15 +154,15 @@ chnclear name = depT_ $ opcs "chnclear" [(Xr, [Sr])] [name] chnUpdateUdo :: Monad m => DepT m () -chnUpdateUdo = verbatim $ unlines [ +chnUpdateUdo = verbatim $ Text.unlines [ "giPort init 1", - "opcode " ++ chnUpdateOpcodeName ++ ", i, 0", + "opcode " <> chnUpdateOpcodeName <> ", i, 0", "xout giPort", "giPort = giPort + 1", "endop"] -chnUpdateOpcodeName :: String +chnUpdateOpcodeName :: Text chnUpdateOpcodeName = "FreePort" freeChn :: Monad m => DepT m E @@ -185,7 +188,7 @@ event_i :: Monad m => Event -> DepT m () event_i = eventBy "event_i" Ir -eventBy :: Monad m => String -> Rate -> Event -> DepT m () +eventBy :: Monad m => Text -> Rate -> Event -> DepT m () eventBy name rate a = depT_ $ opcs name [(Xr, Sr : repeat rate)] (str "i" : (eventInstrId a) : (eventStart a) : (eventDur a) : (eventArgs a)) @@ -231,8 +234,8 @@ autoOff :: Monad m => E -> [E] -> DepT m [E] autoOff dt a = do ihold - when1 Kr (trig a) - turnoff + when1 IfKr (trig a) $ + toBlock turnoff return a where trig = (<* eps) . (env + ) . setRate Kr . flip follow dt . l2 @@ -300,13 +303,13 @@ ftgen :: E -> Gen -> E ftgen n g = opcs "ftgen" [(Ir, repeat Ir)] $ [n, 0, int $ genSize g, genIdE $ genId g] - ++ (maybe [] (return . str) $ genFile g) + ++ (maybe [] (return . prim . PrimString) $ genFile g) ++ (fmap double $ genArgs g) genIdE :: GenId -> E genIdE = \case IntGenId n -> int n - StringGenId a -> str a + StringGenId a -> prim (PrimString a) vco2init :: [E] -> E vco2init = opcs "vco2init" [(Ir, repeat Ir)] @@ -368,8 +371,8 @@ ----------------------------------------------------------- -- soundfonts -sfload :: Monad m => String -> DepT m E -sfload fileName = depT $ opcs "sfload" [(Ir, [Sr])] [str fileName] +sfload :: Monad m => Text -> DepT m E +sfload fileName = depT $ opcs "sfload" [(Ir, [Sr])] [prim $ PrimString fileName] sfplist :: Monad m => E -> DepT m () sfplist sf = depT_ $ opcs "sfplist" [(Xr, [Ir])] [sf] @@ -377,7 +380,7 @@ sfpreset :: Monad m => Int -> Int -> E -> Int -> DepT m () sfpreset bank prog sf index = depT_ $ opcs "iPreset sfpreset" [(Xr, [Ir, Ir, Ir, Ir])] [int prog, int bank, sf, int index] -sfSetList :: Monad m => String -> [(Int, Int, Int)] -> DepT m () +sfSetList :: Monad m => Text -> [(Int, Int, Int)] -> DepT m () sfSetList fileName presets = do sf <- sfload fileName sfplist sf @@ -389,7 +392,7 @@ -- if we use the scaling at I-rate we don't need to use portamento. -- If we want to scale with signal the portamento is must midiVolumeFactor :: E -> E -midiVolumeFactor idx = ifB (n <* 2) 1 (recip sqrtN) +midiVolumeFactor idx = ifExp IfIr (n <* 2) 1 (recip sqrtN) where sqrtN = sqrt n n = activeIr idx diff --git a/src/Csound/Typed/GlobalState/Options.hs b/src/Csound/Typed/GlobalState/Options.hs --- a/src/Csound/Typed/GlobalState/Options.hs +++ b/src/Csound/Typed/GlobalState/Options.hs @@ -28,6 +28,8 @@ import qualified Data.IntMap as IM import qualified Data.Map as M +import Data.Text (Text) +import Data.Text qualified as Text import Csound.Dynamic hiding (csdFlags) @@ -48,12 +50,13 @@ , csdTabFi :: Maybe TabFi -- ^ Default fidelity of the arrays , csdScaleUI :: Maybe (Double, Double) -- ^ Scale factors for UI-window , csdJacko :: Maybe Jacko - , csdJackConnect :: Maybe [(String, String)] -- ^ list of jack connections to make after csound app is launched (Linux only) + , csdJackConnect :: Maybe [(Text, Text)] -- ^ list of jack connections to make after csound app is launched (Linux only) , csdTrace :: Maybe Bool -- ^ Do we need debug-trace, default is False + , csdRender :: Maybe RenderOptions } deriving (Eq, Show, Read) instance Default Options where - def = Options def def def def def def def def def + def = Options def def def def def def def def def def #if MIN_VERSION_base(4,11,0) instance Semigroup Options where @@ -80,7 +83,9 @@ , csdScaleUI = csdScaleUI a <|> csdScaleUI b , csdJacko = csdJacko a <|> csdJacko b , csdJackConnect = mappend (csdJackConnect a) (csdJackConnect b) - , csdTrace = csdTrace a <|> csdTrace b } + , csdTrace = csdTrace a <|> csdTrace b + , csdRender = csdRender a <|> csdRender b + } defScaleUI :: Options -> (Double, Double) defScaleUI = maybe (1, 1) id . csdScaleUI @@ -101,7 +106,7 @@ data TabFi = TabFi { tabFiBase :: Int , tabFiGens :: IM.IntMap Int - , tabNamedFiGens :: M.Map String Int + , tabNamedFiGens :: M.Map Text Int } deriving (Eq, Show, Read) instance Default TabFi where @@ -122,7 +127,7 @@ -- given GEN-routine. -- -- with this function we can set lower table sizes for tables that are usually used in the envelopes. -fineFi :: Int -> [(Int, Int)] -> [(String, Int)] -> TabFi +fineFi :: Int -> [(Int, Int)] -> [(Text, Int)] -> TabFi fineFi n xs ys = TabFi n (IM.fromList xs) (M.fromList ys) -- | Sets the same table size for all tables. @@ -193,7 +198,7 @@ -- Identifiers for named GEN-routines -idPadsynth, idTanh, idExp, idSone, idFarey, idWave :: String +idPadsynth, idTanh, idExp, idSone, idFarey, idWave :: Text idPadsynth = "padsynth" @@ -206,7 +211,7 @@ ---------------------------------------------------------- -- Jacko -type JackoConnect = (String, String) +type JackoConnect = (Text, Text) -- | Describes the Jacko header. All information that is going to be set in the global settings for Jacko opcodes. -- The jacko opcodes allows us to easily turn our app into Jack-client. We can also do it with command line flags. @@ -214,8 +219,8 @@ -- -- see the Csound docs for details: data Jacko = Jacko - { jackoClient :: String - , jackoServer :: String + { jackoClient :: Text + , jackoServer :: Text , jackoAudioIns :: [JackoConnect] , jackoAudioOuts :: [JackoConnect] , jackoMidiIns :: [JackoConnect] @@ -235,9 +240,9 @@ , jackoFreewheel = False , jackoInfo = False } -renderJacko :: Jacko -> String -renderJacko spec = unlines $ filter ( /= "") - [ "JackoInit " ++ (show $ jackoServer spec) ++ ", " ++ (show $ jackoClient spec) +renderJacko :: Jacko -> Text +renderJacko spec = Text.unlines $ filter ( /= "") + [ "JackoInit " <> (Text.pack $ show $ jackoServer spec) <> ", " <> (Text.pack $ show $ jackoClient spec) , if (jackoFreewheel spec) then "JackoFreewheel 1" else "" , if (jackoInfo spec) then "JackoInfo" else "" , renderConnections "JackoAudioInConnect" $ jackoAudioIns spec @@ -246,9 +251,9 @@ , renderConnections "JackoMidiOutConnect" $ jackoMidiOuts spec , "JackoOn" ] where - renderConnections name links = unlines $ fmap (renderLink name) links + renderConnections name links = Text.unlines $ fmap (renderLink name) links - renderLink name (a, b) = name ++ " " ++ (show a) ++ ", " ++ (show b) + renderLink name (a, b) = name <> " " <> Text.pack (show a) <> ", " <> Text.pack (show b) csdNeedTrace :: Options -> Bool diff --git a/src/Csound/Typed/GlobalState/Port.hs b/src/Csound/Typed/GlobalState/Port.hs --- a/src/Csound/Typed/GlobalState/Port.hs +++ b/src/Csound/Typed/GlobalState/Port.hs @@ -5,12 +5,13 @@ -- cn write a signal to the port or can read the singals. module Csound.Typed.GlobalState.Port( IsPort(..), mixPort, modifyPort, - Port(..), freePort, + Port(..), freePort, PortCtrl(..), freePortCtrl ) where import Control.Monad import Control.Monad.Trans.Class +import Data.Proxy import Csound.Dynamic @@ -19,11 +20,11 @@ import Csound.Typed.Types.Tuple import Csound.Typed.Types.Prim -import Csound.Typed.GlobalState.Opcodes(freeChn, chnName, chnget, chnset, chngetK, chnsetK) +import Csound.Typed.GlobalState.Opcodes(freeChn, chnName, chnget, chnset, chngetK, chnsetK) -- port class -class IsPort p where +class IsPort p where readPort :: Sigs a => p a -> SE a writePort :: Sigs a => p a -> a -> SE () @@ -32,7 +33,7 @@ modifyPort :: (Sigs a, IsPort port) => port a -> (a -> a) -> SE () modifyPort p f = do - value <- readPort p + value <- readPort p writePort p $ f value -- port for audio signals @@ -46,7 +47,7 @@ tupleMethods = makeTupleMethods to from where to :: D -> Port a - to = Port . toGE + to = Port . toGE from :: Port a -> D from (Port e) = fromGE e @@ -61,10 +62,10 @@ writePort port a = SE $ do (names, values) <- lift getNamesAndValues zipWithM_ chnset names values - where + where getNamesAndValues = do names <- getNames port - values <- fromTuple a + values <- fromTuple a return (names, values) ------------------------------------------------------------- @@ -79,7 +80,7 @@ tupleMethods = makeTupleMethods to from where to :: D -> PortCtrl a - to = PortCtrl . toGE + to = PortCtrl . toGE from :: PortCtrl a -> D from (PortCtrl e) = fromGE e @@ -94,10 +95,10 @@ writePort port a = SE $ do (names, values) <- lift getNamesAndValues zipWithM_ chnsetK names values - where + where getNamesAndValues = do names <- getNamesCtrl port - values <- fromTuple a + values <- fromTuple a return (names, values) ------------------------------------------------------- @@ -105,9 +106,9 @@ getNames :: forall a . Sigs a => Port a -> GE [E] getNames (Port ref) = do idx <- ref - return $ fmap (flip chnName idx) [1 .. (tupleArity ((error "No def here") :: a))] + return $ fmap (flip chnName idx) [1 .. (tupleArity (Proxy :: Proxy a))] getNamesCtrl :: forall a . Sigs a => PortCtrl a -> GE [E] getNamesCtrl (PortCtrl ref) = do idx <- ref - return $ fmap (flip chnName idx) [1 .. (tupleArity ((error "No def here") :: a))] + return $ fmap (flip chnName idx) [1 .. (tupleArity (Proxy :: Proxy a))] diff --git a/src/Csound/Typed/GlobalState/SE.hs b/src/Csound/Typed/GlobalState/SE.hs --- a/src/Csound/Typed/GlobalState/SE.hs +++ b/src/Csound/Typed/GlobalState/SE.hs @@ -23,11 +23,10 @@ fmap f = SE . fmap f . unSE instance Applicative SE where - pure = return + pure = SE . return (<*>) = ap instance Monad SE where - return = SE . return ma >>= mf = SE $ unSE ma >>= unSE . mf runSE :: SE a -> GE a diff --git a/src/Csound/Typed/Gui/BoxModel.hs b/src/Csound/Typed/Gui/BoxModel.hs --- a/src/Csound/Typed/Gui/BoxModel.hs +++ b/src/Csound/Typed/Gui/BoxModel.hs @@ -11,16 +11,16 @@ import Data.Default data Interval = Interval - { start :: Int - , leng :: Int + { start :: !Int + , leng :: !Int } deriving (Show) -- | A rectangle. data Rect = Rect - { px :: Int - , py :: Int - , width :: Int - , height :: Int + { px :: !Int + , py :: !Int + , width :: !Int + , height :: !Int } deriving (Show) fromRect :: Rect -> (Interval, Interval) @@ -30,10 +30,10 @@ toRect a b = Rect (start a) (start b) (leng a) (leng b) data AbsScene ctx a - = Elem Rect a + = Elem !Rect !a | EmptyScene - | Group [AbsScene ctx a] - | Ctx Rect ctx (AbsScene ctx a) + | Group ![AbsScene ctx a] + | Ctx !Rect !ctx !(AbsScene ctx a) deriving (Show) @@ -71,11 +71,10 @@ deriving (Show, Functor) instance Applicative (Scene ctx) where - pure = return + pure = Prim (<*>) = ap instance Monad (Scene ctx) where - return = Prim ma >>= mf = joinScene $ fmap mf ma where joinScene :: Scene ctx (Scene ctx a) -> Scene ctx a diff --git a/src/Csound/Typed/Gui/Cabbage/Cabbage.hs b/src/Csound/Typed/Gui/Cabbage/Cabbage.hs --- a/src/Csound/Typed/Gui/Cabbage/Cabbage.hs +++ b/src/Csound/Typed/Gui/Cabbage/Cabbage.hs @@ -20,6 +20,7 @@ import Data.Maybe import Control.Monad.Trans.Writer.Strict +import Data.Text (Text) import Csound.Typed.Gui.Cabbage.CabbageLang @@ -43,7 +44,7 @@ --------------------------------------- -- widgets -widget :: String -> CabProp -> Cab +widget :: Text -> CabProp -> Cab widget name props = Cab' $ tell [Line name $ runCabProp props] --------------------------------------- @@ -79,10 +80,10 @@ --------------------------------------- -- properties -mkProperty :: String -> [Arg] -> CabProp +mkProperty :: Text -> [Arg] -> CabProp mkProperty name args = CabProp' $ tell [Property name args] -data Col = Hash String | Rgb Int Int Int +data Col = Hash Text | Rgb Int Int Int colProp :: Col -> [Arg] colProp x = case x of @@ -95,13 +96,13 @@ bounds :: Int -> Int -> Int -> Int -> CabProp bounds x y w h = mkProperty "bounds" (fmap IntArg [x, y, w, h]) -channel :: String -> CabProp +channel :: Text -> CabProp channel name = mkProperty "channel" [StringArg name] -text1 :: String -> CabProp +text1 :: Text -> CabProp text1 name = mkProperty "text" [StringArg name] -text2 :: String -> String -> CabProp +text2 :: Text -> Text -> CabProp text2 name1 name2 = mkProperty "text" [StringArg name1, StringArg name2] value :: Float -> CabProp @@ -140,7 +141,7 @@ latched :: Bool -> CabProp latched b = mkProperty "latched" [boolProp b] -identchannel :: String -> CabProp +identchannel :: Text -> CabProp identchannel s = mkProperty "identchannel" [StringArg s] rotate :: Float -> Float -> Float -> CabProp @@ -152,40 +153,40 @@ visible :: Bool -> CabProp visible a = mkProperty "visible" [boolProp a] -caption :: String -> CabProp +caption :: Text -> CabProp caption a = mkProperty "caption" [StringArg a] -widgetarray :: String -> Int -> CabProp +widgetarray :: Text -> Int -> CabProp widgetarray name n = mkProperty "widgetarray" [StringArg name, IntArg n] -popuptext :: String -> CabProp +popuptext :: Text -> CabProp popuptext a = mkProperty "popuptext" [StringArg a] active :: Bool -> CabProp active a = mkProperty "active" [boolProp a] -svgfile :: String -> String -> CabProp +svgfile :: Text -> Text -> CabProp svgfile ty fileName = mkProperty "svgfile" (fmap StringArg [ty, fileName]) -populate :: String -> String -> CabProp +populate :: Text -> Text -> CabProp populate filetype dir = mkProperty "populate" (fmap StringArg [filetype, dir]) -mode :: String -> CabProp +mode :: Text -> CabProp mode a = mkProperty "mode" [StringArg a] -file :: String -> CabProp +file :: Text -> CabProp file a = mkProperty "file" [StringArg a] -shape :: String -> CabProp +shape :: Text -> CabProp shape a = mkProperty "shape" [StringArg a] corners :: Float -> CabProp corners a = mkProperty "corners" [FloatArg a] -channeltype :: String -> CabProp +channeltype :: Text -> CabProp channeltype a = mkProperty "channeltype" [StringArg a] -align :: String -> CabProp +align :: Text -> CabProp align a = mkProperty "align" [StringArg a] sliderincr :: Float -> CabProp @@ -215,13 +216,13 @@ size :: Int -> Int -> CabProp size w h = mkProperty "size" (fmap IntArg [w, h]) -pluginid :: String -> CabProp +pluginid :: Text -> CabProp pluginid a = mkProperty "pluginid" [StringArg a] guirefresh :: Int -> CabProp guirefresh a = mkProperty "guirefresh" [IntArg a] -plant :: String -> CabProp +plant :: Text -> CabProp plant a = mkProperty "plant" [StringArg a] child :: Bool -> CabProp @@ -239,7 +240,7 @@ scrollbars :: Bool -> CabProp scrollbars a = mkProperty "scrollbars" [boolProp a] -fontstyle :: String -> CabProp +fontstyle :: Text -> CabProp fontstyle a = mkProperty "fontstyle" [StringArg a] scrubberpos :: Int -> CabProp @@ -248,7 +249,7 @@ zoom :: Float -> CabProp zoom a = mkProperty "zoom" [FloatArg a] -displaytype :: String -> CabProp +displaytype :: Text -> CabProp displaytype a = mkProperty "displaytype" [StringArg a] updaterate :: Int -> CabProp diff --git a/src/Csound/Typed/Gui/Cabbage/CabbageLang.hs b/src/Csound/Typed/Gui/Cabbage/CabbageLang.hs --- a/src/Csound/Typed/Gui/Cabbage/CabbageLang.hs +++ b/src/Csound/Typed/Gui/Cabbage/CabbageLang.hs @@ -2,21 +2,22 @@ Lang, Line(..), Property(..), Arg(..), ppCabbage ) where -import Text.PrettyPrint.Leijen +import Data.Text (Text) +import Text.PrettyPrint.Leijen.Text type Lang = [Line] data Line = Line - { lineDef :: String + { lineDef :: Text , lineProperties :: [Property] } data Property = Property - { propertyName :: String + { propertyName :: Text , propertyArgs :: [Arg] } -data Arg = StringArg String | FloatArg Float | IntArg Int | ColonArg Float Float +data Arg = StringArg Text | FloatArg Float | IntArg Int | ColonArg Float Float -------------------------------------------------- -- pretty print @@ -25,14 +26,14 @@ ppCabbage xs = vcat $ fmap ppLine xs ppLine :: Line -> Doc -ppLine (Line name props) = text name <+> hcat (punctuate comma (fmap ppProp props)) +ppLine (Line name props) = textStrict name <+> hcat (punctuate comma (fmap ppProp props)) ppProp :: Property -> Doc -ppProp (Property name args) = text name <> tupled (fmap ppArg args) +ppProp (Property name args) = textStrict name <> tupled (fmap ppArg args) ppArg :: Arg -> Doc ppArg x = case x of - StringArg s -> dquotes (text s) + StringArg s -> dquotes (textStrict s) FloatArg a -> float a IntArg a -> int a ColonArg a b -> float a <> colon <> float b diff --git a/src/Csound/Typed/Gui/Gui.hs b/src/Csound/Typed/Gui/Gui.hs --- a/src/Csound/Typed/Gui/Gui.hs +++ b/src/Csound/Typed/Gui/Gui.hs @@ -30,17 +30,19 @@ ) where import Prelude hiding(elem, span) +import Data.Text (Text) +import Data.Text qualified as Text import Data.Default import Data.Maybe(isNothing) import Data.Monoid import qualified Data.IntMap as IM -import Text.PrettyPrint.Leijen(Doc) +import Text.PrettyPrint.Leijen.Text (Doc) import Csound.Dynamic(DepT, depT_, Var(..), VarType(..), Rate(..), noRate, MainExp(..), InstrId(..)) -import qualified Text.PrettyPrint.Leijen as P(int, double, vcat, empty, text) +import qualified Text.PrettyPrint.Leijen.Text as P(int, double, vcat, empty, textStrict) import qualified Csound.Typed.Gui.BoxModel as Box import Csound.Typed.Constants(infiniteDur) @@ -59,7 +61,7 @@ { singleContent :: Win , singleIsKeybdSensitive :: Bool } | Tabs - { tabsTitle :: String + { tabsTitle :: Text , tabsRect :: Maybe Rect , tabsContent :: [Win] , tabsIsKeybdSensitive :: Bool } @@ -70,7 +72,7 @@ Tabs _ _ _ res -> res data Win = Win - { winTitle :: String + { winTitle :: Text , winRect :: Maybe Rect , winGui :: Gui } @@ -99,7 +101,7 @@ | Text ValDiap ValStep -- other widgets - | Box String + | Box Text | ButBank Int Int | Button InstrId | Toggle @@ -108,7 +110,7 @@ type ElemOuts = [Var] -defText :: String -> Gui +defText :: Text -> Gui defText str = Gui $ Box.Prim (ElemWithOuts [Var LocalVar Ir "keybd"] [] $ Box str) fromElem :: ElemOuts -> [InitMe] -> Elem -> Gui @@ -226,7 +228,7 @@ guiStmt defaultScaleUI panels = depT_ $ noRate (phi defaultScaleUI) where phi scaleUI | null panels = EmptyExp - | otherwise = Verbatim $ show $ P.vcat [P.vcat $ fmap (drawGui scaleUI) panels, P.text "FLrun"] + | otherwise = Verbatim $ Text.pack $ show $ P.vcat [P.vcat $ fmap (drawGui scaleUI) panels, P.textStrict "FLrun"] drawGui :: ScaleFactor -> Panel -> Doc drawGui defaultScaleUI x = case x of @@ -249,7 +251,7 @@ onPanel title isKeybdSensitive rect body = P.vcat -- panel with default position no border and capture of keyboard events - [ ppProc "FLpanel" [ P.text $ show title, P.int $ width rect, P.int $ height rect, P.int (-1), P.int (-1), P.int 0 + [ ppProc "FLpanel" [ P.textStrict title, P.int $ width rect, P.int $ height rect, P.int (-1), P.int (-1), P.int 0 , P.int $ if isKeybdSensitive then 1 else 0 ] , body , ppProc "FLpanelEnd" []] @@ -260,7 +262,7 @@ , ppProc "FLtabsEnd" []] -panelTitle :: Panel -> String +panelTitle :: Panel -> Text panelTitle x = case x of Single w _ -> winTitle w Tabs title _ _ _ -> title @@ -302,7 +304,7 @@ drawTab :: (Int, Int) -> Rect -> Win -> Doc drawTab shift r w = group (winTitle w) r $ drawWin (withRelWinMargin $ shiftRect shift r) w where group title rect body = P.vcat - [ ppProc "FLgroup" $ (P.text $ show title) : rectToFrame rect + [ ppProc "FLgroup" $ (P.textStrict $ Text.pack $ show title) : rectToFrame rect , body , ppProc "FLgroupEnd" []] @@ -324,7 +326,7 @@ drawBorder :: BorderType -> Rect -> Doc -> Doc drawBorder borderType rect a = P.vcat - [ ppProc "FLgroup" $ ((P.text $ show "") : frame) ++ [borderAsInt borderType] + [ ppProc "FLgroup" $ (P.empty : frame) ++ [borderAsInt borderType] , a , ppProc "FLgroupEnd" []] where borderAsInt = P.int . fromEnum @@ -371,7 +373,9 @@ where label = getLabel ctx f = fWithLabel (getLabel ctx) - fWithLabel label name args = ppMoOpc (fmap ppVar $ elemOuts el) name ((P.text $ show $ label) : args) + + fWithLabel :: Text -> Text -> [Doc] -> Doc + fWithLabel label name args = ppMoOpc (fmap ppVar $ elemOuts el) name ((P.textStrict label) : args) fNoLabel name args = ppMoOpc (fmap ppVar $ elemOuts el) name args frame = frameBy rect frameWithoutLabel = frameBy rectWithoutLabel @@ -464,7 +468,7 @@ setProp :: Prop -> Gui -> Gui setProp p = props [p] -setLabel :: String -> Gui -> Gui +setLabel :: Text -> Gui -> Gui setLabel = setProp . SetLabel setLabelType :: LabelType -> Gui -> Gui @@ -580,7 +584,7 @@ -- other widgets Box label -> let symbolsPerLine = 60 - numOfLines = succ $ div (length label) symbolsPerLine + numOfLines = succ $ div (Text.length label) symbolsPerLine in (xBox 15 symbolsPerLine, yBox 15 numOfLines) ButBank xn yn -> (xn * 70, yn * 35) @@ -618,7 +622,7 @@ flSetColor, flSetColor2, flSetTextColor, flSetTextSize, flSetTextType, flSetFont :: Var -> PropCtx -> Doc -flSetProp :: String +flSetProp :: Text -> (PropCtx -> Maybe a) -> (PropCtx -> Doc) -> Var -> PropCtx -> Doc diff --git a/src/Csound/Typed/Gui/Pretty.hs b/src/Csound/Typed/Gui/Pretty.hs --- a/src/Csound/Typed/Gui/Pretty.hs +++ b/src/Csound/Typed/Gui/Pretty.hs @@ -7,13 +7,14 @@ getToggleType, appMaterial, getColor1, getColor2, getTextColor, genGetColor ) where -import Data.Char import Data.Default import Data.Colour.Names(white, gray, black) import Data.Colour.SRGB +import Data.Text (Text) +import Data.Text qualified as Text -import Text.PrettyPrint.Leijen(Doc, int, hcat, hsep, punctuate, comma, text, char) -import qualified Text.PrettyPrint.Leijen as P((<+>), empty) +import Text.PrettyPrint.Leijen.Text(Doc, int, hcat, hsep, punctuate, comma, textStrict, char) +import qualified Text.PrettyPrint.Leijen.Text as P((<+>), empty) import Csound.Dynamic(Var(..), VarType(..), Rate(..)) @@ -22,17 +23,17 @@ ------------------------------------------------------------- -- pretty printers -ppProc :: String -> [Doc] -> Doc -ppProc name xs = text name P.<+> (hsep $ punctuate comma xs) +ppProc :: Text -> [Doc] -> Doc +ppProc name xs = textStrict name P.<+> (hsep $ punctuate comma xs) -ppMoOpc :: [Doc] -> String -> [Doc] -> Doc -ppMoOpc outs name ins = f outs P.<+> text name P.<+> f ins +ppMoOpc :: [Doc] -> Text -> [Doc] -> Doc +ppMoOpc outs name ins = f outs P.<+> textStrict name P.<+> f ins where f = hsep . punctuate comma ppVar :: Var -> Doc ppVar v = case v of - Var ty rate name -> hcat [ppVarType ty, ppRate rate, text (varPrefix ty : name)] - VarVerbatim _ name -> text name + Var ty rate name -> hcat [ppVarType ty, ppRate rate, textStrict (Text.cons (varPrefix ty) name)] + VarVerbatim _ name -> textStrict name varPrefix :: VarType -> Char varPrefix x = case x of @@ -48,7 +49,7 @@ ppRate x = case x of Sr -> char 'S' _ -> phi x - where phi = text . map toLower . show + where phi = textStrict . Text.toLower . Text.pack . show ------------------------------------------------------------------ -- Converting readable properties to integer codes diff --git a/src/Csound/Typed/Gui/Types.hs b/src/Csound/Typed/Gui/Types.hs --- a/src/Csound/Typed/Gui/Types.hs +++ b/src/Csound/Typed/Gui/Types.hs @@ -28,6 +28,7 @@ import Data.Colour import Csound.Typed.Gui.BoxModel(Rect(..)) +import Data.Text (Text) -- | The Csound colours. type Color = Colour Double @@ -42,8 +43,8 @@ -- | A value span is a diapason of the value and a type -- of the scale (can be linear or exponential). data ValSpan = ValSpan - { valSpanDiap :: ValDiap - , valSpanScale :: ValScaleType } + { valSpanDiap :: !ValDiap + , valSpanScale :: !ValScaleType } -- | Makes a linear @ValSpan@ with specified boundaries. -- @@ -190,7 +191,7 @@ -- | Properties of the widgets. data Prop - = SetLabel String + = SetLabel Text | SetMaterial Material | SetBoxType BoxType | SetColor1 Color | SetColor2 Color | SetTextColor Color @@ -206,7 +207,7 @@ -- cascading context, here we group properties by type data PropCtx = PropCtx - { ctxLabel :: Maybe String + { ctxLabel :: Maybe Text , ctxMaterial :: Maybe Material , ctxLabelType :: Maybe LabelType , ctxBoxType :: Maybe BoxType @@ -245,5 +246,5 @@ SetTextType a -> x { ctxTextType = Just a } SetKnobType a -> x { ctxKnobType = Just a } -getLabel :: PropCtx -> String +getLabel :: PropCtx -> Text getLabel = maybe "" id . ctxLabel diff --git a/src/Csound/Typed/Gui/Widget.hs b/src/Csound/Typed/Gui/Widget.hs --- a/src/Csound/Typed/Gui/Widget.hs +++ b/src/Csound/Typed/Gui/Widget.hs @@ -26,6 +26,8 @@ import Control.Monad.Trans.Class import Data.Boolean +import Data.Text (Text) +import Data.Text qualified as Text import Csound.Dynamic hiding (int, when1) import qualified Csound.Typed.GlobalState.Elements as C @@ -58,41 +60,41 @@ -- | Renders the GUI elements with tabs. Rectangles are calculated -- automatically. -tabs :: [(String, Gui)] -> SE () +tabs :: [(Text, Gui)] -> SE () tabs = genTabs False -- | Renders the GUI elements with tabs. Rectangles are calculated -- automatically. -keyTabs :: [(String, Gui)] -> SE () +keyTabs :: [(Text, Gui)] -> SE () keyTabs = genTabs True -genTabs :: Bool -> [(String, Gui)] -> SE () +genTabs :: Bool -> [(Text, Gui)] -> SE () genTabs isKey xs = geToSe $ saveGuiRoot $ Tabs "" Nothing (fmap (\(title, gui) -> Win title Nothing gui) xs) isKey -- | Renders the GUI elements on the window. We can specify the window title -- and rectangle of the window. -panelBy :: String -> Maybe Rect -> Gui -> SE () +panelBy :: Text -> Maybe Rect -> Gui -> SE () panelBy = genPanelBy False -- | Renders the GUI elements on the window. We can specify the window title -- and rectangle of the window. Panesls are sensitive to keyboard events. -keyPanelBy :: String -> Maybe Rect -> Gui -> SE () +keyPanelBy :: Text -> Maybe Rect -> Gui -> SE () keyPanelBy = genPanelBy True -genPanelBy :: Bool -> String -> Maybe Rect -> Gui -> SE () +genPanelBy :: Bool -> Text -> Maybe Rect -> Gui -> SE () genPanelBy isKeybd title mrect gui = geToSe $ saveGuiRoot $ Single (Win title mrect gui) isKeybd -- | Renders the GUI elements with tabs. We can specify the window title and -- rectangles for all tabs and for the main window. -tabsBy :: String -> Maybe Rect -> [(String, Maybe Rect, Gui)] -> SE () +tabsBy :: Text -> Maybe Rect -> [(Text, Maybe Rect, Gui)] -> SE () tabsBy = genTabsBy False -- | Renders the GUI elements with tabs. We can specify the window title and -- rectangles for all tabs and for the main window. Tabs are sensitive to keyboard events. -keyTabsBy :: String -> Maybe Rect -> [(String, Maybe Rect, Gui)] -> SE () +keyTabsBy :: Text -> Maybe Rect -> [(Text, Maybe Rect, Gui)] -> SE () keyTabsBy = genTabsBy True -genTabsBy :: Bool -> String -> Maybe Rect -> [(String, Maybe Rect, Gui)] -> SE () +genTabsBy :: Bool -> Text -> Maybe Rect -> [(Text, Maybe Rect, Gui)] -> SE () genTabsBy isKeybd title mrect gui = geToSe $ saveGuiRoot $ Tabs title mrect (fmap (\(a, b, c) -> Win a b c) gui) isKeybd -- | Widgets that produce something has inputs. @@ -197,33 +199,33 @@ -- primitive elements -- | Appends a title to a group of widgets. -setTitle :: String -> Gui -> SE Gui +setTitle :: Text -> Gui -> SE Gui setTitle name g - | null name = return g + | Text.null name = return g | otherwise = do gTitle <- box name return $ ver [sca 0.01 gTitle, g] -setSourceTitle :: String -> Source a -> Source a +setSourceTitle :: Text -> Source a -> Source a setSourceTitle name ma = source $ do (gui, val) <- ma newGui <- setTitle name gui return (newGui, val) -setLabelSource :: String -> Source a -> Source a +setLabelSource :: Text -> Source a -> Source a setLabelSource a - | null a = id + | Text.null a = id | otherwise = fmap (first $ setLabel a) -setLabelSink :: String -> Sink a -> Sink a +setLabelSink :: Text -> Sink a -> Sink a setLabelSink a - | null a = id + | Text.null a = id | otherwise = fmap (first $ setLabel a) -setLabelSnkSource :: String -> SinkSource a -> SinkSource a +setLabelSnkSource :: Text -> SinkSource a -> SinkSource a setLabelSnkSource a - | null a = id - | otherwise = fmap (\(x, y, z) -> (setLabel a x, y, z)) + | Text.null a = id + | otherwise = fmap (\(x, y, z) -> (setLabel a x, y, z)) singleOut :: Maybe Double -> Elem -> Source Sig singleOut v0 el = geToSe $ do @@ -290,7 +292,7 @@ -- > knob valueSpan initValue -- -- doc: -knob :: String -> ValSpan -> Double -> Source Sig +knob :: Text -> ValSpan -> Double -> Source Sig knob name sp v0 = setLabelSource name $ singleOut (Just v0) $ Knob sp -- | FLroller is a sort of knob, but put transversally. @@ -298,7 +300,7 @@ -- > roller valueSpan step initVal -- -- doc: -roller :: String -> ValSpan -> ValStep -> Double -> Source Sig +roller :: Text -> ValSpan -> ValStep -> Double -> Source Sig roller name sp step v0 = setLabelSource name $ singleOut (Just v0) $ Roller sp step -- | FLslider puts a slider into the corresponding container. @@ -306,14 +308,14 @@ -- > slider valueSpan initVal -- -- doc: -slider :: String -> ValSpan -> Double -> Source Sig +slider :: Text -> ValSpan -> Double -> Source Sig slider name sp v0 = setLabelSource name $ singleOut (Just v0) $ Slider sp -- | Constructs a list of linear unit sliders (ranges in [0, 1]). It takes a list -- of init values. -sliderBank :: String -> [Double] -> Source [Sig] +sliderBank :: Text -> [Double] -> Source [Sig] sliderBank name ds = source $ do - (gs, vs) <- fmap unzip $ zipWithM (\n d -> slider (show n) uspan d) [(1::Int) ..] ds + (gs, vs) <- fmap unzip $ zipWithM (\n d -> slider (Text.pack $ show n) uspan d) [(1::Int) ..] ds gui <- setTitle name $ hor gs return (gui, vs) @@ -323,7 +325,7 @@ -- > numeric diapason step initValue -- -- doc: -numeric :: String -> ValDiap -> ValStep -> Double -> Source Sig +numeric :: Text -> ValDiap -> ValStep -> Double -> Source Sig numeric name diap step v0 = setLabelSource name $ singleOut (Just v0) $ Text diap step -- | A FLTK widget that displays text inside of a box. @@ -333,18 +335,18 @@ -- > box text -- -- doc: -box :: String -> Display +box :: Text -> Display box label - | length label < lim = rawBox label - | otherwise = fmap (padding 0 . ver) $ mapM rawBox $ parts lim label + | Text.length label < lim = rawBox label + | otherwise = fmap (padding 0 . ver) $ mapM rawBox $ parts lim label where parts n xs - | length xs < n = [xs] + | Text.length xs < n = [xs] | otherwise = a : parts n b - where (a, b) = splitAt n xs + where (a, b) = Text.splitAt n xs lim = 255 -rawBox :: String -> Display +rawBox :: Text -> Display rawBox label = geToSe $ do (_, handle) <- newGuiVar let gui = fromElem [guiHandleToVar handle] [] (Box label) @@ -356,7 +358,7 @@ -- > button text -- -- doc: -button :: String -> Source (Evt Unit) +button :: Text -> Source (Evt Unit) button name = setLabelSource name $ source $ do flag <- geToSe $ onGlobals $ C.newPersistentGlobalVar Kr 0 flagChanged <- geToSe $ onGlobals $ C.newPersistentGlobalVar Kr 0 @@ -368,9 +370,9 @@ where instr ref = SE $ do val <- readVar ref - whens Kr - [ (val ==* 0, writeVar ref 1) - ] (writeVar ref 0) + whens IfKr + [ (val ==* 0, toBlock $ writeVar ref 1) + ] (toBlock $ writeVar ref 0) turnoff instrCh ref refCh = SE $ do @@ -382,12 +384,12 @@ -- > button text -- -- doc: -toggle :: String -> Bool -> Source (Evt D) +toggle :: Text -> Bool -> Source (Evt D) toggle name initVal = mapSource snaps $ toggleSig name initVal -- | A variance on the function 'Csound.Gui.Widget.toggle', but it produces -- a signal of piecewise constant function. -toggleSig :: String -> Bool -> Source Sig +toggleSig :: Text -> Bool -> Source Sig toggleSig name initVal = setLabelSource name $ singleOut (initToggle initVal) Toggle initToggle :: Bool -> Maybe Double @@ -399,7 +401,7 @@ -- > butBank xNumOfButtons yNumOfButtons -- -- doc: -butBank :: String -> Int -> Int -> (Int, Int) -> Source (Evt (D, D)) +butBank :: Text -> Int -> Int -> (Int, Int) -> Source (Evt (D, D)) butBank name xn yn inits = mapSource (fmap split2 . snaps) $ butBankSig1 name xn yn inits where split2 a = (floor' $ a / y, mod' a x) @@ -409,7 +411,7 @@ -- | A variance on the function 'Csound.Gui.Widget.butBank', but it produces -- a signal of piecewise constant function. -- Result is (x, y) coordinate of the triggered button. -butBankSig :: String -> Int -> Int -> (Int, Int) -> Source (Sig, Sig) +butBankSig :: Text -> Int -> Int -> (Int, Int) -> Source (Sig, Sig) butBankSig name xn yn inits = mapSource split2 $ butBankSig1 name xn yn inits where split2 a = (floor' $ a / y, mod' a x) @@ -421,39 +423,39 @@ -- > butBank xNumOfButtons yNumOfButtons -- -- doc: -butBank1 :: String -> Int -> Int -> (Int, Int) -> Source (Evt D) +butBank1 :: Text -> Int -> Int -> (Int, Int) -> Source (Evt D) butBank1 name xn yn inits = mapSource snaps $ butBankSig1 name xn yn inits -butBankSig1 :: String -> Int -> Int -> (Int, Int) -> Source Sig +butBankSig1 :: Text -> Int -> Int -> (Int, Int) -> Source Sig butBankSig1 name xn yn (x0, y0) = setSourceTitle name $ singleOut (Just n) $ ButBank xn yn where n = fromIntegral $ y0 + x0 * yn -- | FLtext that is sink shows current the value of a valuator in a text field. -setNumeric :: String -> ValDiap -> ValStep -> Double -> Sink Sig +setNumeric :: Text -> ValDiap -> ValStep -> Double -> Sink Sig setNumeric name diap step v0 = setLabelSink name $ singleIn printk2 (Just v0) $ Text diap step -- | A slider that serves as indicator. It consumes values instead of producing. -- -- > meter valueSpan initValue -meter :: String -> ValSpan -> Double -> Sink Sig +meter :: Text -> ValSpan -> Double -> Sink Sig meter name sp v = setLabelSink name $ singleIn setVal (Just v) (Slider sp) ------------------------------------------------------------- -- writeable widgets -setToggleSig :: String -> Bool -> SinkSource Sig +setToggleSig :: Text -> Bool -> SinkSource Sig setToggleSig name initVal = setLabelSnkSource name $ singleInOut setVal (initToggle initVal) Toggle -setToggle :: String -> Bool -> SinkSource (Evt D) +setToggle :: Text -> Bool -> SinkSource (Evt D) setToggle name initVal = sinkSource $ do (g, outs, ins) <- setToggleSig name initVal let evtOuts a = outs =<< stepper 0 (fmap sig a) return (g, evtOuts, snaps ins) -setKnob :: String -> ValSpan -> Double -> SinkSource Sig +setKnob :: Text -> ValSpan -> Double -> SinkSource Sig setKnob name sp v0 = setLabelSnkSource name $ singleInOut setVal' (Just v0) $ Knob sp -setSlider :: String -> ValSpan -> Double -> SinkSource Sig +setSlider :: Text -> ValSpan -> Double -> SinkSource Sig setSlider name sp v0 = setLabelSnkSource name $ singleInOut setVal' (Just v0) $ Slider sp ------------------------------------------------------------- diff --git a/src/Csound/Typed/Render.hs b/src/Csound/Typed/Render.hs --- a/src/Csound/Typed/Render.hs +++ b/src/Csound/Typed/Render.hs @@ -23,7 +23,7 @@ import System.FilePath import Text.Read (readMaybe) -import Text.PrettyPrint.Leijen(displayS, renderPretty) +import Text.PrettyPrint.Leijen.Text (displayTStrict, renderPretty) import Csound.Dynamic hiding (csdFlags) import Csound.Typed.Types @@ -59,24 +59,31 @@ renderOutBy_ :: Options -> SE () -> IO String renderOutBy_ options sigs = do - finalOptions <- fmap (maybe options (options `mappend` )) getUserOptions - evalGE finalOptions $ fmap renderCsd $ toCsd Nothing finalOptions (fmap (const unit) sigs) + finalOptions <- fmap (maybe options (options `mappend` )) getUserOptions + evalGE finalOptions $ fmap (renderCsd renderOpts) $ toCsd Nothing finalOptions (fmap (const unit) sigs) + where + renderOpts = fromMaybe def $ csdRender options + renderOut :: Sigs a => SE a -> IO String renderOut = renderOutBy def renderOutBy :: Sigs a => Options -> SE a -> IO String renderOutBy options sigs = do - finalOptions <- fmap (maybe options (options `mappend` )) getUserOptions - evalGE finalOptions $ fmap renderCsd $ toCsd Nothing finalOptions sigs + finalOptions <- fmap (maybe options (options `mappend` )) getUserOptions + evalGE finalOptions $ fmap (renderCsd renderOpts) $ toCsd Nothing finalOptions sigs + where + renderOpts = fromMaybe def $ csdRender options renderEff :: (Sigs a, Sigs b) => (a -> SE b) -> IO String renderEff = renderEffBy def renderEffBy :: (Sigs a, Sigs b) => Options -> (a -> SE b) -> IO String renderEffBy options eff = do - finalOptions <- fmap (maybe options (options `mappend` )) getUserOptions - evalGE finalOptions $ fmap renderCsd $ toCsd (Just (arityIns $ funArity eff)) finalOptions (eff =<< getIns) + finalOptions <- fmap (maybe options (options `mappend` )) getUserOptions + evalGE finalOptions $ fmap (renderCsd renderOpts) $ toCsd (Just (arityIns $ funArity eff)) finalOptions (eff =<< getIns) + where + renderOpts = fromMaybe def $ csdRender options renderHistory :: Maybe Int -> Int -> Options -> GE Csd renderHistory mnchnls_i nchnls opt = do @@ -106,7 +113,7 @@ getPlugins hist = case cabbageGui hist of Nothing -> [] - Just x -> [(Plugin "Cabbage" (displayS (renderPretty 1 10000 $ ppCabbage x) ""))] + Just x -> [(Plugin "Cabbage" (displayTStrict (renderPretty 1 10000 $ ppCabbage x)))] getInstr0 :: Maybe Int -> Int -> Options -> Dep () -> History -> Dep () getInstr0 mnchnls_i nchnls opt udos hist = do diff --git a/src/Csound/Typed/Types.hs b/src/Csound/Typed/Types.hs --- a/src/Csound/Typed/Types.hs +++ b/src/Csound/Typed/Types.hs @@ -8,15 +8,16 @@ -- can use these functions. withInits, withDs, withSigs, withTabs, withD, withSig, withTab, withSeed, -- * Tuples - module Csound.Typed.Types.Tuple, + module Csound.Typed.Types.Tuple, -- * Events module Csound.Typed.Types.Evt, -- * Arrays - module Csound.Typed.Types.Array, + module Csound.Typed.Types.Array, + module Csound.Typed.Types.PureArray, -- * Arguments for monophonic synths - module Csound.Typed.Types.MonoArg, + module Csound.Typed.Types.MonoArg, -- * Signal space (generic signal transformers) module Csound.Typed.Types.SigSpace, @@ -32,6 +33,7 @@ import Csound.Typed.Types.Evt import Csound.Typed.Types.Lift import Csound.Typed.Types.Array +import Csound.Typed.Types.PureArray import Csound.Typed.Types.MonoArg import Csound.Typed.Types.SigSpace @@ -50,7 +52,7 @@ withInits :: (Tuple a, Tuple b) => a -> b -> a withInits a b = genWithInits a (fromTuple b) --- | A special case of @withInits@. Here all inits are numbers. +-- | A special case of @withInits@. Here all inits are numbers. withDs :: Tuple a => a -> [D] -> a withDs a ds = genWithInits a (mapM toGE ds) @@ -58,7 +60,7 @@ withD :: Tuple a => a -> D -> a withD = withInits --- | A special case of @withInits@. Here all inits are signals. +-- | A special case of @withInits@. Here all inits are signals. withSigs :: Tuple a => a -> [Sig] -> a withSigs a sigs = genWithInits a (mapM toGE sigs) @@ -66,7 +68,7 @@ withSig :: Tuple a => a -> Sig -> a withSig = withInits --- | A special case of @withInits@. Here all inits are arrays. +-- | A special case of @withInits@. Here all inits are arrays. withTabs :: Tuple a => a -> [Tab] -> a withTabs a tabs = genWithInits a (mapM toGE tabs) @@ -74,8 +76,8 @@ withTab :: Tuple a => a -> Tab -> a withTab = withInits --- | Applies a seed to the random value. --- It's equivalent to the @withD@ but it has a special +-- | Applies a seed to the random value. +-- It's equivalent to the @withD@ but it has a special -- meaning of canceling the side effect. When random -- opcode is provided with seed value it's no longer -- contains a side effect so we don't need to restrict it. diff --git a/src/Csound/Typed/Types/Array.hs b/src/Csound/Typed/Types/Array.hs --- a/src/Csound/Typed/Types/Array.hs +++ b/src/Csound/Typed/Types/Array.hs @@ -31,6 +31,8 @@ import Control.Monad +import Data.Proxy +import Data.Text (Text) import Csound.Dynamic hiding (writeArr, writeInitArr, readArr, newLocalArrVar, newTmpArrVar, int) import qualified Csound.Dynamic as D @@ -89,7 +91,7 @@ newArrBy :: forall ix a . (Tuple a, Tuple ix) => (Rate -> GE [E] -> SE Var) -> [D] -> SE (Arr ix a) newArrBy mkVar sizes = - fmap Arr $ mapM (\x -> mkVar x (mapM toGE sizes)) (tupleRates $ (undefined :: a)) + fmap Arr $ mapM (\x -> mkVar x (mapM toGE sizes)) (tupleRates $ (Proxy :: Proxy a)) getIndices :: Tuple ix => [Int] -> [ix] getIndices xs = fmap (toTuple . return . fmap D.int) $ getIntIndices xs @@ -417,7 +419,7 @@ isArrayInit = True noArrayInit = False -binOp :: String -> Arr a b -> Arr a b -> SE (Arr a b) +binOp :: Text -> Arr a b -> Arr a b -> SE (Arr a b) binOp name (Arr xs) (Arr ys) = fmap Arr $ zipWithM go xs ys where go x y = SE $ do @@ -425,7 +427,7 @@ infOprArr isArrayInit outVar name (inlineVar x) (inlineVar y) return outVar -convert :: String -> Arr a b -> SE (Arr a b) +convert :: Text -> Arr a b -> SE (Arr a b) convert name (Arr vars) = fmap Arr $ mapM go vars where go v = SE $ do @@ -435,7 +437,7 @@ idRate1 = fmap (\r -> (r, [r])) [Kr, Ar, Ir, Sr, Fr] -convert2 :: String -> Arr a b -> Arr a b -> SE (Arr a b) +convert2 :: Text -> Arr a b -> Arr a b -> SE (Arr a b) convert2 name (Arr xs) (Arr ys) = fmap Arr $ zipWithM go xs ys where go x y = SE $ do @@ -445,15 +447,15 @@ idRate2 = fmap (\r -> (r, [r, r])) [Kr, Ar, Ir, Sr, Fr] -extractArray :: (Tuple b) => String -> Arr a b -> SE b +extractArray :: (Tuple b) => Text -> Arr a b -> SE b extractArray name (Arr vs) = SE $ fmap (toTuple . return) $ mapM (f . inlineVar) vs where f a = depT $ opcs name [(Xr, [Xr])] [a] -extract1 :: (Tuple b, Tuple c) => Rate -> String -> Arr a b -> SE c +extract1 :: (Tuple b, Tuple c) => Rate -> Text -> Arr a b -> SE c extract1 rate name (Arr vs) = SE $ fmap (toTuple . return) $ mapM (f . inlineVar) vs where f a = depT $ opcs name [(rate, [Xr])] [a] -extractWith :: (Tuple b, Tuple c, Tuple d) => String -> (Rate, [Rate]) -> Arr a b -> c -> SE d +extractWith :: (Tuple b, Tuple c, Tuple d) => Text -> (Rate, [Rate]) -> Arr a b -> c -> SE d extractWith name rates (Arr vs) argument = SE $ fmap (toTuple . return) $ hideGEinDep $ do argExps <- fromTuple argument return $ zipWithM (\var x -> f (inlineVar var) x) vs argExps @@ -600,18 +602,18 @@ --------------------------------------------------------------- -binOpCopy :: String -> Arr a b -> Arr a b -> Arr a b -> SE () +binOpCopy :: Text -> Arr a b -> Arr a b -> Arr a b -> SE () binOpCopy name (Arr xs) (Arr ys) (Arr outs) = mapM_ go $ zip3 xs ys outs where go (x, y, outVar) = SE $ infOprArr noArrayInit outVar name (inlineVar x) (inlineVar y) -convertCopy :: String -> Arr a b -> Arr a b -> SE () +convertCopy :: Text -> Arr a b -> Arr a b -> SE () convertCopy name (Arr vars) (Arr outs) = zipWithM_ go vars outs where go v outVar = SE $ opcsArr noArrayInit outVar name idRate1 [inlineVar v] idRate1 = fmap (\r -> (r, [r])) [Kr, Ar, Ir, Sr, Fr] -convert2Copy :: String -> Arr a b -> Arr a b -> Arr a b -> SE () +convert2Copy :: Text -> Arr a b -> Arr a b -> Arr a b -> SE () convert2Copy name (Arr xs) (Arr ys) (Arr outs) = mapM_ go $ zip3 xs ys outs where go (x, y, outVar) = SE $ opcsArr noArrayInit outVar name idRate2 [inlineVar x, inlineVar y] diff --git a/src/Csound/Typed/Types/Evt.hs b/src/Csound/Typed/Types/Evt.hs --- a/src/Csound/Typed/Types/Evt.hs +++ b/src/Csound/Typed/Types/Evt.hs @@ -8,6 +8,7 @@ import Data.Default import Data.Boolean +import Data.Kind (Type) import Csound.Typed.Types.Prim import Csound.Typed.Types.Tuple @@ -57,15 +58,15 @@ sigToEvt = boolToEvt . ( ==* 1) . kr -- | Filters events with predicate. -filterE :: (a -> BoolD) -> Evt a -> Evt a +filterE :: (a -> BoolSig) -> Evt a -> Evt a filterE pr evt = Evt $ \bam -> runEvt evt $ \a -> - when1 (boolSig $ pr a) $ bam a + when1 (pr a) $ bam a -- | Filters events with effectful predicate. -filterSE :: (a -> SE BoolD) -> Evt a -> Evt a +filterSE :: (a -> SE BoolSig) -> Evt a -> Evt a filterSE mpr evt = Evt $ \bam -> runEvt evt $ \a -> do pr <- mpr a - when1 (boolSig pr) $ bam a + when1 pr $ bam a -- | Accumulator for events with side effects. accumSE :: (Tuple s) => s -> (a -> s -> SE (b, s)) -> Evt a -> Evt b @@ -83,19 +84,19 @@ -- | Accumulator for events with side effects and filtering. Event triggers -- only if the first element in the tripplet is true. -filterAccumSE :: (Tuple s) => s -> (a -> s -> SE (BoolD, b, s)) -> Evt a -> Evt b +filterAccumSE :: (Tuple s) => s -> (a -> s -> SE (BoolSig, b, s)) -> Evt a -> Evt b filterAccumSE s0 update evt = Evt $ \bam -> do (readSt, writeSt) <- sensorsSE s0 runEvt evt $ \a -> do s1 <- readSt (isOn, b, s2) <- update a s1 - when1 (boolSig isOn) $ bam b + when1 isOn $ bam b writeSt s2 -- | Accumulator with filtering. It can skip the events from the event stream. -- If the third element of the triple equals to 1 then we should include the -- event in the resulting stream. If the element equals to 0 we skip the event. -filterAccumE :: (Tuple s) => s -> (a -> s -> (BoolD, b, s)) -> Evt a -> Evt b +filterAccumE :: (Tuple s) => s -> (a -> s -> (BoolSig, b, s)) -> Evt a -> Evt b filterAccumE s0 update = filterAccumSE s0 $ \a s -> return $ update a s -- | Get values of some signal at the given events. @@ -131,7 +132,7 @@ -- > type instance Snap (a, b, c, d) = (Snap a, Snap b, Snap c, Snap d) -- > type instance Snap (a, b, c, d, e) = (Snap a, Snap b, Snap c, Snap d, Snap e) -- > type instance Snap (a, b, c, d, e, f) = (Snap a, Snap b, Snap c, Snap d, Snap e, Snap f) -type family Snap a :: * +type family Snap a :: Type type instance Snap D = D type instance Snap Str = Str diff --git a/src/Csound/Typed/Types/Lift.hs b/src/Csound/Typed/Types/Lift.hs --- a/src/Csound/Typed/Types/Lift.hs +++ b/src/Csound/Typed/Types/Lift.hs @@ -1,4 +1,4 @@ -{-# Language FlexibleInstances #-} +{-# Language FlexibleInstances, ScopedTypeVariables #-} module Csound.Typed.Types.Lift( GE, E, -- * Lifters @@ -19,6 +19,7 @@ ) where +import Data.Proxy import Csound.Dynamic import Csound.Typed.Types.Prim import Csound.Typed.Types.Tuple @@ -60,17 +61,13 @@ -- multi out helpers -fromPm :: Tuple a => Pm -> a -fromPm (Pm a) = res - where res = toTuple $ fmap ( $ tupleArity res) a - -fromDm :: Tuple a => Dm -> SE a -fromDm (Dm a) = res - where - res = fmap toTuple $ fromDep $ hideGEinDep $ fmap ( $ (tupleArity $ proxy res)) a +fromPm :: forall a. Tuple a => Pm -> a +fromPm (Pm a) = + toTuple $ fmap ( $ tupleArity (Proxy :: Proxy a)) a - proxy :: SE a -> a - proxy = const undefined +fromDm :: forall a. Tuple a => Dm -> SE a +fromDm (Dm a) = + fmap toTuple $ fromDep $ hideGEinDep $ fmap ( $ (tupleArity (Proxy :: Proxy a))) a -- pure single diff --git a/src/Csound/Typed/Types/Prim.hs b/src/Csound/Typed/Types/Prim.hs --- a/src/Csound/Typed/Types/Prim.hs +++ b/src/Csound/Typed/Types/Prim.hs @@ -32,7 +32,7 @@ -- ** logic funs when1, whens, untilDo, whileDo, boolSig, equalsTo, notEqualsTo, lessThan, greaterThan, lessThanEquals, greaterThanEquals, - whenD1, whenDs, untilDoD, whileDoD, untilBeginD, + whenD1, whenDs, untilDoD, whileDoD ) where import Prelude hiding ((<*)) @@ -48,10 +48,13 @@ import Data.Default import Data.Boolean +import Data.Kind (Type) import Data.String +import Data.Text (Text) +import Data.Text qualified as Text -import Csound.Dynamic hiding (genId, double, int, str, when1, whens, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd, untilDo, whileBegin, whileEnd, whileDo) -import qualified Csound.Dynamic as D(double, int, str, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd, whileBegin, whileEnd) +import Csound.Dynamic hiding (genId, double, int, str, when1, whens, whileEnd) +import qualified Csound.Dynamic as D import Csound.Typed.GlobalState.GE import Csound.Typed.GlobalState.SE import Csound.Typed.GlobalState.Options @@ -169,7 +172,7 @@ preTab :: TabSize -> Int -> TabArgs -> Tab preTab size gen args = TabPre $ PreTab size (IntGenId gen) args -preStringTab :: TabSize -> String -> TabArgs -> Tab +preStringTab :: TabSize -> Text -> TabArgs -> Tab preStringTab size gen args = TabPre $ PreTab size (StringGenId gen) args data PreTab = PreTab @@ -214,7 +217,7 @@ fromPreTab a = withOptions $ \opt -> go (defTabFi opt) a where go :: TabFi -> PreTab -> Gen - go tabFi tab = Gen size (preTabGen tab) args file + go tabFi tab = Gen size (preTabGen tab) args (Text.pack <$> file) where size = defineTabSize (getTabSizeBase tabFi tab) (preTabSize tab) (args, file) = defineTabArgs size (preTabArgs tab) @@ -389,7 +392,7 @@ toGE x = case x of Sig a -> a - PrimSig d -> return $ D.double d + PrimSig d -> return $ setRate Kr $ D.double d instance Val D where fromGE = D @@ -548,7 +551,7 @@ ; asin = dOn1 asin asin; atan = dOn1 atan atan; acos = dOn1 acos acos ; asinh = dOn1 asinh asinh; acosh = dOn1 acosh acosh; atanh = dOn1 atanh atanh } class IsPrim a where - type PrimOf a :: * + type PrimOf a :: Type getPrim :: a -> Maybe (PrimOf a) fromPrim :: PrimOf a -> a @@ -628,27 +631,27 @@ instance IfB Sig where ifB x a b = case x of PrimBoolSig c -> if c then a else b - _ -> on3 ifB x a b + _ -> on3 (ifExp IfKr) x a b instance IfB D where ifB x a b = case x of PrimBoolD c -> if c then a else b - _ -> on3 ifB x a b + _ -> on3 (ifExp IfIr) x a b instance IfB Tab where ifB x a b = case x of PrimBoolD c -> if c then a else b - _ -> on3 ifB x a b + _ -> on3 (ifExp IfIr) x a b instance IfB Str where ifB x a b = case x of PrimBoolD c -> if c then a else b - _ -> on3 ifB x a b + _ -> on3 (ifExp IfIr) x a b instance IfB Spec where ifB x a b = case x of PrimBoolD c -> if c then a else b - _ -> on3 ifB x a b + _ -> on3 (ifExp IfIr) x a b instance EqB Sig where { (==*) = op2 (==) (==*); (/=*) = op2 (/=) (/=*) } instance EqB D where { (==*) = op2 (==) (==*); (/=*) = op2 (/=) (/=*) } @@ -656,108 +659,59 @@ instance OrdB Sig where { (<*) = op2 (<) (<*) ; (>*) = op2 (>) (>*); (<=*) = op2 (<=) (<=*); (>=*) = op2 (>=) (>=*) } instance OrdB D where { (<*) = op2 (<) (<*) ; (>*) = op2 (>) (>*); (<=*) = op2 (<=) (<=*); (>=*) = op2 (>=) (>=*) } +-- | Constructs generic if-block statement with single then case +-- We can choose constructors for: if, while, until statements +ifBlockBy :: Val cond => (E -> DepT GE (CodeBlock E) -> DepT GE ()) -> cond -> SE () -> SE () +ifBlockBy cons p body = + fromDep_ $ do + pE <- lift $ toGE p + cons pE (toBlock $ unSE body) + -- | Invokes the given procedure if the boolean signal is true. when1 :: BoolSig -> SE () -> SE () when1 xp body = case xp of PrimBoolSig p -> if p then body else return () - _ -> do - ifBegin xp - body - ifEnd + _ -> ifBlockBy (D.when1 IfKr) xp body -- | The chain of @when1@s. Tests all the conditions in sequence -- if everything is false it invokes the procedure given in the second argument. whens :: [(BoolSig, SE ())] -> SE () -> SE () whens bodies el = case bodies of [] -> el - a:as -> do - ifBegin (fst a) - snd a - elseIfs as - elseBegin - el - foldl1 (>>) $ replicate (length bodies) ifEnd - where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBegin p >> body) - -ifBegin :: BoolSig -> SE () -ifBegin a = fromDep_ $ D.ifBegin Kr =<< lift (toGE a) - -ifEnd :: SE () -ifEnd = fromDep_ D.ifEnd - -elseBegin :: SE () -elseBegin = fromDep_ D.elseBegin + _ -> fromDep_ $ join $ lift $ do + checksE <- mapM (toGE . fst) bodies + let bodiesE = fmap (toBlock . unSE . snd) bodies + elE = toBlock $ unSE el + pure $ D.whens IfKr (zip checksE bodiesE) elE -- | Invokes the given procedure if the boolean signal is true. whenD1 :: BoolD -> SE () -> SE () whenD1 xp body = case xp of PrimBoolD p -> if p then body else return () - _ -> do - ifBeginD xp - body - ifEnd + _ -> ifBlockBy (D.when1 IfIr) xp body -- | The chain of @when1@s. Tests all the conditions in sequence -- if everything is false it invokes the procedure given in the second argument. whenDs :: [(BoolD, SE ())] -> SE () -> SE () whenDs bodies el = case bodies of [] -> el - a:as -> do - ifBeginD (fst a) - snd a - elseIfs as - elseBegin - el - foldl1 (>>) $ replicate (length bodies) ifEnd - where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBeginD p >> body) - -ifBeginD :: BoolD -> SE () -ifBeginD a = fromDep_ $ D.ifBegin Ir =<< lift (toGE a) - --- elseIfBegin :: BoolSig -> SE () --- elseIfBegin a = fromDep_ $ D.elseIfBegin =<< lift (toGE a) + _ -> fromDep_ $ join $ lift $ do + checksE <- mapM (toGE . fst) bodies + let bodiesE = fmap (toBlock . unSE . snd) bodies + elE = toBlock $ unSE el + pure $ D.whens IfIr (zip checksE bodiesE) elE untilDo :: BoolSig -> SE () -> SE () -untilDo p body = do - untilBegin p - body - untilEnd +untilDo = ifBlockBy (D.untilBlock IfKr) whileDo :: BoolSig -> SE () -> SE () -whileDo p body = do - whileBegin p - body - whileEnd - -whileBegin :: BoolSig -> SE () -whileBegin a = fromDep_ $ D.whileBegin =<< lift (toGE a) - -whileEnd :: SE () -whileEnd = fromDep_ D.whileEnd - -untilBegin :: BoolSig -> SE () -untilBegin a = fromDep_ $ D.untilBegin =<< lift (toGE a) - -untilEnd :: SE () -untilEnd = fromDep_ D.untilEnd +whileDo = ifBlockBy (D.whileBlock IfKr) untilDoD :: BoolD -> SE () -> SE () -untilDoD p body = do - untilBeginD p - body - untilEnd +untilDoD = ifBlockBy (D.untilBlock IfIr) whileDoD :: BoolD -> SE () -> SE () -whileDoD p body = do - whileBeginD p - body - whileEnd - -whileBeginD :: BoolD -> SE () -whileBeginD a = fromDep_ $ D.whileBegin =<< lift (toGE a) - -untilBeginD :: BoolD -> SE () -untilBeginD a = fromDep_ $ D.untilBegin =<< lift (toGE a) +whileDoD = ifBlockBy (D.whileBlock IfIr) -- | Creates a constant boolean signal. boolSig :: BoolD -> BoolSig diff --git a/src/Csound/Typed/Types/PureArray.hs b/src/Csound/Typed/Types/PureArray.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types/PureArray.hs @@ -0,0 +1,70 @@ +-- | Pure (read-only) arrays +module Csound.Typed.Types.PureArray + ( PureArr + , PureArrD + , newPureArr + , newPureArrD + , readPureArr + , readPureArrD + ) where + +import Data.List qualified as List +import Data.Proxy + +import Csound.Dynamic (E, IfRate (..)) +import Csound.Dynamic qualified as D +import Csound.Typed.Types.Prim +import Csound.Typed.Types.Tuple +import Csound.Typed.GlobalState.GE + +-- | Pure (read-only) array. +-- We can initialise it and it's a pure value. +-- After initialisation we can read values with lookupPureArr +-- +-- This version works on initialisation rate +newtype PureArrD a = PureArrD (GE [E]) + +-- | Pure (read-only) array. +-- We can initialise it and it's a pure value. +-- After initialisation we can read values with lookupPureArr +-- +-- This version works on control rate +newtype PureArr a = PureArr (GE [E]) + +----------------------------------------------------------------------------- +-- initialization + +-- | Inits pure array that can be read at control rate +newPureArr :: Tuple a => [a] -> PureArr a +newPureArr = PureArr . newPureArrBy IfKr + +-- | Inits pure array that can be read at initialisation rate +newPureArrD :: Arg a => [a] -> PureArrD a +newPureArrD = PureArrD . newPureArrBy IfKr + +newPureArrBy :: forall a . Tuple a => IfRate -> [a] -> GE [E] +newPureArrBy procRate initVals = do + initPrimVals <- List.transpose <$> mapM fromTuple initVals + pure $ zipWith (\outRate initPrims -> D.initPureArr outRate procRate initPrims) outRates initPrimVals + where + outRates = tupleRates (Proxy @a) + +----------------------------------------------------------------------------- +-- read values + +readPureArr :: Tuple a => PureArr a -> Sig -> a +readPureArr (PureArr vals) index = + readPureArrBy IfKr vals (toGE index) + +readPureArrD :: Arg a => PureArrD a -> D -> a +readPureArrD (PureArrD vals) index = + readPureArrBy IfIr vals (toGE index) + +readPureArrBy :: forall a . Tuple a => IfRate -> GE [E] -> GE E -> a +readPureArrBy procRate vals index = toTuple $ do + indexE <- index + valsE <- vals + pure $ zipWith (\outRate arr -> D.readPureArr outRate procRate arr (D.setRate indexRate indexE)) outRates valsE + where + indexRate = D.fromIfRate procRate + outRates = tupleRates (Proxy @a) diff --git a/src/Csound/Typed/Types/SigSpace.hs b/src/Csound/Typed/Types/SigSpace.hs --- a/src/Csound/Typed/Types/SigSpace.hs +++ b/src/Csound/Typed/Types/SigSpace.hs @@ -17,6 +17,7 @@ import Control.Applicative import Csound.Typed.Types.Prim import Csound.Typed.GlobalState.SE +import Data.Kind (Type) import Data.NumInstances.Tuple() -- | A class for easy way to process the outputs of the instruments. @@ -476,7 +477,7 @@ ----------------------------------------------------------------------- class SigSpace b => At a b c where - type AtOut a b c :: * + type AtOut a b c :: Type at :: (a -> b) -> c -> AtOut a b c instance SigSpace a => At Sig Sig a where diff --git a/src/Csound/Typed/Types/Tuple.hs b/src/Csound/Typed/Types/Tuple.hs --- a/src/Csound/Typed/Types/Tuple.hs +++ b/src/Csound/Typed/Types/Tuple.hs @@ -3,6 +3,9 @@ TypeFamilies, FlexibleContexts, FlexibleInstances, + RankNTypes, + ScopedTypeVariables, + InstanceSigs, CPP #-} module Csound.Typed.Types.Tuple( -- ** Tuple @@ -34,6 +37,7 @@ import Control.Monad.Trans.Class import Data.Default import Data.Boolean +import Data.Proxy import Csound.Dynamic import Csound.Typed.Types.Prim @@ -49,8 +53,8 @@ data TupleMethods a = TupleMethods { fromTuple_ :: a -> GE [E] , toTuple_ :: GE [E] -> a - , tupleArity_ :: a -> Int - , tupleRates_ :: a -> [Rate] + , tupleArity_ :: Proxy a -> Int + , tupleRates_ :: Proxy a -> [Rate] , defTuple_ :: a } fromTuple :: Tuple a => a -> GE [E] @@ -59,10 +63,10 @@ toTuple :: Tuple a => GE [E] -> a toTuple = toTuple_ tupleMethods -tupleArity :: Tuple a => a -> Int +tupleArity :: Tuple a => Proxy a -> Int tupleArity = tupleArity_ tupleMethods -tupleRates :: Tuple a => a -> [Rate] +tupleRates :: Tuple a => Proxy a -> [Rate] tupleRates = tupleRates_ tupleMethods defTuple :: Tuple a => a @@ -77,11 +81,13 @@ { fromTuple_ = fromTuple . from , toTuple_ = to . toTuple , tupleArity_ = const $ tupleArity $ proxy to - , tupleRates_ = tupleRates . from + , tupleRates_ = const $ tupleRates $ proxy to , defTuple_ = to defTuple } - where proxy :: (a -> b) -> a - proxy = undefined + where + proxy :: (a -> b) -> Proxy a + proxy = const Proxy + -- Tuple instances primTupleMethods :: (Val a, Default a) => Rate -> TupleMethods a @@ -109,20 +115,25 @@ instance Tuple TabList where tupleMethods = primTupleMethods Kr instance (Tuple a, Tuple b) => Tuple (a, b) where - tupleMethods = TupleMethods fromTuple' toTuple' tupleArity' tupleRates' defTuple' - where - fromTuple' (a, b) = liftA2 (++) (fromTuple a) (fromTuple b) - tupleArity' x = let (a, b) = proxy x in tupleArity a + tupleArity b - where proxy :: (a, b) -> (a, b) - proxy = const (undefined, undefined) - toTuple' xs = (a, b) - where a = toTuple $ fmap (take (tupleArity a)) xs - xsb = fmap (drop (tupleArity a)) xs - b = toTuple $ fmap (take (tupleArity b)) xsb + tupleMethods = TupleMethods + { fromTuple_ = \(a, b) -> liftA2 (++) (fromTuple a) (fromTuple b) + , tupleArity_ = \x -> let (a, b) = splitProxy x in tupleArity a + tupleArity b + , toTuple_ = \xs -> + let a = toTuple $ fmap (take (tupleArity $ proxyAsType a)) xs + xsb = fmap (drop (tupleArity $ proxyAsType a)) xs + b = toTuple $ fmap (take (tupleArity $ proxyAsType b)) xsb + in (a, b) - tupleRates' (a, b) = tupleRates a ++ tupleRates b - defTuple' = (defTuple, defTuple) + , tupleRates_ = \x -> let (a, b) = splitProxy x in tupleRates a ++ tupleRates b + , defTuple_ = (defTuple, defTuple) + } +proxyAsType :: a -> Proxy a +proxyAsType = const Proxy + +splitProxy :: Proxy (a, b) -> (Proxy a, Proxy b) +splitProxy = const (Proxy, Proxy) + instance (Tuple a, Tuple b, Tuple c) => Tuple (a, b, c) where tupleMethods = makeTupleMethods cons3 split3 instance (Tuple a, Tuple b, Tuple c, Tuple d) => Tuple (a, b, c, d) where tupleMethods = makeTupleMethods cons4 split4 instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e) => Tuple (a, b, c, d, e) where tupleMethods = makeTupleMethods cons5 split5 @@ -133,9 +144,9 @@ ------------------------------------------------------------------------------- -- multiple outs -multiOuts :: Tuple a => E -> a -multiOuts expr = res - where res = toTuple $ return $ mo (tupleArity res) expr +multiOuts :: forall a . Tuple a => E -> a +multiOuts expr = + toTuple $ return $ mo (tupleArity (Proxy :: Proxy a)) expr ar1 :: Sig -> Sig ar2 :: (Sig, Sig) -> (Sig, Sig) @@ -178,11 +189,8 @@ instance Sig2s Sig6 instance Sig2s Sig8 -outArity :: Tuple a => SE a -> Int -outArity = tupleArity . proxy - where - proxy :: SE a -> a - proxy = const undefined +outArity :: forall a . Tuple a => SE a -> Int +outArity = const $ tupleArity (Proxy :: Proxy a) --------------------------------------------------------------------------- -- Arguments @@ -209,11 +217,11 @@ toArg :: Arg a => a toArg = arg 4 -argArity :: Arg a => a -> Int -argArity = tupleArity +argArity :: forall a . Arg a => a -> Int +argArity = const (tupleArity (Proxy :: Proxy a)) -toNote :: Arg a => a -> GE [E] -toNote a = zipWithM phi (tupleRates a) =<< fromTuple a +toNote :: forall a . Arg a => a -> GE [E] +toNote a = zipWithM phi (tupleRates (Proxy :: Proxy a)) =<< fromTuple a where phi rate x = case rate of Sr -> saveStr $ getStringUnsafe x @@ -240,7 +248,7 @@ instance IfB BoolTuple where ifB mp (BoolTuple mas) (BoolTuple mbs) = BoolTuple $ - liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs + liftA3 (\p as bs -> zipWith (ifExp IfKr p) as bs) (toGE mp) mas mbs -- | @ifB@ for tuples of csound values. ifTuple :: (Tuple a) => BoolSig -> a -> a -> a @@ -258,42 +266,40 @@ newtype BoolArg = BoolArg { unBoolArg :: GE [E] } -toBoolArg :: (Arg a, Tuple a) => a -> BoolArg +toBoolArg :: (Tuple a) => a -> BoolArg toBoolArg = BoolArg . fromTuple -fromBoolArg :: (Arg a, Tuple a) => BoolArg -> a +fromBoolArg :: (Tuple a) => BoolArg -> a fromBoolArg = toTuple . unBoolArg -type instance BooleanOf BoolArg = BoolD +type instance BooleanOf BoolArg = BoolSig instance IfB BoolArg where ifB mp (BoolArg mas) (BoolArg mbs) = BoolArg $ - liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs + liftA3 (\p as bs -> zipWith (ifExp IfKr p) as bs) (toGE mp) mas mbs -- | @ifB@ for constants. -ifArg :: (Arg a, Tuple a) => BoolD -> a -> a -> a +ifArg :: (Arg a, Tuple a) => BoolSig -> a -> a -> a ifArg p a b = fromBoolArg $ ifB p (toBoolArg a) (toBoolArg b) -- | @guardedB@ for constants. -guardedArg :: (Tuple b, Arg b) => [(BoolD, b)] -> b -> b +guardedArg :: (Tuple b) => [(BoolSig, b)] -> b -> b guardedArg bs b = fromBoolArg $ guardedB undefined (fmap (second toBoolArg) bs) (toBoolArg b) -- | @caseB@ for constants. -caseArg :: (Tuple b, Arg b) => a -> [(a -> BoolD, b)] -> b -> b +caseArg :: (Tuple b, Arg b) => a -> [(a -> BoolSig, b)] -> b -> b caseArg a bs other = fromBoolArg $ caseB a (fmap (second toBoolArg) bs) (toBoolArg other) ----------------------------------------------------------- -- tuple constructors -pureTuple :: Tuple a => GE (MultiOut [E]) -> a -pureTuple a = res - where res = toTuple $ fmap ($ tupleArity res) a +pureTuple :: forall a . Tuple a => GE (MultiOut [E]) -> a +pureTuple a = + toTuple $ fmap ($ tupleArity (Proxy :: Proxy a)) a -dirtyTuple :: Tuple a => GE (MultiOut [E]) -> SE a -dirtyTuple a = res - where - res = fmap (toTuple . return) $ SE - $ mapM depT =<< (lift $ fmap ($ (tupleArity $ proxy res)) a) - proxy :: SE a -> a - proxy = const undefined +dirtyTuple :: forall a . Tuple a => GE (MultiOut [E]) -> SE a +dirtyTuple a = + fmap (toTuple . return) $ SE + $ mapM depT =<< (lift $ fmap ($ (tupleArity (Proxy :: Proxy a))) a) +