csound-expression 1.0.1 → 1.0.2
raw patch · 13 files changed
+137/−110 lines, 13 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- csound-expression.cabal +1/−2
- src/Csound/Exp.hs +37/−11
- src/Csound/Exp/Cons.hs +1/−1
- src/Csound/Exp/Logic.hs +12/−11
- src/Csound/Exp/Numeric.hs +8/−8
- src/Csound/Exp/Wrapper.hs +31/−8
- src/Csound/Opcode/Data.hs +1/−1
- src/Csound/Render.hs +0/−2
- src/Csound/Render/Instr.hs +12/−15
- src/Csound/Render/Pretty.hs +7/−5
- src/Csound/Render/Sco.hs +1/−2
- src/Csound/Tfm/RateGraph.hs +26/−9
- src/Csound/Tfm/TfmTree.hs +0/−35
csound-expression.cabal view
@@ -1,5 +1,5 @@ Name: csound-expression-Version: 1.0.1+Version: 1.0.2 Cabal-Version: >= 1.6 License: BSD3 License-file: LICENSE@@ -88,7 +88,6 @@ Csound.Exp.Numeric Csound.Tfm.RateGraph- Csound.Tfm.TfmTree Csound.Render Csound.Render.Pretty
src/Csound/Exp.hs view
@@ -1,8 +1,8 @@ module Csound.Exp(- E, RatedExp(..), RatedVar(..), onExp, Exp(..), Name,+ E, RatedExp(..), RatedVar(..), onExp, Exp, toPrimOr, PrimOr(..), MainExp(..), Name, VarType(..), Var(..), Info(..), OpcType(..), Rate(..), Signature(..), isProcedure, isInfix, isPrefix, - Prim(..), Tab(..),+ Prim(..), Tab(..), TabMap, Inline(..), InlineExp(..), PreInline(..), BoolExp, CondInfo, CondOp(..), isTrue, isFalse, NumExp, NumOp(..) @@ -15,6 +15,7 @@ import Data.Map(Map) import qualified Data.IntMap as IM+import qualified Data.Map as M import Data.Fix -- | The inner representation of csound expressions.@@ -39,7 +40,18 @@ data VarType = LocalVar | GlobalVar deriving (Show, Eq, Ord) -data Exp a +type Exp a = MainExp (PrimOr a)++toPrimOr :: E -> PrimOr E+toPrimOr a = PrimOr $ case ratedExpExp $ unFix a of+ ExpPrim (PString _) -> Right a+ ExpPrim p -> Left p+ _ -> Right a++newtype PrimOr a = PrimOr { unPrimOr :: Either Prim a }+ deriving (Show, Eq, Ord)++data MainExp a = ExpPrim Prim | Tfm Info [a] | ConvertRate Rate Rate a@@ -97,7 +109,9 @@ | PrimTab Tab | PrimString String deriving (Show, Eq, Ord)- + +type TabMap = M.Map Tab Int+ -- | Csound f-tables. You can make a value of 'Tab' with the function 'gen'. data Tab = Tab { tabSize :: Int@@ -160,15 +174,28 @@ -- instances for cse instance Functor RatedExp where- fmap f (RatedExp r d a) = RatedExp r (fmap f d) (fmap f a)+ fmap f (RatedExp r d a) = RatedExp r (fmap f d) (fmap (fmap f) a) instance Foldable RatedExp where- foldMap f (RatedExp _ d a) = foldMap f d <> foldMap f a+ foldMap f (RatedExp _ d a) = foldMap f d <> foldMap (foldMap f) a instance Traversable RatedExp where- traverse f (RatedExp r d a) = RatedExp r <$> traverse f d <*> traverse f a+ traverse f (RatedExp r d a) = RatedExp r <$> traverse f d <*> traverse (traverse f) a -instance Functor Exp where+instance Functor PrimOr where+ fmap f (PrimOr a) = PrimOr (fmap f a)++instance Foldable PrimOr where+ foldMap f x = case unPrimOr x of+ Left _ -> mempty+ Right a -> f a++instance Traversable PrimOr where+ traverse f x = case unPrimOr x of+ Left p -> pure $ PrimOr $ Left p+ Right a -> PrimOr . Right <$> f a++instance Functor MainExp where fmap f x = case x of ExpPrim p -> ExpPrim p Tfm t xs -> Tfm t $ map f xs@@ -181,7 +208,7 @@ WriteVar v a -> WriteVar v (f a) -instance Foldable Exp where+instance Foldable MainExp where foldMap f x = case x of ExpPrim p -> mempty Tfm t xs -> foldMap f xs@@ -193,7 +220,7 @@ ReadVar v -> mempty WriteVar v a -> f a -instance Traversable Exp where+instance Traversable MainExp where traverse f x = case x of ExpPrim p -> pure $ ExpPrim p Tfm t xs -> Tfm t <$> traverse f xs@@ -204,7 +231,6 @@ ExpNum a -> ExpNum <$> traverse f a ReadVar v -> pure $ ReadVar v WriteVar v a -> WriteVar v <$> f a- instance Functor (Inline a) where fmap f a = a{ inlineEnv = fmap f $ inlineEnv a }
src/Csound/Exp/Cons.hs view
@@ -32,7 +32,7 @@ withInits :: (Val a, CsdTuple inits) => a -> inits -> Sig withInits a b = wrap $ onExp phi $ unwrap a where phi x = case x of- Tfm t xs -> Tfm t (xs ++ fromCsdTuple b)+ Tfm t xs -> Tfm t (xs ++ (fmap toPrimOr $ fromCsdTuple b)) x -> x ------------------------------------------------
src/Csound/Exp/Logic.hs view
@@ -39,29 +39,29 @@ boolExp = PreInline cond' :: BoolSig -> Sig -> Sig -> Sig-cond' p t e = wrap $ mkCond (condInfo $ Fix $ unwrap p) (unwrap t) (unwrap e)- where mkCond :: CondInfo E -> RatedExp E -> RatedExp E -> RatedExp E+cond' p t e = wrap $ mkCond (condInfo $ toPrimOr $ Fix $ unwrap p) (unwrap t) (unwrap e)+ where mkCond :: CondInfo (PrimOr E) -> RatedExp E -> RatedExp E -> RatedExp E mkCond p t e | isTrue p = t | isFalse p = e- | otherwise = noRate $ If p (Fix t) (Fix e) + | otherwise = noRate $ If p (toPrimOr $ Fix t) (toPrimOr $ Fix e) -condInfo :: E -> CondInfo E+condInfo :: PrimOr E -> CondInfo (PrimOr E) condInfo exp = (\(a, b) -> Inline a (IM.fromList b)) $ evalState (condInfo' exp) 0- where condInfo' :: E -> State Int (InlineExp CondOp, [(Int, E)])+ where condInfo' :: PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)]) condInfo' e = maybe (onLeaf e) (onExp e) $ parseNode e onLeaf e = state $ \n -> ((InlinePrim n, [(n, e)]), n+1) onExp e (op, args) = mkNode <$> mapM condInfo' args where mkNode as = (InlineExp op (map fst as), concat $ map snd as) - parseNode :: E -> Maybe (CondOp, [E])- parseNode x = case ratedExpExp $ unFix x of- ExpBool (PreInline op args) -> Just (op, args)+ parseNode :: PrimOr E -> Maybe (CondOp, [PrimOr E])+ parseNode x = case unPrimOr $ fmap (ratedExpExp . unFix) x of+ Right (ExpBool (PreInline op args)) -> Just (op, args) _ -> Nothing boolOps :: (Val a) => CondOp -> [E] -> a-boolOps op as = noRate $ ExpBool $ boolExp op as+boolOps op as = noRate $ ExpBool $ boolExp op $ fmap toPrimOr as boolOp0 :: Val a => CondOp -> a boolOp0 op = boolOps op []@@ -78,13 +78,14 @@ where phi (ExpBool (PreInline op args)) = ExpBool $ case op of TrueOp -> boolExp FalseOp [] FalseOp -> boolExp TrueOp []- And -> boolExp Or $ map notE args- Or -> boolExp And $ map notE args+ 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 +
src/Csound/Exp/Numeric.hs view
@@ -12,6 +12,13 @@ ------------------------------------------------------- -- instances for numerical expressions +class NumOpt a where+ maybeInt :: a -> Maybe Int+ maybeDouble :: a -> Maybe Double+ fromInt :: Int -> a+ fromDouble :: Double -> a+ fromNum :: NumExp a -> a+ instance NumOpt E where maybeInt x = case ratedExpExp $ unFix x of ExpPrim (PrimInt n) -> Just n@@ -23,7 +30,7 @@ fromInt = prim . PrimInt fromDouble = prim . PrimDouble- fromNum = noRate . ExpNum + fromNum = noRate . ExpNum . fmap toPrimOr -------------------------------------------- -- numeric instances@@ -196,13 +203,6 @@ ------------------------------------------------------------ -class NumOpt a where- maybeInt :: a -> Maybe Int- maybeDouble :: a -> Maybe Double- fromInt :: Int -> a- fromDouble :: Double -> a- fromNum :: NumExp a -> a- isZero :: NumOpt a => a -> Bool isZero a = maybe False id $ liftA2 (||) ((== 0) <$> maybeInt a) ((==0) <$> maybeDouble a)
src/Csound/Exp/Wrapper.hs view
@@ -10,7 +10,8 @@ str, double, int, ir, tfm, pref, prim, p, isMultiOutSignature,- noRate, setRate, getRates,+ noRate, setRate, + getRates, tabMap, readVar, writeVar, gOutVar, Channel ) where@@ -19,9 +20,12 @@ import Control.Monad(ap) import Control.Monad.Trans.State +import Data.List(nub) import Data.String import Data.Fix import Control.Monad.Trans.State+import qualified Data.Map as M+import Data.Foldable(foldMap) import Csound.Exp @@ -30,7 +34,6 @@ -- | Output of the instrument. type Out = SE [Sig] - -- | Audio or control rate signals. newtype Sig = Sig { unSig :: E } @@ -99,7 +102,7 @@ inf name signature = Info name signature Infix Nothing tfm :: Val a => Info -> [RatedExp E] -> a-tfm info args = wrap $ noRate $ Tfm info $ map Fix args+tfm info args = wrap $ noRate $ Tfm info $ map (toPrimOr . Fix) args gvar, var :: Val a => Rate -> Name -> a @@ -125,7 +128,7 @@ str = prim . PrimString writeVar :: (Val a) => Var -> a -> SE ()-writeVar v x = se_ $ noRate $ WriteVar v $ Fix $ unwrap x +writeVar v x = se_ $ noRate $ WriteVar v $ toPrimOr $ Fix $ unwrap x readVar :: (Val a) => Var -> a readVar v = noRate $ ReadVar v@@ -146,12 +149,32 @@ se_ = fmap (const ()) . (se :: E -> SE E) --------------------------------------------------- basic destructors+-- basic extractors getPrimUnsafe :: Val a => a -> Prim getPrimUnsafe a = case ratedExpExp $ unwrap a of ExpPrim p -> p +tabMap :: [E] -> TabMap+tabMap es = M.fromList $ zip (nub $ getFtables =<< es) [1 ..]+ where + getFtables :: E -> [Tab]+ getFtables = cata $ \re -> case fmap fromPrimOr $ ratedExpExp re of + ExpPrim p -> fromPrim p+ Tfm _ as -> concat as+ ConvertRate _ _ a -> a+ ExpNum a -> foldMap id a+ Select _ _ a -> a+ If info a b -> foldMap id info ++ a ++ b+ ReadVar _ -> []+ WriteVar _ a -> a+ where fromPrim x = case x of+ PrimTab t -> [t]+ _ -> []+ fromPrimOr x = case unPrimOr x of+ Left p -> fromPrim p+ Right a -> a+ -------------------------------------------- -- signals from primitive types @@ -436,11 +459,11 @@ e' = Fix $ onExp (setMultiRate rates) $ unFix e setMultiRate rates (Tfm info xs) = Tfm (info{ infoSignature = MultiRate rates ins }) xs - where MultiRate _ ins = infoSignature info+ where MultiRate _ ins = infoSignature info - select n r e = withRate r $ Select r n e+ select n r e = withRate r $ Select r n (PrimOr $ Right e) -getRates :: Exp a -> [Rate]+getRates :: MainExp a -> [Rate] getRates (Tfm info _) = case infoSignature info of MultiRate outs _ -> outs
src/Csound/Opcode/Data.hs view
@@ -425,7 +425,7 @@ instance Nums D conv :: Nums a => NumOp -> a -> a-conv op a = noRate $ ExpNum $ PreInline op [toE a]+conv op a = noRate $ ExpNum $ PreInline op [toPrimOr $ toE a] -- | Returns the amplitude equivalent of the decibel value x. Thus:
src/Csound/Render.hs view
@@ -12,11 +12,9 @@ import Csound.Exp import Csound.Exp.Wrapper hiding (double, int)-import Csound.Tfm.TfmTree(tabMap) import Csound.Render.Sco import Csound.Render.Instr import Csound.Render.Options-import Csound.Tfm.TfmTree(TabMap) import Csound.Exp.Numeric import Csound.Render.Pretty
src/Csound/Render/Instr.hs view
@@ -17,7 +17,6 @@ import Csound.Exp.Wrapper hiding (double, int) import Csound.Tfm.RateGraph-import Csound.Tfm.TfmTree import Csound.Render.Pretty type InstrId = Int@@ -29,7 +28,7 @@ renderInstrBody :: KrateSet -> TabMap -> E -> [Doc] renderInstrBody krateSet ft sig = map (stmt . clearEmptyResults) $ collectRates krateSet st g where stmt :: ([RatedVar], Exp RatedVar) -> Doc- stmt (res, exp) = renderExp (ppOuts res) exp+ stmt (res, exp) = renderExp ft (ppOuts res) exp st = getRenderState g g = toDag ft sig@@ -53,7 +52,7 @@ selectInfo = filter (isSelect . ratedExpExp . snd) a extract (n, x) = case ratedExpExp x of- Select rate order parent -> (parent, [MultiOutPort n order])+ Select rate order (PrimOr (Right parent)) -> (parent, [MultiOutPort n order]) filterMultiOutHelpers :: [(RatedVar, Exp RatedVar)] -> [(RatedVar, Exp RatedVar)] filterMultiOutHelpers = filter (not . isSelect . snd) @@ -64,7 +63,7 @@ toDag :: TabMap -> E -> Dag RatedExp -toDag ft exp = fromDag $ cse $ substTabs ft exp+toDag ft exp = fromDag $ cse exp clearEmptyResults :: ([RatedVar], Exp RatedVar) -> ([RatedVar], Exp RatedVar)@@ -79,23 +78,21 @@ tfmMultiRates :: RenderState -> [(RatedVar, Exp RatedVar)] -> State Int [([RatedVar], Exp RatedVar)] tfmMultiRates st as = mapM substRate as where substRate (n, exp) - | isMultiOutExp exp = fmap (,exp) $ getMultiOutVars (multiOutsLinks st IM.! ratedVarId n) exp+ | isMultiOutExp exp = fmap (,exp) $ getMultiOutVars (multiOutsLinks st IM.! ratedVarId n) (getRates exp) | otherwise = return ([n], exp) isMultiOutExp x = case x of Tfm i _ -> isMultiOutSignature (infoSignature i) _ -> False -getMultiOutVars :: [MultiOutPort] -> Exp RatedVar -> State Int [RatedVar]-getMultiOutVars ports exp = fmap (zipWith RatedVar (getRates exp)) (getPorts ports)+getMultiOutVars :: [MultiOutPort] -> [Rate] -> State Int [RatedVar]+getMultiOutVars ports rates = fmap (zipWith RatedVar rates) (getPorts ports) where getPorts ps = state $ \lastFreshId -> let ps' = sortBy (comparing orderMultiOutPort) ps (ids, lastPortOrder) = runState (mapM (fillMissingPorts lastFreshId) ps') 0- ids' = ids ++ [map (+ lastFreshId) [lastPortOrder + 1 .. portsSize - 1]] - in (concat ids', lastFreshId + portsSize - inUsePortsSize) - - - rates = getRates exp+ ids' = ids ++ [map (+ lastFreshId) [0 .. portsSize - 1 - lastPortOrder]] + in (concat ids', lastFreshId + portsSize - inUsePortsSize) + portsSize = length rates inUsePortsSize = length ports @@ -113,10 +110,10 @@ getRate :: RatedExp a -> Rate getRate = fromJust . ratedExpRate -renderExp :: Doc -> Exp RatedVar -> Doc-renderExp res exp = case fmap ppRatedVar exp of+renderExp :: TabMap -> Doc -> Exp RatedVar -> Doc+renderExp m res exp = case fmap (ppPrimOrVar m) exp of ExpPrim (PString n) -> ppStrget res n- ExpPrim p -> res $= ppPrim p+ ExpPrim p -> res $= ppPrim m p Tfm info [a, b] | isInfix info -> res $= binary (infoName info) a b Tfm info xs -> ppOpc res (infoName info) xs ConvertRate to from x -> ppConvertRate res to from x
src/Csound/Render/Pretty.hs view
@@ -4,7 +4,7 @@ binaries, unaries, funcs, binary, unary, func, ppMapTable,- ($=), ppRatedVar, ppOuts, ppOpc, ppProc, ppVar,+ ($=), ppPrimOrVar, ppRatedVar, ppOuts, ppOpc, ppProc, ppVar, ppPrim, ppTab, ppStrget, ppStrset, ppTabDef, ppConvertRate, ppIf, ppCsdFile, ppInstr, ppInstr0, ppScore, ppNote, ppTotalDur, ppOrc, ppSco, ppInline, ppCondOp, ppNumOp@@ -44,6 +44,8 @@ _ -> phi x where phi = text . map toLower . show +ppPrimOrVar :: TabMap -> PrimOr RatedVar -> Doc+ppPrimOrVar m x = either (ppPrim m) ppRatedVar $ unPrimOr x ppRatedVar :: RatedVar -> Doc ppRatedVar (RatedVar r x) = ppRate r <> int x@@ -70,13 +72,13 @@ LocalVar -> empty GlobalVar -> char 'g' -ppPrim :: Prim -> Doc-ppPrim x = case x of+ppPrim :: TabMap -> Prim -> Doc+ppPrim m x = case x of P n -> char 'p' <> int n PrimInt n -> int n PrimDouble d -> double d- PrimString s -> text s- PrimTab f -> ppTab f+ PrimString s -> dquotes $ text s+ PrimTab f -> int $ m M.! f ppTab :: Tab -> Doc ppTab (Tab size n xs) = text "gen" <> int n <+> int size <+> (hsep $ map double xs)
src/Csound/Render/Sco.hs view
@@ -15,7 +15,6 @@ import Csound.Exp import Csound.Exp.Wrapper hiding (int, double)-import Csound.Tfm.TfmTree(TabMap) import Csound.Exp.Cons(opcs) import Csound.Exp.Numeric @@ -89,7 +88,7 @@ expReader instr instrId = swap $ runSE $ do as <- instr let vars = instrPorts instrId as - zipWithM writeVar vars as+ zipWithM (\v a -> writeVar v $ readVar v + a) vars as return vars
src/Csound/Tfm/RateGraph.hs view
@@ -7,7 +7,8 @@ import qualified Data.IntMap as IM import qualified Data.Set as S import Data.Ord(comparing)-import Data.Maybe(fromJust)+import Data.Maybe(fromJust, catMaybes)+import Data.Either import Data.Default @@ -22,6 +23,7 @@ import Debug.Trace + echo :: Show a => String -> a -> a echo msg a = trace (msg ++ ": " ++ show a) a @@ -120,7 +122,7 @@ notifyChildren :: AgentId -> Rate -> Exp Int -> MsgBox s -> ST s ()-notifyChildren pid curRate exp box = mapM_ (\(to, query) -> sendQuery to query box) $ case exp of+notifyChildren pid curRate exp box = mapM_ (\(to, query) -> sendQuery to query box) $ catMaybes $ fmap wrapFromEither $ case exp of Tfm info xs -> notifyTfm curRate (infoSignature info) xs WriteVar v a -> [(a, mkQuery 0 $ varRate v)] If info a b -> (a, mkQuery (-2) curRate) : (b, mkQuery (-1) curRate) : encodeIfEnv (max Kr curRate) (inlineEnv info)@@ -136,6 +138,9 @@ encodeIfEnv rate info = map (\(port, arg) -> (arg, mkQuery port rate)) $ IM.toList info + wrapFromEither (to, query) = either (const Nothing) (Just . \x -> (x, query)) (unPrimOr to)++ notifyParents :: MsgBox s -> M.Map Rate RatedVar -> [Query] -> ST s () notifyParents box convTab qs = mapM_ (notifyParent box convTab) qs @@ -166,7 +171,7 @@ getConversions pid curRate convTable = uncurry phi =<< M.toList convTable where phi rate var@(RatedVar r n) | n == pid = []- | otherwise = [(var, ConvertRate r curRate $ RatedVar curRate pid)] + | otherwise = [(var, ConvertRate r curRate $ PrimOr $ Right $ RatedVar curRate pid)] processLine :: MsgBox s -> (Int, RatedExp Int) -> ST s [(RatedVar, Exp RatedVar)]@@ -179,16 +184,28 @@ rateExp curRate rs exp = case exp of ExpPrim (P n) | curRate == Sr -> ExpPrim (PString n) ExpPrim p -> ExpPrim p- Tfm i _ -> Tfm i vs - Select rate pid a -> Select rate pid (RatedVar Xr a) - If condInfo _ _ -> case vs of+ Tfm i vsOld -> Tfm i $ mergeWithPrimOr vsOld vs+ Select rate pid a -> Select rate pid (fmap (RatedVar Xr) a) + If condInfo a' b' -> case mergeWithPrimOr (encodeIfEnv condInfo a' b') vs of a:b:rest -> If (decodeIfEnv condInfo rest) a b- ExpNum (PreInline op _) -> ExpNum (PreInline op vs)+ ExpNum (PreInline op vsOld) -> ExpNum (PreInline op $ mergeWithPrimOr vsOld vs) ReadVar v -> ReadVar v- WriteVar v _ -> WriteVar v (head vs)+ WriteVar v vsOld -> WriteVar v (substPrimOr vsOld $ head vs) where vs = map responseRatedVar $ sortBy (comparing $ addrArg . responseAddr) rs- decodeIfEnv info xs = info{ inlineEnv = IM.fromList $ zip [0..] xs }+ decodeIfEnv info xs = info{ inlineEnv = IM.fromList $ zip [0..] xs } + encodeIfEnv info a b = a:b:(IM.elems $ inlineEnv info) ++substPrimOr :: PrimOr a -> b -> PrimOr b+substPrimOr p val = PrimOr $ case unPrimOr p of+ Left a -> Left a+ Right _ -> Right val++mergeWithPrimOr :: [PrimOr a] -> [b] -> [PrimOr b]+mergeWithPrimOr xs ys = case (xs, ys) of+ ([], _) -> []+ (PrimOr (Left a):as, bs) -> PrimOr (Left a) : mergeWithPrimOr as bs+ (PrimOr (Right _):as, b:bs) -> PrimOr (Right b) : mergeWithPrimOr as bs findRate :: [Rate] -> Rate findRate [x] = x
− src/Csound/Tfm/TfmTree.hs
@@ -1,35 +0,0 @@-module Csound.Tfm.TfmTree(- TabMap, tabMap, substTabs-) where--import Data.List(nub)-import Data.Fix-import qualified Data.Map as M-import Data.Foldable(foldMap)--import Csound.Exp--type TabMap = M.Map Tab Int---- substitute ftables for ids --substTabs :: TabMap -> E -> E-substTabs m = cata $ \(RatedExp r d x) -> Fix $ RatedExp r d $ case x of- ExpPrim (PrimTab t) -> ExpPrim (PrimInt $ m M.! t)- _ -> x---tabMap :: [E] -> TabMap-tabMap es = M.fromList $ zip (nub $ getFtables =<< es) [1 ..]--getFtables :: E -> [Tab]-getFtables = cata $ \(RatedExp _ _ x) -> case x of- ExpPrim (PrimTab t) -> [t]- ExpPrim _ -> []- Tfm _ as -> concat as- ConvertRate _ _ a -> a- ExpNum a -> foldMap id a- Select _ _ a -> a- If info a b -> foldMap id info ++ a ++ b- ReadVar _ -> []- WriteVar _ a -> a