csound-expression-dynamic 0.2.0 → 0.3.0

raw patch · 7 files changed

+234/−24 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• csound-expression-dynamic.cabal +1/−1
• src/Csound/Dynamic/Build.hs +17/−2
• src/Csound/Dynamic/Build/Logic.hs +18/−1
• src/Csound/Dynamic/Render/Instr.hs +32/−4
• src/Csound/Dynamic/Render/Pretty.hs +73/−13
• src/Csound/Dynamic/Types/Dep.hs +70/−1
• src/Csound/Dynamic/Types/Exp.hs +23/−2

@@ -1,5 +1,5 @@ Name:          csound-expression-dynamic-Version:       0.2.0+Version:       0.3.0 Cabal-Version: >= 1.6 License:       BSD3 License-file:  LICENSE

@@ -14,13 +14,17 @@     numExp1, numExp2,     tfm, tfmNoInlineArgs, pn, withInits,     double, int, str, verbatim, instrIdE,+    inlineVar,      -- ** Opcodes constructors     Spec1, spec1, opcs, opcsNoInlineArgs, opr1, opr1k, infOpr, oprBy,     Specs, specs, MultiOut, mopcs, mo,       -- * Global init statements-    setSr, setKsmps, setNchnls, setNchnls_i, setKr, setZeroDbfs+    setSr, setKsmps, setNchnls, setNchnls_i, setKr, setZeroDbfs,++    -- * Arrays+    opcsArr, infOprArr ) where  import qualified Data.Map as M(fromList, toList)@@ -49,6 +53,9 @@ tfm :: Info -> [E] -> E tfm info args = noRate $ Tfm info $ zipWith toPrimOrTfm (getInfoRates info) args +tfmArr :: Monad m => IsArrInit -> Var -> Info -> [E] -> DepT m ()+tfmArr isArrInit var info args = depT_ $ noRate $ TfmArr isArrInit var info $ zipWith toPrimOrTfm (getInfoRates info) args+ getInfoRates :: Info -> [Rate] getInfoRates a = getInRates $ infoSignature a     where@@ -58,6 +65,9 @@  tfmNoInlineArgs :: Info -> [E] -> E tfmNoInlineArgs info args = noRate $ Tfm info $ fmap (PrimOr . Right) args+            +inlineVar :: Var -> E        +inlineVar = Fix . RatedExp Nothing Nothing . ReadVar  pn :: Int -> E pn = prim . P@@ -126,6 +136,12 @@ numExp2 :: NumOp -> E -> E -> E numExp2 op a b = noRate $ ExpNum $ fmap toPrimOr $ PreInline op [a, b] +opcsArr :: Monad m => IsArrInit -> Var -> Name -> Spec1 -> [E] -> DepT m ()+opcsArr isArrInit out name signature = tfmArr isArrInit out (opcPrefix name $ spec1 signature)++infOprArr :: Monad m => IsArrInit -> Var -> Name -> E -> E -> DepT m ()+infOprArr isArrInit out name a b = tfmArr isArrInit out (oprInfix name $ spec1 [(Ar, [Ar, Ar]), (Kr, [Kr, Kr]), (Ir, [Ir, Ir])]) [a, b]+ -- multiple output  -- User friendly type for multiple outputs type signatures@@ -177,7 +193,6 @@ onExp :: (Exp E -> Exp E) -> E -> E onExp f x = case unFix x of     a -> Fix $ a{ ratedExpExp = f (ratedExpExp a) }-  ---------------------------------------------------------------- -- global inits

@@ -5,7 +5,9 @@     when1, whens,     ifBegin, ifEnd, elseBegin,     untilDo,-    untilBegin, untilEnd+    untilBegin, untilEnd,+    whileDo,+    whileBegin, whileRef, whileEnd ) where  import Control.Monad.Trans.State(State, state, evalState)@@ -56,6 +58,21 @@  untilEnd :: Monad m => DepT m () untilEnd = stmtOnlyT UntilEnd++whileDo :: Monad m => E -> DepT m () -> DepT m ()+whileDo p body = do+    whileBegin p+    body+    whileEnd++whileBegin :: Monad m => E -> DepT m ()+whileBegin = withCond WhileBegin++whileRef :: Monad m => Var -> DepT m ()+whileRef var = stmtOnlyT $ WhileRefBegin var++whileEnd :: Monad m => DepT m ()+whileEnd = stmtOnlyT WhileEnd  withCond :: Monad m => (CondInfo (PrimOr E) -> MainExp (PrimOr E)) -> E -> DepT m () withCond stmt p = depT_ $ noRate $ stmt (condInfo p)

@@ -50,6 +50,9 @@     -- looping constructions     UntilBegin _ -> StartFrame     UntilEnd     -> StopFrame+    WhileBegin _ -> StartFrame+    WhileRefBegin _ -> StartFrame+    WhileEnd     -> StopFrame         _            -> NoFrame  @@ -137,7 +140,7 @@                     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@@ -149,6 +152,10 @@         Xr -> Ar         r  -> r     ReadVar v -> varRate v+    ReadArr v _ -> varRate v+    ReadMacrosString _ -> Sr+    ReadMacrosDouble _ -> Ir+    ReadMacrosInt _ -> Ir     _  -> Xr         where tfmNoRate name rates tab = case sort rates of               [Xr]  -> tfmNoRate name [Ar] tab                @@ -163,19 +170,34 @@     Select rate pid a -> Select rate pid (fmap (ratedVar Xr) a)         If p t e -> If (rec2 condRate p) (rec1 curRate t) (rec1 curRate e)      ExpNum _ -> rec2 curRate expr    +         ReadVar v -> ReadVar v     WriteVar v a -> WriteVar v $ rec1 (varRate v) a-    InitVar v a -> InitVar v $ rec1 Ir a -- rec1 (varRate v) a+    InitVar v a -> InitVar v $ rec1 Ir a -- rec1 (varRate v) a    +    +    ReadArr v as -> ReadArr v $ arrIndex v as+    WriteArr v as b -> WriteArr v (arrIndex v as) (rec1 (varRate v) b)    +    WriteInitArr v as b -> WriteInitArr v (arrIndex v as) (rec1 Ir b)+    InitArr v as -> InitArr v $ fmap (rec1 Ir) as+    TfmArr isInit v i xs -> TfmArr isInit v i $ mergeWithPrimOr (ratesFromSignature curRate (infoSignature i)) xs+     ExpPrim p -> ExpPrim p     IfBegin rootRate _ -> rec2 rootRate expr     UntilBegin _ -> rec2 condRate expr+    WhileBegin _ -> rec2 condRate expr    +    WhileRefBegin var -> WhileRefBegin var --    ElseIfBegin _ -> rec2 condRate expr     ElseBegin -> ElseBegin     IfEnd -> IfEnd     UntilEnd -> UntilEnd+    WhileEnd -> WhileEnd         EmptyExp -> EmptyExp         Verbatim a -> Verbatim a-+    InitMacrosString name initValue -> InitMacrosString name initValue+    InitMacrosDouble name initValue -> InitMacrosDouble name initValue+    ReadMacrosString name -> ReadMacrosString name+    ReadMacrosDouble name -> ReadMacrosDouble name+    ReadMacrosInt name -> ReadMacrosInt name     ExpBool _           -> error $ msg "ExpBool expression should be substituted"     ConvertRate _ _ _   -> error $ msg "ConvertRate couldn't be here. It's introduced on the later stages of processing"      where ratesFromSignature rate signature = case signature of@@ -188,8 +210,14 @@           rec2 r = fmap (fmap (ratedVar r))             rec1 r = fmap (ratedVar r) +          arrIndex v as = fmap (rec1 (arrIndexVarRate v)) as+           msg txt = "Csound.Dynamic.Render.Instr.rateExp: " ++ txt -          +         +arrIndexVarRate v = case varRate v of    +    Ir -> Ir+    _  -> Kr+ mergeWithPrimOr :: [Rate] -> [PrimOr Int] -> [PrimOr (Var Rate)] mergeWithPrimOr = zipWith phi     where 

@@ -9,6 +9,7 @@  import Text.PrettyPrint.Leijen import Csound.Dynamic.Types+import qualified Csound.Dynamic.Tfm.DeduceTypes as R(Var(..))  vcatSep :: [Doc] -> Doc vcatSep = vcat . punctuate line@@ -114,8 +115,20 @@ type TabDepth = Int  ppStmt :: [RatedVar] -> Exp RatedVar -> State TabDepth Doc-ppStmt outs expr = ppExp (ppOuts 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)+    ([], 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)+    ([], WriteArr outVar bs a) | varRate outVar == Sr -> Just $ tab $ ppStringCopy (ppArrIndex outVar $ fmap ppPrimOrVar bs) (ppPrimOrVar a)+    _ -> Nothing++ppStringCopy :: Doc -> Doc -> Doc+ppStringCopy outs src = ppOpc outs "strcpyk" [src]+ ppExp :: Doc -> Exp RatedVar -> State TabDepth Doc ppExp res expr = case fmap ppPrimOrVar expr of     ExpPrim (PString n)             -> tab $ ppStrget res n@@ -130,28 +143,75 @@     InitVar v a                     -> tab $ ppOpc (ppVar v) "init" [a]     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 +    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+    TfmArr isInit v op args | isPrefix op  -> tab $ ppTfmArrOut isInit v <+> prefix (infoName op) args+    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")         ElseBegin                       -> left >> (succTab $ text "else")     IfEnd                           -> left >> (tab     $ text "endif")     UntilBegin a                    -> succTab          $ text "until " <> ppCond a <> text " do"     UntilEnd                        -> left >> (tab     $ text "od")-    EmptyExp                        -> return empty+    WhileBegin a                    -> succTab          $ text "while " <> ppCond a <> text " do"+    WhileRefBegin var               -> succTab          $ text "while " <> ppVar var <+> equals <+> text "1" <+> text "do"+    WhileEnd                        -> left >> (tab     $ text "od")+    InitMacrosString name initValue -> tab $ initMacros (text name) (text initValue)+    InitMacrosDouble name initValue -> tab $ initMacros (text name) (double initValue)+    InitMacrosInt name initValue    -> tab $ initMacros (text name) (int initValue)+    ReadMacrosString name           -> tab $ res <+> text "strcpy" <+> readMacro name+    ReadMacrosDouble name           -> tab $ res $= readMacro name+    ReadMacrosInt name              -> tab $ res $= readMacro name+    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+-- pp macros+ +readMacro name = char '$' <> text name++initMacros name initValue = vcat +    [ text "#ifndef" <+> name+    , text "#define " <+> name <+> char '#' <> initValue <> char '#'+    , text "#end"+    ]++-- pp arrays++ppTfmArrOut isInit v = ppVar v <> (if isInit then (text "[]") else empty)++ppArrIndex v as = ppVar v <> (hcat $ fmap brackets as)+ppArrVar n v = ppVar v <> (hcat $ replicate n $ text "[]")++ppReadArr v as = ppArrIndex v as++ppWriteArr v as b = ppArrIndex v as <+> equalsWord <+> b+    where equalsWord = if (varRate v == Sr) then text "strcpy" else equals++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 +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 

@@ -6,7 +6,15 @@      -- * Variables     newLocalVar, newLocalVars,-    writeVar, readVar, readOnlyVar, initVar, appendVarBy+    writeVar, readVar, readOnlyVar, initVar, appendVarBy,++    -- * Arrays+    newLocalArrVar, newTmpArrVar,+    readArr, readOnlyArr, writeArr, writeInitArr, initArr, appendArrBy,++    -- * Read macros    +    readMacrosDouble, readMacrosInt, readMacrosString, +    initMacrosDouble, initMacrosString, initMacrosInt ) where  import Control.Applicative@@ -133,4 +141,65 @@ appendVarBy :: Monad m => (E -> E -> E) -> Var -> E -> DepT m () appendVarBy op v x = writeVar v . op x =<< readVar v +--------------------------------------------------+-- arrays +-- init++newLocalArrVar :: Monad m => Rate -> m [E] -> DepT m Var+newLocalArrVar rate val = do+    var <- newVar rate+    initArr var =<< lift val+    return var++newTmpArrVar :: Monad m => Rate -> DepT m Var+newTmpArrVar rate = newVar rate++-- ops++readArr :: Monad m => Var -> [E] -> DepT m E+readArr v ixs = depT $ noRate $ ReadArr v (fmap toPrimOr ixs)++readOnlyArr :: Var -> [E] -> E+readOnlyArr v ixs = noRate $ ReadArr v (fmap toPrimOr ixs)++writeArr :: Monad m => Var -> [E] -> E -> DepT m ()+writeArr v ixs a = depT_ $ noRate $ WriteArr v (fmap toPrimOr ixs) (toPrimOr a)++writeInitArr :: Monad m => Var -> [E] -> E -> DepT m ()+writeInitArr v ixs a = depT_ $ noRate $ WriteInitArr v (fmap toPrimOr ixs) (toPrimOr a)++initArr :: Monad m => Var -> [E] -> DepT m ()+initArr v xs = depT_ $ noRate $ InitArr v $ fmap toPrimOr xs++appendArrBy :: Monad m => (E -> E -> E) -> Var -> [E] -> E -> DepT m () +appendArrBy op v ixs x = writeArr v ixs . op x =<< readArr v ixs++--------------------------------------------------+-- read global macros arguments++readMacrosDouble :: String -> E+readMacrosDouble = readMacrosBy ReadMacrosDouble Ir++readMacrosInt :: String -> E+readMacrosInt = readMacrosBy ReadMacrosInt Ir++readMacrosString :: String -> E+readMacrosString = readMacrosBy ReadMacrosString Sr++initMacrosDouble :: Monad m => String -> Double -> DepT m ()+initMacrosDouble = initMacrosBy InitMacrosDouble++initMacrosString :: Monad m => String -> String -> DepT m ()+initMacrosString = initMacrosBy InitMacrosString++initMacrosInt :: Monad m => String -> Int -> DepT m ()+initMacrosInt = initMacrosBy InitMacrosInt++readMacrosBy :: (String -> Exp E) -> Rate -> String -> E+readMacrosBy readMacro rate name = withRate rate $ readMacro name++initMacrosBy :: Monad m => (String -> a -> Exp E) -> String -> a -> DepT m ()+initMacrosBy maker name value = depT_ $ noRate $ maker name value++   

@@ -14,7 +14,8 @@     Inline(..), InlineExp(..), PreInline(..),     BoolExp, CondInfo, CondOp(..), isTrue, isFalse,         NumExp, NumOp(..), Note,    -    MultiOut+    MultiOut,+    IsArrInit, ArrSize, ArrIndex ) where  import Control.Applicative@@ -152,7 +153,13 @@     -- | Reading/writing a named variable     | InitVar Var a     | ReadVar Var-    | WriteVar Var a    +    | WriteVar Var a  +    -- | Arrays+    | InitArr Var (ArrSize a)    +    | ReadArr Var (ArrIndex a)+    | WriteArr Var (ArrIndex a) a+    | WriteInitArr Var (ArrIndex a) a+    | TfmArr IsArrInit Var Info [a]     -- | Imperative If-then-else     | IfBegin Rate (CondInfo a) --  | ElseIfBegin (CondInfo a) -- It's expressed with nested if-else@@ -161,13 +168,27 @@     -- | looping constructions     | UntilBegin (CondInfo a)     | UntilEnd+    | WhileBegin (CondInfo a)+    | WhileRefBegin Var+    | WhileEnd     -- | Verbatim stmt     | Verbatim String     -- | Dependency tracking     | Starts     | Seq a a     | Ends a+    -- | read macros arguments+    | InitMacrosInt String Int+    | InitMacrosDouble String Double+    | InitMacrosString String String+    | ReadMacrosInt String+    | ReadMacrosDouble String+    | ReadMacrosString String     deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)  ++type IsArrInit = Bool+type ArrSize a = [a]+type ArrIndex a = [a]  isEmptyExp :: E -> Bool isEmptyExp e = isNothing (ratedExpDepends re) && (ratedExpExp re == EmptyExp)