packages feed

csound-expression-dynamic (empty) → 0.0.0

raw patch · 18 files changed

+2239/−0 lines, 18 filesdep +Booleandep +arraydep +basesetup-changed

Dependencies added: Boolean, array, base, containers, data-default, data-fix, data-fix-cse, transformers, wl-pprint

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Anton Kholomiov 2013++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Anton Kholomiov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ csound-expression-dynamic.cabal view
@@ -0,0 +1,53 @@+Name:          csound-expression-dynamic+Version:       0.0.0+Cabal-Version: >= 1.6+License:       BSD3+License-file:  LICENSE+Author:	       Anton Kholomiov+Synopsis:      dynamic core for csound-expression library+Stability:     Experimental+Tested-With:   GHC==7.6+Build-Type:    Simple+Category:      Music, Sound+Maintainer:    <anton.kholomiov@gmail.com>++Description:   ++Homepage:        https://github.com/anton-k/csound-expression-dynamic+Bug-Reports:     https://github.com/anton-k/csound-expression-dynamic/issues++Source-repository head+    Type: git+    Location: https://github.com/anton-k/csound-expression-dynamic+++Library+  Ghc-Options:    -Wall+  Build-Depends:+        base >= 4, base < 5, data-default, containers, array, transformers, wl-pprint, +        Boolean >= 0.1.0, data-fix, data-fix-cse+  Hs-Source-Dirs:      src/+  Exposed-Modules:+    Csound.Dynamic++    Csound.Dynamic.Types+    Csound.Dynamic.Types.Exp+    Csound.Dynamic.Types.Dep+    Csound.Dynamic.Types.CsdFile+    Csound.Dynamic.Types.Flags+    Csound.Dynamic.Types.EventList++    Csound.Dynamic.Build+    Csound.Dynamic.Build.Numeric+    Csound.Dynamic.Build.Logic++    Csound.Dynamic.Render++  Other-Modules:+    Csound.Dynamic.Tfm.DeduceTypes+    Csound.Dynamic.Tfm.UnfoldMultiOuts+    Csound.Dynamic.Render.Pretty+    Csound.Dynamic.Render.Instr+     ++
+ src/Csound/Dynamic.hs view
@@ -0,0 +1,29 @@+-- | Exports everything.+module Csound.Dynamic (+    module Csound.Dynamic.Types,+    module Csound.Dynamic.Types.Exp,+    module Csound.Dynamic.Types.Dep,+    module Csound.Dynamic.Types.CsdFile,+    module Csound.Dynamic.Types.EventList,+    module Csound.Dynamic.Types.Flags,++    module Csound.Dynamic.Build,+    module Csound.Dynamic.Build.Numeric,+    module Csound.Dynamic.Build.Logic,++    module Csound.Dynamic.Render+) where++import Csound.Dynamic.Types+import Csound.Dynamic.Types.Exp+import Csound.Dynamic.Types.Dep+import Csound.Dynamic.Types.CsdFile+import Csound.Dynamic.Types.EventList+import Csound.Dynamic.Types.Flags++import Csound.Dynamic.Build+import Csound.Dynamic.Build.Numeric+import Csound.Dynamic.Build.Logic++import Csound.Dynamic.Render+
+ src/Csound/Dynamic/Build.hs view
@@ -0,0 +1,190 @@+module Csound.Dynamic.Build (+    +    -- * Expression tree+    -- | Working with expression tree+    toExp, onExp, ++    -- * Rates+    -- | Updating rates+    setRate, +  +    -- * Queries+    getRates, isMultiOutSignature, getPrimUnsafe,++    -- * Constructors+    -- | Basic constructors+    prim, opcPrefix, oprPrefix, oprInfix, +    numExp1, numExp2,+    tfm, tfmNoInlineArgs, pn, withInits,+    double, int, str, verbatim,++    -- ** Opcodes constructors+    Spec1, spec1, opcs, opcsNoInlineArgs, opr1, opr1k, infOpr, oprBy,+    Specs, specs, MultiOut, mopcs, mo, ++    -- * Global init statements+    setSr, setKsmps, setNchnls, setKr, setZeroDbfs+) where++import qualified Data.Map as M(fromList)++import Data.Fix(Fix(..))++import Csound.Dynamic.Types++------------------------------------------------+-- basic constructors+  +prim :: Prim -> E+prim = noRate . ExpPrim ++opcPrefix :: Name -> Signature -> Info+opcPrefix name signature = Info name signature Opcode++oprPrefix :: Name -> Signature -> Info+oprPrefix name signature = Info name signature Prefix++oprInfix :: Name -> Signature -> Info+oprInfix name signature = Info name signature Infix++tfm :: Info -> [E] -> E+tfm info args = noRate $ Tfm info $ fmap toPrimOr args++tfmNoInlineArgs :: Info -> [E] -> E+tfmNoInlineArgs info args = noRate $ Tfm info $ fmap (PrimOr . Right) args++pn :: Int -> E+pn = prim . P++withInits :: E -> [E] -> E+withInits a es = onExp phi a+    where phi x = case x of+            Tfm t xs -> Tfm t (xs ++ (fmap toPrimOr es))+            _        -> x++-- | Converts Haskell's doubles to Csound's doubles+double :: Double -> E+double = prim . PrimDouble++-- | Converts Haskell's strings to Csound's strings+str :: String -> E+str = prim . PrimString++-- | Converts Haskell's integers to Csound's doubles+int :: Int -> E+int = prim . PrimInt++verbatim :: Monad m => String -> DepT m ()+verbatim = stmtOnlyT . Verbatim++----------------------------------------------------------------------+-- constructing opcodes++-- single output++-- User friendly type for single output type signatures+type Spec1 = [(Rate, [Rate])]++spec1 :: Spec1 -> Signature+spec1 = SingleRate . M.fromList++opcs :: Name -> Spec1 -> [E] -> E+opcs name signature = tfm (opcPrefix name $ spec1 signature)++opcsNoInlineArgs :: Name -> Spec1 -> [E] -> E+opcsNoInlineArgs name signature = tfmNoInlineArgs (opcPrefix name $ spec1 signature)++opr1 :: Name -> E -> E+opr1 name a = tfm (oprPrefix name $ spec1 [(Ar, [Ar]), (Kr, [Kr]), (Ir, [Ir])]) [a]++oprBy :: Name -> Spec1 -> [E] -> E+oprBy name signature = tfm (oprPrefix name $ spec1 signature)++opr1k :: Name -> E -> E+opr1k name a = tfm (oprPrefix name $ spec1 [(Kr, [Kr]), (Ir, [Ir])]) [a]++infOpr :: Name -> E -> E -> E+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] ++numExp2 :: NumOp -> E -> E -> E+numExp2 op a b = noRate $ ExpNum $ fmap toPrimOr $ PreInline op [a, b]++-- multiple output++-- User friendly type for multiple outputs type signatures+type Specs = ([Rate], [Rate])++specs :: Specs -> Signature+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          +          e' = onExp (setMultiRate outRates) e+          +          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"  +            +          select cellId rate expr = withRate rate $ Select rate cellId (PrimOr $ Right expr)++-- rate coversion++setRate :: Rate -> E -> E+setRate r a = Fix $ (\x -> x { ratedExpRate = Just r }) $ unFix a++getRates :: MainExp a -> [Rate]+getRates (Tfm info _) = case infoSignature info of+    MultiRate outs _ -> outs+    _ -> 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+    _ -> False++getPrimUnsafe :: E -> Prim+getPrimUnsafe x = case toExp x of+    ExpPrim a   -> a+    _           -> error "Csound.Dynamic.Build.getPrimUnsafe:Expression is not a primitive"++-- expression tree++toExp :: E -> Exp E+toExp = ratedExpExp . unFix++-- Lifts transformation of main expression+onExp :: (Exp E -> Exp E) -> E -> E+onExp f x = case unFix x of+    a -> Fix $ a{ ratedExpExp = f (ratedExpExp a) }+++----------------------------------------------------------------+-- global inits++setSr, setKsmps, setNchnls, setKr :: Monad m => Int -> DepT m ()+    +setZeroDbfs :: Monad m => Double -> DepT m  ()++setSr       = gInit "sr"+setKr       = gInit "kr"+setNchnls   = gInit "nchnls"+setKsmps    = gInit "ksmps"+setZeroDbfs = gInitDouble "0dbfs"++gInit :: Monad m => String -> Int -> DepT m ()+gInit name val = writeVar (VarVerbatim Ir name) (int val)++gInitDouble :: Monad m => String -> Double -> DepT m ()+gInitDouble name val = writeVar (VarVerbatim Ir name) (double val)+
+ src/Csound/Dynamic/Build/Logic.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# Language TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}+-- | Boolean instances+module Csound.Dynamic.Build.Logic(+    when1, whens,+    ifBegin, ifEnd, elseBegin, elseIfBegin+) where++import Control.Monad.Trans.State(State, state, evalState)+import qualified Data.IntMap as IM(fromList)++import Data.Boolean+import Csound.Dynamic.Types+import Csound.Dynamic.Build(onExp, toExp)++------------------------------------------------------+-- imperative if-then-else++when1 :: Monad m => E -> DepT m () -> DepT m ()+when1 p body = do+    ifBegin p+    body+    ifEnd++whens :: Monad m => [(E, DepT m ())] -> DepT m () -> DepT m ()+whens bodies el = case bodies of+    []   -> el+    a:as -> do+        ifBegin (fst a)+        snd a+        elseIfs as+        elseBegin +        el+        ifEnd+    where elseIfs = mapM_ (\(p, body) -> elseIfBegin p >> body)++ifBegin :: Monad m => E -> DepT m ()+ifBegin = withCond IfBegin++elseIfBegin :: Monad m => E -> DepT m ()+elseIfBegin = withCond ElseIfBegin++elseBegin :: Monad m => DepT m ()+elseBegin = stmtOnlyT ElseBegin++ifEnd :: Monad m => DepT m ()+ifEnd = stmtOnlyT IfEnd++withCond :: Monad m => (CondInfo (PrimOr E) -> MainExp (PrimOr E)) -> E -> DepT m ()+withCond stmt p = depT_ $ noRate $ stmt (condInfo p)++instance Boolean E where+    true = boolOp0 TrueOp+    false = boolOp0 FalseOp+    notB = notE+    (&&*) = boolOp2 And+    (||*) = boolOp2 Or++-- instances++type instance BooleanOf E = E++instance IfB E where+    ifB = condExp+    +instance EqB E where+    (==*) = boolOp2 Equals+    (/=*) = boolOp2 NotEquals+    +instance OrdB E where+    (<*) = boolOp2 Less+    (>*) = boolOp2 Greater+    (<=*) = boolOp2 LessEquals+    (>=*) = boolOp2 GreaterEquals++--------------------------------------------------------------------------+-- if-then-else+--+-- performs inlining of the boolean expressions++boolExp :: a -> [b] -> PreInline a b+boolExp = PreInline++condExp :: E -> E -> E -> E+condExp = mkCond . condInfo+    where mkCond :: CondInfo (PrimOr E) -> E -> E -> E+          mkCond pr th el +            | isTrue pr = th+            | isFalse pr = el+            | otherwise = noRate $ If pr (toPrimOr th) (toPrimOr el)            ++condInfo :: E -> CondInfo (PrimOr E)+condInfo p = go $ toPrimOr p+    where+        go :: PrimOr E -> CondInfo (PrimOr E)+        go expr = (\(a, b) -> Inline a (IM.fromList b)) $ evalState (condInfo' expr) 0+        condInfo' :: PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])+        condInfo' e = maybe (onLeaf e) (onExpr e) $ parseNode e+        onLeaf e = state $ \n -> ((InlinePrim n, [(n, e)]), n+1)  +        onExpr  _ (op, args) = fmap mkNode $ mapM condInfo' args+            where mkNode as = (InlineExp op (map fst as), concat $ map snd as) ++        parseNode :: PrimOr E -> Maybe (CondOp, [PrimOr E])+        parseNode x = case unPrimOr $ fmap toExp x of+          Right (ExpBool (PreInline op args)) -> Just (op, args)+          _ -> Nothing    ++--------------------------------------------------------------------------------+-- constructors for boolean expressions++boolOps :: CondOp -> [E] -> E+boolOps op as = noRate $ ExpBool $ boolExp op $ fmap toPrimOr as++boolOp0 :: CondOp -> E+boolOp2 :: CondOp -> E -> E -> E++boolOp0 op = boolOps op []+boolOp2 op a b = boolOps op [a, b]++-----------------------------------------------------------------------------+-- no support for not in csound so we perform not-elimination+notE :: E -> E+notE x = onExp phi x+    where phi (ExpBool (PreInline op args)) = ExpBool $ case op of+            TrueOp            -> boolExp FalseOp        []+            FalseOp           -> boolExp TrueOp         []+            And               -> boolExp Or             $ fmap (fmap notE) args+            Or                -> boolExp And            $ fmap (fmap notE) args+            Equals            -> boolExp NotEquals      args+            NotEquals         -> boolExp Equals         args+            Less              -> boolExp GreaterEquals  args+            Greater           -> boolExp LessEquals     args+            LessEquals        -> boolExp Greater        args+            GreaterEquals     -> boolExp Less           args++          phi _ = error "Logic.hs:notE - expression is not Boolean"  +
+ src/Csound/Dynamic/Build/Numeric.hs view
@@ -0,0 +1,159 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# Language TypeSynonymInstances, FlexibleInstances #-}+-- | Numeric instances+module Csound.Dynamic.Build.Numeric(+    ceilE, floorE, roundE, intE, fracE        +) where++import Data.Monoid++import Csound.Dynamic.Types+import Csound.Dynamic.Build(toExp, prim, opr1, numExp1)++---------------------------------------------+-- monoid++instance Monoid E where+    mempty  = 0+    mappend = (+)++--------------------------------------------+-- numeric instances++instance Num E where    +    (+) a b +        | isZero a = b+        | isZero b = a+        | otherwise = biOpt (+) Add a b+        +    (*) a b +        | isZero a || isZero b = fromDouble 0+        | otherwise = biOpt (*) Mul a b+        +    (-) a b  +        | isZero a = negate b+        | isZero b = a+        | otherwise = biOpt (-) Sub a b    +    +    negate = unOpt negate (numExp1 Neg)+    +    fromInteger = fromDouble . fromInteger+    abs = unOpt abs (opr1 "abs")+    signum = undefined++instance Fractional E where+    (/) a b +        | isZero a = fromDouble 0+        | isZero b = error "csound (/): division by zero" +        | otherwise = biOpt (/) Div a b++    fromRational = fromDouble . fromRational    ++instance Floating E where+    pi = fromDouble pi+    exp = unOpt exp (opr1 "exp")+    sqrt = unOpt sqrt (opr1 "sqrt")+    log = unOpt log (opr1 "log")+    logBase a n = case n of+        2 -> unOpt (flip logBase 2) (opr1 "logbtwo") a+        10 -> unOpt (flip logBase 10) (opr1 "log10") a+        b -> log a / log b+    (**) = biOpt (**) Pow+    sin = unOpt sin (opr1 "sin")+    tan = unOpt tan (opr1 "tan")+    cos = unOpt cos (opr1 "cos")+    asin = unOpt asin (opr1 "sininv")+    atan = unOpt atan (opr1 "taninv")+    acos = unOpt acos (opr1 "cosinv")+    sinh = unOpt sinh (opr1 "sinh")+    tanh = unOpt tanh (opr1 "tanh")+    cosh = unOpt cosh (opr1 "cosh")+    asinh a = log $ a + sqrt (a * a + 1)+    acosh a = log $ a + sqrt (a + 1) * sqrt (a - 1)+    atanh a = 0.5 * log ((1 + a) / (1 - a))++enumError :: String -> a+enumError name = error $ name ++ " -- is defined only for literals"+    +instance Enum E where+    succ = (+1)+    pred = \x -> x - 1+    toEnum = fromDouble . fromIntegral+    fromEnum = error "fromEnum is not defined for Csound values" +    enumFrom a = a : enumFrom (a+1)    +    enumFromThen a b = a : enumFromThen (a + b) b+     +    enumFromTo a b = case (toNumOpt a, toNumOpt b) of+        (Left x, Left y) -> fmap fromDouble $ enumFromTo x y+        _ -> enumError "[a .. b]"+            +    enumFromThenTo a b c = case (toNumOpt a, toNumOpt b, toNumOpt c) of+        (Left x, Left y, Left z) -> fmap fromDouble $ enumFromThenTo x y z+        _ -> enumError "[a, b .. c]"+    +    +instance Real E where toRational = error "instance of the Real is not defined for Csound values. It's here only for other classes."+        +instance Integral E where+    quot a b = intE $ (intE a) / (intE b)+    rem a b = (a `quot` b) * b - a+    mod = mod'+    div a b = intE $ a - mod a b / b+    quotRem a b = (quot a b, rem a b)+    divMod a b = (div a b, mod a b)+    toInteger = error "toInteger is not defined for Csound values"++------------------------------------------------------------+-- Optimizations for constants+--+-- If an arithmetic expression contains constants we can execute+-- it and render as constant. We check wether all arguments +-- are constants. If it's so we apply some numeric function and+-- propogate a constant value.++toNumOpt :: E -> Either Double E+toNumOpt x = case toExp x of+    ExpPrim (PrimDouble d) -> Left d+    _ -> Right x++fromNumOpt :: Either Double E -> E+fromNumOpt = either (prim . PrimDouble) id ++expNum :: NumExp E -> E+expNum = noRate . ExpNum . fmap toPrimOr++fromDouble :: Double -> E+fromDouble = fromNumOpt . Left++isZero :: E -> Bool+isZero a = either ( == 0) (const False) $ toNumOpt a++-- optimization for unary functions+unOpt :: (Double -> Double) -> (E -> E) -> E -> E+unOpt doubleOp op a = fromNumOpt $ either (Left . doubleOp) (Right . op) $ toNumOpt a++-- optimization for binary functions+biOpt :: (Double -> Double -> Double) -> NumOp -> E -> E -> E+biOpt doubleOp op a b = fromNumOpt $ case (toNumOpt a, toNumOpt b) of+    (Left da, Left db) -> Left $ doubleOp da db+    _ -> Right $ noOpt2 a b+    where noOpt2 x y = expNum $ PreInline op [x, y]++doubleToInt :: (Double -> Int) -> (E -> E) -> E -> E+doubleToInt fun = unOpt (fromIntegral . fun) ++-- arithmetic++mod' :: E -> E -> E+mod' = biOpt (\a b -> fromIntegral $ mod (floor a :: Int) (floor b)) Mod+ +-- other functions++ceilE, floorE, fracE, intE, roundE :: E -> E++ceilE   = doubleToInt ceiling (opr1 "ceil")+floorE  = doubleToInt floor (opr1 "floor")+roundE  = doubleToInt round (opr1 "round")+fracE   = unOpt (snd . (properFraction :: (Double -> (Int, Double)))) (opr1 "frac") +intE    = doubleToInt truncate (opr1 "int")+
+ src/Csound/Dynamic/Render.hs view
@@ -0,0 +1,31 @@+module Csound.Dynamic.Render(+    renderCsd      +) where++import qualified Text.PrettyPrint.Leijen as P++import Csound.Dynamic.Render.Instr+import Csound.Dynamic.Render.Pretty+import Csound.Dynamic.Types++renderCsd :: Csd -> String+renderCsd a = show $ ppCsdFile +    (renderFlags $ csdFlags a)+    (renderOrc $ csdOrc a)+    (renderSco   $ csdSco a)++renderFlags :: Flags -> Doc+renderFlags = P.pretty++renderOrc :: Orc -> Doc+renderOrc a = vcatSep $ headExpr : instrExprs+    where+        headExpr    = renderInstrBody (orcHead a)+        instrExprs  = fmap renderInstr (orcInstruments a)++renderSco :: Sco -> Doc+renderSco a = vcatSep +    [ P.vcat $ fmap (uncurry ppGen)   $ scoGens a+    , maybe P.empty ppTotalDur $ scoTotalDur a    +    , P.vcat $ fmap (uncurry ppNotes) $ scoNotes a ]    +
+ src/Csound/Dynamic/Render/Instr.hs view
@@ -0,0 +1,169 @@+module Csound.Dynamic.Render.Instr(+    renderInstr, renderInstrBody+) where++import Control.Arrow(second)+import Control.Monad.Trans.State.Strict+import Data.List(sort, find)+import qualified Data.Map as M++import Data.Maybe(fromJust)+import Data.Fix(Fix(..), cata)+import Data.Fix.Cse(fromDag, cse)++import qualified Text.PrettyPrint.Leijen as P++import Csound.Dynamic.Tfm.DeduceTypes+import Csound.Dynamic.Tfm.UnfoldMultiOuts++import Csound.Dynamic.Types hiding (Var)+import Csound.Dynamic.Build(getRates, isMultiOutSignature)+import Csound.Dynamic.Render.Pretty++type Dag f = [(Int, f Int)]++renderInstr :: Instr -> Doc+renderInstr a = ppInstr (instrName a) $ renderInstrBody (instrBody a)++renderInstrBody :: E -> Doc+renderInstrBody = P.vcat . flip evalState 0 +    . mapM (uncurry ppStmt . clearEmptyResults) . collectRates . toDag ++-------------------------------------------------------------+-- E -> Dag++toDag :: E -> Dag RatedExp +toDag expr = fromDag $ cse $ trimByArgLength expr++trimByArgLength :: E -> E+trimByArgLength = cata $ \x -> Fix x{ ratedExpExp = phi $ ratedExpExp x }+    where phi x = case x of+            Tfm info xs -> Tfm (info{infoSignature = trimInfo (infoSignature info) xs}) xs+            _ -> 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)    +                  +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) res+    where res = unfoldMultiOuts unfoldSpec lastFreshId dag1  +          (dag1, lastFreshId) = rateGraph dag++-----------------------------------------------------------+-- Dag -> Dag++-----------------------------------------------------------+-- deduces types++rateGraph :: [Stmt RatedExp Int] -> ([Stmt RatedExp (Var Rate)], Int)+rateGraph dag = (stmts, lastId)+     where (stmts, lastId) = deduceTypes algSpec dag+           algSpec = TypeGraph mkConvert' defineType'++           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 +                     ratesForConversion = filter (not . flip coherentRates possibleRate) desiredRates+                     expr' = RatedExp Nothing Nothing $ rateExp possibleRate $ ratedExpExp expr+                     outVar' = ratedVar possibleRate outVar++----------------------------------------------------------+-- unfolds multiple rates++unfoldSpec :: UnfoldMultiOuts RatedExp Rate +unfoldSpec = UnfoldMultiOuts getSelector' getParentTypes'+    where getSelector' x = case ratedExpExp x of+                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 +                _ -> Nothing++coherentRates :: Rate -> Rate -> Bool+coherentRates to from = case (to, from) of+    (a, b)  | a == b    -> True+    (Xr, _)             -> True   +    (Kr, Ir)            -> True+    _                   -> False++deduceRate :: [Rate] -> RatedExp Int -> Rate+deduceRate desiredRates expr = case ratedExpExp expr of+    ExpPrim _ -> case desiredRates of+        [Sr] -> Sr+        _ -> Ir+       +    Tfm info _ -> case infoSignature info of+        MultiRate _ _ -> Xr+        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+        r  -> r+    ReadVar v -> varRate v+    _  -> Xr    +    where tfmNoRate name rates tab = case sort rates of+              [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])         ++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 $ mergeWithPrimOrBy (flip ratedVar) xs (ratesFromSignature curRate (infoSignature i))+    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 (varRate v) a+    ExpPrim p -> ExpPrim p+    IfBegin _ -> rec2 condRate expr+    ElseIfBegin _ -> rec2 condRate expr+    ElseBegin -> ElseBegin+    IfEnd -> IfEnd+    EmptyExp -> EmptyExp    +    Verbatim a -> Verbatim a++    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" +    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))  +          rec1 r = fmap (ratedVar r)++          msg txt = "Csound.Dynamic.Render.Instr.rateExp: " ++ txt ++          ++mergeWithPrimOrBy :: (a -> b -> c) -> [PrimOr a] -> [b] -> [PrimOr c]+mergeWithPrimOrBy cons = zipWith (\primOr b -> fmap (flip cons b) primOr)++
+ src/Csound/Dynamic/Render/Pretty.hs view
@@ -0,0 +1,233 @@+module Csound.Dynamic.Render.Pretty(+    Doc, vcatSep,+    ppCsdFile, ppGen, ppNotes, ppInstr, ppStmt, ppTotalDur+) where++import Control.Monad.Trans.State.Strict+import Data.Char(toLower)+import qualified Data.IntMap as IM++import Text.PrettyPrint.Leijen++import Csound.Dynamic.Types++vcatSep :: [Doc] -> Doc+vcatSep = vcat . punctuate line++binaries, unaries :: String -> [Doc] -> Doc++binaries op as = binary op (as !! 0) (as !! 1)+unaries  op as = unary  op (as !! 0)++binary :: String -> Doc -> Doc -> Doc+binary op a b = parens $ a <+> text op <+> b++unary :: String -> Doc -> Doc+unary op a = parens $ text op <> a++func :: String -> Doc -> Doc+func op a = text op <> parens a++ppCsdFile :: Doc -> Doc -> Doc -> Doc+ppCsdFile flags orc sco = +    tag "CsoundSynthesizer" $ vcatSep [+        tag "CsOptions" flags,+        tag "CsInstruments" orc,+        tag "CsScore" sco]    ++tag :: String -> Doc -> Doc+tag name content = vcatSep [+    char '<' <> text name <> char '>', +    content, +    text "</" <> text name <> char '>']  ++ppNotes :: InstrId -> [CsdEvent Note] -> Doc+ppNotes instrId = vcat . fmap (ppNote instrId)++ppNote :: InstrId -> CsdEvent Note -> Doc+ppNote instrId evt = char 'i' +    <+> ppInstrId instrId +    <+> double (csdEventStart evt) <+> double (csdEventDur evt) +    <+> hsep (fmap ppPrim $ csdEventContent evt)++ppPrim :: Prim -> Doc+ppPrim x = case x of+    P n -> char 'p' <> int n+    PrimInstrId a -> ppInstrId a+    PString a -> int a    +    PrimInt n -> int n+    PrimDouble d -> double d+    PrimString s -> dquotes $ text s+    +ppGen :: Int -> Gen -> Doc+ppGen tabId ft = char 'f' +    <>  int tabId +    <+> int 0 +    <+> (int $ genSize ft)+    <+> (int $ genId ft) +    <+> (maybe empty (text . show) $ genFile ft)+    <+> (hsep $ map double $ genArgs ft)++ppInstr :: InstrId -> Doc -> Doc+ppInstr instrId body = vcat [+    text "instr" <+> ppInstrId instrId,+    body,+    text "endin"]++ppInstrId :: InstrId -> Doc+ppInstrId x = case x of+    InstrId den nom -> int nom <> maybe empty ppAfterDot den +    InstrLabel name -> dquotes $ text name+    where ppAfterDot a = text $ ('.': ) $ reverse $ show a++type TabDepth = Int++ppStmt :: [RatedVar] -> Exp RatedVar -> State TabDepth Doc+ppStmt outs expr = ppExp (ppOuts outs) expr++ppExp :: Doc -> Exp RatedVar -> State TabDepth Doc+ppExp res expr = case fmap ppPrimOrVar expr of+    ExpPrim (PString n)             -> tab $ ppStrget res n+    ExpPrim p                       -> tab $ res $= ppPrim p+    Tfm info [a, b] | isInfix  info -> tab $ res $= binary (infoName info) a b+    Tfm info xs     | isPrefix info -> tab $ res $= prefix (infoName info) xs+    Tfm info xs                     -> tab $ ppOpc res (infoName info) xs+    ConvertRate to from x           -> tab $ ppConvertRate res to from x+    If info t e                     -> tab $ ppIf res (ppCond info) t e+    ExpNum (PreInline op as)        -> tab $ res $= ppNumOp op as+    WriteVar v a                    -> tab $ ppVar v $= a+    InitVar v a                     -> tab $ ppOpc (ppVar v) "init" [a]+    ReadVar v                       -> tab $ res $= ppVar v++    IfBegin a                       -> succTab          $ text "if "     <> ppCond a <> text " then"+    ElseIfBegin a                   -> left >> (succTab $ text "elseif " <> ppCond a <> text " then")    +    ElseBegin                       -> left >> (succTab $ text "else")+    IfEnd                           -> left >> (tab     $ text "endif")+    EmptyExp                        -> return empty+    Verbatim str                    -> return $ text str+    x -> error $ "unknown expression: " ++ show x+    where tab doc = fmap (shiftByTab doc) get +          tabWidth = 4+          shiftByTab doc n+            | n == 0    = doc+            | otherwise = (text $ replicate (tabWidth * n) ' ') <> doc ++          left = modify pred+          succTab doc = do+            a <- tab doc+            modify succ+            return a++          prefix name args = text name <> tupled args++ppCond :: Inline CondOp Doc -> Doc+ppCond = ppInline ppCondOp ++($=) :: Doc -> Doc -> Doc+($=) a b = a <+> equals <+> b++ppOuts :: [RatedVar] -> Doc+ppOuts xs = hsep $ punctuate comma $ map ppRatedVar xs++ppPrimOrVar :: PrimOr RatedVar -> Doc+ppPrimOrVar x = either ppPrim ppRatedVar $ unPrimOr x++ppStrget :: Doc -> Int -> Doc+ppStrget out n = ppOpc out "strget" [char 'p' <> int n]+ +ppIf :: Doc -> Doc -> Doc -> Doc -> Doc+ppIf res p t e = vcat +    [ text "if" <+> p <+> text "then"+    , text "    " <> res <+> char '=' <+> t+    , text "else"+    , text "    " <> res <+> char '=' <+> e+    , text "endif" +    ]++ppOpc :: Doc -> String -> [Doc] -> Doc+ppOpc out name xs = out <+> ppProc name xs++ppProc :: String -> [Doc] -> Doc+ppProc name xs = text name <+> (hsep $ punctuate comma xs)++ppVar :: Var -> Doc+ppVar v = case v of+    Var ty rate name   -> ppVarType ty <> ppRate rate <> text (varPrefix ty : name)+    VarVerbatim _ name -> text name++varPrefix :: VarType -> Char+varPrefix x = case x of+    LocalVar  -> 'l'+    GlobalVar -> 'g'++ppVarType :: VarType -> Doc+ppVarType x = case x of+    LocalVar  -> empty+    GlobalVar -> char 'g'++ppConvertRate :: Doc -> Rate -> Rate -> Doc -> Doc+ppConvertRate out to from var = case (to, from) of+    (Ar, Kr) -> upsamp var +    (Ar, Ir) -> upsamp $ k var+    (Kr, Ar) -> downsamp var+    (Kr, Ir) -> out $= k var+    (Ir, Ar) -> downsamp var+    (Ir, Kr) -> out $= i var+    (a, b)   -> error $ "bug: no rate conversion from " ++ show b ++ " to " ++ show a ++ "."+    where +        upsamp x = ppOpc out "upsamp" [x]+        downsamp x = ppOpc out "downsamp" [x]+        k = func "k"+        i = func "i"++-- expressions++ppInline :: (a -> [Doc] -> Doc) -> Inline a Doc -> Doc+ppInline ppNode a = iter $ inlineExp a    +    where iter x = case x of+              InlinePrim n        -> inlineEnv a IM.! n+              InlineExp op args   -> ppNode op $ fmap iter args  ++-- booleans++ppCondOp :: CondOp -> [Doc] -> Doc  +ppCondOp op = case op of+    TrueOp            -> const $ text "(1 == 1)"                +    FalseOp           -> const $ text "(0 == 1)"+    And               -> bi "&&"+    Or                -> bi "||"+    Equals            -> bi "=="+    NotEquals         -> bi "!="+    Less              -> bi "<"+    Greater           -> bi ">"+    LessEquals        -> bi "<="    +    GreaterEquals     -> bi ">="                         +    where bi  = binaries +          +-- numeric++ppNumOp :: NumOp -> [Doc] -> Doc+ppNumOp op = case  op of+    Add -> bi "+"+    Sub -> bi "-"+    Mul -> bi "*"+    Div -> bi "/"+    Neg -> uno "-"    +    Pow -> bi "^"    +    Mod -> bi "%"+    where +        bi  = binaries+        uno = unaries++ppRatedVar :: RatedVar -> Doc+ppRatedVar v = ppRate (ratedVarRate v) <> int (ratedVarId v)++ppRate :: Rate -> Doc+ppRate x = case x of+    Sr -> char 'S'+    _  -> phi x+    where phi = text . map toLower . show ++ppTotalDur :: Double -> Doc+ppTotalDur d = text "f0" <+> double d+
+ src/Csound/Dynamic/Tfm/DeduceTypes.hs view
@@ -0,0 +1,124 @@+module Csound.Dynamic.Tfm.DeduceTypes(+    Var(..), TypeGraph(..), Convert(..), Stmt, deduceTypes    +) where++import Data.List(nub)+import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.Traversable as T++import Data.STRef+import Control.Monad.ST+import Data.Array.ST++type TypeRequests s ty = STArray s Int [ty]++initTypeRequests :: Int -> ST s (TypeRequests s ty)+initTypeRequests size = newArray (0, size - 1) []++requestType :: Var ty -> TypeRequests s ty -> ST s ()+requestType v arr = modifyArray arr (varId v) (varType v :)++modifyArray :: Ix i => STArray s i a -> i -> (a -> a) -> ST s ()+modifyArray arr i f = writeArray arr i . f =<< readArray arr i++getTypes :: Int -> TypeRequests s ty -> ST s [ty]+getTypes n arr = readArray arr n++-- | Typed variable.+data Var a = Var +    { varId   :: Int+    , varType :: a +    } deriving (Show, Eq, Ord)++data GetType ty     +    = NoConversion ty +    -- If there is a conversion we look for a fresh identifier by map +    -- (map converts mismatched type to fresh identifier)+    | ConversionLookup (Var ty) (M.Map ty Int)++type TypeMap ty = IM.IntMap (GetType ty)++lookupVar :: (Show a, Ord a) => TypeMap a -> Var a -> Var a+lookupVar m (Var i r) = case m IM.! i of+    NoConversion     ty        -> Var i ty+    ConversionLookup noConv f  -> maybe noConv (flip Var r) $ M.lookup r f ++-- Statement: assignment, like+--    leftHandSide = RightHandSide( arguments )+type Stmt f a = (a, f a)++-- When we haave type collisions we have to insert converters:+data Convert a = Convert+    { convertFrom   :: Var a+    , convertTo     :: Var a }++data Line f a = Line +    { lineType      :: (Int, GetType a) +    , lineStmt      :: Stmt f (Var a) +    , lineConverts  :: [Convert a] }++-- Algorithm specification for the given functor 'f' and type labels of 'a'.+data TypeGraph f a = TypeGraph +    -- create a type conversion statement+    { mkConvert   :: Convert a -> Stmt f (Var a)+    -- for a given statement and a list of requested types for the output produces a pair of+    -- (nonConvertibleTypes, statementWithDeducedTypes)+    -- nonConvertibleTypes is used for insertion of converters.+    , defineType  :: Stmt f Int -> [a] -> ([a], Stmt f (Var a)) }++-- | Deduces types for a dag:+--+-- deduceTypes (functorSpecificFuns) (dag) = (dagWithTypes, lastFreshIdentifier)+--+-- Assumption -- dag is labeled with integers. Labels are unique+-- and a list of labels is a range (0, n) (It's just what we get with CSE algorithm). +-- +-- Algorithm proceeds as follows. We init an array of type requests and a reference for fresh identifiers. +-- Type request comes from right hand side of the statement. We need fresh identifiers for converters.+-- If we are going to use a new statement for conversion we need new variables.+-- +-- (discussLine)+-- Then we process lines in reverse order and collect type requests by looking at right hand sides+-- and writing type requests for all arguments. +--+-- (processLine)+-- In the second run we substitute all identifiers with typed variables. It's no so strightforward+-- due to converters. If there are converters we have to insert new statements and substitute identifiers+-- with new ones. That's why we convert variables to variables in the processLine. +--+deduceTypes :: (Show a, Ord a, T.Traversable f) => TypeGraph f a -> [Stmt f Int] -> ([Stmt f (Var a)], Int)+deduceTypes spec as = runST $ do+    freshIds <- newSTRef n+    typeRequests <- initTypeRequests n+    lines' <- mapM (discussLine spec typeRequests freshIds) $ reverse as+    let typeMap = IM.fromList $ fmap lineType lines'+    lastId <- readSTRef freshIds+    return (reverse $ processLine typeMap =<< lines', lastId)+    where n = length as+          processLine typeMap line = fmap (mkConvert spec) (lineConverts line) ++ [(a, fmap (lookupVar typeMap) b)]+              where (a, b) = lineStmt line            ++discussLine :: (Ord a, T.Traversable f) => TypeGraph f a -> TypeRequests s a -> STRef s Int -> Stmt f Int -> ST s (Line f a)+discussLine spec typeRequests freshIds stmt@(pid, _) = do+    (conv, expr') <- fmap (defineType spec stmt . nub) $ getTypes pid typeRequests+    _ <- T.traverse (flip requestType typeRequests) (snd expr')+    let curType = fst expr'+    (getType, convs) <- mkGetType conv curType freshIds+    return $ Line (pid, getType) expr' convs++mkGetType :: Ord a => [a] -> Var a -> STRef s Int -> ST s (GetType a, [Convert a])+mkGetType typesToConvert curVar freshIds +    | null typesToConvert = return (NoConversion $ varType curVar, [])+    | otherwise = do+        ids <- nextIds n freshIds+        return (ConversionLookup curVar $ M.fromList (zip typesToConvert ids), +                zipWith (\i t -> Convert curVar (Var i t)) ids typesToConvert)+    where n = length typesToConvert    ++nextIds :: Int -> STRef s Int -> ST s [Int]+nextIds n ref = do+    curId <- readSTRef ref+    writeSTRef ref (curId + n)    +    return [curId .. n + curId]+
+ src/Csound/Dynamic/Tfm/UnfoldMultiOuts.hs view
@@ -0,0 +1,70 @@+{-# Language TupleSections #-}+module Csound.Dynamic.Tfm.UnfoldMultiOuts(+    unfoldMultiOuts, UnfoldMultiOuts(..), Selector(..)+) where++import Data.List(sortBy)+import Data.Ord(comparing)+import Data.Maybe(mapMaybe, isNothing)+import Control.Monad.Trans.State.Strict+import qualified Data.IntMap as IM++import Csound.Dynamic.Tfm.DeduceTypes(Var(..))++type ChildrenMap = IM.IntMap [Port]++lookupChildren :: ChildrenMap -> Var a -> [Port]+lookupChildren m parentVar = m IM.! varId parentVar++mkChildrenMap :: [(Var a, Selector a)] -> ChildrenMap+mkChildrenMap = IM.fromListWith (++) . fmap extract +    where extract (var, sel) = (varId $ selectorParent sel, +                                return $ Port (varId var) (selectorOrder sel))++data Port = Port +    { portId    :: Int+    , portOrder :: Int } deriving (Show)++type SingleStmt f a = (Var a, f (Var a))+type MultiStmt  f a = ([Var a], f (Var a))++data Selector a = Selector +    { selectorParent  :: Var a+    , selectorOrder   :: Int }++data UnfoldMultiOuts f a = UnfoldMultiOuts {+    getSelector    :: f (Var a) -> Maybe (Selector a),+    getParentTypes :: f (Var a) -> Maybe [a] }++unfoldMultiOuts :: UnfoldMultiOuts f a -> Int -> [SingleStmt f a] -> [MultiStmt f a]+unfoldMultiOuts algSpec lastFreshId stmts = evalState st lastFreshId+    where selectors = mapMaybe (\(lhs, rhs) -> fmap (lhs,) $ getSelector algSpec rhs) stmts+          st = mapM (unfoldStmt algSpec $ mkChildrenMap selectors) $ dropSelectors stmts+          dropSelectors = filter (isNothing . getSelector algSpec . snd)++unfoldStmt :: UnfoldMultiOuts f a -> ChildrenMap -> SingleStmt f a -> State Int (MultiStmt f a)+unfoldStmt algSpec childrenMap (lhs, rhs) = case getParentTypes algSpec rhs of+    Nothing    -> return ([lhs], rhs)+    Just types -> fmap (,rhs) $ formLhs (lookupChildren childrenMap lhs) types++formLhs :: [Port] -> [a] -> State Int [Var a]+formLhs ports types = fmap (zipWith (flip Var) types) (getPorts ports)+    where getPorts ps = state $ \lastFreshId -> +            let ps' = sortBy (comparing portOrder) ps+                (ids, lastPortOrder) = runState (mapM (fillMissingPorts lastFreshId) ps') 0+                freshIdForTail = 1 + lastFreshId + inUsePortsSize+                tailIds = map (+ freshIdForTail) [0 .. outputArity - 1 - lastPortOrder]+            in  (concat ids ++ tailIds, lastFreshId + outputArity - inUsePortsSize)++          outputArity = length types    +          inUsePortsSize = length ports  +                                +          fillMissingPorts :: Int -> Port -> State Int [Int]+          fillMissingPorts lastFreshId port = state $ \s ->+                if s == order+                then ([e], next) +                else (fmap (+ lastFreshId) [s .. order - 1] ++ [e], next)+            where e = portId port+                  order = portOrder port                  +                  next = order + 1+
+ src/Csound/Dynamic/Types.hs view
@@ -0,0 +1,16 @@+module Csound.Dynamic.Types(++    module Csound.Dynamic.Types.Exp,+    module Csound.Dynamic.Types.Dep,+    module Csound.Dynamic.Types.EventList,+    module Csound.Dynamic.Types.Flags,+    module Csound.Dynamic.Types.CsdFile++) where ++import Csound.Dynamic.Types.Exp+import Csound.Dynamic.Types.Dep+import Csound.Dynamic.Types.EventList+import Csound.Dynamic.Types.Flags+import Csound.Dynamic.Types.CsdFile+
+ src/Csound/Dynamic/Types/CsdFile.hs view
@@ -0,0 +1,45 @@+-- | The Csound file+module Csound.Dynamic.Types.CsdFile(            +    Csd(..), Flags, Orc(..), Sco(..), Instr(..), InstrBody,+    intInstr, alwaysOn+) where++import Csound.Dynamic.Types.Exp+import Csound.Dynamic.Types.Flags+import Csound.Dynamic.Types.EventList++data Csd = Csd+    { csdFlags  :: Flags+    , csdOrc    :: Orc+    , csdSco    :: Sco+    } ++data Orc = Orc+    { orcHead           :: InstrBody+    , orcInstruments    :: [Instr]+    }++type InstrBody = E++data Instr = Instr+    { instrName :: InstrId+    , instrBody :: InstrBody+    }++data Sco = Sco +    { scoTotalDur   :: Maybe Double+    , scoGens       :: [(Int, Gen)]+    , scoNotes      :: [(InstrId, [CsdEvent Note])]  }++----------------------------------------------------------------+-- instruments++intInstr :: Int -> E -> Instr+intInstr n expr = Instr (intInstrId n) expr++----------------------------------------------------------------+-- score++alwaysOn :: InstrId -> (InstrId, [CsdEvent Note])+alwaysOn instrId = (instrId, [(0, -1, [])])+
+ src/Csound/Dynamic/Types/Dep.hs view
@@ -0,0 +1,119 @@+-- | Dependency tracking+module Csound.Dynamic.Types.Dep(+    DepT(..), runDepT, LocalHistory(..),    +    -- * Dependencies+    depT, depT_, mdepT, stripDepT, stmtOnlyT, execDepT,++    -- * Variables+    newLocalVar, newLocalVars,+    writeVar, readVar, readOnlyVar, initVar, appendVarBy+) where++import Control.Applicative+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Control.Monad(ap, liftM, zipWithM_)+import Data.Default++import Data.Fix(Fix(..))++import Csound.Dynamic.Types.Exp++-- | 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]@. +-- So it's okay to do some side effects when playing a note.+newtype DepT m a = DepT { unDepT :: StateT LocalHistory m a }++data LocalHistory = LocalHistory+    { expDependency :: Maybe E+    , newLocalVarId :: Int }++instance Default LocalHistory where+    def = LocalHistory Nothing 0++instance Monad m => Functor (DepT m) where+    fmap = liftM ++instance Monad m => Applicative (DepT m) where+    pure = return+    (<*>) = ap++instance Monad m => Monad (DepT m) where+    return = DepT . return+    ma >>= mf = DepT $ unDepT ma >>= unDepT . mf++instance MonadTrans DepT where+    lift ma = DepT $ lift ma+   +runDepT :: DepT m a -> m (a, LocalHistory)+runDepT a = runStateT (unDepT a) def++execDepT :: Monad m => DepT m a -> m E+execDepT a = liftM (maybe emptyE id . expDependency . snd) $ runDepT a++-- dependency tracking++depT :: Monad m => E -> DepT m E+depT a = DepT $ StateT $ \s -> do+    let x = Fix $ (unFix a) { ratedExpDepends = expDependency s }+    return (x, s { expDependency = Just x })    ++depT_ :: (Monad m) => E -> DepT m ()+depT_ = fmap (const ()) . depT++mdepT :: (Monad m) => MultiOut [E] -> MultiOut (DepT m [E])+mdepT mas = \n -> mapM depT $ ( $ n) mas++stripDepT :: Monad m => DepT m a -> m a+stripDepT (DepT a) = evalStateT a def ++stmtOnlyT :: Monad m => Exp E -> DepT m ()+stmtOnlyT stmt = depT_ $ noRate stmt++emptyE :: E +emptyE = noRate $ EmptyExp ++-- local variables++newLocalVars :: Monad m => [Rate] -> m [E] -> DepT m [Var]+newLocalVars rs vs = do+    vars <- mapM newVar rs+    zipWithM_ initVar vars =<< lift vs+    return vars++newLocalVar :: Monad m => Rate -> m E -> DepT m Var+newLocalVar rate val = do+    var <- newVar rate+    initVar var =<< lift val+    return var++newVar :: Monad m => Rate -> DepT m Var+newVar rate = DepT $ do+    s <- get+    let v = Var LocalVar rate (show $ newLocalVarId s)    +    put $ s { newLocalVarId = succ $ newLocalVarId s }+    return v++--------------------------------------------------+-- variables++-- generic funs++writeVar :: Monad m => Var -> E -> DepT m ()+writeVar v x = depT_ $ noRate $ WriteVar v $ toPrimOr x ++readVar :: Monad m => Var -> DepT m E+readVar v = depT $ noRate $ ReadVar v++readOnlyVar :: Var -> E+readOnlyVar v = noRate $ ReadVar v++initVar :: Monad m => Var -> E -> DepT m ()+initVar v x = depT_ $ noRate $ InitVar v $ toPrimOr x++appendVarBy :: Monad m => (E -> E -> E) -> Var -> E -> DepT m ()+appendVarBy op v x = writeVar v . op x =<< readVar v++
+ src/Csound/Dynamic/Types/EventList.hs view
@@ -0,0 +1,66 @@+{-# Language DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Csound.Dynamic.Types.EventList(+    CsdSco(..), +    CsdEvent, csdEventStart, csdEventDur, csdEventContent,+    CsdEventList(..), delayCsdEventList, rescaleCsdEventList+) where++import Data.Traversable+import Data.Foldable++-- | The Csound note. It's a triple of+--+-- > (startTime, duration, parameters)+type CsdEvent a = (Double, Double, a)++csdEventStart   :: CsdEvent a -> Double+csdEventDur     :: CsdEvent a -> Double+csdEventContent :: CsdEvent a -> a++csdEventStart   (a, _, _) = a+csdEventDur     (_, a, _) = a+csdEventContent (_, _, a) = a++csdEventTotalDur :: CsdEvent a -> Double+csdEventTotalDur (start, dur, _) = start + dur++-- | A class that represents Csound scores. All functions that use score are defined+-- in terms of this class. If you want to use your own score representation, just define+-- two methods of the class.+--+-- The properties:+--+-- > forall a . toCsdEventList (singleCsdEvent a) === CsdEventList 1 [(0, 1, a)]+class CsdSco f where    +    -- | Converts a given score representation to the canonical one.+    toCsdEventList :: f a -> CsdEventList a+    -- | Constructs a scores that contains only one event. The event happens immediately and lasts for 1 second.+    singleCsdEvent ::  CsdEvent a -> f a++-- | 'Csound.Base.CsdEventList' is a canonical representation of the Csound scores.+-- A scores is a list of events and we should know the total duration of the scores.+-- It's not meant to be used directly. We can use a better alternative. More convenient+-- type that belongs to 'Csound.Base.CsdSco' type class (see temporal-csound package).+data CsdEventList a = CsdEventList+    { csdEventListDur   :: Double+    , csdEventListNotes :: [CsdEvent a] +    } deriving (Eq, Show, Functor, Foldable, Traversable)++instance CsdSco CsdEventList where+    toCsdEventList = id+    singleCsdEvent evt = CsdEventList (csdEventTotalDur evt) [evt]++delayCsdEventList :: Double -> CsdEventList a -> CsdEventList a+delayCsdEventList k (CsdEventList totalDur events) = +    CsdEventList (k + totalDur) (fmap (delayCsdEvent k) events)++delayCsdEvent :: Double -> CsdEvent a -> CsdEvent a +delayCsdEvent k (start, dur, a) = (k + start, dur, a)++rescaleCsdEventList :: Double -> CsdEventList a -> CsdEventList a+rescaleCsdEventList k (CsdEventList totalDur events) = +    CsdEventList (k * totalDur) (fmap (rescaleCsdEvent k) events)++rescaleCsdEvent :: Double -> CsdEvent a -> CsdEvent a+rescaleCsdEvent k (start, dur, a) = (k * start, k * dur, a)+
+ src/Csound/Dynamic/Types/Exp.hs view
@@ -0,0 +1,296 @@+-- | Main types+{-# Language DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Csound.Dynamic.Types.Exp(+    E, RatedExp(..), isEmptyExp, RatedVar, ratedVar, ratedVarRate, ratedVarId, +    ratedExp, noRate, withRate,+    Exp, toPrimOr, PrimOr(..), MainExp(..), Name, +    InstrId(..), intInstrId, ratioInstrId, stringInstrId,+    VarType(..), Var(..), Info(..), OpcFixity(..), Rate(..), +    Signature(..), isInfix, isPrefix,    +    Prim(..), Gen(..),  +    Inline(..), InlineExp(..), PreInline(..),+    BoolExp, CondInfo, CondOp(..), isTrue, isFalse,    +    NumExp, NumOp(..), Note,    +    MultiOut+) where++import Control.Applicative++import Data.Traversable+import Data.Foldable hiding (concat)++import Data.Map(Map)+import Data.Maybe(isNothing)+import qualified Data.IntMap as IM+import Data.Fix++import qualified Csound.Dynamic.Tfm.DeduceTypes as R(Var(..)) ++type Name = String++-- | An instrument identifier+data InstrId +    = InstrId +    { instrIdFrac :: Maybe Int+    , instrIdCeil :: Int }+    | InstrLabel String +    deriving (Show, Eq, Ord)+    +-- | Constructs an instrument id with the integer.+intInstrId :: Int -> InstrId+intInstrId n = InstrId Nothing n++-- | Constructs an instrument id with fractional part.+ratioInstrId :: Int -> Int -> InstrId+ratioInstrId beforeDot afterDot = InstrId (Just $ afterDot) beforeDot++-- | Constructs an instrument id with the string label.+stringInstrId :: String -> InstrId+stringInstrId = InstrLabel++-- | The inner representation of csound expressions.+type E = Fix RatedExp++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 a          +        -- ^ Dependency (it is used for expressions with side effects,+        -- value contains the privious statement)+    , ratedExpExp       :: Exp a    +        -- ^ Main expression+    } deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++-- | RatedVar is for pretty printing of the wiring ports.+type RatedVar = R.Var Rate++-- | Makes an rated variable.+ratedVar :: Rate -> Int -> RatedVar+ratedVar     = flip R.Var++-- | Querries a rate.+ratedVarRate :: RatedVar -> Rate+ratedVarRate = R.varType++-- | Querries an integral identifier.+ratedVarId :: RatedVar -> Int+ratedVarId   = R.varId++ratedExp :: Maybe Rate -> Exp E -> E+ratedExp r = Fix . RatedExp r Nothing++noRate :: Exp E -> E+noRate = ratedExp Nothing+  +withRate :: Rate -> Exp E -> E+withRate r = ratedExp (Just r)+++-- | It's a primitive value or something else. It's used for inlining+-- of the constants (primitive values).+newtype PrimOr a = PrimOr { unPrimOr :: Either Prim a }+    deriving (Show, Eq, Ord, Functor)++-- | Constructs PrimOr values from the expressions. It does inlining in+-- case of primitive values.+toPrimOr :: E -> PrimOr E+toPrimOr a = PrimOr $ case ratedExpExp $ unFix a of+    ExpPrim (PString _) -> Right a+    ExpPrim p -> Left p+    _         -> Right a++-- Expressions with inlining.+type Exp a = MainExp (PrimOr a)++-- Csound expressions+data MainExp a     +    = EmptyExp+    -- | Primitives+    | ExpPrim Prim+    -- | 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    +    -- | Boolean expressions (rendered in infix notation in the Csound)+    | ExpBool (BoolExp a)+    -- | Numerical expressions (rendered in infix notation in the Csound)+    | ExpNum (NumExp a)+    -- | Reading/writing a named variable+    | InitVar Var a+    | ReadVar Var+    | WriteVar Var a    +    -- | Imperative If-then-else+    | IfBegin (CondInfo a)+    | ElseIfBegin (CondInfo a)+    | ElseBegin+    | IfEnd+    -- | Verbatim stmt+    | Verbatim String+    deriving (Show, Eq, Ord, Functor, Foldable, Traversable)  ++isEmptyExp :: E -> Bool+isEmptyExp e = isNothing (ratedExpDepends re) && (ratedExpExp re == EmptyExp)+    where re = unFix e++-- Named variable+data Var +    = Var+        { varType :: VarType    -- global / local+        , varRate :: Rate+        , varName :: Name } +    | VarVerbatim +        { varRate :: Rate+        , varName :: Name        +        } deriving (Show, Eq, Ord)       +        +-- 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)++-- Opcode information.+data Info = Info +    -- Opcode name+    { infoName          :: Name     +    -- Opcode type signature+    , infoSignature     :: Signature+    -- Opcode can be infix or prefix+    , infoOpcFixity     :: OpcFixity+    } deriving (Show, Eq, Ord)           +  +isPrefix, isInfix :: Info -> Bool++isPrefix = (Prefix ==) . infoOpcFixity+isInfix  = (Infix  ==) . infoOpcFixity+ +-- Opcode fixity+data OpcFixity = Prefix | Infix | Opcode+    deriving (Show, Eq, Ord)++-- | The Csound rates.+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)    +    | Sr    -- strings+    | Fr    -- spectrum (for pvs opcodes)+    | Wr    -- special spectrum +    | Tvar  -- I don't understand what it is (fix me) used with Fr+    deriving (Show, Eq, Ord, Enum, Bounded)+    +-- 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 +-- 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 +    -- 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. +    -- It contains rates for outputs and inputs.+    | MultiRate +        { outMultiRate :: [Rate] +        , inMultiRate  :: [Rate] } +    deriving (Show, Eq, Ord)++-- Primitive values+data Prim +    -- instrument p-arguments+    = P Int +    | PString Int       -- >> p-string: +    | PrimInt Int +    | PrimDouble Double +    | PrimString String +    | PrimInstrId InstrId+    deriving (Show, Eq, Ord)++-- Gen routine.+data Gen = Gen +    { genSize    :: Int+    , genId      :: Int+    , genArgs    :: [Double]+    , genFile    :: Maybe String+    } deriving (Show, Eq, Ord)++-- Csound note+type Note = [Prim]++------------------------------------------------------------+-- types for arithmetic and boolean expressions++data Inline a b = Inline +    { inlineExp :: InlineExp a+    , inlineEnv :: IM.IntMap b    +    } deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++-- Inlined expression. +data InlineExp a+    = InlinePrim Int+    | InlineExp a [InlineExp a]+    deriving (Show, Eq, Ord)++-- Expression as a tree (to be inlined)+data PreInline a b = PreInline a [b]+    deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++-- booleans++type BoolExp a = PreInline CondOp a+type CondInfo a = Inline CondOp a++-- Conditional operators+data CondOp  +    = TrueOp | FalseOp | And | Or+    | Equals | NotEquals | Less | Greater | LessEquals | GreaterEquals+    deriving (Show, Eq, Ord)    ++isTrue, isFalse :: CondInfo a -> Bool++isTrue  = isCondOp TrueOp+isFalse = isCondOp FalseOp++isCondOp :: CondOp -> CondInfo a -> Bool+isCondOp op = maybe False (op == ) . getCondInfoOp++getCondInfoOp :: CondInfo a -> Maybe CondOp+getCondInfoOp x = case inlineExp x of+    InlineExp op _ -> Just op+    _ -> Nothing++-- Numeric expressions (or Csound infix operators)++type NumExp a = PreInline NumOp a++data NumOp = Add | Sub | Neg | Mul | Div | Pow | Mod +    deriving (Show, Eq, Ord)++-------------------------------------------------------+-- instances for cse that ghc was not able to derive for me++instance Foldable PrimOr where foldMap = foldMapDefault++instance Traversable PrimOr where+    traverse f x = case unPrimOr x of+        Left  p -> pure $ PrimOr $ Left p+        Right a -> PrimOr . Right <$> f a++----------------------------------------------------------++-- | Multiple output. Specify the number of outputs to get the result.+type MultiOut a = Int -> a++--------------------------------------------------------------+-- comments+-- +-- 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+
+ src/Csound/Dynamic/Types/Flags.hs view
@@ -0,0 +1,469 @@+-- | Csound's command line flags. See original documentation for detailed overview: <http://www.csounds.com/manual/html/CommandFlagsCategory.html>+module Csound.Dynamic.Types.Flags(+    Flags(..),++    -- * Audio file output+    AudioFileOutput(..),+    FormatHeader(..), FormatSamples(..), FormatType(..),+    Dither(..), IdTags(..),++    -- * Realtime Audio Input/Output+    Rtaudio(..), PulseAudio(..),+       +    -- * MIDI File Input/Ouput+    MidiIO(..),++    -- * MIDI Realtime Input/Ouput+    MidiRT(..), Rtmidi(..),++    -- * Display+    Displays(..), DisplayMode(..),++    -- * Performance Configuration and Control+    Config(..)+) where++import Control.Applicative++import Data.Char+import Data.Default+import Data.Maybe+import Data.Monoid++import Text.PrettyPrint.Leijen++mappendBool :: Bool -> Bool -> Bool+mappendBool a b = getAny $ mappend (Any a) (Any b)++data Flags = Flags+    { audioFileOutput   :: AudioFileOutput+    , idTags            :: IdTags+    , rtaudio           :: Maybe Rtaudio+    , pulseAudio        :: Maybe PulseAudio+    , midiIO            :: MidiIO+    , midiRT            :: MidiRT+    , rtmidi            :: Maybe Rtmidi+    , displays          :: Displays+    , config            :: Config +    , flagsVerbatim     :: Maybe String }++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 +        { audioFileOutput   = mappend (audioFileOutput a) (audioFileOutput b)+        , idTags            = mappend (idTags a) (idTags b)+        , rtaudio           = rtaudio a <|> rtaudio b+        , pulseAudio        = pulseAudio a <|> pulseAudio b+        , midiIO            = mappend (midiIO a) (midiIO b)+        , midiRT            = mappend (midiRT a) (midiRT b)+        , rtmidi            = rtmidi a <|> rtmidi b+        , displays          = mappend (displays a) (displays b)+        , config            = mappend (config a) (config b)+        , flagsVerbatim     = mappend (flagsVerbatim a) (flagsVerbatim b) }++-- Audio file output++data AudioFileOutput = AudioFileOutput+    { formatSamples     :: Maybe FormatSamples+    , formatType        :: Maybe FormatType+    , output            :: Maybe String+    , input             :: Maybe String+    , nosound           :: Bool+    , nopeaks           :: Bool+    , dither            :: Maybe Dither }++instance Default AudioFileOutput where+    def = AudioFileOutput def def def def False False def+ +instance Monoid AudioFileOutput where+    mempty = def+    mappend a b = AudioFileOutput +        { formatSamples     = formatSamples a <|> formatSamples b+        , formatType        = formatType a <|> formatType b+        , output            = output a <|> output b+        , input             = input a <|> input b+        , nosound           = mappendBool (nosound a) (nosound b)+        , nopeaks           = mappendBool (nopeaks a) (nopeaks b)+        , dither            = dither a <|> dither b }++data FormatHeader = NoHeader | RewriteHeader++data FormatSamples +    = Bit24 | Alaw | Uchar | Schar +    | FloatSamples | Ulaw | Short | Long+    deriving (Show)++data Dither = Triangular | Uniform+    deriving (Show)++data FormatType +    = Aiff | Au | Avr | Caf | Flac | Htk+    | Ircam | Mat4 | Mat5 | Nis | Paf | Pvf+    | Raw | Sd2 | Sds | Svx | Voc | W64 +    | Wav | Wavex | Xi+    deriving (Show)++-- Output file id tags++data IdTags = IdTags +    { idArtist      :: Maybe String+    , idComment     :: Maybe String+    , idCopyright   :: Maybe String+    , idDate        :: Maybe String+    , idSoftware    :: Maybe String+    , idTitle       :: Maybe String }++instance Default IdTags where+    def = IdTags def def def def def def++instance Monoid IdTags where+    mempty = def+    mappend a b = IdTags +        { idArtist      = idArtist a <|> idArtist b+        , idComment     = idComment a <|> idComment b+        , idCopyright   = idCopyright a <|> idCopyright b+        , idDate        = idDate a <|> idDate b+        , idSoftware    = idSoftware a <|> idSoftware b+        , idTitle       = idTitle a <|> idTitle b }++-- Realtime Audio Input/Output++data Rtaudio +    = PortAudio | Alsa +    | Jack +        { jackClient    :: String+        , jackInport    :: String+        , jackOutport   :: String } +    | Mme | CoreAudio+    | NoRtaudio++data PulseAudio = PulseAudio+    { paServer  :: String+    , paOutput  :: String+    , paInput   :: String }++-- MIDI File Input/Ouput++data MidiIO = MidiIO +    { midiFile          :: Maybe String+    , midiOutFile       :: Maybe String+    , muteTracks        :: Maybe String+    , rawControllerMode :: Bool+    , terminateOnMidi   :: Bool }++instance Default MidiIO where+    def = MidiIO def def def False False++instance Monoid MidiIO where+    mempty = def+    mappend a b = MidiIO +        { midiFile          = midiFile a <|> midiFile b+        , midiOutFile       = midiOutFile a <|> midiOutFile b+        , muteTracks        = muteTracks a <|> muteTracks b+        , rawControllerMode = mappendBool (rawControllerMode a)  (rawControllerMode b)+        , terminateOnMidi   = mappendBool (terminateOnMidi a) (terminateOnMidi b) }++-- MIDI Realtime Input/Ouput++data MidiRT = MidiRT+    { midiDevice        :: Maybe String+    , midiKey           :: Maybe Int+    , midiKeyCps        :: Maybe Int+    , midiKeyOct        :: Maybe Int+    , midiKeyPch        :: Maybe Int+    , midiVelocity      :: Maybe Int+    , midiVelocityAmp   :: Maybe Int+    , midiOutDevice     :: Maybe String }+   +instance Default MidiRT where+    def = MidiRT def def def def+                 def def def def++instance Monoid MidiRT where+    mempty = def+    mappend a b = MidiRT +        { midiDevice        = midiDevice a <|> midiDevice b+        , midiKey           = midiKey a <|> midiKey b+        , midiKeyCps        = midiKeyCps a <|> midiKeyCps b+        , midiKeyOct        = midiKeyOct a <|> midiKeyOct b+        , midiKeyPch        = midiKeyPch a <|> midiKeyPch b+        , midiVelocity      = midiVelocity a <|> midiVelocity b+        , midiVelocityAmp   = midiVelocityAmp a <|> midiVelocityAmp b+        , midiOutDevice     = midiOutDevice a <|> midiOutDevice b }++data Rtmidi = PortMidi | AlsaMidi | MmeMidi | WinmmMidi | VirtualMidi | NoRtmidi++-- Display++data Displays = Displays+    { csdLineNums       :: Maybe Int+    , displayMode       :: Maybe DisplayMode+    , displayHeartbeat  :: Maybe Int+    , messageLevel      :: Maybe Int+    , mAmps             :: Maybe Int+    , mRange            :: Maybe Int+    , mWarnings         :: Maybe Int+    , mDb               :: Maybe Int+    , mColours          :: Maybe Int+    , mBenchmarks       :: Maybe Int+    , msgColor          :: Bool+    , displayVerbose    :: Bool+    , listOpcodes       :: Maybe Int }++data DisplayMode = NoDisplay | PostScriptDisplay | AsciiDisplay++instance Default Displays where+    def = Displays def (Just NoDisplay) +            def def def def+            def def def def+            False False+            def++instance Monoid Displays where+    mempty = def+    mappend a b = Displays +        { csdLineNums       = csdLineNums a <|> csdLineNums b+        , displayMode       = displayMode a <|> displayMode b+        , displayHeartbeat  = displayHeartbeat a <|> displayHeartbeat b+        , messageLevel      = messageLevel a <|> messageLevel b+        , mAmps             = mAmps a <|> mAmps b+        , mRange            = mRange a <|> mRange b+        , mWarnings         = mWarnings a <|> mWarnings b+        , mDb               = mDb a <|> mDb b+        , mColours          = mColours a <|> mColours b+        , mBenchmarks       = mBenchmarks a <|> mBenchmarks b+        , msgColor          = mappendBool (msgColor a) (msgColor b)+        , displayVerbose    = mappendBool (displayVerbose a) (displayVerbose b)+        , listOpcodes       = listOpcodes a <|> listOpcodes b }        ++-- Performance Configuration and Control++data Config = Config+    { hwBuf         :: Maybe Int+    , ioBuf         :: Maybe Int+    , newKr         :: Maybe Int+    , newSr         :: Maybe Int+    , scoreIn       :: Maybe String+    , omacro        :: Maybe (String, String)+    , smacro        :: Maybe (String, String)+    , setSched      :: Bool+    , schedNum      :: Maybe Int+    , strsetN       :: Maybe (Int, String)+    , skipSeconds   :: Maybe Double+    , setTempo      :: Maybe Int }++instance Default Config where+    def = Config def def def def def def def+                 False+                 def def def def   ++instance Monoid Config where+    mempty = def+    mappend a b = Config+        { hwBuf     = hwBuf a <|> hwBuf b+        , ioBuf     = ioBuf a <|> ioBuf b+        , newKr     = newKr a <|> newKr b+        , newSr     = newSr a <|> newSr b+        , scoreIn   = scoreIn a <|> scoreIn b+        , omacro    = omacro a <|> omacro b+        , smacro    = smacro a <|> smacro b+        , setSched  = mappendBool (setSched a) (setSched b)+        , schedNum  = schedNum a <|> schedNum b+        , strsetN   = strsetN a <|> strsetN b+        , skipSeconds  = skipSeconds a <|> skipSeconds b+        , setTempo  = setTempo a <|> setTempo b }++----------------------------------------------------+-- rendering++-- just an alias for 'pretty'+p :: Pretty b => (a -> Maybe b) -> (a -> Maybe Doc)+p = (fmap pretty . )++pe :: Pretty b => (a -> b) -> (a -> Maybe Doc)+pe f = phi . f +    where phi x  +            | null (show res)   = Nothing+            | otherwise         = Just res+            where res = pretty x++bo :: String -> (a -> Bool) -> (a -> Maybe Doc)+bo property extract a+    | extract a = Just $ text property+    | otherwise = Nothing    ++mp :: (String -> String) -> (a -> Maybe String) -> (a -> Maybe Doc)+mp f a = p (fmap f . a)++mi :: (String -> String) -> (a -> Maybe Int) -> (a -> Maybe Doc)+mi f a = mp f (fmap show . a)++p1 :: String -> String -> String+p1 pref x = ('-' : pref) ++ (' ' : x)++p2 :: String -> String -> String+p2 pref x = ('-' : '-' : pref) ++ ('=' : x)+   +p3 :: String -> String -> String+p3 pref x = ('-' : '+' : pref) ++ ('=' : x)++fields :: [a -> Maybe Doc] -> a -> Doc+fields fs a = hsep $ catMaybes $ fmap ( $ a) fs++instance Pretty Flags where+    pretty = fields+        [ pe audioFileOutput +        , pe idTags +        , p  rtaudio+        , p  pulseAudio+        , pe midiIO+        , pe midiRT+        , p  rtmidi+        , pe displays+        , pe config+        , p  flagsVerbatim ]++instance Pretty AudioFileOutput where+    pretty = fields +        [ pSamplesAndType . (\x -> (formatSamples x, formatType x))+        , mp (p2 "output") output+        , mp (p2 "input")  input+        , bo "--nosound" nosound+        , bo "--nopeaks" nopeaks+        , mp (p2 "d/Mither") $ fmap (firstToLower . show) . dither ]++pSamplesAndType :: (Maybe FormatSamples, Maybe FormatType) -> Maybe Doc+pSamplesAndType (ma, mb) = fmap pretty $ case (ma, mb) of+    (Nothing, Nothing)  -> Nothing+    (Just a, Nothing)   -> Just $ p2 "format" $ samplesToStr a+    (Nothing, Just b)   -> Just $ p2 "format" $ typeToStr b+    (Just a, Just b)    -> Just $ p2 "format" $ samplesAndTypeToStr a b+    where+        samplesToStr x = case x of+            Bit24   -> "24bit"+            FloatSamples -> "float"+            _   -> firstToLower $ show x++        typeToStr = firstToLower . show++        samplesAndTypeToStr a b = samplesToStr a ++ ":" ++ typeToStr b++instance Pretty Dither where+    pretty = pretty . p2 "dither" . show++instance Pretty IdTags where+    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 +            p3' a b = fmap substSpaces $ p3 a b+            substSpaces x+                | isSpace x = '_'+                | otherwise = x  ++instance Pretty Rtaudio where+    pretty x = case x of+        PortAudio   -> rt "PortAudio"+        Jack name ins outs -> rt "jack" <+> jackFields name ins outs+        Mme -> rt "mme"+        Alsa  -> rt "alsa"+        CoreAudio -> rt "CoreAudio"+        NoRtaudio   -> rt "0"+        where +            rt = text . p3 "rtaudio"+            jackFields name ins outs = hsep +                [ text $ p3 "jack_client" name+                , text $ p3 "jack_inportname" ins+                , text $ p3 "jack_outportname" outs ]++instance Pretty PulseAudio where+    pretty a = hsep $ fmap text $+        [ p3 "server" $ paServer a+        , p3 "output_stream" $ paOutput a+        , p3 "input_stream" $ paInput a ]++instance Pretty MidiIO where+    pretty = fields +        [ mp (p2 "midifile") midiFile+        , mp (p2 "midioutfile") midiOutFile+        , mp (p3 "mute_tracks") muteTracks+        , bo "-+raw_controller_mode" rawControllerMode+        , bo "--terminate-on-midi" terminateOnMidi ]++instance Pretty MidiRT where+    pretty = fields+        [ mp (p2 "midi-device")         midiDevice+        , mi (p2 "midi-key")            midiKey+        , mi (p2 "midi-key-cps")        midiKeyCps+        , mi (p2 "midi-key-oct")        midiKeyOct+        , mi (p2 "midi-key-pch")        midiKeyPch+        , 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"+        PortMidi    -> "PortMidi"+        AlsaMidi    -> "alsa"+        MmeMidi     -> "mme"+        WinmmMidi   -> "winmm"+        NoRtmidi    -> "0"++instance Pretty Displays where+    pretty = fields+        [ mi (p2 "csd-line-nums")   csdLineNums +        , p                         displayMode+        , mi (p2 "heartbeat")       displayHeartbeat+        , mi (p2 "messagelevel")    messageLevel+        , mi (p2 "m-amps")          mAmps+        , mi (p2 "m-range")         mRange+        , mi (p2 "m-warnings")      mWarnings+        , mi (p2 "m-dB")            mDb+        , mi (p2 "m-colours")       mColours+        , mi (p2 "m-benchmarks")    mBenchmarks+        , bo "-+msg_color"          msgColor+        , bo "--verbose"            displayVerbose+        , mi (p2 "list-opcodes")    listOpcodes ]++instance Pretty DisplayMode where+    pretty x = text $ case x of+        NoDisplay           -> "--nodisplays"+        PostScriptDisplay   -> "--postscriptdisplay"+        AsciiDisplay        -> "--asciidisplay"+        +instance Pretty Config where+    pretty = fields +        [ mi (p2 "hardwarebufsamps")    hwBuf+        , mi (p2 "iobufsamps")          ioBuf+        , mi (p2 "control-rate")        newKr+        , mi (p2 "sample-rate")         newSr+        , mp (p2 "score-in")            scoreIn+        , macro "omacro"                omacro+        , macro "smacro"                smacro+        , bo "--sched"                  setSched+        , mi (p2 "sched")               schedNum+        , strset                        strsetN+        , mp (p3 "skip_seconds")        (fmap show . skipSeconds)+        , mi (p2 "tempo")               setTempo ]+        where+            macro name f = fmap (pretty . phi) . f+                where phi (a, b) = "--" ++ name ++ ":" ++ a ++ "=" ++ b+            strset f = fmap (pretty . phi) . f+                where phi (n, a) = "--strset" ++ (show n) ++ "=" ++ a++---------------------------------------------------+-- utilities++firstToLower :: String -> String+firstToLower x = case x of +    a:as -> toLower a : as+    []   -> []+