diff --git a/csound-expression-dynamic.cabal b/csound-expression-dynamic.cabal --- a/csound-expression-dynamic.cabal +++ b/csound-expression-dynamic.cabal @@ -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 diff --git a/src/Csound/Dynamic/Build/Logic.hs b/src/Csound/Dynamic/Build/Logic.hs --- a/src/Csound/Dynamic/Build/Logic.hs +++ b/src/Csound/Dynamic/Build/Logic.hs @@ -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" diff --git a/src/Csound/Dynamic/Render/Instr.hs b/src/Csound/Dynamic/Render/Instr.hs --- a/src/Csound/Dynamic/Render/Instr.hs +++ b/src/Csound/Dynamic/Render/Instr.hs @@ -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 diff --git a/src/Csound/Dynamic/Render/Pretty.hs b/src/Csound/Dynamic/Render/Pretty.hs --- a/src/Csound/Dynamic/Render/Pretty.hs +++ b/src/Csound/Dynamic/Render/Pretty.hs @@ -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 diff --git a/src/Csound/Dynamic/Tfm/Liveness.hs b/src/Csound/Dynamic/Tfm/Liveness.hs --- a/src/Csound/Dynamic/Tfm/Liveness.hs +++ b/src/Csound/Dynamic/Tfm/Liveness.hs @@ -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) diff --git a/src/Csound/Dynamic/Types/CsdFile.hs b/src/Csound/Dynamic/Types/CsdFile.hs --- a/src/Csound/Dynamic/Types/CsdFile.hs +++ b/src/Csound/Dynamic/Types/CsdFile.hs @@ -5,7 +5,6 @@ intInstr, alwaysOn ) where -import Csound.Dynamic.Build.Numeric import Csound.Dynamic.Types.Exp import Csound.Dynamic.Types.Flags diff --git a/src/Csound/Dynamic/Types/Exp.hs b/src/Csound/Dynamic/Types/Exp.hs --- a/src/Csound/Dynamic/Types/Exp.hs +++ b/src/Csound/Dynamic/Types/Exp.hs @@ -1,4 +1,5 @@ -- | Main types +{-# OPTIONS_GHC -Wno-orphans #-} {-# Language DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric,