csound-expression-dynamic 0.3.5 → 0.3.6
raw patch · 7 files changed
+133/−118 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- csound-expression-dynamic.cabal +2/−2
- src/Csound/Dynamic/Build/Logic.hs +9/−17
- src/Csound/Dynamic/Render/Instr.hs +8/−2
- src/Csound/Dynamic/Render/Pretty.hs +69/−52
- src/Csound/Dynamic/Tfm/Liveness.hs +44/−44
- src/Csound/Dynamic/Types/CsdFile.hs +0/−1
- src/Csound/Dynamic/Types/Exp.hs +1/−0
csound-expression-dynamic.cabal view
@@ -1,6 +1,6 @@ Name: csound-expression-dynamic-Version: 0.3.5-Cabal-Version: >= 1.10+Version: 0.3.6+Cabal-Version: >= 1.22 License: BSD3 License-file: LICENSE Author: Anton Kholomiov
src/Csound/Dynamic/Build/Logic.hs view
@@ -33,7 +33,7 @@ ifBegin rate (fst a) snd a elseIfs as- elseBegin + elseBegin el foldl1 (>>) $ replicate (1 + length as) ifEnd where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBegin rate p >> body)@@ -90,11 +90,11 @@ instance IfB E where ifB = condExp- + instance EqB E where (==*) = boolOp2 Equals (/=*) = boolOp2 NotEquals- + instance OrdB E where (<*) = boolOp2 Less (>*) = boolOp2 Greater@@ -112,10 +112,10 @@ condExp :: E -> E -> E -> E condExp = mkCond . condInfo where mkCond :: CondInfo (PrimOr E) -> E -> E -> E- mkCond pr th el + mkCond pr th el | isTrue pr = th | isFalse pr = el- | otherwise = noRate $ If pr (toPrimOr th) (toPrimOr el) + | otherwise = noRate $ If pr (toPrimOr th) (toPrimOr el) condInfo :: E -> CondInfo (PrimOr E) condInfo p = go $ toPrimOr p@@ -124,14 +124,14 @@ 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) + 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) + 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 + _ -> Nothing -------------------------------------------------------------------------------- -- constructors for boolean expressions@@ -146,14 +146,6 @@ boolOp2 op a b = boolOps op [a, b] -fromBoolOpt :: Either Bool E -> E-fromBoolOpt = either (\x -> if x then true else false) id --toNumOpt :: E -> Either Double E-toNumOpt x = case toExp x of- ExpPrim (PrimDouble d) -> Left d- _ -> Right x- ----------------------------------------------------------------------------- -- no support for not in csound so we perform not-elimination notE :: E -> E@@ -170,5 +162,5 @@ LessEquals -> boolExp Greater args GreaterEquals -> boolExp Less args - phi _ = error "Logic.hs:notE - expression is not Boolean" + phi _ = error "Logic.hs:notE - expression is not Boolean"
src/Csound/Dynamic/Render/Instr.hs view
@@ -8,7 +8,7 @@ import qualified Data.Map as M import Data.Maybe(fromJust)-import Data.Fix(Fix(..), cata)+import Data.Fix(Fix(..), foldFix) import Data.Fix.Cse(fromDag, cseFramed, FrameInfo(..)) import qualified Text.PrettyPrint.Leijen as P@@ -20,6 +20,7 @@ import Csound.Dynamic.Types hiding (Var) import Csound.Dynamic.Build(getRates, isMultiOutSignature) import Csound.Dynamic.Render.Pretty+import qualified Csound.Dynamic.Types as T(Var) type Dag f = [(Int, f Int)] @@ -57,7 +58,7 @@ trimByArgLength :: E -> E-trimByArgLength = cata $ \x -> Fix x{ ratedExpExp = phi $ ratedExpExp x }+trimByArgLength = foldFix $ \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@@ -200,6 +201,10 @@ ReadMacrosInt name -> ReadMacrosInt name ExpBool _ -> error $ msg "ExpBool expression should be substituted" ConvertRate _ _ _ -> error $ msg "ConvertRate couldn't be here. It's introduced on the later stages of processing"+ Seq _ _ -> error "No rateExp for Seq"+ Ends _ -> error "No rateExp for Ends"+ InitMacrosInt _ _ -> error "No rateExp for InitMacrosInt"+ Starts -> error "No rateExp for Starts" where ratesFromSignature rate signature = case signature of SingleRate table -> table M.! rate MultiRate _ rs -> rs@@ -214,6 +219,7 @@ msg txt = "Csound.Dynamic.Render.Instr.rateExp: " ++ txt +arrIndexVarRate :: T.Var -> Rate arrIndexVarRate v = case varRate v of Ir -> Ir _ -> Kr
src/Csound/Dynamic/Render/Pretty.hs view
@@ -29,68 +29,68 @@ func op a = text op <> parens a ppCsdFile :: Doc -> Doc -> Doc -> [Plugin] -> Doc-ppCsdFile flags orc sco plugins = +ppCsdFile flags orc sco plugins = tag "CsoundSynthesizer" $ vcatSep [ tag "CsOptions" flags, tag "CsInstruments" orc, tag "CsScore" sco, ppPlugins plugins- ] + ] ppPlugins :: [Plugin] -> Doc ppPlugins plugins = vcatSep $ fmap (\(Plugin name body) -> tag name (text body)) plugins tag :: String -> Doc -> Doc tag name content = vcatSep [- char '<' <> text name <> char '>', - content, - text "</" <> text name <> char '>'] + char '<' <> text name <> char '>',+ content,+ text "</" <> text name <> char '>'] ppNotes :: InstrId -> [CsdEvent] -> Doc ppNotes instrId = vcat . fmap (ppNote instrId) ppNote :: InstrId -> CsdEvent -> Doc-ppNote instrId evt = char 'i' - <+> ppInstrId instrId - <+> double (csdEventStart evt) <+> double (csdEventDur evt) +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 + PString a -> int a PrimInt n -> int n PrimDouble d -> double d PrimString s -> dquotes $ text s PrimVar targetRate v -> ppConverter targetRate (varRate v) $ ppVar v where- ppConverter dst src t - | dst == src = t - | dst == Ar && src == Kr = a(t) - | dst == Ar && src == Ir = a(k(t)) + ppConverter dst src t+ | dst == src = t+ | dst == Ar && src == Kr = a(t)+ | dst == Ar && src == Ir = a(k(t)) | dst == Kr = k(t) | dst == Ir && src == Kr = i(t) | dst == Ir && src == Ar = i(k(t)) | otherwise = t- where - tfm ch v = hcat [char ch, parens v] + where+ tfm ch v = hcat [char ch, parens v] a = tfm 'a' k = tfm 'k' i = tfm 'i' - + ppGen :: Int -> Gen -> Doc-ppGen tabId ft = char 'f' - <> int tabId - <+> int 0 +ppGen tabId ft = char 'f'+ <> int tabId+ <+> int 0 <+> (int $ genSize ft)- <+> (ppGenId $ genId ft) + <+> (ppGenId $ genId ft) <+> (maybe empty (text . show) $ genFile ft) <+> (hsep $ map double $ genArgs ft) ppGenId :: GenId -> Doc-ppGenId genId = case genId of+ppGenId x = case x of IntGenId a -> int a StringGenId a -> dquotes $ text a @@ -102,27 +102,27 @@ ppInstrHeadId :: InstrId -> Doc ppInstrHeadId x = case x of- InstrId den nom -> int nom <> maybe empty ppAfterDot den + InstrId den nom -> int nom <> maybe empty ppAfterDot den InstrLabel name -> text name where ppAfterDot a = text $ ('.': ) $ reverse $ show a ppInstrId :: InstrId -> Doc ppInstrId x = case x of- InstrId den nom -> int nom <> maybe empty ppAfterDot den + 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 = maybe (ppExp (ppOuts outs) expr) id (maybeStringCopy outs expr) +ppStmt outs expr = maybe (ppExp (ppOuts outs) expr) id (maybeStringCopy outs expr) maybeStringCopy :: [RatedVar] -> Exp RatedVar -> Maybe (State TabDepth Doc) maybeStringCopy outs expr = case (outs, expr) of- ([R.Var n Sr], ExpPrim (PrimVar rate var)) -> Just $ tab $ ppStringCopy (ppOuts outs) (ppVar var)- ([R.Var n Sr], ReadVar var) -> Just $ tab $ ppStringCopy (ppOuts outs) (ppVar var)+ ([R.Var _ Sr], ExpPrim (PrimVar _rate var)) -> Just $ tab $ ppStringCopy (ppOuts outs) (ppVar var)+ ([R.Var _ Sr], ReadVar var) -> Just $ tab $ ppStringCopy (ppOuts outs) (ppVar var) ([], WriteVar outVar a) | varRate outVar == Sr -> Just $ tab $ ppStringCopy (ppVar outVar) (ppPrimOrVar a)- ([R.Var n Sr], ReadArr var as) -> Just $ tab $ ppStringCopy (ppOuts outs) (ppReadArr var $ fmap ppPrimOrVar as)+ ([R.Var _ Sr], ReadArr var as) -> Just $ tab $ ppStringCopy (ppOuts outs) (ppReadArr var $ fmap ppPrimOrVar as) ([], WriteArr outVar bs a) | varRate outVar == Sr -> Just $ tab $ ppStringCopy (ppArrIndex outVar $ fmap ppPrimOrVar bs) (ppPrimOrVar a) _ -> Nothing @@ -144,7 +144,7 @@ ReadVar v -> tab $ res $= ppVar v InitArr v as -> tab $ ppOpc (ppArrVar (length as) v) "init" as- ReadArr v as -> tab $ if (varRate v /= Sr) then res $= ppReadArr v as else res <+> text "strcpy" <+> ppReadArr v as + ReadArr v as -> tab $ if (varRate v /= Sr) then res $= ppReadArr v as else res <+> text "strcpy" <+> ppReadArr v as WriteArr v as b -> tab $ ppWriteArr v as b WriteInitArr v as b -> tab $ ppWriteInitArr v as b TfmArr isInit v op [a,b]| isInfix op -> tab $ ppTfmArrOut isInit v <+> binary (infoName op) a b@@ -152,7 +152,7 @@ TfmArr isInit v op xs -> tab $ ppOpc (ppTfmArrOut isInit v) (infoName op) xs IfBegin _ a -> succTab $ text "if " <> ppCond a <> text " then"--- ElseIfBegin a -> left >> (succTab $ text "elseif " <> ppCond a <> text " then") +-- ElseIfBegin a -> left >> (succTab $ text "elseif " <> ppCond a <> text " then") ElseBegin -> left >> (succTab $ text "else") IfEnd -> left >> (tab $ text "endif") UntilBegin a -> succTab $ text "until " <> ppCond a <> text " do"@@ -166,16 +166,18 @@ ReadMacrosString name -> tab $ res <+> text "strcpy" <+> readMacro name ReadMacrosDouble name -> tab $ res $= readMacro name ReadMacrosInt name -> tab $ res $= readMacro name- EmptyExp -> return empty + EmptyExp -> return empty Verbatim str -> return $ text str x -> error $ "unknown expression: " ++ show x -- pp macros- ++readMacro :: String -> Doc readMacro name = char '$' <> text name -initMacros name initValue = vcat +initMacros :: Doc -> Doc -> Doc+initMacros name initValue = vcat [ text "#ifndef" <+> name , text "#define " <+> name <+> char '#' <> initValue <> char '#' , text "#end"@@ -183,38 +185,53 @@ -- pp arrays +ppTfmArrOut :: Bool -> Var -> Doc ppTfmArrOut isInit v = ppVar v <> (if isInit then (text "[]") else empty) +ppArrIndex :: Var -> [Doc] -> Doc ppArrIndex v as = ppVar v <> (hcat $ fmap brackets as)++ppArrVar :: Int -> Var -> Doc ppArrVar n v = ppVar v <> (hcat $ replicate n $ text "[]") +ppReadArr :: Var -> [Doc] -> Doc ppReadArr v as = ppArrIndex v as +ppWriteArr :: Var -> ArrIndex Doc -> Doc -> Doc ppWriteArr v as b = ppArrIndex v as <+> equalsWord <+> b where equalsWord = if (varRate v == Sr) then text "strcpy" else equals +ppWriteInitArr :: Var -> [Doc] -> Doc -> Doc ppWriteInitArr v as b = ppArrIndex v as <+> initWord <+> b where initWord = text $ if (varRate v == Sr) then "strcpy" else "init" ------------------------------------- -tab doc = fmap (shiftByTab doc) get +tab :: Monad m => Doc -> StateT TabDepth m Doc+tab doc = fmap (shiftByTab doc) get++tabWidth :: TabDepth tabWidth = 4++shiftByTab :: Doc -> TabDepth -> Doc shiftByTab doc n | n == 0 = doc- | otherwise = (text $ replicate (tabWidth * n) ' ') <> doc + | otherwise = (text $ replicate (tabWidth * n) ' ') <> doc +left :: State TabDepth () left = modify pred +succTab :: Monad m => Doc -> StateT TabDepth m Doc succTab doc = do a <- tab doc modify succ return a +prefix :: String -> [Doc] -> Doc prefix name args = text name <> tupled args ppCond :: Inline CondOp Doc -> Doc-ppCond = ppInline ppCondOp +ppCond = ppInline ppCondOp ($=) :: Doc -> Doc -> Doc ($=) a b = a <+> equals <+> b@@ -227,14 +244,14 @@ 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 +ppIf res p t e = vcat [ text "if" <+> p <+> text "then" , text " " <> res <+> char '=' <+> t , text "else" , text " " <> res <+> char '=' <+> e- , text "endif" + , text "endif" ] ppOpc :: Doc -> String -> [Doc] -> Doc@@ -260,14 +277,14 @@ ppConvertRate :: Doc -> Rate -> Rate -> Doc -> Doc ppConvertRate out to from var = case (to, from) of- (Ar, Kr) -> upsamp var + (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 + where upsamp x = ppOpc out "upsamp" [x] downsamp x = ppOpc out "downsamp" [x] k = func "k"@@ -276,16 +293,16 @@ -- expressions ppInline :: (a -> [Doc] -> Doc) -> Inline a Doc -> Doc-ppInline ppNode a = iter $ inlineExp a +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 + InlineExp op args -> ppNode op $ fmap iter args -- booleans -ppCondOp :: CondOp -> [Doc] -> Doc +ppCondOp :: CondOp -> [Doc] -> Doc ppCondOp op = case op of- TrueOp -> const $ text "(1 == 1)" + TrueOp -> const $ text "(1 == 1)" FalseOp -> const $ text "(0 == 1)" And -> bi "&&" Or -> bi "||"@@ -293,10 +310,10 @@ NotEquals -> bi "!=" Less -> bi "<" Greater -> bi ">"- LessEquals -> bi "<=" - GreaterEquals -> bi ">=" - where bi = binaries - + LessEquals -> bi "<="+ GreaterEquals -> bi ">="+ where bi = binaries+ -- numeric ppNumOp :: NumOp -> [Doc] -> Doc@@ -305,10 +322,10 @@ Sub -> bi "-" Mul -> bi "*" Div -> bi "/"- Neg -> uno "-" - Pow -> bi "^" + Neg -> uno "-"+ Pow -> bi "^" Mod -> bi "%"- where + where bi = binaries uno = unaries @@ -319,7 +336,7 @@ ppRate x = case x of Sr -> char 'S' _ -> phi x- where phi = text . map toLower . show + where phi = text . map toLower . show ppTotalDur :: Double -> Doc ppTotalDur d = text "f0" <+> double d
src/Csound/Dynamic/Tfm/Liveness.hs view
@@ -66,10 +66,10 @@ type SubstTable s = StArr s data Registers s = Registers- { registers :: M.Map Rate IdList- , livenessTable :: LivenessTable- , substTable :: SubstTable s- }+ { registers :: M.Map Rate IdList+ , livenessTable :: LivenessTable+ , substTable :: SubstTable s+ } type Memory s a = StateT (Registers s) (ST s) a @@ -78,36 +78,36 @@ initRegs :: M.Map Rate IdList initRegs = M.fromList $ fmap (\x -> (x, initIdList)) [(minBound :: Rate) .. maxBound]- where initIdList = IdList [0..] 0+ where initIdList = IdList [0..] 0 isAlive :: LineNumber -> Var -> Memory s Bool isAlive lineNum v = do- tab <- fmap livenessTable get- return $ lineNum < tab A.! (varId v)+ tab <- fmap livenessTable get+ return $ lineNum < tab A.! (varId v) lookUpSubst :: Int -> Memory s Int lookUpSubst i = do- tab <- fmap substTable get- lift $ A.readArray tab i+ tab <- fmap substTable get+ lift $ A.readArray tab i saveSubst :: Int -> Int -> Memory s () saveSubst from to = do- tab <- fmap substTable get- lift $ A.writeArray tab from to+ tab <- fmap substTable get+ lift $ A.writeArray tab from to substLhs :: Var -> Memory s Var substLhs v = do- v1 <- allocAndSkipInits v- saveSubst (varId v) (varId v1)- return v1+ v1 <- allocAndSkipInits v+ saveSubst (varId v) (varId v1)+ return v1 substRhs :: LineNumber -> Var -> Memory s Var substRhs lineNum v = do- i1 <- lookUpSubst (varId v)- let v1 = D.Var i1 (varType v)- b <- isAlive lineNum v- unless b $ free v1- return v1+ i1 <- lookUpSubst (varId v)+ let v1 = D.Var i1 (varType v)+ b <- isAlive lineNum v+ unless b $ free v1+ return v1 allocAndSkipInits :: Var -> Memory s Var allocAndSkipInits v@@ -119,43 +119,43 @@ alloc :: Rate -> Memory s Var alloc rate = state $ \mem ->- let (i, mem1) = allocRegister rate mem- in (D.Var i rate, mem1)- where- allocRegister :: Rate -> Registers s -> (Int, Registers s)- allocRegister r mem = (i, onRegs (M.update (const $ Just is) r) mem)- where (i, is) = allocId $ registers mem M.! r+ let (i, mem1) = allocRegister rate mem+ in (D.Var i rate, mem1)+ where+ allocRegister :: Rate -> Registers s -> (Int, Registers s)+ allocRegister r mem = (i, onRegs (M.update (const $ Just is) r) mem)+ where (i, is) = allocId $ registers mem M.! r free :: Var -> Memory s () free v = state $ \mem ->- let mem1 = freeRegister (varType v) (varId v) mem- in ((), mem1)- where- freeRegister :: Rate -> Int -> Registers s -> Registers s- freeRegister rate i = onRegs $ M.update (Just . freeId i) rate+ let mem1 = freeRegister (varType v) (varId v) mem+ in ((), mem1)+ where+ freeRegister :: Rate -> Int -> Registers s -> Registers s+ freeRegister rate i = onRegs $ M.update (Just . freeId i) rate -------------------------------------------------------------------------- analyse :: Traversable f => Int -> Dag f -> LivenessTable analyse lastFreshId as = A.runSTUArray $ do- arr <- A.newArray (0, lastFreshId) 0- mapM_ (go arr) $ countLines as- return arr- where- go :: Traversable f => StArr s -> (LineNumber, Exp f) -> ST s ()- go arr (lineNum, (_, rhs)) = mapM (countVar arr lineNum) rhs >> return ()+ arr <- A.newArray (0, lastFreshId) 0+ mapM_ (go arr) $ countLines as+ return arr+ where+ go :: Traversable f => StArr s -> (LineNumber, Exp f) -> ST s ()+ go arr (lineNum, (_, rhs)) = mapM (countVar arr lineNum) rhs >> return () - countVar :: StArr s -> LineNumber -> Var -> ST s ()- countVar arr lineNum v = do- val <- A.readArray arr i- A.writeArray arr i (val `max` lineNum)- where i = varId v+ countVar :: StArr s -> LineNumber -> Var -> ST s ()+ countVar arr lineNum v = do+ val <- A.readArray arr i+ A.writeArray arr i (val `max` lineNum)+ where i = varId v substExp :: Traversable f => (LineNumber, Exp f) -> Memory s (Exp f) substExp (lineNum, (lhs, rhs)) = do- freshLhs <- traverse substLhs lhs- freshRhs <- traverse (substRhs lineNum) rhs- return (freshLhs, freshRhs)+ freshLhs <- traverse substLhs lhs+ freshRhs <- traverse (substRhs lineNum) rhs+ return (freshLhs, freshRhs) initSt :: Int -> LivenessTable -> ST s (Registers s) initSt lastFreshId livenessTab = fmap (Registers initRegs livenessTab) (initSubstTable lastFreshId)
src/Csound/Dynamic/Types/CsdFile.hs view
@@ -5,7 +5,6 @@ intInstr, alwaysOn ) where -import Csound.Dynamic.Build.Numeric import Csound.Dynamic.Types.Exp import Csound.Dynamic.Types.Flags
src/Csound/Dynamic/Types/Exp.hs view
@@ -1,4 +1,5 @@ -- | Main types+{-# OPTIONS_GHC -Wno-orphans #-} {-# Language DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric,