diff --git a/csound-expression-dynamic.cabal b/csound-expression-dynamic.cabal --- a/csound-expression-dynamic.cabal +++ b/csound-expression-dynamic.cabal @@ -1,5 +1,5 @@ Name: csound-expression-dynamic -Version: 0.3.0 +Version: 0.3.2 Cabal-Version: >= 1.6 License: BSD3 License-file: LICENSE @@ -11,7 +11,7 @@ Category: Music, Sound Maintainer: -Description: +Description: Homepage: https://github.com/anton-k/csound-expression-dynamic Bug-Reports: https://github.com/anton-k/csound-expression-dynamic/issues @@ -24,7 +24,7 @@ Library Ghc-Options: -Wall Build-Depends: - base >= 4, base < 5, data-default, containers, array, transformers >= 0.3, wl-pprint, + base >= 4, base < 5, data-default, containers, array, transformers >= 0.3, wl-pprint, Boolean >= 0.1.0, data-fix, data-fix-cse >= 0.0.2, hashable Hs-Source-Dirs: src/ Exposed-Modules: @@ -34,21 +34,22 @@ Csound.Dynamic.Types.Exp Csound.Dynamic.Types.Dep Csound.Dynamic.Types.CsdFile - Csound.Dynamic.Types.Flags + Csound.Dynamic.Types.Flags Csound.Dynamic.Build Csound.Dynamic.Build.Numeric Csound.Dynamic.Build.Logic Csound.Dynamic.Render - + + Csound.Dynamic.Render.Instr + Csound.Dynamic.Render.Pretty Other-Modules: Csound.Dynamic.Tfm.DeduceTypes Csound.Dynamic.Tfm.Liveness Csound.Dynamic.Tfm.UnfoldMultiOuts - Csound.Dynamic.Render.Pretty - Csound.Dynamic.Render.Instr - + + diff --git a/src/Csound/Dynamic/Build.hs b/src/Csound/Dynamic/Build.hs --- a/src/Csound/Dynamic/Build.hs +++ b/src/Csound/Dynamic/Build.hs @@ -1,8 +1,8 @@ module Csound.Dynamic.Build ( - + -- * Expression tree -- | Working with expression tree - toExp, onExp, + toExp, onExp, -- * Rates -- * Queries @@ -10,7 +10,7 @@ -- * Constructors -- | Basic constructors - prim, opcPrefix, oprPrefix, oprInfix, + prim, opcPrefix, oprPrefix, oprInfix, numExp1, numExp2, tfm, tfmNoInlineArgs, pn, withInits, double, int, str, verbatim, instrIdE, @@ -18,7 +18,7 @@ -- ** Opcodes constructors Spec1, spec1, opcs, opcsNoInlineArgs, opr1, opr1k, infOpr, oprBy, - Specs, specs, MultiOut, mopcs, mo, + Specs, specs, MultiOut, mopcs, mo, -- * Global init statements setSr, setKsmps, setNchnls, setNchnls_i, setKr, setZeroDbfs, @@ -37,9 +37,9 @@ ------------------------------------------------ -- basic constructors - + prim :: Prim -> E -prim = noRate . ExpPrim +prim = noRate . ExpPrim opcPrefix :: Name -> Signature -> Info opcPrefix name signature = Info name signature Opcode @@ -65,8 +65,8 @@ tfmNoInlineArgs :: Info -> [E] -> E tfmNoInlineArgs info args = noRate $ Tfm info $ fmap (PrimOr . Right) args - -inlineVar :: Var -> E + +inlineVar :: Var -> E inlineVar = Fix . RatedExp Nothing Nothing . ReadVar pn :: Int -> E @@ -131,7 +131,7 @@ infOpr name a b = tfm (oprInfix name $ spec1 [(Ar, [Ar, Ar]), (Kr, [Kr, Kr]), (Ir, [Ir, Ir])]) [a, b] numExp1 :: NumOp -> E -> E -numExp1 op x = noRate $ ExpNum $ fmap toPrimOr $ PreInline op [x] +numExp1 op x = noRate $ ExpNum $ fmap toPrimOr $ PreInline op [x] numExp2 :: NumOp -> E -> E -> E numExp2 op a b = noRate $ ExpNum $ fmap toPrimOr $ PreInline op [a, b] @@ -148,22 +148,22 @@ type Specs = ([Rate], [Rate]) specs :: Specs -> Signature -specs = uncurry MultiRate +specs = uncurry MultiRate mopcs :: Name -> Specs -> [E] -> MultiOut [E] mopcs name signature as = \numOfOuts -> mo numOfOuts $ tfm (opcPrefix name $ specs signature) as mo :: Int -> E -> [E] mo n e = zipWith (\cellId r -> select cellId r e') [0 ..] outRates - where outRates = take n $ getRates $ toExp e + where outRates = take n $ getRates $ toExp e e' = onExp (setMultiRate outRates) e - - setMultiRate rates (Tfm info xs) = Tfm (info{ infoSignature = MultiRate rates ins }) xs + + setMultiRate rates (Tfm info xs) = Tfm (info{ infoSignature = MultiRate rates ins }) xs where ins = case infoSignature info of MultiRate _ a -> a - _ -> error "Tuple.hs: multiOutsSection -- should be multiOut expression" - setMultiRate _ _ = error "Tuple.hs: multiOutsSection -- argument should be Tfm-expression" - + _ -> error "Tuple.hs: multiOutsSection -- should be multiOut expression" + setMultiRate _ _ = error "Tuple.hs: multiOutsSection -- argument should be Tfm-expression" + select cellId rate expr = withRate rate $ Select rate cellId (PrimOr $ Right expr) @@ -173,7 +173,7 @@ _ -> error "Build.hs:getRates - argument should be multiOut" getRates _ = error "Build.hs:getRates - argument should be Tfm-expression" - + isMultiOutSignature :: Signature -> Bool isMultiOutSignature x = case x of MultiRate _ _ -> True @@ -198,7 +198,7 @@ -- global inits setSr, setKsmps, setNchnls, setNchnls_i, setKr :: Monad m => Int -> DepT m () - + setZeroDbfs :: Monad m => Double -> DepT m () setGlobal :: (Monad m, Show a) => String -> a -> DepT m () diff --git a/src/Csound/Dynamic/Render.hs b/src/Csound/Dynamic/Render.hs --- a/src/Csound/Dynamic/Render.hs +++ b/src/Csound/Dynamic/Render.hs @@ -1,5 +1,5 @@ module Csound.Dynamic.Render( - renderCsd + renderCsd ) where import qualified Text.PrettyPrint.Leijen as P @@ -9,7 +9,7 @@ import Csound.Dynamic.Types renderCsd :: Csd -> String -renderCsd a = show $ ppCsdFile +renderCsd a = show $ ppCsdFile (renderFlags $ csdFlags a) (renderOrc $ csdOrc a) (renderSco $ csdSco a) @@ -25,8 +25,8 @@ instrExprs = fmap renderInstr (orcInstruments a) renderSco :: Sco -> Doc -renderSco a = vcatSep +renderSco a = vcatSep [ P.vcat $ fmap (uncurry ppGen) $ scoGens a - , maybe P.empty ppTotalDur $ scoTotalDur a - , P.vcat $ fmap (uncurry ppNotes) $ scoNotes a ] + , maybe P.empty ppTotalDur $ scoTotalDur a + , P.vcat $ fmap (uncurry ppNotes) $ scoNotes a ] diff --git a/src/Csound/Dynamic/Render/Instr.hs b/src/Csound/Dynamic/Render/Instr.hs --- a/src/Csound/Dynamic/Render/Instr.hs +++ b/src/Csound/Dynamic/Render/Instr.hs @@ -1,6 +1,6 @@ module Csound.Dynamic.Render.Instr( renderInstr, renderInstrBody -) where +) where import Control.Arrow(second) import Control.Monad.Trans.State.Strict @@ -27,17 +27,17 @@ renderInstr a = ppInstr (instrName a) $ renderInstrBody (instrBody a) renderInstrBody :: E -> Doc -renderInstrBody a +renderInstrBody a | null dag = P.empty | otherwise = render dag - where + where dag = toDag a - render = P.vcat . flip evalState 0 . mapM (uncurry ppStmt . clearEmptyResults) . collectRates + render = P.vcat . flip evalState 0 . mapM (uncurry ppStmt . clearEmptyResults) . collectRates ------------------------------------------------------------- -- E -> Dag -toDag :: E -> Dag RatedExp +toDag :: E -> Dag RatedExp toDag expr = filterDepCases $ fromDag $ cseFramed getFrameInfo $ trimByArgLength expr getFrameInfo :: RatedExp a -> FrameInfo @@ -45,14 +45,14 @@ -- Imperative If-then-else IfBegin _ _ -> StartFrame -- ElseIfBegin _ -> NextFrame - ElseBegin -> NextFrame + ElseBegin -> NextFrame IfEnd -> StopFrame -- looping constructions UntilBegin _ -> StartFrame UntilEnd -> StopFrame WhileBegin _ -> StartFrame WhileRefBegin _ -> StartFrame - WhileEnd -> StopFrame + WhileEnd -> StopFrame _ -> NoFrame @@ -63,16 +63,16 @@ _ -> x trimInfo signature args = case signature of SingleRate tab -> SingleRate $ fmap trim tab - MultiRate outs ins -> MultiRate outs (trim ins) - where trim = take (length args) - + MultiRate outs ins -> MultiRate outs (trim ins) + where trim = take (length args) + clearEmptyResults :: ([RatedVar], Exp RatedVar) -> ([RatedVar], Exp RatedVar) clearEmptyResults (res, expr) = (filter ((/= Xr) . ratedVarRate) res, expr) - + collectRates :: Dag RatedExp -> [([RatedVar], Exp RatedVar)] collectRates dag = fmap (second ratedExpExp) res2 where res2 = liveness lastFreshId1 res1 - (res1, lastFreshId1)= unfoldMultiOuts unfoldSpec lastFreshId dag1 + (res1, lastFreshId1)= unfoldMultiOuts unfoldSpec lastFreshId dag1 (dag1, lastFreshId) = rateGraph dag ----------------------------------------------------------- @@ -94,13 +94,13 @@ where (stmts, lastId) = deduceTypes algSpec dag algSpec = TypeGraph mkConvert' defineType' - mkConvert' a = (to, RatedExp Nothing Nothing $ + mkConvert' a = (to, RatedExp Nothing Nothing $ ConvertRate (ratedVarRate to) (ratedVarRate from) $ PrimOr $ Right from) where from = convertFrom a to = convertTo a defineType' (outVar, expr) desiredRates = (ratesForConversion, (outVar', expr')) - where possibleRate = deduceRate desiredRates expr + where possibleRate = deduceRate desiredRates expr ratesForConversion = filter (not . flip coherentRates possibleRate) desiredRates expr' = RatedExp Nothing Nothing $ rateExp possibleRate $ ratedExpExp expr outVar' = ratedVar possibleRate outVar @@ -108,21 +108,21 @@ ---------------------------------------------------------- -- unfolds multiple rates -unfoldSpec :: UnfoldMultiOuts RatedExp Rate +unfoldSpec :: UnfoldMultiOuts RatedExp Rate unfoldSpec = UnfoldMultiOuts getSelector' getParentTypes' where getSelector' x = case ratedExpExp x of - Select _ order (PrimOr (Right parent)) -> Just $ Selector parent order + Select _ order (PrimOr (Right parent)) -> Just $ Selector parent order _ -> Nothing getParentTypes' x = case ratedExpExp x of - Tfm i _ -> if (isMultiOutSignature $ infoSignature i) - then Just (getRates $ ratedExpExp x) - else Nothing + Tfm i _ -> if (isMultiOutSignature $ infoSignature i) + then Just (getRates $ ratedExpExp x) + else Nothing _ -> Nothing coherentRates :: Rate -> Rate -> Bool coherentRates to from = case (to, from) of (a, b) | a == b -> True - (Xr, _) -> True + (Xr, _) -> True (Kr, Ir) -> True _ -> False @@ -131,22 +131,22 @@ ExpPrim _ -> case desiredRates of [Sr] -> Sr _ -> Ir - + Tfm info _ -> case infoSignature info of MultiRate _ _ -> Xr - SingleRate tab -> + SingleRate tab -> let r1 = tfmNoRate (infoName info) desiredRates tab in case ratedExpRate expr of Just r | M.member r tab -> r Just _ -> r1 Nothing -> r1 - + ExpNum _ -> case ratedExpRate expr of Just r -> r Nothing -> case maximum (Ar : desiredRates) of Xr -> Ar r -> r - + Select rate _ _ -> rate If _ _ _ -> case head $ sort desiredRates of Xr -> Ar @@ -156,27 +156,27 @@ ReadMacrosString _ -> Sr ReadMacrosDouble _ -> Ir ReadMacrosInt _ -> Ir - _ -> Xr + _ -> Xr where tfmNoRate name rates tab = case sort rates of - [Xr] -> tfmNoRate name [Ar] tab + [Xr] -> tfmNoRate name [Ar] tab Xr:as -> tfmNoRate name as tab - as | any (== Ir) as -> fromJust $ find (flip M.member tab) (Ir : as ++ [minBound .. maxBound]) - as -> fromJust $ find (flip M.member tab) (as ++ [minBound .. maxBound]) + as | any (== Ir) as -> fromJust $ find (flip M.member tab) (Ir : as ++ [minBound .. maxBound]) + as -> fromJust $ find (flip M.member tab) (as ++ [minBound .. maxBound]) -rateExp :: Rate -> Exp Int -> Exp RatedVar +rateExp :: Rate -> Exp Int -> Exp RatedVar rateExp curRate expr = case expr of ExpPrim (P n) | curRate == Sr -> ExpPrim (PString n) Tfm i xs -> Tfm i $ mergeWithPrimOr (ratesFromSignature curRate (infoSignature i)) xs - Select rate pid a -> Select rate pid (fmap (ratedVar Xr) a) - If p t e -> If (rec2 condRate p) (rec1 curRate t) (rec1 curRate e) - ExpNum _ -> rec2 curRate expr - + Select rate pid a -> Select rate pid (fmap (ratedVar Xr) a) + If p t e -> If (rec2 condRate p) (rec1 curRate t) (rec1 curRate e) + ExpNum _ -> rec2 curRate expr + ReadVar v -> ReadVar v WriteVar v a -> WriteVar v $ rec1 (varRate v) a - InitVar v a -> InitVar v $ rec1 Ir a -- rec1 (varRate v) a - + InitVar v a -> InitVar v $ rec1 Ir a -- rec1 (varRate v) a + ReadArr v as -> ReadArr v $ arrIndex v as - WriteArr v as b -> WriteArr v (arrIndex v as) (rec1 (varRate v) b) + WriteArr v as b -> WriteArr v (arrIndex v as) (rec1 (varRate v) b) WriteInitArr v as b -> WriteInitArr v (arrIndex v as) (rec1 Ir b) InitArr v as -> InitArr v $ fmap (rec1 Ir) as TfmArr isInit v i xs -> TfmArr isInit v i $ mergeWithPrimOr (ratesFromSignature curRate (infoSignature i)) xs @@ -184,14 +184,14 @@ ExpPrim p -> ExpPrim p IfBegin rootRate _ -> rec2 rootRate expr UntilBegin _ -> rec2 condRate expr - WhileBegin _ -> rec2 condRate expr + WhileBegin _ -> rec2 condRate expr WhileRefBegin var -> WhileRefBegin var -- ElseIfBegin _ -> rec2 condRate expr ElseBegin -> ElseBegin IfEnd -> IfEnd UntilEnd -> UntilEnd - WhileEnd -> WhileEnd - EmptyExp -> EmptyExp + WhileEnd -> WhileEnd + EmptyExp -> EmptyExp Verbatim a -> Verbatim a InitMacrosString name initValue -> InitMacrosString name initValue InitMacrosDouble name initValue -> InitMacrosDouble name initValue @@ -199,30 +199,30 @@ ReadMacrosDouble name -> ReadMacrosDouble name ReadMacrosInt name -> ReadMacrosInt name ExpBool _ -> error $ msg "ExpBool expression should be substituted" - ConvertRate _ _ _ -> error $ msg "ConvertRate couldn't be here. It's introduced on the later stages of processing" + ConvertRate _ _ _ -> error $ msg "ConvertRate couldn't be here. It's introduced on the later stages of processing" where ratesFromSignature rate signature = case signature of SingleRate table -> table M.! rate MultiRate _ rs -> rs condRate :: Rate condRate = max Kr curRate -- Kr - - rec2 r = fmap (fmap (ratedVar r)) + + rec2 r = fmap (fmap (ratedVar r)) rec1 r = fmap (ratedVar r) arrIndex v as = fmap (rec1 (arrIndexVarRate v)) as - msg txt = "Csound.Dynamic.Render.Instr.rateExp: " ++ txt - -arrIndexVarRate v = case varRate v of + msg txt = "Csound.Dynamic.Render.Instr.rateExp: " ++ txt + +arrIndexVarRate v = case varRate v of Ir -> Ir _ -> Kr mergeWithPrimOr :: [Rate] -> [PrimOr Int] -> [PrimOr (Var Rate)] mergeWithPrimOr = zipWith phi - where + where phi r (PrimOr x) = PrimOr $ case x of - Left p -> Left $ updateVarTargetRate r p + Left p -> Left $ updateVarTargetRate r p Right n -> Right $ ratedVar r n updateVarTargetRate r p = case p of PrimVar _ v -> PrimVar r v diff --git a/src/Csound/Dynamic/Types.hs b/src/Csound/Dynamic/Types.hs --- a/src/Csound/Dynamic/Types.hs +++ b/src/Csound/Dynamic/Types.hs @@ -5,7 +5,7 @@ module Csound.Dynamic.Types.Flags, module Csound.Dynamic.Types.CsdFile -) where +) where import Csound.Dynamic.Types.Exp import Csound.Dynamic.Types.Dep diff --git a/src/Csound/Dynamic/Types/CsdFile.hs b/src/Csound/Dynamic/Types/CsdFile.hs --- a/src/Csound/Dynamic/Types/CsdFile.hs +++ b/src/Csound/Dynamic/Types/CsdFile.hs @@ -1,5 +1,5 @@ -- | The Csound file -module Csound.Dynamic.Types.CsdFile( +module Csound.Dynamic.Types.CsdFile( Csd(..), Flags, Orc(..), Sco(..), Plugin(..), Instr(..), InstrBody, CsdEvent, csdEventStart, csdEventDur, csdEventContent, csdEventTotalDur, intInstr, alwaysOn @@ -14,7 +14,7 @@ , csdOrc :: Orc , csdSco :: Sco , csdPlugins :: [Plugin] - } + } data Orc = Orc { orcHead :: InstrBody @@ -28,7 +28,7 @@ , instrBody :: InstrBody } -data Sco = Sco +data Sco = Sco { scoTotalDur :: Maybe Double , scoGens :: [(Int, Gen)] , scoNotes :: [(InstrId, [CsdEvent])] } diff --git a/src/Csound/Dynamic/Types/Dep.hs b/src/Csound/Dynamic/Types/Dep.hs --- a/src/Csound/Dynamic/Types/Dep.hs +++ b/src/Csound/Dynamic/Types/Dep.hs @@ -1,8 +1,8 @@ -- | Dependency tracking module Csound.Dynamic.Types.Dep( - DepT(..), LocalHistory(..), runDepT, execDepT, evalDepT, + DepT(..), LocalHistory(..), runDepT, execDepT, evalDepT, -- * Dependencies - depT, depT_, mdepT, stripDepT, stmtOnlyT, + depT, depT_, mdepT, stripDepT, stmtOnlyT, -- * Variables newLocalVar, newLocalVars, @@ -12,8 +12,8 @@ newLocalArrVar, newTmpArrVar, readArr, readOnlyArr, writeArr, writeInitArr, initArr, appendArrBy, - -- * Read macros - readMacrosDouble, readMacrosInt, readMacrosString, + -- * Read macros + readMacrosDouble, readMacrosInt, readMacrosString, initMacrosDouble, initMacrosString, initMacrosInt ) where @@ -27,10 +27,10 @@ import Csound.Dynamic.Types.Exp --- | Csound's synonym for 'IO'-monad. 'Dep' means Side Effect. +-- | Csound's synonym for 'IO'-monad. 'Dep' means Side Effect. -- You will bump into 'Dep' trying to read and write to delay lines, --- making random signals or trying to save your audio to file. --- Instrument is expected to return a value of @Dep [Sig]@. +-- making random signals or trying to save your audio to file. +-- Instrument is expected to return a value of @Dep [Sig]@. -- So it's okay to do some side effects when playing a note. newtype DepT m a = DepT { unDepT :: StateT LocalHistory m a } @@ -43,7 +43,7 @@ def = LocalHistory start 0 0 instance Monad m => Functor (DepT m) where - fmap = liftM + fmap = liftM instance Monad m => Applicative (DepT m) where pure = return @@ -61,7 +61,7 @@ evalDepT :: (Functor m, Monad m) => DepT m a -> m a evalDepT a = evalStateT (unDepT $ a) def - + execDepT :: (Functor m, Monad m) => DepT m () -> m E execDepT a = fmap expDependency $ execStateT (unDepT $ a) def @@ -80,10 +80,10 @@ depT a = DepT $ do s <- get let a1 = Fix $ (unFix a) { ratedExpDepends = Just (newLineNum s) } - put $ s { - newLineNum = succ $ newLineNum s, + put $ s { + newLineNum = succ $ newLineNum s, expDependency = depends (expDependency s) a1 } - return a1 + return a1 depT_ :: (Monad m) => E -> DepT m () depT_ = fmap (const ()) . depT @@ -92,13 +92,13 @@ mdepT mas = \n -> mapM depT $ ( $ n) mas stripDepT :: Monad m => DepT m a -> m a -stripDepT (DepT a) = evalStateT a def +stripDepT (DepT a) = evalStateT a def stmtOnlyT :: Monad m => Exp E -> DepT m () stmtOnlyT stmt = depT_ $ noRate stmt -emptyE :: E -emptyE = noRate $ EmptyExp +emptyE :: E +emptyE = noRate $ EmptyExp -- local variables @@ -117,7 +117,7 @@ newVar :: Monad m => Rate -> DepT m Var newVar rate = DepT $ do s <- get - let v = Var LocalVar rate (show $ newLocalVarId s) + let v = Var LocalVar rate (show $ newLocalVarId s) put $ s { newLocalVarId = succ $ newLocalVarId s } return v @@ -127,7 +127,7 @@ -- generic funs writeVar :: Monad m => Var -> E -> DepT m () -writeVar v x = depT_ $ noRate $ WriteVar v $ toPrimOr x +writeVar v x = depT_ $ noRate $ WriteVar v $ toPrimOr x readVar :: Monad m => Var -> DepT m E readVar v = depT $ noRate $ ReadVar v @@ -172,7 +172,7 @@ initArr :: Monad m => Var -> [E] -> DepT m () initArr v xs = depT_ $ noRate $ InitArr v $ fmap toPrimOr xs -appendArrBy :: Monad m => (E -> E -> E) -> Var -> [E] -> E -> DepT m () +appendArrBy :: Monad m => (E -> E -> E) -> Var -> [E] -> E -> DepT m () appendArrBy op v ixs x = writeArr v ixs . op x =<< readArr v ixs -------------------------------------------------- @@ -202,4 +202,4 @@ initMacrosBy :: Monad m => (String -> a -> Exp E) -> String -> a -> DepT m () initMacrosBy maker name value = depT_ $ noRate $ maker name value - + diff --git a/src/Csound/Dynamic/Types/Exp.hs b/src/Csound/Dynamic/Types/Exp.hs --- a/src/Csound/Dynamic/Types/Exp.hs +++ b/src/Csound/Dynamic/Types/Exp.hs @@ -1,19 +1,19 @@ -- | Main types -{-# Language - DeriveFunctor, DeriveFoldable, DeriveTraversable, - DeriveGeneric, +{-# Language + DeriveFunctor, DeriveFoldable, DeriveTraversable, + DeriveGeneric, TypeSynonymInstances, FlexibleInstances #-} module Csound.Dynamic.Types.Exp( - E, RatedExp(..), isEmptyExp, RatedVar, ratedVar, ratedVarRate, ratedVarId, + E, RatedExp(..), isEmptyExp, RatedVar, ratedVar, ratedVarRate, ratedVarId, ratedExp, noRate, withRate, setRate, - Exp, toPrimOr, toPrimOrTfm, PrimOr(..), MainExp(..), Name, + Exp, toPrimOr, toPrimOrTfm, PrimOr(..), MainExp(..), Name, InstrId(..), intInstrId, ratioInstrId, stringInstrId, - VarType(..), Var(..), Info(..), OpcFixity(..), Rate(..), - Signature(..), isInfix, isPrefix, + VarType(..), Var(..), Info(..), OpcFixity(..), Rate(..), + Signature(..), isInfix, isPrefix, Prim(..), Gen(..), GenId(..), Inline(..), InlineExp(..), PreInline(..), - BoolExp, CondInfo, CondOp(..), isTrue, isFalse, - NumExp, NumOp(..), Note, + BoolExp, CondInfo, CondOp(..), isTrue, isFalse, + NumExp, NumOp(..), Note, MultiOut, IsArrInit, ArrSize, ArrIndex ) where @@ -31,19 +31,19 @@ import qualified Data.IntMap as IM import Data.Fix -import qualified Csound.Dynamic.Tfm.DeduceTypes as R(Var(..)) +import qualified Csound.Dynamic.Tfm.DeduceTypes as R(Var(..)) type Name = String type LineNum = Int -- | An instrument identifier -data InstrId - = InstrId +data InstrId + = InstrId { instrIdFrac :: Maybe Int , instrIdCeil :: Int } - | InstrLabel String + | InstrLabel String deriving (Show, Eq, Ord, Generic) - + -- | Constructs an instrument id with the integer. intInstrId :: Int -> InstrId intInstrId n = InstrId Nothing n @@ -58,18 +58,18 @@ -- | The inner representation of csound expressions. type E = Fix RatedExp - + instance Hashable E where hashWithSalt s x = s `hashWithSalt` cata hash x -data RatedExp a = RatedExp - { ratedExpRate :: Maybe Rate - -- ^ Rate (can be undefined or Nothing, +data RatedExp a = RatedExp + { ratedExpRate :: Maybe Rate + -- ^ Rate (can be undefined or Nothing, -- it means that rate should be deduced automatically from the context) - , ratedExpDepends :: Maybe LineNum + , ratedExpDepends :: Maybe LineNum -- ^ Dependency (it is used for expressions with side effects, -- value contains the privious statement) - , ratedExpExp :: Exp a + , ratedExpExp :: Exp a -- ^ Main expression } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) @@ -93,7 +93,7 @@ noRate :: Exp E -> E noRate = ratedExp Nothing - + withRate :: Rate -> Exp E -> E withRate r = ratedExp (Just r) @@ -115,7 +115,7 @@ ExpPrim p -> Left p ReadVar v | noDeps -> Left (PrimVar (varRate v) v) _ -> Right a - where + where noDeps = isNothing $ ratedExpDepends $ unFix a -- | Constructs PrimOr values from the expressions. It does inlining in @@ -126,7 +126,7 @@ ExpPrim p | (r == Ir || r == Sr) -> Left p ReadVar v | noDeps -> Left (PrimVar (varRate v) v) _ -> Right a - where + where noDeps = isNothing $ ratedExpDepends $ unFix a @@ -134,18 +134,18 @@ type Exp a = MainExp (PrimOr a) -- Csound expressions -data MainExp a +data MainExp a = EmptyExp -- | Primitives | ExpPrim Prim - -- | Application of the opcode: we have opcode information (Info) and the arguments [a] + -- | Application of the opcode: we have opcode information (Info) and the arguments [a] | Tfm Info [a] -- | Rate conversion | ConvertRate Rate Rate a -- | Selects a cell from the tuple, here argument is always a tuple (result of opcode that returns several outputs) | Select Rate Int a -- | if-then-else - | If (CondInfo a) a a + | If (CondInfo a) a a -- | Boolean expressions (rendered in infix notation in the Csound) | ExpBool (BoolExp a) -- | Numerical expressions (rendered in infix notation in the Csound) @@ -153,9 +153,9 @@ -- | Reading/writing a named variable | InitVar Var a | ReadVar Var - | WriteVar Var a + | WriteVar Var a -- | Arrays - | InitArr Var (ArrSize a) + | InitArr Var (ArrSize a) | ReadArr Var (ArrIndex a) | WriteArr Var (ArrIndex a) a | WriteInitArr Var (ArrIndex a) a @@ -184,7 +184,7 @@ | ReadMacrosInt String | ReadMacrosDouble String | ReadMacrosString String - deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) type IsArrInit = Bool type ArrSize a = [a] @@ -195,35 +195,35 @@ where re = unFix e -- Named variable -data Var +data Var = Var { varType :: VarType -- global / local , varRate :: Rate - , varName :: Name } - | VarVerbatim + , varName :: Name } + | VarVerbatim { varRate :: Rate - , varName :: Name - } deriving (Show, Eq, Ord, Generic) - + , varName :: Name + } deriving (Show, Eq, Ord, Generic) + -- Variables can be global (then we have to prefix them with `g` in the rendering) or local. data VarType = LocalVar | GlobalVar deriving (Show, Eq, Ord, Generic) -- Opcode information. -data Info = Info +data Info = Info -- Opcode name - { infoName :: Name + { infoName :: Name -- Opcode type signature , infoSignature :: Signature -- Opcode can be infix or prefix , infoOpcFixity :: OpcFixity - } deriving (Show, Eq, Ord, Generic) - + } deriving (Show, Eq, Ord, Generic) + isPrefix, isInfix :: Info -> Bool isPrefix = (Prefix ==) . infoOpcFixity isInfix = (Infix ==) . infoOpcFixity - + -- Opcode fixity data OpcFixity = Prefix | Infix | Opcode deriving (Show, Eq, Ord, Generic) @@ -232,55 +232,55 @@ data Rate -- rate: ---------------------------- = Xr -- audio or control (and I use it for opcodes that produce no output, ie procedures) - | Ar -- audio - | Kr -- control - | Ir -- init (constants) + | Ar -- audio + | Kr -- control + | Ir -- init (constants) | Sr -- strings | Fr -- spectrum (for pvs opcodes) - | Wr -- special spectrum + | Wr -- special spectrum | Tvar -- I don't understand what it is (fix me) used with Fr deriving (Show, Eq, Ord, Enum, Bounded, Generic) - + -- Opcode type signature. Opcodes can produce single output (SingleRate) or multiple outputs (MultiRate). --- In Csound opcodes are often have several signatures. That is one opcode name can produce signals of the +-- In Csound opcodes are often have several signatures. That is one opcode name can produce signals of the -- different rate (it depends on the type of the outputs). Here we assume (to make things easier) that --- opcodes that MultiRate-opcodes can produce only the arguments of the same type. -data Signature +-- opcodes that MultiRate-opcodes can produce only the arguments of the same type. +data Signature -- For SingleRate-opcodes type signature is the Map from output rate to the rate of the arguments. -- With it we can deduce the type of the argument from the type of the output. - = SingleRate (Map Rate [Rate]) - -- For MultiRate-opcodes Map degenerates to the singleton. We have only one link. + = SingleRate (Map Rate [Rate]) + -- For MultiRate-opcodes Map degenerates to the singleton. We have only one link. -- It contains rates for outputs and inputs. - | MultiRate - { outMultiRate :: [Rate] - , inMultiRate :: [Rate] } + | MultiRate + { outMultiRate :: [Rate] + , inMultiRate :: [Rate] } deriving (Show, Eq, Ord) instance Hashable Signature where hashWithSalt s x = case x of SingleRate m -> s `hashWithSalt` (0 :: Int) `hashWithSalt` (hash $ fmap (\b -> (take 5 b)) $ head' $ toList m) MultiRate a b -> s `hashWithSalt` (1 :: Int) `hashWithSalt` (hash $ take 5 a) `hashWithSalt` (hash $ take 5 b) - where + where head' xs = case xs of [] -> Nothing x:_ -> Just x -- Primitive values -data Prim +data Prim -- instrument p-arguments - = P Int - | PString Int -- >> p-string (read p-string notes at the bottom of the file): - | PrimInt Int - | PrimDouble Double - | PrimString String + = P Int + | PString Int -- >> p-string (read p-string notes at the bottom of the file): + | PrimInt Int + | PrimDouble Double + | PrimString String | PrimInstrId InstrId - | PrimVar - { primVarTargetRate :: Rate + | PrimVar + { primVarTargetRate :: Rate , primVar :: Var } deriving (Show, Eq, Ord, Generic) -- Gen routine. -data Gen = Gen +data Gen = Gen { genSize :: Int , genId :: GenId , genArgs :: [Double] @@ -296,15 +296,15 @@ ------------------------------------------------------------ -- types for arithmetic and boolean expressions -data Inline a b = Inline +data Inline a b = Inline { inlineExp :: InlineExp a - , inlineEnv :: IM.IntMap b + , inlineEnv :: IM.IntMap b } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) instance (Hashable a, Hashable b) => Hashable (Inline a b) where - hashWithSalt s (Inline a m) = s `hashWithSalt` (hash a) `hashWithSalt` (hash $ IM.toList m) + hashWithSalt s (Inline a m) = s `hashWithSalt` (hash a) `hashWithSalt` (hash $ IM.toList m) --- Inlined expression. +-- Inlined expression. data InlineExp a = InlinePrim Int | InlineExp a [InlineExp a] @@ -320,10 +320,10 @@ type CondInfo a = Inline CondOp a -- Conditional operators -data CondOp +data CondOp = TrueOp | FalseOp | And | Or | Equals | NotEquals | Less | Greater | LessEquals | GreaterEquals - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) isTrue, isFalse :: CondInfo a -> Bool @@ -342,7 +342,7 @@ type NumExp a = PreInline NumOp a -data NumOp = Add | Sub | Neg | Mul | Div | Pow | Mod +data NumOp = Add | Sub | Neg | Mul | Div | Pow | Mod deriving (Show, Eq, Ord, Generic) ------------------------------------------------------- @@ -386,10 +386,10 @@ -------------------------------------------------------------- -- comments --- --- p-string -- --- separate p-param for strings (we need it to read strings from global table) +-- p-string +-- +-- separate p-param for strings (we need it to read strings from global table) -- Csound doesn't permits us to use more than four string params so we need to -- keep strings in the global table and use `strget` to read them diff --git a/src/Csound/Dynamic/Types/Flags.hs b/src/Csound/Dynamic/Types/Flags.hs --- a/src/Csound/Dynamic/Types/Flags.hs +++ b/src/Csound/Dynamic/Types/Flags.hs @@ -9,7 +9,7 @@ -- * Realtime Audio Input/Output Rtaudio(..), PulseAudio(..), - + -- * MIDI File Input/Ouput MidiIO(..), @@ -44,15 +44,16 @@ , midiRT :: MidiRT , rtmidi :: Maybe Rtmidi , displays :: Displays - , config :: Config - , flagsVerbatim :: Maybe String } + , config :: Config + , flagsVerbatim :: Maybe String + } deriving (Eq, Show, Read) instance Default Flags where def = Flags def def def def def def def def def def instance Monoid Flags where mempty = def - mappend a b = Flags + mappend a b = Flags { audioFileOutput = mappend (audioFileOutput a) (audioFileOutput b) , idTags = mappend (idTags a) (idTags b) , rtaudio = rtaudio a <|> rtaudio b @@ -62,7 +63,8 @@ , rtmidi = rtmidi a <|> rtmidi b , displays = mappend (displays a) (displays b) , config = mappend (config a) (config b) - , flagsVerbatim = mappend (flagsVerbatim a) (flagsVerbatim b) } + , flagsVerbatim = mappend (flagsVerbatim a) (flagsVerbatim b) + } -- Audio file output @@ -73,14 +75,15 @@ , input :: Maybe String , nosound :: Bool , nopeaks :: Bool - , dither :: Maybe Dither } + , dither :: Maybe Dither + } deriving (Eq, Show, Read) instance Default AudioFileOutput where def = AudioFileOutput def def def def False False def - + instance Monoid AudioFileOutput where mempty = def - mappend a b = AudioFileOutput + mappend a b = AudioFileOutput { formatSamples = formatSamples a <|> formatSamples b , formatType = formatType a <|> formatType b , output = output a <|> output b @@ -90,38 +93,40 @@ , dither = dither a <|> dither b } data FormatHeader = NoHeader | RewriteHeader + deriving (Eq, Show, Read) -data FormatSamples - = Bit24 | Alaw | Uchar | Schar +data FormatSamples + = Bit24 | Alaw | Uchar | Schar | FloatSamples | Ulaw | Short | Long - deriving (Show) + deriving (Eq, Show, Read) data Dither = Triangular | Uniform - deriving (Show) + deriving (Eq, Show, Read) -data FormatType +data FormatType = Aiff | Au | Avr | Caf | Flac | Htk | Ircam | Mat4 | Mat5 | Nis | Paf | Pvf - | Raw | Sd2 | Sds | Svx | Voc | W64 + | Raw | Sd2 | Sds | Svx | Voc | W64 | Wav | Wavex | Xi - deriving (Show) + deriving (Eq, Show, Read) -- Output file id tags -data IdTags = IdTags +data IdTags = IdTags { idArtist :: Maybe String , idComment :: Maybe String , idCopyright :: Maybe String , idDate :: Maybe String , idSoftware :: Maybe String - , idTitle :: Maybe String } + , idTitle :: Maybe String + } deriving (Eq, Show, Read) instance Default IdTags where def = IdTags def def def def def def instance Monoid IdTags where mempty = def - mappend a b = IdTags + mappend a b = IdTags { idArtist = idArtist a <|> idArtist b , idComment = idComment a <|> idComment b , idCopyright = idCopyright a <|> idCopyright b @@ -131,35 +136,38 @@ -- Realtime Audio Input/Output -data Rtaudio - = PortAudio | Alsa - | Jack +data Rtaudio + = PortAudio | Alsa + | Jack { jackClient :: String , jackInport :: String - , jackOutport :: String } + , jackOutport :: String } | Mme | CoreAudio | NoRtaudio + deriving (Eq, Show, Read) data PulseAudio = PulseAudio { paServer :: String , paOutput :: String - , paInput :: String } + , paInput :: String + } deriving (Eq, Show, Read) -- MIDI File Input/Ouput -data MidiIO = MidiIO +data MidiIO = MidiIO { midiFile :: Maybe String , midiOutFile :: Maybe String , muteTracks :: Maybe String , rawControllerMode :: Bool - , terminateOnMidi :: Bool } + , terminateOnMidi :: Bool + } deriving (Eq, Show, Read) instance Default MidiIO where def = MidiIO def def def False False instance Monoid MidiIO where mempty = def - mappend a b = MidiIO + mappend a b = MidiIO { midiFile = midiFile a <|> midiFile b , midiOutFile = midiOutFile a <|> midiOutFile b , muteTracks = muteTracks a <|> muteTracks b @@ -176,15 +184,16 @@ , midiKeyPch :: Maybe Int , midiVelocity :: Maybe Int , midiVelocityAmp :: Maybe Int - , midiOutDevice :: Maybe String } - + , midiOutDevice :: Maybe String + } deriving (Eq, Show, Read) + instance Default MidiRT where def = MidiRT def def def def def def def def instance Monoid MidiRT where mempty = def - mappend a b = MidiRT + mappend a b = MidiRT { midiDevice = midiDevice a <|> midiDevice b , midiKey = midiKey a <|> midiKey b , midiKeyCps = midiKeyCps a <|> midiKeyCps b @@ -195,6 +204,7 @@ , midiOutDevice = midiOutDevice a <|> midiOutDevice b } data Rtmidi = PortMidi | AlsaMidi | AlsaSeq | CoreMidi | MmeMidi | WinmmeMidi | VirtualMidi | NoRtmidi + deriving (Eq, Show, Read) -- Display @@ -211,12 +221,14 @@ , mBenchmarks :: Maybe Int , msgColor :: Bool , displayVerbose :: Bool - , listOpcodes :: Maybe Int } + , listOpcodes :: Maybe Int + } deriving (Eq, Show, Read) data DisplayMode = NoDisplay | PostScriptDisplay | AsciiDisplay + deriving (Eq, Show, Read) instance Default Displays where - def = Displays def (Just NoDisplay) + def = Displays def (Just NoDisplay) def def def def def def def def False False @@ -224,7 +236,7 @@ instance Monoid Displays where mempty = def - mappend a b = Displays + mappend a b = Displays { csdLineNums = csdLineNums a <|> csdLineNums b , displayMode = displayMode a <|> displayMode b , displayHeartbeat = displayHeartbeat a <|> displayHeartbeat b @@ -237,7 +249,7 @@ , mBenchmarks = mBenchmarks a <|> mBenchmarks b , msgColor = mappendBool (msgColor a) (msgColor b) , displayVerbose = mappendBool (displayVerbose a) (displayVerbose b) - , listOpcodes = listOpcodes a <|> listOpcodes b } + , listOpcodes = listOpcodes a <|> listOpcodes b } -- Performance Configuration and Control @@ -253,12 +265,13 @@ , schedNum :: Maybe Int , strsetN :: Maybe (Int, String) , skipSeconds :: Maybe Double - , setTempo :: Maybe Int } + , setTempo :: Maybe Int + } deriving (Eq, Show, Read) instance Default Config where def = Config def def def def def def def False - def def def def + def def def def instance Monoid Config where mempty = def @@ -284,8 +297,8 @@ p = (fmap pretty . ) pe :: Pretty b => (a -> b) -> (a -> Maybe Doc) -pe f = phi . f - where phi x +pe f = phi . f + where phi x | null (show res) = Nothing | otherwise = Just res where res = pretty x @@ -293,7 +306,7 @@ bo :: String -> (a -> Bool) -> (a -> Maybe Doc) bo property extract a | extract a = Just $ text property - | otherwise = Nothing + | otherwise = Nothing mp :: (String -> String) -> (a -> Maybe String) -> (a -> Maybe Doc) mp f a = p (fmap f . a) @@ -306,7 +319,7 @@ p2 :: String -> String -> String p2 pref x = ('-' : '-' : pref) ++ ('=' : x) - + p3 :: String -> String -> String p3 pref x = ('-' : '+' : pref) ++ ('=' : x) @@ -315,19 +328,19 @@ instance Pretty Flags where pretty = fields - [ pe audioFileOutput - , pe idTags + [ pe displays + , pe config + , pe audioFileOutput + , pe idTags , p rtaudio , p pulseAudio + , p rtmidi , pe midiIO , pe midiRT - , p rtmidi - , pe displays - , pe config , p flagsVerbatim ] instance Pretty AudioFileOutput where - pretty = fields + pretty = fields [ pSamplesAndType . (\x -> (formatSamples x, formatType x)) , mp (p2 "output") output , mp (p2 "input") input @@ -355,18 +368,18 @@ pretty = pretty . p2 "dither" . show instance Pretty IdTags where - pretty = fields + pretty = fields [ mp (p3' "id_artist") idArtist , mp (p3' "id_comment") idComment , mp (p3' "id_copyright") idCopyright , mp (p3' "id_date") idDate , mp (p3' "id_software") idSoftware , mp (p3' "id_title") idTitle ] - where + where p3' a b = fmap substSpaces $ p3 a b substSpaces x | isSpace x = '_' - | otherwise = x + | otherwise = x instance Pretty Rtaudio where pretty x = case x of @@ -376,9 +389,9 @@ Alsa -> rt "alsa" CoreAudio -> rt "auhal" NoRtaudio -> rt "0" - where + where rt = text . p3 "rtaudio" - jackFields name ins outs = hsep + jackFields name ins outs = hsep [ text $ p3 "jack_client" name , text $ p3 "jack_inportname" ins , text $ p3 "jack_outportname" outs ] @@ -390,7 +403,7 @@ , p3 "input_stream" $ paInput a ] instance Pretty MidiIO where - pretty = fields + pretty = fields [ mp (p2 "midifile") midiFile , mp (p2 "midioutfile") midiOutFile , mp (p3 "mute_tracks") muteTracks @@ -407,7 +420,7 @@ , mi (p2 "midi-velocity") midiVelocity , mi (p2 "midi-velocity-amp") midiVelocityAmp , mp (p1 "Q") midiOutDevice ] - + instance Pretty Rtmidi where pretty x = text $ p3 "rtmidi" $ case x of VirtualMidi -> "virtual" @@ -421,7 +434,7 @@ instance Pretty Displays where pretty = fields - [ mi (p2 "csd-line-nums") csdLineNums + [ mi (p2 "csd-line-nums") csdLineNums , p displayMode , mi (p2 "heartbeat") displayHeartbeat , mi (p2 "messagelevel") messageLevel @@ -440,9 +453,9 @@ NoDisplay -> "--nodisplays" PostScriptDisplay -> "--postscriptdisplay" AsciiDisplay -> "--asciidisplay" - + instance Pretty Config where - pretty = fields + pretty = fields [ mi (p2 "hardwarebufsamps") hwBuf , mi (p2 "iobufsamps") ioBuf , mi (p2 "control-rate") newKr @@ -465,7 +478,7 @@ -- utilities firstToLower :: String -> String -firstToLower x = case x of +firstToLower x = case x of a:as -> toLower a : as [] -> []