csound-expression-dynamic 0.3.9 → 0.3.9.1

raw patch · 18 files changed

+2383/−870 lines, 18 filesdep +base64-bytestringdep +bytestringdep +cerealdep −hashabledep −wl-pprintPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base64-bytestring, bytestring, cereal, cereal-text, cryptohash-sha256, dlist, pretty-show, safe, text, unordered-containers, vector, wl-pprint-text

Dependencies removed: hashable, wl-pprint

API changes (from Hackage documentation)

Files

• csound-expression-dynamic.cabal +46/−8
• src/Csound/Dynamic.hs +1/−1
• src/Csound/Dynamic/Build.hs +79/−53
• src/Csound/Dynamic/Build/Logic.hs +124/−42
• src/Csound/Dynamic/Const.hs +51/−0
• src/Csound/Dynamic/Render.hs +25/−11
• src/Csound/Dynamic/Render/Instr.hs +38/−197
• src/Csound/Dynamic/Render/Pretty.hs +244/−64
• src/Csound/Dynamic/Tfm/DeduceTypes.hs +0/−124
• src/Csound/Dynamic/Tfm/IfBlocks.hs +573/−0
• src/Csound/Dynamic/Tfm/InferTypes.hs +692/−0
• src/Csound/Dynamic/Tfm/Liveness.hs +78/−62
• src/Csound/Dynamic/Tfm/UnfoldMultiOuts.hs +49/−33
• src/Csound/Dynamic/Types.hs +0/−1
• src/Csound/Dynamic/Types/CsdFile.hs +14/−14
• src/Csound/Dynamic/Types/Dep.hs +74/−26
• src/Csound/Dynamic/Types/Exp.hs +196/−140
• src/Csound/Dynamic/Types/Flags.hs +99/−94

@@ -1,18 +1,17 @@ Name:          csound-expression-dynamic-Version:       0.3.9-Cabal-Version: >= 1.22+Version:       0.3.9.1+Cabal-Version: 1.12 License:       BSD3 License-file:  LICENSE Author:	       Anton Kholomiov Synopsis:      dynamic core for csound-expression library+Description:   Basic bare bone library to generate Csound code 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 @@ -24,14 +23,35 @@ Library   Ghc-Options:    -Wall   Build-Depends:-        base >= 4.6, base < 5, data-default, containers, array, transformers >= 0.3, wl-pprint >= 1.2.1,-        Boolean >= 0.1.0, data-fix >= 0.3.0, data-fix-cse >= 0.0.3, hashable >=1.2.7.0,-        deriving-compat+        base >= 4.10, base < 5+      , base64-bytestring+      , bytestring+      , data-default+      , dlist+      , cereal+      , cereal-text+      , containers+      , array+      , transformers >= 0.3+      , wl-pprint-text >= 1.2.0.2+      , Boolean >= 0.1.0+      , data-fix >= 0.3.2+      , data-fix-cse >= 0.0.3+      , deriving-compat+      , safe+      , text+      , cryptohash-sha256+      , vector+      , unordered-containers+      , pretty-show+      , safe   Hs-Source-Dirs:      src/   default-language: Haskell2010   Exposed-Modules:     Csound.Dynamic +    Csound.Dynamic.Const+     Csound.Dynamic.Types     Csound.Dynamic.Types.Exp     Csound.Dynamic.Types.Dep@@ -47,9 +67,27 @@     Csound.Dynamic.Render.Instr     Csound.Dynamic.Render.Pretty   Other-Modules:-    Csound.Dynamic.Tfm.DeduceTypes+    Csound.Dynamic.Tfm.IfBlocks+    Csound.Dynamic.Tfm.InferTypes     Csound.Dynamic.Tfm.Liveness     Csound.Dynamic.Tfm.UnfoldMultiOuts++  default-extensions:+    BangPatterns+    DeriveFunctor+    DeriveFoldable+    DeriveTraversable+    DerivingStrategies+    DeriveGeneric+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    LambdaCase+    RecordWildCards+    OverloadedStrings+    ScopedTypeVariables+    TupleSections+    TypeApplications+   

@@ -3,7 +3,7 @@     module Csound.Dynamic.Types,     module Csound.Dynamic.Types.Exp,     module Csound.Dynamic.Types.Dep,-    module Csound.Dynamic.Types.CsdFile,    +    module Csound.Dynamic.Types.CsdFile,     module Csound.Dynamic.Types.Flags,      module Csound.Dynamic.Build,

@@ -1,39 +1,41 @@ module Csound.Dynamic.Build (--    -- * Expression tree-    -- | Working with expression tree-    toExp, onExp,+  -- * Expression tree+  -- | Working with expression tree+  toExp, onExp, -    -- * Rates-    -- * Queries-    getRates, isMultiOutSignature, getPrimUnsafe,+  -- * Rates+  -- * Queries+  getRates, isMultiOutSignature, getPrimUnsafe, -    -- * Constructors-    -- | Basic constructors-    prim, opcPrefix, oprPrefix, oprInfix,-    numExp1,-    tfm, tfmNoInlineArgs, pn, withInits,-    double, int, str, verbatim, instrIdE,-    inlineVar, gInit, gInitDouble,+  -- * Constructors+  -- | Basic constructors+  prim, opcPrefix, oprPrefix, oprInfix,+  numExp1,+  tfm, tfmNoInlineArgs, pn, withInits,+  double, int, str, verbatim, instrIdE,+  inlineVar, gInit, gInitDouble, -    -- ** Opcodes constructors-    Spec1, spec1, opcs, opcsNoInlineArgs, opr1, opr1k, infOpr, oprBy,-    Specs, specs, MultiOut, mopcs, mo,+  -- ** 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,+  -- * Global init statements+  setSr, setKsmps, setNchnls, setNchnls_i, setKr, setZeroDbfs, -    -- * Arrays-    opcsArr, infOprArr+  -- * Arrays+  opcsArr, infOprArr, initPureArr, readPureArr ) where  import qualified Data.Map as M(fromList, toList)+import Data.Serialize qualified as Cereal  import Data.List(transpose) import Data.Fix(Fix(..))  import Csound.Dynamic.Types.Exp import Csound.Dynamic.Types.Dep+import Data.Text (Text)+import Data.Text qualified as Text  ------------------------------------------------ -- basic constructors@@ -50,36 +52,43 @@ oprInfix :: Name -> Signature -> Info oprInfix name signature = Info name signature Infix +toArgs :: [Rate] -> [E] -> [PrimOr E]+toArgs = zipWith toPrimOrTfm+ tfm :: Info -> [E] -> E-tfm info args = noRate $ Tfm info $ zipWith toPrimOrTfm (getInfoRates info) args+tfm info args = noRate $ Tfm info $ toArgs (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+tfmArr isArrInit var info args = depT_ $ noRate $ TfmArr isArrInit var info $ toArgs (getInfoRates info) args  getInfoRates :: Info -> [Rate] getInfoRates a = getInRates $ infoSignature a-    where-        getInRates x = case x of-            SingleRate m    -> fmap minimum $ transpose $ fmap snd $ M.toList m-            MultiRate _ ins -> ins+  where+    getInRates x =+      case x of+        SingleRate m    -> fmap minimum $ transpose $ fmap snd $ M.toList m+        MultiRate _ ins -> ins  tfmNoInlineArgs :: Info -> [E] -> E tfmNoInlineArgs info args = noRate $ Tfm info $ fmap (PrimOr . Right) args  inlineVar :: Var -> E-inlineVar = Fix . RatedExp Nothing Nothing . ReadVar+inlineVar var = Fix $ RatedExp h Nothing Nothing $ ReadVar var+  where+    h = Cereal.encode var  pn :: Int -> E pn = prim . P  withInits :: E -> [E] -> E withInits a es = onExp phi a-    where phi x = case x of-            -- for opcodes with single output-            Tfm t xs -> Tfm t (xs ++ (fmap toPrimOr es))-            -- for opcodes with multiple outputs-            Select r n expr -> Select r n $ fmap (\t -> withInits t es) expr-            _        -> x+  where+    phi = \case+      -- for opcodes with single output+      Tfm t xs -> Tfm t (xs ++ (fmap toPrimOr es))+      -- for opcodes with multiple outputs+      Select r n expr -> Select r n $ fmap (\t -> withInits t es) expr+      x        -> x  -- | Converts Haskell's doubles to Csound's doubles double :: Double -> E@@ -87,20 +96,22 @@  -- | Converts Haskell's strings to Csound's strings str :: String -> E-str = prim . PrimString+str = prim . PrimString . Text.pack  -- | Converts Haskell's integers to Csound's doubles int :: Int -> E int = prim . PrimInt -verbatim :: Monad m => String -> DepT m ()+verbatim :: Monad m => Text -> DepT m () verbatim = stmtOnlyT . Verbatim  instrIdE :: InstrId -> E-instrIdE x = case x of+instrIdE x =+  case x of     InstrId Nothing  m -> int m     InstrId (Just _) _ -> error "instrId undefined for fractional InstrIds"-    InstrLabel s -> str s+    InstrLabel s -> prim (PrimString s)+ ---------------------------------------------------------------------- -- constructing opcodes @@ -139,6 +150,16 @@ 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] +initPureArr :: Rate -> IfRate -> [E] -> E+initPureArr outRate procRate initVals =+  noRate $ InitPureArr outRate procRate $ toArgs (repeat initRate) initVals+  where+    initRate = fromIfRate procRate++readPureArr :: Rate -> IfRate -> E -> E -> E+readPureArr outRate procRate arr index =+  noRate $ ReadPureArr outRate procRate (toPrimOr arr) (toPrimOrTfm (fromIfRate procRate) index)+ -- multiple output  -- User friendly type for multiple outputs type signatures@@ -152,27 +173,31 @@  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+  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"+    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)+    select cellId rate expr = withRate rate $ Select rate cellId (PrimOr $ Right expr)   getRates :: MainExp a -> [Rate]-getRates (Tfm info _) = case infoSignature info of+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+isMultiOutSignature x =+  case x of     MultiRate _ _ -> True     _ -> False @@ -188,7 +213,8 @@  -- Lifts transformation of main expression onExp :: (Exp E -> Exp E) -> E -> E-onExp f x = case unFix x of+onExp f x =+  case unFix x of     a -> Fix $ a{ ratedExpExp = f (ratedExpExp a) }  ----------------------------------------------------------------@@ -198,8 +224,8 @@  setZeroDbfs :: Monad m => Double -> DepT m  () -setGlobal :: (Monad m, Show a) => String -> a -> DepT m  ()-setGlobal name val = verbatim $ name ++ " = " ++ show val+setGlobal :: (Monad m, Show a) => Text -> a -> DepT m  ()+setGlobal name val = verbatim $ Text.unwords [name, "=", Text.pack $ show val]  setSr       = setGlobal "sr" setKr       = setGlobal "kr"@@ -208,9 +234,9 @@ setKsmps    = setGlobal "ksmps" setZeroDbfs = setGlobal "0dbfs" -gInit :: Monad m => String -> Int -> DepT m ()+gInit :: Monad m => Text -> Int -> DepT m () gInit name val = writeVar (VarVerbatim Ir name) (int val) -gInitDouble :: Monad m => String -> Double -> DepT m ()+gInitDouble :: Monad m => Text -> Double -> DepT m () gInitDouble name val = writeVar (VarVerbatim Ir name) (double val) 

@@ -3,70 +3,150 @@ -- | Boolean instances module Csound.Dynamic.Build.Logic(     when1, whens,-    ifBegin, ifEnd, elseBegin,-    untilDo,-    untilBegin, untilEnd,-    whileDo,-    whileBegin, whileRef, whileEnd+    ifExp,+    ifElseBlock,+    -- ifBegin, ifEnd, elseBegin,+    untilBlock,+    whileBlock,++    -- untilDo,+    -- untilBegin, untilEnd,+    -- whileDo,+    -- whileBegin,+    whileRef, whileEnd ) where -import Control.Monad.Trans.State(State, state, evalState)+import Control.Monad+import Control.Monad.Trans.State.Strict (State, state, evalState, runStateT, StateT(..)) import qualified Data.IntMap as IM(fromList)  import Data.Boolean import Csound.Dynamic.Types import Csound.Dynamic.Build(onExp, toExp)+import Data.List qualified as List+import Data.Fix +ifT :: forall m . Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m E+ifT ifRate check (DepT th) (DepT el) = DepT $ StateT $ \s -> do+  (_thE, thS) <- runStateT th (startSt s)+  (_elE, elS) <- runStateT el (startSt thS)+  let thDeps = expDependency thS+      elDeps = expDependency elS+      a  = noRate $ IfElseBlock ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thDeps) (CodeBlock $ PrimOr $ Right elDeps)+      a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum elS) }+      s1 = elS+            { newLineNum = succ $ newLineNum elS+            , expDependency = a1+            -- depends (expDependency thS) (depends (expDependency elS) a1)+            }+  pure (a1, s1)+  where+    startSt s = s+      { expDependency = rehashE $ Fix $ (unFix $ noRate Starts) { ratedExpDepends = Just (newLineNum s) }+      , newLineNum = succ $ newLineNum s+      }+++ifT1, untilT, whileT :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m E++ifT1 = ifT1By IfBlock+untilT = ifT1By UntilBlock+whileT = ifT1By WhileBlock++ifT1By :: Monad m+  => (IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)+  -> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E+ifT1By cons ifRate check (DepT th) = DepT $ StateT $ \s -> do+  (_thE, thS)  <- runStateT th (startSt s)+  let thDeps = expDependency thS+      a  = noRate $ cons ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thDeps)+      a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum thS) }+      s1 = thS+            { newLineNum = succ $ newLineNum thS+            , expDependency = a1+            -- depends (expDependency thS) (depends (expDependency elS) a1)+            }+  pure (a1, s1)+  where+    startSt s = s+      { expDependency = rehashE $ Fix $ (unFix $ noRate Starts) { ratedExpDepends = Just (newLineNum s) }+      , newLineNum = succ $ newLineNum s+      }+++ ------------------------------------------------------ -- imperative if-then-else -when1 :: Monad m => Rate -> E -> DepT m () -> DepT m ()-when1 rate p body = do-    ifBegin rate p-    body-    ifEnd+setIfRate :: IfRate -> E -> E+setIfRate rate = setRate (fromIfRate rate) -whens :: Monad m => Rate -> [(E, DepT m ())] -> DepT m () -> DepT m ()-whens rate bodies el = case bodies of-    []   -> el-    a:as -> do-        ifBegin rate (fst a)-        snd a-        elseIfs as-        elseBegin-        el-        foldl1 (>>) $ replicate (1 + length as) ifEnd-    where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBegin rate p >> body)+when1 :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()+when1 ifRate p body = void $ ifT1 ifRate p body -ifBegin :: Monad m => Rate -> E -> DepT m ()-ifBegin rate = withCond $ IfBegin rate+whens :: Monad m => IfRate -> [(E, DepT m (CodeBlock E))] -> DepT m (CodeBlock E) -> DepT m ()+whens rate bodies el =+  void $ List.foldl' go el (List.reverse bodies)+  where+    go res (check, th) = CodeBlock <$> ifT rate check th res +ifElseBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m ()+ifElseBlock rate p th el = void $ ifElseBlock rate p th el++{-+ifElseBlock' :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m (CodeBlock E)+ifElseBlock' ifRate p th el = do+  thE <- th+  elE <- el+  fmap CodeBlock $ depT $ noRate $+    IfElseBlock ifRate+      (condInfo $ setIfRate ifRate p)+      (PrimOr . Right <$> thE)+      (PrimOr . Right <$> elE)+-}+-- withCond ifRate stmt p = depT_ $ noRate $ stmt (condInfo $ setIfRate ifRate p)++{-+ifBegin :: Monad m => IfRate -> E -> DepT m ()+ifBegin ifRate = withCond ifRate $ (IfBegin ifRate)+ elseBegin :: Monad m => DepT m () elseBegin = stmtOnlyT ElseBegin  ifEnd :: Monad m => DepT m () ifEnd = stmtOnlyT IfEnd+-} -untilDo :: Monad m => E -> DepT m () -> DepT m ()-untilDo p body = do-    untilBegin p+untilBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()+untilBlock ifRate p body = void $ untilT ifRate p body++whileBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()+whileBlock ifRate p body = void $ whileT ifRate p body++{-+untilDo :: Monad m => IfRate -> E -> DepT m () -> DepT m ()+untilDo ifRate p body = do+    untilBegin ifRate p     body     untilEnd -untilBegin :: Monad m => E -> DepT m ()-untilBegin = withCond UntilBegin+untilBegin :: Monad m => IfRate -> E -> DepT m ()+untilBegin ifRate = withCond ifRate (UntilBegin ifRate)  untilEnd :: Monad m => DepT m () untilEnd = stmtOnlyT UntilEnd+-} -whileDo :: Monad m => E -> DepT m () -> DepT m ()-whileDo p body = do-    whileBegin p+{-+whileDo :: Monad m => IfRate -> E -> DepT m () -> DepT m ()+whileDo ifRate p body = do+    whileBegin ifRate p     body     whileEnd -whileBegin :: Monad m => E -> DepT m ()-whileBegin = withCond WhileBegin+whileBegin :: Monad m => IfRate -> E -> DepT m ()+whileBegin ifRate = withCond IfKr (WhileBegin ifRate)+-}  whileRef :: Monad m => Var -> DepT m () whileRef var = stmtOnlyT $ WhileRefBegin var@@ -74,8 +154,10 @@ 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)+{-+withCond :: Monad m => IfRate -> (CondInfo (PrimOr E) -> MainExp (PrimOr E)) -> E -> DepT m ()+withCond ifRate stmt p = depT_ $ noRate $ stmt (condInfo $ setIfRate ifRate p)+-}  instance Boolean E where     true = boolOp0 TrueOp@@ -88,9 +170,6 @@  type instance BooleanOf E = E -instance IfB E where-    ifB = condExp- instance EqB E where     (==*) = boolOp2 Equals     (/=*) = boolOp2 NotEquals@@ -109,22 +188,25 @@ boolExp :: a -> [b] -> PreInline a b boolExp = PreInline -condExp :: E -> E -> E -> E-condExp = mkCond . condInfo+ifExp :: IfRate -> E -> E -> E -> E+ifExp ifRate c = mkCond (condInfo (setIfRate ifRate c))     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)+            | otherwise = noRate $ If ifRate 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) 

@@ -0,0 +1,51 @@+-- | Constants+module Csound.Dynamic.Const+  ( controlOpcodes+  , audioOpcodes+  ) where++import Data.HashSet (HashSet)+import Data.HashSet qualified as HashSet+import Data.Text++-- | Envelope generators are Kr by default+controlOpcodes :: HashSet Text+controlOpcodes =+  HashSet.fromList+    [ "adsr"+    , "madsr"+    , "xadsr"+    , "linen"+    , "linenr"+    , "envlpx"+    , "envlpxr"+    , "expon"+    , "expseg"+    , "expsegr"+    , "jspline"+    , "line"+    , "linseg"+    , "linsegr"+    , "rspline"+    , "transeg"+    , "bpf"+    , "bpfcos"+    ]++-- | Oscillators and table access are Ar by default+audioOpcodes :: HashSet Text+audioOpcodes =+  HashSet.fromList+    [ "oscil"+    , "oscili"+    , "oscil3"+    , "poscil"+    , "poscil3"+    , "oscilikt"+    , "table"+    , "tablei"+    , "table3"+    , "tab"+    , "tabw"+    ]+

@@ -1,32 +1,46 @@ module Csound.Dynamic.Render(-    renderCsd+  RenderOptions (..),+  renderCsd,+  module X ) where -import qualified Text.PrettyPrint.Leijen as P+import qualified Text.PrettyPrint.Leijen.Text as P  import Csound.Dynamic.Render.Instr import Csound.Dynamic.Render.Pretty import Csound.Dynamic.Types+import Csound.Dynamic.Tfm.InferTypes as X (InferenceOptions (..), OpcodeInferenceStrategy (..))+import Data.Default -renderCsd :: Csd -> String-renderCsd a = show $ ppCsdFile+data RenderOptions = RenderOptions+  { inferenceOptions :: !InferenceOptions+  }+  deriving (Eq, Ord, Show, Read)++instance Default RenderOptions where+  def = RenderOptions+          { inferenceOptions = def+          }++renderCsd :: RenderOptions -> Csd -> String+renderCsd opts a = show $ ppCsdFile     (renderFlags $ csdFlags a)-    (renderOrc $ csdOrc a)+    (renderOrc (inferenceOptions opts) $ csdOrc a)     (renderSco   $ csdSco a)     (csdPlugins 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)+renderOrc :: InferenceOptions -> Orc -> Doc+renderOrc opts a = vcatSep $ headExpr : instrExprs+  where+    headExpr    = renderInstrBody opts (orcHead a)+    instrExprs  = fmap (renderInstr opts) (orcInstruments a)  renderSco :: Sco -> Doc renderSco a = vcatSep-    [ P.vcat $ fmap (uncurry ppGen)   $ scoGens a+    [ P.vcat $ fmap (uncurry ppGen) $ scoGens a     , maybe P.empty ppTotalDur $ scoTotalDur a     , P.vcat $ fmap (uncurry ppNotes) $ scoNotes a ] 

@@ -1,238 +1,79 @@ module Csound.Dynamic.Render.Instr(-    renderInstr, renderInstrBody+  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(..), foldFix)-import Data.Fix.Cse(fromDag, cseFramed, FrameInfo(..))+import Data.Fix.Cse(fromDag, cse {-cseFramed, FrameInfo(..)-}) -import qualified Text.PrettyPrint.Leijen as P+import qualified Text.PrettyPrint.Leijen.Text as P -import Csound.Dynamic.Tfm.DeduceTypes+import Csound.Dynamic.Tfm.InferTypes (InferenceOptions)+import Csound.Dynamic.Tfm.InferTypes qualified as Infer import Csound.Dynamic.Tfm.UnfoldMultiOuts+import Csound.Dynamic.Tfm.IfBlocks import Csound.Dynamic.Tfm.Liveness  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)+-- import Debug.Trace  type Dag f = [(Int, f Int)] -renderInstr :: Instr -> Doc-renderInstr a = ppInstr (instrName a) $ renderInstrBody (instrBody a)+renderInstr :: InferenceOptions -> Instr -> Doc+renderInstr opts a = ppInstr (instrName a) $ renderInstrBody opts (instrBody a) -renderInstrBody :: E -> Doc-renderInstrBody a+renderInstrBody :: InferenceOptions -> E -> Doc+renderInstrBody opts a   | null dag  = P.empty   | otherwise = render dag     where       dag = toDag a-      render = P.vcat . flip evalState 0 . mapM (uncurry ppStmt . clearEmptyResults) . collectRates+      render = P.vcat . flip evalState 0 . mapM (uncurry ppStmt . clearEmptyResults) . collectRates opts  ------------------------------------------------------------- -- E -> Dag  toDag :: E -> Dag RatedExp-toDag expr = filterDepCases $ fromDag $ cseFramed getFrameInfo $ trimByArgLength expr--getFrameInfo :: RatedExp a -> FrameInfo-getFrameInfo x = case ratedExpExp x of-    -- Imperative If-then-else-    IfBegin _ _   -> StartFrame---     ElseIfBegin _ -> NextFrame-    ElseBegin     -> NextFrame-    IfEnd         -> StopFrame-    -- looping constructions-    UntilBegin _ -> StartFrame-    UntilEnd     -> StopFrame-    WhileBegin _ -> StartFrame-    WhileRefBegin _ -> StartFrame-    WhileEnd     -> StopFrame-    _            -> NoFrame-+toDag expr = fromDag $ cse $ trimByArgLength expr  trimByArgLength :: E -> E 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-          trimInfo signature args = case signature of-            SingleRate tab -> SingleRate $ fmap trim tab-            MultiRate outs ins -> MultiRate outs (trim ins)-            where trim = take (length args)+  where+    phi x = case x of+      Tfm info xs -> Tfm (info{infoSignature = trimInfo (infoSignature info) xs}) xs+      _ -> x -clearEmptyResults :: ([RatedVar], Exp RatedVar) -> ([RatedVar], Exp RatedVar)-clearEmptyResults (res, expr) = (filter ((/= Xr) . ratedVarRate) res, expr)+    trimInfo signature args = case signature of+      SingleRate tab -> SingleRate $ fmap trim tab+      MultiRate outs ins -> MultiRate outs (trim ins)+      where+        trim = take (length args) -collectRates :: Dag RatedExp -> [([RatedVar], Exp RatedVar)]-collectRates dag = fmap (second ratedExpExp) res2-    where res2 = liveness lastFreshId1 res1-          (res1, lastFreshId1)= unfoldMultiOuts unfoldSpec lastFreshId dag1-          (dag1, lastFreshId) = rateGraph dag+clearEmptyResults :: ([Infer.Var], Exp Infer.Var) -> ([Infer.Var], Exp Infer.Var)+clearEmptyResults (res, expr) = (filter ((/= Xr) . Infer.varType) res, expr) +collectRates :: InferenceOptions -> Dag RatedExp -> [([Infer.Var], Exp Infer.Var)]+collectRates opts dag = fmap (second ratedExpExp) res4+  where+    res4 = liveness lastFreshId3 res3+    (res3, lastFreshId3) = unfoldMultiOuts inferRes2+    inferRes2 = inferRes1 { Infer.typedProgram = filterDepCases $ Infer.typedProgram inferRes1 }+    inferRes1 = collectIfBlocks inferRes+    inferRes = Infer.inferTypes opts $ fmap (uncurry Infer.Stmt) $+        -- (\a -> trace (unlines ["DAG", unlines $ fmap (\(ls, rs) -> unwords [show ls, "=", show $ fmap (either (const (-1)) id . unPrimOr) $ ratedExpExp rs]) a]) $ a)+        dag+ ----------------------------------------------------------- -- Dag -> Dag -filterDepCases :: Dag RatedExp -> Dag RatedExp-filterDepCases = filter (not . isDepCase . snd)+filterDepCases :: [Infer.Stmt Infer.Var] -> [Infer.Stmt Infer.Var]+filterDepCases = filter (not . isDepCase . Infer.stmtRhs)   where isDepCase x = case ratedExpExp x of           Starts  -> True           Seq _ _ -> True           Ends _  -> True           _       -> False---------------------------------------------------------------- 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-    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-              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 $ mergeWithPrimOr (ratesFromSignature curRate (infoSignature i)) xs-    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 _ | curRate == Ar || curRate == Xr -> rec2 Xr expr-    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--    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"-    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--          condRate :: Rate-          condRate = max Kr curRate -- Kr--          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 :: T.Var -> Rate-arrIndexVarRate v = case varRate v of-    Ir -> Ir-    _  -> Kr--mergeWithPrimOr :: [Rate] -> [PrimOr Int] -> [PrimOr (Var Rate)]-mergeWithPrimOr = zipWith phi-    where-        phi r (PrimOr x) = PrimOr $ case x of-            Left  p -> Left $ updateVarTargetRate r p-            Right n -> Right $ ratedVar r n-        updateVarTargetRate r p = case p of-            PrimVar _ v -> PrimVar r v-            _           -> p--

@@ -1,32 +1,39 @@ module Csound.Dynamic.Render.Pretty(     Doc, vcatSep,-    ppCsdFile, ppGen, ppNotes, ppInstr, ppStmt, ppTotalDur+    ppCsdFile, ppGen, ppNotes, ppInstr, ppStmt, ppTotalDur,+    PrettyE(..), PrettyShowE(..),+    ppE ) where  import Control.Monad.Trans.State.Strict-import Data.Char(toLower) import qualified Data.IntMap as IM -import Text.PrettyPrint.Leijen+import Text.PrettyPrint.Leijen.Text import Csound.Dynamic.Types-import qualified Csound.Dynamic.Tfm.DeduceTypes as R(Var(..))+import Csound.Dynamic.Tfm.InferTypes qualified as R(Var(..))+import Data.Text (Text)+import Data.Text qualified as Text+import Text.Show.Pretty (ppShow)+import Data.Fix (foldFix)+import Data.ByteString.Base64 qualified as Base64+import Data.Text.Encoding qualified as Text  vcatSep :: [Doc] -> Doc vcatSep = vcat . punctuate line -binaries, unaries :: String -> [Doc] -> Doc+binaries, unaries :: Text -> [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+binary :: Text -> Doc -> Doc -> Doc+binary op a b = parens $ a <+> textStrict op <+> b -unary :: String -> Doc -> Doc-unary op a = parens $ text op <> a+unary :: Text -> Doc -> Doc+unary op a = parens $ textStrict op <> a -func :: String -> Doc -> Doc-func op a = text op <> parens a+func :: Text -> Doc -> Doc+func op a = textStrict op <> parens a  ppCsdFile :: Doc -> Doc -> Doc -> [Plugin] -> Doc ppCsdFile flags orc sco plugins =@@ -38,13 +45,13 @@         ]  ppPlugins :: [Plugin] -> Doc-ppPlugins plugins = vcatSep $ fmap (\(Plugin name body) -> tag name (text body)) plugins+ppPlugins plugins = vcatSep $ fmap (\(Plugin name body) -> tag name (textStrict body)) plugins -tag :: String -> Doc -> Doc+tag :: Text -> Doc -> Doc tag name content = vcatSep [-    char '<' <> text name <> char '>',+    char '<' <> textStrict name <> char '>',     content,-    text "</" <> text name <> char '>']+    text "</" <> textStrict name <> char '>']  ppNotes :: InstrId -> [CsdEvent] -> Doc ppNotes instrId = vcat . fmap (ppNote instrId)@@ -62,7 +69,7 @@     PString a -> int a     PrimInt n -> int n     PrimDouble d -> double d-    PrimString s -> dquotes $ text s+    PrimString s -> dquotes $ textStrict s     PrimVar targetRate v -> ppConverter targetRate (varRate v) $ ppVar v     where         ppConverter dst src t@@ -86,13 +93,13 @@     <+> int 0     <+> (int $ genSize ft)     <+> (ppGenId $ genId ft)-    <+> (maybe empty (text . show) $ genFile ft)+    <+> (maybe empty (textStrict . Text.pack . show) $ genFile ft)     <+> (hsep $ map double $ genArgs ft)  ppGenId :: GenId -> Doc ppGenId x = case x of     IntGenId a      -> int a-    StringGenId a   -> dquotes $ text a+    StringGenId a   -> dquotes $ textStrict a  ppInstr :: InstrId -> Doc -> Doc ppInstr instrId body = vcat [@@ -103,33 +110,33 @@ ppInstrHeadId :: InstrId -> Doc ppInstrHeadId x = case x of     InstrId den nom -> int nom <> maybe empty ppAfterDot den-    InstrLabel name -> text name-    where ppAfterDot a = text $ ('.': ) $ reverse $ show a+    InstrLabel name -> textStrict name+    where ppAfterDot a = textStrict $ Text.pack $ ('.': ) $ reverse $ show a  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+    InstrLabel name -> dquotes $ textStrict name+    where ppAfterDot a = textStrict $ Text.pack $ ('.': ) $ reverse $ show a  type TabDepth = Int -ppStmt :: [RatedVar] -> Exp RatedVar -> State TabDepth Doc+ppStmt :: [R.Var] -> Exp R.Var -> State TabDepth Doc ppStmt outs expr = maybe (ppExp (ppOuts outs) expr) id (maybeStringCopy outs expr) -maybeStringCopy :: [RatedVar] -> Exp RatedVar -> Maybe (State TabDepth Doc)+maybeStringCopy :: [R.Var] -> Exp R.Var -> Maybe (State TabDepth Doc) maybeStringCopy outs expr = case (outs, expr) of-    ([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)+    ([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 _ 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  ppStringCopy :: Doc -> Doc -> Doc ppStringCopy outs src = ppOpc outs "strcpyk" [src] -ppExp :: Doc -> Exp RatedVar -> State TabDepth Doc+ppExp :: Doc -> Exp R.Var -> State TabDepth Doc ppExp res expr = case fmap ppPrimOrVar expr of     ExpPrim (PString n)             -> tab $ ppStrget res n     ExpPrim p                       -> tab $ res $= ppPrim p@@ -137,13 +144,13 @@     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+    If _ifRate 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 -    InitArr v as                    -> tab $ ppOpc (ppArrVar (length as) v) "init" as+    InitArr v as                    -> tab $ ppOpc (ppArrVar (length as) (ppVar 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@@ -151,30 +158,45 @@     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 +    InitPureArr _outRate _procRate initVals -> tab $ ppOpc (ppArrVar 1 res) "fillarray" initVals+    ReadPureArr outRate _procRate arr index -> tab $ if (outRate /= Sr) then res $= ppReadPureArr arr [index] else res <+> text "strcpy" <+> ppReadPureArr arr [index]+     IfBegin _ a                     -> succTab          $ text "if "     <> ppCond a <> text " then"+    IfBlock _ cond (CodeBlock th) ->  tab $ ppIf1 res (ppCond cond)  th+    IfElseBlock _ cond (CodeBlock th) (CodeBlock el) -> tab $ ppIf res (ppCond cond)  th el --     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"+    UntilBlock _ cond (CodeBlock th) -> tab $ ppUntil res (ppCond cond)  th+    WhileBlock _ cond (CodeBlock th) -> tab $ ppWhile res (ppCond cond)  th+    WhileRefBlock var (CodeBlock th) -> tab $ ppWhileRef res var th++    UntilBegin _ a                  -> succTab          $ text "until " <> ppCond a <> text " do"     UntilEnd                        -> left >> (tab     $ text "od")-    WhileBegin a                    -> succTab          $ text "while " <> ppCond a <> text " do"+    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)+    InitMacrosString name initValue -> tab $ initMacros (textStrict name) (textStrict initValue)+    InitMacrosDouble name initValue -> tab $ initMacros (textStrict name) (double initValue)+    InitMacrosInt name initValue    -> tab $ initMacros (textStrict 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+    Verbatim str                    -> return $ textStrict str +    Select _rate _n a                 -> tab $ res $= ("SELECTS" <+> a)+    Starts                          -> tab $ res $= "STARTS"+    Seq a b                         -> tab $ hsep ["SEQ", a, b]+    Ends _a                          -> tab $ "ENDS"+    ExpBool _                        -> tab "ExpBool" +    -- x -> error $ "unknown expression: " ++ show x+ -- pp macros -readMacro :: String -> Doc-readMacro name = char '$' <> text name+readMacro :: Text -> Doc+readMacro name = char '$' <> textStrict name  initMacros :: Doc -> Doc -> Doc initMacros name initValue = vcat@@ -191,12 +213,15 @@ 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 "[]")+ppArrVar :: Int -> Doc -> Doc+ppArrVar n v = v <> (hcat $ replicate n $ text "[]")  ppReadArr :: Var -> [Doc] -> Doc ppReadArr v as = ppArrIndex v as +ppReadPureArr :: Doc -> [Doc] -> Doc+ppReadPureArr v as = v <> (hcat $ fmap brackets 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@@ -216,7 +241,7 @@ shiftByTab :: Doc -> TabDepth -> Doc shiftByTab doc n     | n == 0    = doc-    | otherwise = (text $ replicate (tabWidth * n) ' ') <> doc+    | otherwise = indent (tabWidth * n) doc  left :: State TabDepth () left = modify pred@@ -227,8 +252,8 @@     modify succ     return a -prefix :: String -> [Doc] -> Doc-prefix name args = text name <> tupled args+prefix :: Text -> [Doc] -> Doc+prefix name args = textStrict name <> tupled args  ppCond :: Inline CondOp Doc -> Doc ppCond = ppInline ppCondOp@@ -236,10 +261,10 @@ ($=) :: Doc -> Doc -> Doc ($=) a b = a <+> equals <+> b -ppOuts :: [RatedVar] -> Doc+ppOuts :: [R.Var] -> Doc ppOuts xs = hsep $ punctuate comma $ map ppRatedVar xs -ppPrimOrVar :: PrimOr RatedVar -> Doc+ppPrimOrVar :: PrimOr R.Var -> Doc ppPrimOrVar x = either ppPrim ppRatedVar $ unPrimOr x  ppStrget :: Doc -> Int -> Doc@@ -254,16 +279,36 @@     , text "endif"     ] -ppOpc :: Doc -> String -> [Doc] -> Doc+ppIf1, ppWhile, ppUntil :: Doc -> Doc -> Doc -> Doc++ppIf1 = ppIfBy "if"+ppWhile = ppIfBy "while"+ppUntil = ppIfBy "until"++ppIfBy :: Text -> Doc -> Doc -> Doc -> Doc+ppIfBy leadTag res p t = vcat+    [ textStrict leadTag <+> p <+> text "then"+    , text "    " <> res <+> char '=' <+> t+    , text "endif"+    ]++ppWhileRef :: Doc -> Var -> Doc -> Doc+ppWhileRef res p t = vcat+    [ textStrict "while" <+> ppVar p <+> text "then"+    , text "    " <> res <+> char '=' <+> t+    , text "endif"+    ]++ppOpc :: Doc -> Text -> [Doc] -> Doc ppOpc out name xs = out <+> ppProc name xs -ppProc :: String -> [Doc] -> Doc-ppProc name xs = text name <+> (hsep $ punctuate comma xs)+ppProc :: Text -> [Doc] -> Doc+ppProc name xs = textStrict 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+    Var ty rate name   -> ppVarType ty <> ppRate rate <> textStrict (Text.cons (varPrefix ty) name)+    VarVerbatim _ name -> textStrict name  varPrefix :: VarType -> Char varPrefix x = case x of@@ -275,20 +320,25 @@     LocalVar  -> empty     GlobalVar -> char 'g' -ppConvertRate :: Doc -> Rate -> Rate -> Doc -> Doc+ppConvertRate :: Doc -> Rate -> Maybe 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+    (Ar, Just Kr) -> upsamp var+    (Ar, Just Ir) -> upsamp $ toK var+    (Kr, Just Ar) -> downsamp var+    (Kr, Just Ir) -> out $= var+    (Ir, Just Ar) -> downsamp var+    (Ir, Just Kr) -> out $= toI var+    (Ar, Nothing) -> out $= toA var+    (Kr, Nothing) -> out $= toK var+    (Ir, Nothing) -> out $= toI var+    (a, Just b) | a == b -> out $= 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"+        toA = func "a"+        toK = func "k"+        toI = func "i"  -- expressions @@ -329,15 +379,145 @@         bi  = binaries         uno = unaries -ppRatedVar :: RatedVar -> Doc-ppRatedVar v = ppRate (ratedVarRate v) <> int (ratedVarId v)+ppRatedVar :: R.Var -> Doc+ppRatedVar v = ppRate (R.varType v) <> int (R.varId v)  ppRate :: Rate -> Doc-ppRate x = case x of+ppRate x = case removeArrRate x of     Sr -> char 'S'     _  -> phi x-    where phi = text . map toLower . show+    where phi = textStrict . Text.toLower . Text.pack . show  ppTotalDur :: Double -> Doc ppTotalDur d = text "f0" <+> double d++--------------------------------------------------------------+-- debug++newtype PrettyShowE = PrettyShowE E+newtype PrettyE = PrettyE E++instance Show PrettyShowE where+  show (PrettyShowE expr) = ppShow expr++instance Show PrettyE where+  show (PrettyE expr) = show $ ppE expr++ppE :: E -> Doc+ppE = foldFix go+  where+    go :: RatedExp Doc -> Doc+    go x = fromExp (fromInfo x) x++    fromInfo :: RatedExp Doc -> Doc+    fromInfo RatedExp{..} =+      hsep+        [ ppHash ratedExpHash+        , maybe mempty ppRate ratedExpRate+        , maybe mempty pretty ratedExpDepends+        ]++    ppHash = textStrict . Text.take 4 . Text.decodeUtf8 . Base64.encode++    fromExp :: Doc -> RatedExp Doc -> Doc+    fromExp info RatedExp{..} = indent 2 $ post $+      case ratedExpExp of+        ExpPrim p -> ppPrim p+        EmptyExp -> textStrict "EMPTY_EXPR"+        Tfm inf args -> ppTfm inf args+        ConvertRate to from a -> ppConvert to from a+        Select r n a -> ppSelect r n a+        If rate cond th el -> ppIff rate cond th el+        ExpBool args -> hsep ["some bool expr", pretty $ show args]+        ExpNum arg -> ppExpNum arg+        InitVar v a -> ppInitVar v a+        ReadVar v -> "ReadVar" <+> ppVar v+        WriteVar v a -> ppVar v $= pp a++        -- TODO+        InitArr _v _size -> undefined+        ReadArr _v _index -> undefined+        WriteArr _v _index _ -> undefined+        WriteInitArr _v _index _ -> undefined+        TfmArr _isInit _v _info _args -> undefined++        InitPureArr _outRate _procRate _vals -> undefined+        ReadPureArr _outRate _procRate _arr _index -> undefined++        IfBegin rate cond -> hsep ["IF", ppRate $ fromIfRate rate, ppCond $ fmap pp cond, "\n"]++        IfBlock rate cond (CodeBlock th) -> ppIfBlockBy "IF-BLOCK" rate cond th+        IfElseBlock rate cond (CodeBlock th) (CodeBlock el) ->+          ppFun (hsep ["IF-BLOCK", ppRate $ fromIfRate rate, ppCond $ fmap pp cond ])+            [ pp th+            , "ELSE-BLOCK"+            , pp el+            , "END-BLOCK"+            ]+        ElseBegin -> "ELSE"+        IfEnd -> "END_IF"+        UntilBegin rate cond -> hsep ["UNTIL", ppRate $ fromIfRate rate, ppCond $ fmap pp cond, "\n"]+        UntilEnd -> "END_UNTIL"+        WhileBegin rate cond -> hsep ["WHILE", ppRate $ fromIfRate rate, ppCond $ fmap pp cond, "\n"]+        WhileRefBegin v -> hsep ["WHILE_REF", ppVar v]+        WhileEnd -> "END_WHILE"++        UntilBlock rate cond (CodeBlock th) -> ppIfBlockBy "UNTIL-BLOCK" rate cond th+        WhileBlock rate cond (CodeBlock th) -> ppIfBlockBy "WHILE-BLOCK" rate cond th+        WhileRefBlock var (CodeBlock th) -> ppWhileRefBlock var th++        Verbatim txt -> ppFun "VERBATIM" [textStrict txt]+        Starts -> "STARTS"+        Seq a b -> vcat ["SEQ", pp a, pp b]+        Ends a -> vcat ["ENDS", pp a]+        InitMacrosInt _name _n  -> undefined+        InitMacrosDouble _name _d -> undefined+        InitMacrosString _name _str -> undefined+        ReadMacrosInt _name -> undefined+        ReadMacrosDouble _name -> undefined+        ReadMacrosString _name -> undefined+      where+        post a = hsep [hcat ["{",info, "}:"], a]++    ppIfBlockBy leadTag rate cond th =+      ppFun (hsep [leadTag, ppRate $ fromIfRate rate, ppCond $ fmap pp cond ])+        [ pp th+        , "END-BLOCK"+        ]++    ppWhileRefBlock var th =+      ppFun (hsep ["WHILE-REF-BLOCK", ppVar var])+        [ pp th+        , "END-BLOCK"+        ]++    ppTfm info args = ppFun (textStrict $ infoName info) (fmap pp args)++    ppConvert to from a =+      ppFun (hsep [textStrict "Convert-rate", ppRate to, maybe mempty ppRate from]) [pp a]++    ppSelect rate n arg =+      ppFun (hsep ["select", ppRate rate, pretty n]) [pp arg]++    ppIff rate cond th el =+      vcat+        [ hsep ["if", ppRate (fromIfRate rate), ppCond $ fmap pp cond]+        , indent 2 $ vcat+            [ "then" <+> pp th+            , "else" <+> pp el+            ]+        ]++    ppExpNum (PreInline op as) = ppNumOp op (fmap pp as)++    ppInitVar v a =+      ppFun (hsep ["InitVar", ppVar v]) [pp a]++    ppFun name args =+      vcat+        [ name+        , indent 2 $ vcat args+        ]++    pp = either ppPrim id . unPrimOr 

@@ -1,124 +0,0 @@-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 have 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 = succ $ if (null as) then 0 else (fst $ last 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]-

@@ -0,0 +1,573 @@+-- | We collect all if-blocks under the if-the-else expressions and statements.+--+-- For a given if-block of code the taks is to agregate all expressions+-- that can be used inside that block and don't affect external expressions+-- relative to that block+--+-- For exampe consider expression:+--+-- > k3 opcA k2 k1+-- > k4 opcB 1, 120+-- >+-- > if cond then+-- >   k5 = k3+-- > else+-- >   k5 = k4+-- > endif+-- >+-- It can be transformed to:+--+-- > if cond then+-- >  k3 opcA k2 k1+-- >  k5 = k3+-- > else+-- >   k4 opcB 1, 120+-- >   k5 = k4+-- > endif+--+-- We bring relevant to if-blocks expressions inside the block.+-- But we should be careful not to touch the expressions that are dependencies+-- to expressions outside of the block.+--+-- The algorithm to find groups of such expressions proceeds as follows:+--+-- * count how many times given expression is used in RHS of the expression.+--    Create a table for fast access (O (expr-size)). Let's call it global count.+--+-- * for a given expression definition start to follow it's dependencies recursively+--    and count for all siblings how many times they are used in RHS of the expression.--+--    Let's call it local count+--+-- * The rule: for a given integer label/name+--      * if the global count equals to the local count+--          it can be brought inside if-block. Because all it's usages are inside the sub-expressions+--          of that block and does not leak to the outer scope.+--      * if name is not a sibling of the node for which the rule does not hold true+--+--  There are cases when node is inside if sub-graph but the problem is that one of it's+--    parents may be not fit to the graph. To solve this problem we go over the sub-graph 2 times:+--+--    1) to collect local counts we create IntMap of Usage counts local to the if-block+--    2) to mark as False all nodes that are not local to if and also (IMPORTANT) mark as False all it's children.+--        As we traverse the graph in breadth first we will recursively mark all non fit siblings.+--        I hope that it works :)+--        On this stage we create a set of nodes which are truly local+--    this is a set of local variables+--+--    One buggy solution was to traverse the sub graph and put inside the set the+--     nodes which are local regarding the ussage count. But this does not work as+--     valid node can have invalid parent. And algorithm will exclude parent but+--     keep the child which will lead to the broken code.+--+-- This rule works for generic expressions defined on traversable functor F.+--+-- But there are some Csound peculiriaties:+--+-- * reminder:+--      * if-blocks can work on Ir and on Kr rates.+--      * Kr if-blocks are ignored on initialization Ir stage.+--+-- * this leads to csound syntax specific rules:+--+--    * init expressions can not be brought inside Kr if-block (they will be ignored)+--       also Opcodes that run at I-rate.+--+--    * variable / array initialisation can not be brought inside Kr if-block+--+--    * all constants inside the block should have the same rate as the block itself.+--       i.e. ir constants inside Ir block and kr constants inside kr block+--+--  So we should recursively follow the depndencies of the if-block root variable definition.+--  But we also exclude nodes early if they can not be present inside the block by rate.+module Csound.Dynamic.Tfm.IfBlocks+  ( collectIfBlocks+  ) where++import Csound.Dynamic.Types.Exp hiding (Var(..))+import Csound.Dynamic.Types.Exp qualified as Exp+import Control.Monad+import Control.Monad.ST+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Data.Maybe (fromMaybe)+import Data.Vector.Mutable qualified as Vector+import Data.Vector.Unboxed.Mutable qualified as UnboxedVector+import Data.List qualified as List+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.STRef+import Data.Bifunctor (first)+import Csound.Dynamic.Tfm.InferTypes (InferenceResult (..), Stmt(..), Var(..))+import Data.Text qualified as Text+-- import Debug.Trace++type Expr  = Stmt Var++collectIfBlocks :: InferenceResult -> InferenceResult+collectIfBlocks infRes@InferenceResult{..}+  | programHasIfs = runST $ do+      env <- newEnv programLastFreshId typedProgram+      uncurry toResult =<< runStateT (collectIter [] $ List.reverse typedProgram) env+  | otherwise = infRes+  where+    toResult :: [Stmt Var] -> Env s -> ST s InferenceResult+    toResult prog Env{..} = do+      lastId <- readSTRef envLastFreshId+      pure $ infRes { typedProgram = prog, programLastFreshId = lastId }++-- | Monad of the algorithm+type Collect s a = StateT (Env s) (ST s) a++type UsageCounts s = UnboxedVector.STVector s Int+type DagGraph s = Vector.STVector s (RatedExp Var)+type IsInits s =  UnboxedVector.STVector s Bool++-- | Internal mutable state of the algorithm+data Env s = Env+  { envUsageCount  :: UsageCounts s+  , envDag         :: DagGraph s+  , envIsInit      :: IsInits s+  , envLastFreshId :: STRef s Int+  , envDagSize     :: Int+  }++---------------------------------------------------+-- collect interface++getDagSize :: Collect s Int+getDagSize = gets envDagSize++readGlobalUsages :: Int -> Collect s Int+readGlobalUsages n = do+  dagSize <- getDagSize+  if n < dagSize+    then do+      usages <- gets envUsageCount+      lift $ UnboxedVector.read usages n+    else pure 0++readIsInit :: Int -> Collect s Bool+readIsInit n = do+  dagSize <- getDagSize+  if n < dagSize+    then do+      inits <- gets envIsInit+      lift $ UnboxedVector.read inits n+    else pure False++readDag :: Var -> Collect s (Maybe Expr)+readDag lhs = do+  dagSize <- getDagSize+  if varId lhs < dagSize+    then do+      dag <- gets envDag+      fmap (Just . (Stmt lhs )) $ lift $ Vector.read dag (varId lhs)+    else pure Nothing++withDag :: Var -> (Expr -> Collect s ()) -> Collect s ()+withDag n cont = do+  mExpr <- readDag n+  forM_ mExpr cont++freshId :: Collect s Int+freshId = do+  ref <- gets envLastFreshId+  lift $ do+    newId <- readSTRef ref+    modifySTRef' ref succ+    pure newId++---------------------------------------------------------------------------+-- working with DAG-graph++traverseAccumDag :: forall s a . Show a => (Expr -> a -> Collect s a) -> a -> (Expr -> Collect s Bool) -> PrimOr Var -> Collect s a+traverseAccumDag update initSt getIsEnd (PrimOr root) = do+  case root of+    Left _    -> pure initSt+    Right var -> do+      ref <- lift $ newSTRef initSt+      traverseDag var getIsEnd (go ref)+      lift $ readSTRef ref+  where+    go :: STRef s a -> Expr -> Collect s ()+    go ref expr = do+      val <- lift $ readSTRef ref+      newVal <- update expr val+      lift $ writeSTRef ref $+ --       trace (unlines ["GO", show $ stmtLhs expr, show $ ratedExpExp $ stmtRhs expr, show newVal]) $+        newVal++-- | Breadth first traversal+traverseDag :: Var -> (Expr -> Collect s Bool) -> (Expr -> Collect s ()) -> Collect s ()+traverseDag root getIsEnd go =+  withDag root $ \expr -> do+    isTerminal <- getIsEnd expr+    unless isTerminal $ do+      go expr+      mapM_ (\var -> traverseDag var getIsEnd go) (stmtRhs expr)+++-----------------------------------------------------------++newEnv :: forall s . Int -> [Expr] -> ST s (Env s)+newEnv exprSize exprs = do+  usageCount <- UnboxedVector.replicate exprSize 0+  dag <- Vector.new exprSize+  isInit <- UnboxedVector.replicate exprSize False+  exprSizeRef <- newSTRef exprSize+  let env = Env usageCount dag isInit exprSizeRef exprSize+  mapM_ (go env) exprs+  pure env+  where+    go :: Env s -> Expr -> ST s ()+    go env expr = do+      updateUsageCount (envUsageCount env) expr+      updateDag (envDag env) expr+      updateIsInit (envIsInit env) expr++    updateUsageCount :: UsageCounts s -> Expr -> ST s ()+    updateUsageCount usageCounts expr =+      mapM_ count (stmtRhs expr)+      where+        count v = UnboxedVector.modify usageCounts succ (varId v)++    updateDag :: DagGraph s -> Expr -> ST s ()+    updateDag dag (Stmt lhs rhs) =+      Vector.write dag (varId lhs) rhs++    updateIsInit :: IsInits s -> Expr -> ST s ()+    updateIsInit isInit expr =+      when (isInitExpr expr) $+        UnboxedVector.write isInit (varId $ stmtLhs expr) True++-- | Be sure not to bring initialization expression inside the if-blocks+isInitExpr :: Stmt Var -> Bool+isInitExpr expr =+  (varType (stmtLhs expr) == Ir) || checkExpr (ratedExpExp $ stmtRhs expr)+  where+    checkExpr = \case+      InitVar _ _ -> True+      InitArr _ _ -> True+      TfmArr isInit _ _ _ -> isInit+      InitPureArr _ _ _ -> True+      InitMacrosInt _ _ -> True+      InitMacrosDouble _ _ -> True+      InitMacrosString _ _ -> True+      ConvertRate Ir _ _ -> True+      Select Ir _ _ -> True+      _ -> False++data ExprType a+  = PlainType+  | IfType IfRate (CondInfo a) a (IfCons a)+  | IfElseType IfRate (CondInfo a) a a (IfElseCons a)+  | IfExpType IfRate (CondInfo a) a a++data IfCons a = IfCons+  { ifBegin :: IfRate -> CondInfo a -> MainExp a+  , ifEnd   :: MainExp a+  }++data IfElseCons a = IfElseCons+  { ifElseBegin :: IfRate -> CondInfo a -> MainExp a+  , elseBegin   :: MainExp a+  , ifElseEnd   :: MainExp a+  }++type LocalUsageCounts = IntMap Int+type LocalVars = IntSet++-- | We process statements in reverse order+-- and then also accumulation happens in reverse+-- so we don't need to reverse twice+collectIter :: [Stmt Var] -> [Stmt Var] -> Collect s [Stmt Var]+collectIter results = \case+  [] -> pure results+  expr : exprs ->+    case getExprType (stmtRhs expr) of+      PlainType                         -> onPlain expr exprs+      IfType rate check th cons         -> onIf rate check th cons (stmtLhs expr) exprs+      IfElseType rate check th el cons  -> onIfElse rate check th el cons (stmtLhs expr) exprs+      IfExpType rate check th el        -> onIfExp rate check th el (stmtLhs expr) exprs+  where+    onPlain expr rest = collectIter (expr : results) rest++    onIf ifRate check th cons lhs exprs = do+      vs <- blockLocalVars ifRate th+      (newIfBlock, rest) <- redefineIf vs lhs ifRate check cons exprs+      toResult newIfBlock rest++    toResult newIfBlock rest = do+      collectIter (copyToResult newIfBlock results) rest++    copyToResult :: [a] -> [a] -> [a]+    copyToResult items result = List.foldl' (flip (:)) result items++    blockLocalVars ifRate root = do+      localUsage <- getLocalUsage ifRate root+      -- globals <- mapM (\v -> (\g -> (v, (g, localUsage IntMap.! v))) <$> readGlobalUsages v) $ IntMap.keys localUsage+      -- trace (unlines $ show <$> globals) $+      getLocalVars localUsage ifRate root++    onIfElse ifRate check th el cons lhs exprs = do+      thVars <- blockLocalVars ifRate th+      elVars <- blockLocalVars ifRate el+      (newIfBlock, rest) <- redefineIfElse thVars elVars lhs ifRate check cons exprs+      toResult newIfBlock rest++    onIfExp ifRate check th el lhs exprs = do+      thVars <- blockLocalVars ifRate th+      elVars <- blockLocalVars ifRate el+      (newIfBlock, rest) <- redefineIfElseExp thVars elVars th el lhs ifRate check cons exprs+      toResult newIfBlock rest+      where+        cons = IfElseCons { ifElseBegin = IfBegin, elseBegin = ElseBegin, ifElseEnd = IfEnd }++collectSubs :: Bool -> [Expr] -> Collect s [Expr]+collectSubs hasIfs newIfBlock+  | hasIfs    = List.reverse <$> collectIter [] newIfBlock+  | otherwise = pure newIfBlock++redefineIf ::+     LocalVars+  -> Var+  -> IfRate+  -> CondInfo (PrimOr Var)+  -> IfCons (PrimOr Var)+  -> [Expr]+  -> Collect s ([Expr], [Expr])+redefineIf localVars ifBeginId ifRate condInfo IfCons{..} exprs = do+  ifStmts <- getIfStmts+  first (toResult ifStmts) <$> iterRedefine ifRate localVars blockSize [] False [] exprs+  where+    blockSize = IntSet.size localVars++    -- | we expect if-block expressions to be reversed+    toResult (ifBeginStmt, ifEndStmt) blockExprs =+      ifEndStmt : blockExprs <> [ifBeginStmt]++    getIfStmts = do+      ifEndId <- freshId+      let ifEndStmt = Stmt (Var Xr ifEndId) (toRatedExp ifEnd)+          ifBeginStmt = Stmt ifBeginId (toRatedExp $ ifBegin ifRate condInfo)+      pure (ifBeginStmt, ifEndStmt)++iterRedefine :: IfRate -> LocalVars -> Int -> [Expr] -> Bool -> [Expr]-> [Expr] -> Collect s ([Expr], [Expr])+iterRedefine ifRate localVars currentBlockSize resultIfExprs hasIfs resultRest nextExprs+  | currentBlockSize <= 0 = result+  | otherwise      =+      case nextExprs of+        []              -> result+        e@(Stmt lhs _) : es ->+          if isLocal lhs+            then appendLocal e es+            else appendRest e es+  where+    rec onBlockSize expr onIfExprs onRestExprs newNextExprs =+      iterRedefine+        ifRate+        localVars+        (onBlockSize currentBlockSize)+        (onIfExprs resultIfExprs)+        (hasIfs || (isIfExpr $ stmtRhs expr))+        (onRestExprs resultRest)+        newNextExprs++    result = recollect+      ( List.reverse $ resultIfExprs+      , hasIfs+      , List.reverse resultRest <> nextExprs+      )++    recollect (newIfBlock, finalHasIfs, rest) = do+      newIfBlockCollected <- collectSubs finalHasIfs newIfBlock+      pure (newIfBlockCollected, rest)++    appendLocal e es = rec pred e (e : ) id     es+    appendRest e es  = rec id   e id     (e : ) es++    isLocal :: Var -> Bool+    isLocal var = IntSet.member (varId var) localVars++redefineIfElse ::+     LocalVars+  -> LocalVars+  -> Var+  -> IfRate+  -> CondInfo (PrimOr Var)+  -> IfElseCons (PrimOr Var)+  -> [Expr]+  -> Collect s ([Expr], [Expr])+redefineIfElse thLocalVars elLocalVars ifBeginId ifRate condInfo IfElseCons{..} exprs = do+  ifStmts <- getIfElseStmts+  (ifBlockExprs, rest1) <- getIfPart exprs+  (elseBlockExprs, rest2) <- getElsePart rest1+  pure (toResult ifStmts ifBlockExprs elseBlockExprs, rest2)+  where+    -- note that block epxressions are reversed+    toResult (ifBeginStmt, elseBeginStmt, ifEndStmt) ifBlockExprs elseBlockExprs =+      ifEndStmt : mconcat+      [   elseBlockExprs+      ,   [elseBeginStmt]+      ,   ifBlockExprs+      , [ifBeginStmt]+      ]++    getIfElseStmts = do+      let ifBeginStmt = Stmt ifBeginId (toRatedExp $ ifElseBegin ifRate condInfo)+      elseBeginStmt <- (\elId -> Stmt (Var Xr elId) (toRatedExp elseBegin)) <$> freshId+      ifEndStmt <- (\endId -> Stmt (Var Xr endId) (toRatedExp ifElseEnd)) <$> freshId+      pure (ifBeginStmt, elseBeginStmt, ifEndStmt)++    getIfPart es = iterRedefine ifRate thLocalVars ifBlockSize [] False [] es+    getElsePart es = iterRedefine ifRate elLocalVars elseBlockSize [] False [] es++    ifBlockSize = IntSet.size thLocalVars+    elseBlockSize = IntSet.size elLocalVars++redefineIfElseExp ::+     forall s+   . LocalVars+  -> LocalVars+  -> PrimOr Var+  -> PrimOr Var+  -> Var+  -> IfRate+  -> CondInfo (PrimOr Var)+  -> IfElseCons (PrimOr Var)+  -> [Expr]+  -> Collect s ([Expr], [Expr])+redefineIfElseExp thLocalVars elLocalVars th el ifResultId ifRate condInfo IfElseCons{..} exprs = do+  ifStmts <- getIfElseStmts+  -- note that blocks are returned in reversed order+  (ifBlockExprs, rest1) <- getIfPart exprs+  (elseBlockExprs, rest2) <- getElsePart rest1+  ifResult <- toResult ifStmts ifBlockExprs elseBlockExprs+  pure (ifResult, rest2)+  where+     -- note that expressions in the blocks are returned in reversed order+    toResult :: (Expr, Expr, Expr) -> [Expr] -> [Expr] -> Collect s [Expr]+    toResult (ifBeginStmt, elseBeginStmt, ifEndStmt) ifBlockExprs elseBlockExprs = do+      thAssign <- writeRes ifResultId th+      elAssign <- writeRes ifResultId el+      pure $+            ifEndStmt : elAssign : mconcat+            [   elseBlockExprs+            ,   [elseBeginStmt, thAssign]+            ,   ifBlockExprs+            , [ifBeginStmt]+            ]++    getIfElseStmts = do+      ifBeginStmt <- (\ifBeginId -> (Stmt (Var Xr ifBeginId) $ toRatedExp $ ifElseBegin ifRate condInfo)) <$> freshId+      elseBeginStmt <- (\elId -> (Stmt (Var Xr elId) $ toRatedExp elseBegin)) <$> freshId+      ifEndStmt <- (\endId -> (Stmt (Var Xr endId) $ toRatedExp ifElseEnd)) <$> freshId+      pure (ifBeginStmt, elseBeginStmt, ifEndStmt)++    getIfPart es = iterRedefine ifRate thLocalVars ifBlockSize [] False [] es+    getElsePart es = iterRedefine ifRate elLocalVars elseBlockSize [] False [] es++    ifBlockSize = IntSet.size thLocalVars+    elseBlockSize = IntSet.size elLocalVars++    writeRes :: Var -> PrimOr Var -> Collect s Expr+    writeRes resId expr = do+      varWriteId <- freshId+      pure $ Stmt+        { stmtLhs = Var Xr varWriteId+        , stmtRhs = toRatedExp $ WriteVar (toVar resId) expr+        }++    toVar v = Exp.VarVerbatim (varType v) name+      where+        name = Text.toLower $ Text.pack $ show (varType v) ++ show (varId v)+++toRatedExp :: MainExp (PrimOr a) -> RatedExp a+toRatedExp expr =+  RatedExp+    { ratedExpHash = ""+    , ratedExpDepends = Nothing+    , ratedExpRate = Nothing+    , ratedExpExp = expr+    }++type LocalMarks = IntMap Bool++getLocalVars :: forall s . LocalUsageCounts -> IfRate -> PrimOr Var -> Collect s LocalVars+getLocalVars localUsages ifRate root = toSet <$>+  traverseAccumDag update initMarks (isEnd ifRate) root+  where+    initMarks = either (const IntMap.empty) (\var -> IntMap.singleton (varId var) True) $ unPrimOr root++    update :: Expr -> LocalMarks -> Collect s LocalMarks+    update (Stmt lhs rhs) localMarks+      | isParentLocal = do+          isLocal <- fullyInsideLocal lhs+          let tfm = if isLocal then id else onFalseLocal+          pure $ tfm $ IntMap.alter (Just . maybe isLocal (isLocal &&)) (varId lhs) localMarks+      | otherwise = pure $ onFalseLocal localMarks+      where+        isParentLocal = fromMaybe True $ IntMap.lookup (varId lhs) localMarks++        onFalseLocal =+          execState (mapM_ (\v -> modify' $ IntMap.insert (varId v) False) rhs)++    fullyInsideLocal :: Var -> Collect s Bool+    fullyInsideLocal lhs = do+      globalCount <- readGlobalUsages (varId lhs)+      let localCount = IntMap.lookup (varId lhs) localUsages+      pure $ Just globalCount == localCount++    toSet :: LocalMarks -> LocalVars+    toSet = IntMap.keysSet . IntMap.filter id++getLocalUsage :: forall s . IfRate -> PrimOr Var -> Collect s LocalUsageCounts+getLocalUsage ifRate root =+  traverseAccumDag update initCount (isEnd ifRate) root+  where+    initCount = either (const IntMap.empty) (\var -> IntMap.singleton (varId var) 1) $ unPrimOr root++    update :: Expr -> LocalUsageCounts -> Collect s LocalUsageCounts+    update (Stmt _lhs rhs) st = pure $+      execState (mapM_ count rhs) st++    count var = modify' $ IntMap.alter (Just . maybe 1 succ) (varId var)++---------------------------------------------------------------------------++-- | Defines rule that if we are inside Kr if-block we can not bring inside+-- Ir-expressions+isEnd :: IfRate -> Expr -> Collect s Bool+isEnd ifRate (Stmt lhs rhs)+  | isInitVar rhs = pure True+  | otherwise = case ifRate of+      IfIr -> pure False+      IfKr -> readIsInit (varId lhs)++isInitVar :: RatedExp Var -> Bool+isInitVar expr =+  case ratedExpExp expr of+    InitVar _ _ -> True+    InitArr _ _ -> True+    _           -> False++isIfExpr :: RatedExp Var -> Bool+isIfExpr rhs = case getExprType rhs of+  PlainType -> False+  _         -> True++getExprType :: RatedExp Var -> ExprType (PrimOr Var)+getExprType expr =+  case ratedExpExp expr of+    If rate c th el -> IfExpType rate c th el+    IfBlock rate c (CodeBlock th) -> IfType rate c th $ IfCons { ifBegin = IfBegin, ifEnd = IfEnd }+    IfElseBlock rate c (CodeBlock th) (CodeBlock el) -> -- trace (unlines ["TH/EL", show (th, el)])+      IfElseType rate c th el $ IfElseCons { ifElseBegin = IfBegin, elseBegin = ElseBegin, ifElseEnd = IfEnd }+    WhileBlock rate c (CodeBlock th) -> IfType rate c th $ IfCons { ifBegin = WhileBegin, ifEnd = WhileEnd }+    UntilBlock rate c (CodeBlock th) -> IfType rate c th $ IfCons { ifBegin = UntilBegin, ifEnd = UntilEnd }+    -- TODO:+    --     While Ref case+    _ -> PlainType

@@ -0,0 +1,692 @@+-- | Algorithm to infer csound rates. It's type inference for Csound.+--+-- It proceeds from epxression leaves to the top of the expression tree while assigning the rates.+-- The expression is DAG defined as list which is sorted by dependencies from bottom to top.+--+-- We traverse over the list and assign types to the terms.+-- Assumptions:+--+--  * type of primitive values is Ir or Sr+--  * type of numeric expression is minimal type of it's arguments+--+--  * type of opcode is determined by the choice of the most fit signature to the arguments+--     unless it's required by the user to be of specific type.+--     We try to find the signature that leads to lesser amount of destructive conversions overall.+--+--  * If-then-else type:+--      * for condition it is derived form ifRate in the argument of If-constructor+--      * the output is a minimum of types of the branches+--+--  * procedures' output is asssigned with Xr type+--+--  Note on type ordering they go in order of definition from amount of memory used:+--   Xr | Ar | Kr | Ir+--+--   So the Ar is the minimum+module Csound.Dynamic.Tfm.InferTypes+  ( inferTypes+  , InferenceOptions (..)+  , InferenceResult (..)+  , OpcodeInferenceStrategy (..)+  , Stmt(..)+  , Var(..)+  ) where++import Safe+import Control.Monad (zipWithM, foldM)+import Data.Semigroup (Min(..))+import Data.List qualified as List+import Control.Monad.Trans.State.Strict+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.ByteString (ByteString)+import Data.Default+import Data.HashSet (HashSet)+import Data.HashSet qualified as HashSet+import Data.Vector.Mutable (STVector)+import Data.Vector.Mutable qualified as Vector+import Control.Monad.ST+import Data.Maybe (fromMaybe)+import Data.IntMap (IntMap)+import Data.IntMap qualified as IntMap+import Data.Text qualified as Text++import Csound.Dynamic.Const qualified as Const+import Csound.Dynamic.Types.Exp hiding (Var, varType)+import Csound.Dynamic.Types.Exp qualified as Exp+-- import Debug.Trace (trace)++-- core types++data Stmt a = Stmt+  { stmtLhs :: !a+  , stmtRhs :: !(RatedExp a)+  }+  deriving (Show, Eq, Ord)++data Var = Var+  { varType :: !Rate+  , varId   :: !Int+  }+  deriving (Show, Eq, Ord)++data InferenceResult = InferenceResult+  { typedProgram       :: ![Stmt Var]+  , programLastFreshId :: !Int+  , programHasIfs      :: !Bool+      -- ^ does program has if-statemenrs+      -- we need it for the next optimization stage+  }++-- option types++data InferenceOptions = InferenceOptions+  { opcodeInferenceStrategy    :: !OpcodeInferenceStrategy+  , opcodeInferencePreference  :: !OpcodeInferencePreference+  }+  deriving (Eq, Ord, Show, Read)++data OpcodeInferenceStrategy+  = PreferControlRate  -- prefer Kr-outputs for opcodes+  | PreferAudioRate    -- prefer Ar-outputs for opcodes+  deriving (Eq, Ord, Show, Read)++data OpcodeInferencePreference = OpcodeInferencePreference+  { preferControlOpcodes :: HashSet Name  -- ^ set of opcode names to use Kr by default+  , preferAudioOpcodes   :: HashSet Name  -- ^ set of opcode names to use Ar by default+  }+  deriving (Eq, Ord, Show, Read)+++-- | Infer types/rates for a csound program+inferTypes :: InferenceOptions -> [Stmt Int] -> InferenceResult+inferTypes opts exprs = runST $ do+  env <- initEnv+  toResult <$> execStateT (mapM_ (inferIter opts) exprs) env+  where+    initEnv :: ST s (InferEnv s)+    initEnv = do+      typeMap <- Vector.replicate size Xr+      pure InferEnv+        { envTypeMap = typeMap+        , envConversions = IntMap.empty+        , envLastFreshId = size+        , envResult = []+        , envHasIfs = False+        , envPrims = Map.empty+        }++    toResult InferEnv{..} =+      InferenceResult+        { typedProgram  = List.reverse envResult+        , programLastFreshId = envLastFreshId+        , programHasIfs = envHasIfs+        }++    size = succ $ maybe 0 stmtLhs $ headMay $ List.reverse exprs++type Infer s a = StateT (InferEnv s) (ST s) a++-- | Type-inference state+data InferEnv s = InferEnv+  { envTypeMap     :: !(STVector s Rate)+      -- ^ types inferrred so far+  , envConversions :: !(IntMap (Map Rate Var))+     -- ^ conversions+  , envLastFreshId :: !Int+      -- ^ last fresh id (we use it to insert new variables for conversions)+  , envResult      :: ![Stmt Var]+      -- ^ typed program accumulated in reversed order+  , envPrims       :: Map Prim Var+      -- ^ sometimes we need to allocate new primitive value to convert it+  , envHasIfs      :: !Bool+  }++-------------------------------------------------------------------------------------+-- options++type OpcSignature = (Rate, [Rate])++preferOpc :: InferenceOptions -> Name -> Map Rate [Rate] -> Either [OpcSignature] OpcSignature+preferOpc (InferenceOptions strategy opcPrefs) name signatureMap+  | Just sig <- getControl = Right sig+  | Just sig <- getAudio   = Right sig+  | otherwise              = Left $+      case strategy of+        PreferControlRate -> List.reverse $ Map.toList signatureMap+        PreferAudioRate   -> Map.toList signatureMap+  where+    getControl = getBy Kr (preferControlOpcodes opcPrefs)+    getAudio = getBy Ar (preferAudioOpcodes opcPrefs)++    getBy rate s+      | HashSet.member name s = (rate, ) <$> Map.lookup rate signatureMap+      | otherwise = Nothing++instance Default InferenceOptions where+  def = InferenceOptions+    { opcodeInferenceStrategy   = PreferControlRate+    , opcodeInferencePreference =+        OpcodeInferencePreference+          { preferControlOpcodes = Const.controlOpcodes+          , preferAudioOpcodes   = Const.audioOpcodes+          }+    }++-------------------------------------------------------------------------------------+-- inference++inferIter :: forall s . InferenceOptions -> Stmt Int -> Infer s ()+inferIter opts (Stmt lhs rhs) =+  -- trace (unlines ["INFER RHS", show $ ratedExpExp rhs, show $ ratedExpRate rhs, "\n"]) $+  case ratedExpExp rhs of+    -- primitives+    ExpPrim p -> onPrim p++    -- | Application of the opcode: we have opcode information (Info) and the arguments [a]+    Tfm info args -> onTfm info args++    ConvertRate toRate fromRate a -> onConvertRate toRate fromRate a+    Select rate outId arg -> onSelect rate outId arg++    -- | Numerical expressions (rendered in infix notation in the Csound)+    ExpNum args -> onExpNum args+    ExpBool _ -> error "Bool Exp should be substituted"++    -- | Reading/writing a named variable+    InitVar v arg -> onInitVar v arg+    ReadVar v -> onReadVar v+    WriteVar v arg -> onWriteVar v arg++    -- | Selects a cell from the tuple, here argument is always a tuple (result of opcode that returns several outputs)+    -- | if-then-else+    If ifRate cond th el -> onIf ifRate cond th el+    -- | Imperative If-then-else+    IfBlock ifRate cond th -> onIfBlock ifRate cond th+    IfElseBlock ifRate cond th el -> onIfElseBlock ifRate cond th el+    IfBegin ifRate cond -> onIfBegin ifRate cond+    ElseBegin -> saveProcedure ElseBegin+    IfEnd -> saveProcedure IfEnd++    -- | Verbatim stmt+    Verbatim txt -> saveProcedure (Verbatim txt)++    -- | Arrays+    InitArr v arrSize -> onInitArr v arrSize+    ReadArr v index -> onReadArr v index+    WriteArr v index val -> onWriteArr v index val+    WriteInitArr v arrSize initVal -> onWriteInitArr v arrSize initVal+    TfmArr isArrInit v info args -> onTfmArr isArrInit v info args++    -- | Pure arrays (read-only)+    InitPureArr outRate procRate initVals -> onInitPureArr outRate procRate initVals+    ReadPureArr outRate procRate inArr index -> onReadPureArr outRate procRate inArr index++    -- | read macros arguments+    InitMacrosInt name n -> saveProcedure (InitMacrosInt name n)+    InitMacrosDouble name dbl -> saveProcedure (InitMacrosDouble name dbl)+    InitMacrosString name txt -> saveProcedure (InitMacrosString name txt)+    ReadMacrosInt name -> save Ir (ReadMacrosInt name)+    ReadMacrosDouble name -> save Ir (ReadMacrosDouble name)+    ReadMacrosString name -> save Ir (ReadMacrosString name)++    -- | looping constructions+    UntilBlock ifRate cond th -> onUntilBlock ifRate cond th+    WhileBlock ifRate cond th -> onWhileBlock ifRate cond th+    WhileRefBlock var th -> onWhileRefBlock var th++    UntilBegin ifRate cond -> onUntilBegin ifRate cond+    UntilEnd -> saveProcedure UntilEnd+    WhileBegin ifRate cond -> onWhileBegin ifRate cond+    WhileRefBegin v -> saveProcedure (WhileRefBegin v)+    WhileEnd -> saveProcedure WhileEnd++    EmptyExp  -> saveProcedure EmptyExp++    -- | Dependency tracking+    Starts -> saveProcedure Starts+    Seq a b -> saveProcedure (Seq (setXr a) (setXr b))+    Ends a -> saveProcedure (Ends (setXr a))++  where+    onPrim p = save rate (ExpPrim p)+      where+        rate = fromMaybe (primRate p) $ ratedExpRate rhs++    onTfm info args =+      case infoSignature info of+        MultiRate outRates inRates -> onMultiRateTfm info outRates inRates args+        SingleRate rateTab         -> onSingleRateTfm info rateTab args++    onMultiRateTfm info _outRates inRates args = do+      typedExpr <- Tfm info <$> zipWithM applyArg inRates args+      save Xr typedExpr++    onSingleRateTfm info rateTab args+      | Just userRates <- getUserDefinedRate = onFixedRateTfm info userRates args+      | otherwise                            = onFreeTfm info rateTab args+      where+        getUserDefinedRate = do+          userRate <- ratedExpRate rhs+          (userRate, ) <$> Map.lookup userRate rateTab++    onFixedRateTfm info (outRate, inRates) args = do+      typedExpr <- Tfm info <$> zipWithM applyArg inRates args+      save outRate typedExpr++    onFreeTfm info rateTab args = do+      signature <-+        case Map.toList rateTab of+          [rateInfo] -> pure rateInfo+          _ ->+            case preferOpc opts (infoName info) rateTab of+              Right opcRate -> pure opcRate+              Left opcRates -> findSignature args opcRates+      onFixedRateTfm info signature args++    findSignature :: [PrimOr Int] -> [OpcSignature] -> Infer s OpcSignature+    findSignature args allOpcRates = go (fromMaybe (Kr, []) $ headMay allOpcRates) Nothing allOpcRates+      where+        go :: OpcSignature -> Maybe SignatureChoice -> [OpcSignature] -> Infer s OpcSignature+        go defaultRate mBestFit candidateRates =+          case candidateRates of+            [] -> pure $ maybe defaultRate signatureCandidate mBestFit+            candidate : rest -> do+              scores <- tryCandidate candidate+              if isFit scores+                then pure candidate+                else go defaultRate (Just $ getBestFit scores mBestFit) rest++        tryCandidate :: OpcSignature -> Infer s SignatureChoice+        tryCandidate candidate@(_outRate, inRates) = do+          conversions <- countDestructiveConversions inRates+          pure $ SignatureChoice+            { destructiveConversionsCount = conversions+            , signatureCandidate = candidate+            }++        countDestructiveConversions :: [Rate] -> Infer s Int+        countDestructiveConversions rates = foldM countConversion 0 $ zip rates args++        countConversion :: Int -> (Rate, PrimOr Int) -> Infer s Int+        countConversion total (targetRate, arg) = do+          argVar <- mapM (getVar targetRate) arg+          let opcodeArg =+                OpcodeArg+                  { opcodeTo = targetRate+                  , opcodeFrom = varType <$> argVar+                  }+          pure $ if not (destructiveConversion opcodeArg) || unifies opcodeArg+            then total+            else total + 1++        isFit (SignatureChoice score _candidate) = score == 0++        getBestFit (SignatureChoice scores candidate) = \case+          Just (SignatureChoice prevScores prevCandidate) | prevScores < scores -> (SignatureChoice prevScores prevCandidate)+          _ -> (SignatureChoice scores candidate)++    onConvertRate toRate mFromRate arg = do+      fromRate <- maybe (either primRate varType . unPrimOr <$> mapM (getVar Ir) arg) pure mFromRate+      save toRate (ConvertRate toRate (Just fromRate) (Var fromRate <$> arg))++    setXr = fmap (Var Xr)++    onSelect rate outId arg =+      save rate (Select rate outId (Var Xr <$> arg))++    onInitVar v arg = save (Exp.varRate v) =<< typedRhs+      where+        typedRhs = do+          argVar <- mapM (getVar Ir) arg+          pure (InitVar v argVar)++    onReadVar v = save (Exp.varRate v) (ReadVar v)++    onWriteVar v arg = saveProcedure =<< typedRhs+      where+        typedRhs = do+          argVar <- mapM (getVar (Exp.varRate v)) arg+          pure $ WriteVar v argVar++    onExpNum args = do+      argVars <- mapM (mapM $ getVar Ir) args+      save (numRate argVars) (ExpNum argVars)+      where+        numRate :: NumExp (PrimOr Var) -> Rate+        numRate e = max Ar $ getMin $ foldMap (Min . primOrRate) e++    onIf ifRate cond th el = do+      setHasIfs+      thVar <- mapM (getVar condMaxRate) th+      elVar <- mapM (getVar condMaxRate) el+      let rate = min (primOrRate thVar ) (primOrRate elVar)+      condVar <- mapM (mapM $ getVar condMaxRate) cond+      condVarSafe <- insertBoolConverters condMaxRate condVar+      case ifRate of+        IfIr -> saveIr rate condVarSafe thVar elVar+        IfKr -> saveKr rate condVarSafe thVar elVar+      where+        condMaxRate = fromIfRate ifRate++        saveIr rate condVarSafe thVar elVar+          | rate < Ir = do+              thVar1 <- convertIf Ir thVar+              elVar1 <- convertIf Ir elVar+              save Ir (If ifRate condVarSafe thVar1 elVar1)+          | otherwise = save rate (If ifRate condVarSafe thVar elVar)++        saveKr rate condVarSafe thVar elVar+          | rate == Ir = do+              thVar1 <- convertIf Kr thVar+              elVar1 <- convertIf Kr elVar+              save Kr (If ifRate condVarSafe thVar1 elVar1)+          | otherwise  = save rate (If ifRate condVarSafe thVar elVar)++    onIfBlock = onIfBlockBy IfBlock++    onUntilBlock = onIfBlockBy UntilBlock++    onWhileBlock = onIfBlockBy WhileBlock++    onWhileRefBlock var th = do+      setHasIfs+      saveProcedure (WhileRefBlock var (fmap (Var Xr) <$> th))++    onIfBlockBy cons ifRate cond th = do+      setHasIfs+      condVar <- mapM (mapM $ getVar condMaxRate) cond+      condVarSafe <- insertBoolConverters condMaxRate condVar+      saveProcedure (cons ifRate condVarSafe (fmap (Var Xr) <$> th))+      where+        condMaxRate = fromIfRate ifRate++    onIfElseBlock ifRate cond th el = do+      setHasIfs+      condVar <- mapM (mapM $ getVar condMaxRate) cond+      condVarSafe <- insertBoolConverters condMaxRate condVar+      saveProcedure (IfElseBlock ifRate condVarSafe (fmap (Var Xr) <$> th) (fmap (Var Xr) <$> el))+      where+        condMaxRate = fromIfRate ifRate++    onIfBegin ifRate cond = do+      setHasIfs+      ifBeginBy IfBegin ifRate cond++    onWhileBegin = ifBeginBy WhileBegin+    onUntilBegin = ifBeginBy UntilBegin++    ifBeginBy cons ifRate cond = do+      condVar <- mapM (mapM $ getVar condMaxRate) cond+      condVarSafe <- insertBoolConverters condMaxRate condVar+      saveProcedure (cons ifRate condVarSafe)+      where+        condMaxRate = fromIfRate ifRate++    -------------------------------------------------------------+    -- arrays++    onInitArr v arrSize = do+      typedArrSize <- mapM (mapM (getVar Ir)) arrSize+      saveProcedure (InitArr v typedArrSize)++    onReadArr v index = save (Exp.varRate v) . ReadArr v =<< typedIndex+      where+        indexRate = getArrIndexRate v+        typedIndex = mapM (mapM (getVar indexRate)) index++    onWriteArr v index arg = do+      typedIndex <- mapM (mapM (getVar indexRate)) index+      argVar <- mapM (getVar (Exp.varRate v)) arg+      saveProcedure (WriteArr v typedIndex argVar)+      where+        indexRate = getArrIndexRate v++    onWriteInitArr v arrSize initVal = do+      typedArrSize <- mapM (mapM (getVar Ir)) arrSize+      typedInitVal <- mapM (getVar (Exp.varRate v)) initVal+      saveProcedure (WriteInitArr v typedArrSize typedInitVal)++    getArrIndexRate v=+      case Exp.varRate v of+        Ir -> Ir+        Sr -> Ir+        _  -> Kr++    onTfmArr isArrInit vout info args = do+      typedArgs <- getTypedArrArgs args+      saveProcedure (TfmArr isArrInit vout info typedArgs)+      where+        outRate = Exp.varRate vout++        inRates =+          case infoSignature info of+            SingleRate rateMap ->+              case Map.lookup outRate rateMap of+                Just res -> res+                Nothing -> toError "Rate conversion is not supported for arrays"+            MultiRate _ _ -> toError "Arrays with multiple argument s are not supported"+          where+            toError msg = error (unwords [msg, "Found on array opcode", Text.unpack $ infoName info])++        getTypedArrArgs ins = zipWithM applyArg inRates ins++    -------------------------------------------------------------+    -- pure (read-only) arrays++    onInitPureArr outRate processingRate initVals = do+      typedInits <- mapM (mapM (getVar initRate)) initVals+      save (toArrRate outRate) (InitPureArr outRate processingRate typedInits)+      where+        initRate = fromIfRate processingRate++    onReadPureArr outRate processingRate arr index = do+      typedIndex <- mapM (getVar initRate) index+      typedArr <- mapM (getVar outRate) arr+      save outRate (ReadPureArr outRate processingRate typedArr typedIndex)+      where+        initRate = fromIfRate processingRate++    -------------------------------------------------------------+    -- generic funs++    save :: Rate -> Exp Var -> Infer s ()+    save rate typedRhs =+      saveStmt $ Stmt+        { stmtLhs = Var rate lhs+        , stmtRhs = rhs { ratedExpExp = typedRhs }+        }++    -- procedure does not save output rate to type map, as it's never going to+    -- be referenced from any right hand side of the expression+    --+    -- Procedures always have Xr as output rate+    saveProcedure :: Exp Var -> Infer s ()+    saveProcedure typedRhs =+      appendResult $ Stmt+        { stmtLhs = Var Xr lhs+        , stmtRhs = rhs { ratedExpExp = typedRhs }+        }++-------------------------------------------------------------+-- generic funs++setType :: Var -> Infer s ()+setType (Var rate name) = do+  typeMap <- gets envTypeMap+  Vector.write typeMap name rate++appendResult :: Stmt Var -> Infer s ()+appendResult expr = modify' $ \s -> s { envResult = expr : envResult s }++data SignatureChoice = SignatureChoice+  { destructiveConversionsCount :: !Int+  , signatureCandidate          :: !OpcSignature+  }++data OpcodeArg = OpcodeArg+  { opcodeTo   :: !Rate+  , opcodeFrom :: !(PrimOr Rate)+  }++unifies :: OpcodeArg -> Bool+unifies (OpcodeArg to (PrimOr from)) =+  case to of+    Xr -> True+    Ar -> is Ar+    Kr -> is Kr || is Ir || isPrim+    Ir -> is Ir+    _  -> is to+  where+    is r = either primRate id from == r++    isPrim = either (const True) (const False) from++-- | Checks if opcode conversion is destructive+-- Note that we rely on Haskell type-checker and don't consider+-- cases of type-mismatch lke comparing number with string.+--+-- There are two cases of destructive updates:+--+-- * Ar or Kr is converted to Ir+-- * Ar is converted to Kr+destructiveConversion :: OpcodeArg -> Bool+destructiveConversion (OpcodeArg to (PrimOr from)) =+  case to of+    Ir -> fromRate /= Ir+    Kr -> fromRate == Ar+    _  -> False+  where+    fromRate = either primRate id from++applyArg :: Rate -> PrimOr Int -> Infer s (PrimOr Var)+applyArg targetRate arg = do+  argVar <- mapM (getVar Ir) arg+  let opcArg =+        OpcodeArg+          { opcodeTo = targetRate+          , opcodeFrom = varType <$> argVar+          }+  if unifies opcArg+    then pure argVar+    else PrimOr . Right <$> convert (opcodeTo opcArg) argVar++-------------------------------------------------------------------+-- utils++getVar :: Rate -> Int -> Infer s Var+getVar _defaultRate vid = do+  types <- gets envTypeMap+  ty <- Vector.read types vid+  pure (Var ty vid)++convert :: Rate -> PrimOr Var -> Infer s Var+convert toRate (PrimOr fromVar) = do+  case fromVar of+    Left p  -> convertPrim p+    Right v -> convertVar v+  where+    convertPrim :: Prim -> Infer s Var+    convertPrim prim = do+      primMap <- gets envPrims+      v <- case Map.lookup prim primMap of+        Just v  -> pure v+        Nothing -> allocatePrim prim+      convertVar v++    convertVar :: Var -> Infer s Var+    convertVar inVar = do+      mOutVar <- tryExistingConverters inVar+      case mOutVar of+        Just outVar -> pure outVar+        Nothing     -> do+          let rhs = newExp $ ConvertRate toRate (Just $ varType inVar) (PrimOr $ Right inVar)+          outVar <- defineVar toRate rhs+          saveConversion outVar inVar+          pure outVar++    tryExistingConverters :: Var -> Infer s (Maybe Var)+    tryExistingConverters (Var _ name) = do+      convMap <- gets envConversions+      pure $ Map.lookup toRate =<< IntMap.lookup name convMap++    allocatePrim :: Prim -> Infer s Var+    allocatePrim prim = do+      var <- defineVar (primRate prim) (newExp $ ExpPrim prim)+      modify' $ \s -> s { envPrims = Map.insert prim var $ envPrims s }+      pure var++-- | Checks if convertion is identity, then returns original+convertIf :: Rate -> PrimOr Var -> Infer s (PrimOr Var)+convertIf toRate var+  | toRate == primOrRate var = pure var+  | otherwise                = PrimOr . Right <$> convert toRate var++newExp :: Exp a -> RatedExp a+newExp rhs =+  RatedExp+    { ratedExpHash = ignoreHash+    , ratedExpRate = Nothing+    , ratedExpDepends = Nothing+    , ratedExpExp = rhs+    }++-- | On this stage we don't need expression hashes anymore+ignoreHash :: ByteString+ignoreHash = ""++-- | Allocate new var and assign RHS expression to it+defineVar :: Rate -> RatedExp Var -> Infer s Var+defineVar rate rhs = do+  v <- freshVar rate+  appendResult (Stmt v rhs)+  pure v++-- | Allocate fresh variable with given rate+freshVar :: Rate -> Infer s Var+freshVar rate = Var rate <$> freshId++-- | Allocate new fresh id+freshId :: Infer s Int+freshId = do+  lastFreshId <- gets envLastFreshId+  modify' $ \s -> s { envLastFreshId = lastFreshId + 1 }+  pure lastFreshId++insertBoolConverters :: Rate -> CondInfo (PrimOr Var) -> Infer s (CondInfo (PrimOr Var))+insertBoolConverters ifRate = mapM (mapM go)+  where+    go :: Var -> Infer s Var+    go v+      | ifRate >= varType v = pure v+      | otherwise           = convert ifRate (PrimOr $ Right v)++saveStmt :: Stmt Var -> Infer s ()+saveStmt expr = do+  setType (stmtLhs expr)+  appendResult expr++saveConversion :: Var -> Var -> Infer s ()+saveConversion outVar inVar =+  modify' $ \s -> s { envConversions = update $ envConversions s }+  where+    update conversionMap = IntMap.alter go (varId inVar) conversionMap++    go = Just . \case+      Nothing -> Map.singleton (varType outVar) outVar+      Just m  -> Map.insert (varType outVar) outVar m++setHasIfs :: Infer s ()+setHasIfs = modify' $ \s -> s { envHasIfs = True }++----------------------------------------------------------------+-- rate calculations++primRate :: Prim -> Rate+primRate = \case+  PrimString _ -> Sr+  PrimVar r _  -> r+  _            -> Ir++primOrRate :: PrimOr Var -> Rate+primOrRate = either primRate varType . unPrimOr

@@ -1,3 +1,5 @@+-- | Analyses variable for reusal.+-- So that we spend less memory and allocate lesser variables and audio vectors. module Csound.Dynamic.Tfm.Liveness (     liveness ) where@@ -7,22 +9,20 @@ import Control.Monad.Trans.State.Strict import Data.Traversable import Data.Foldable-import qualified Data.Map as M  import Control.Monad.Trans.Class import Control.Monad hiding (mapM, mapM_) import Control.Monad.ST-import qualified Data.Array.Unboxed as A-import qualified Data.Array.MArray as A-import qualified Data.Array.ST as A+import Data.Vector.Unboxed.Mutable qualified as UVector -import qualified Csound.Dynamic.Tfm.DeduceTypes as D-import Csound.Dynamic.Tfm.DeduceTypes(varType, varId)+import Csound.Dynamic.Tfm.InferTypes (Var (..)) import Csound.Dynamic.Types.Exp(Rate(..)) +-- | Reuses variables. It analyses weather the vraibel is used further+-- in the code and if it's not used it tries to reuse it for the next assignments liveness :: Traversable f => Int -> Dag f -> Dag f liveness lastFreshId as = runST $ do-  st <- initSt lastFreshId $ analyse lastFreshId as+  st <- initSt lastFreshId =<< analyse lastFreshId as   evalStateT (mapM substExp $ countLines $ as) st  type LineNumber = Int@@ -30,8 +30,6 @@ countLines :: [a] -> [(LineNumber, a)] countLines = zip [0 ..] -type Var  = D.Var Rate- type Lhs   = [Var] type Rhs f = f Var type Exp f = (Lhs, Rhs f)@@ -41,11 +39,14 @@ -----------------------------------------------  data IdList = IdList-    [Int] -- fresh ids-    Int   -- the biggest used id+    [Int] -- fresh ids (always infinite list)+    !Int   -- the biggest used id  allocId :: IdList -> (Int, IdList)-allocId (IdList is lastId) = (head is, IdList (tail is) (max (head is) lastId))+allocId (IdList is lastId) =+  case  is of+    hd : tl -> (hd, IdList tl (max hd lastId))+    [] -> error "impossible: list of IDs is always infinite"  freeId :: Int -> IdList -> IdList freeId  n (IdList is lastId) = IdList (insertSorted n is) lastId1@@ -58,108 +59,123 @@   | otherwise = a : insertSorted n as insertSorted n [] = [n] +initIdList :: IdList+initIdList = IdList [0..] 0+ ----------------------------------------------- -type StArr s = A.STUArray s Int Int+type StArr s = UVector.STVector s Int -type LivenessTable = A.UArray Int Int-type SubstTable s  = StArr s+type LivenessTable s = UVector.STVector s Int+type SubstTable s    = StArr s  data Registers s = Registers-  { registers     :: M.Map Rate IdList-  , livenessTable :: LivenessTable-  , substTable    :: SubstTable s+  { arRegisters   :: !IdList+  , krRegisters   :: !IdList+  , livenessTable :: !(LivenessTable s)+  , substTable    :: !(SubstTable s)   }  type Memory s a = StateT (Registers s) (ST s) a -onRegs ::  (M.Map Rate IdList -> M.Map Rate IdList) -> (Registers s -> Registers s)-onRegs f rs = rs { registers = f $ registers rs }+onRegs :: Rate -> (IdList -> IdList) -> Memory s ()+onRegs rate f = modify' $ \rs ->+  case rate of+    Ar -> rs { arRegisters = f $ arRegisters rs }+    Kr -> rs { krRegisters = f $ krRegisters rs }+    _  -> rs -initRegs :: M.Map Rate IdList-initRegs = M.fromList $ fmap (\x -> (x, initIdList)) [(minBound :: Rate) .. maxBound]-  where initIdList = IdList [0..] 0+setArRegisters :: IdList -> Memory s ()+setArRegisters ids = modify' $ \s -> s { arRegisters = ids } +setKrRegisters :: IdList -> Memory s ()+setKrRegisters ids = modify' $ \s -> s { krRegisters = ids }++ isAlive :: LineNumber -> Var -> Memory s Bool isAlive lineNum v = do   tab <- fmap livenessTable get-  return $ lineNum < tab A.! (varId v)+  lastUsage <- UVector.read tab (varId v)+  pure $ lineNum < lastUsage  lookUpSubst :: Int -> Memory s Int lookUpSubst i = do   tab <- fmap substTable get-  lift $ A.readArray tab i+  lift $ UVector.read tab i  saveSubst :: Int -> Int -> Memory s () saveSubst from to = do   tab <- fmap substTable get-  lift $ A.writeArray tab from to+  lift $ UVector.write tab from to  substLhs :: Var -> Memory s Var-substLhs v = do-  v1 <- allocAndSkipInits v+substLhs = onlyForAK $ \v -> do+  v1 <- alloc v   saveSubst (varId v) (varId v1)   return v1  substRhs :: LineNumber -> Var -> Memory s Var-substRhs lineNum v = do+substRhs lineNum = onlyForAK $ \v -> do   i1 <- lookUpSubst (varId v)-  let v1 = D.Var i1 (varType v)+  let v1 = Var (varType v) i1   b <- isAlive lineNum v   unless b $ free v1   return v1 -allocAndSkipInits :: Var -> Memory s Var-allocAndSkipInits v-    | isInit r  = return v-    | otherwise = alloc r-    where-        r = varType v-        isInit x = x == Ir || x == Sr--alloc :: Rate -> Memory s Var-alloc rate = state $ \mem ->-  let (i, mem1) = allocRegister rate mem-  in  (D.Var i rate, mem1)+alloc :: Var -> Memory s Var+alloc v =+  case varType v of+    Ar -> allocBy arRegisters setArRegisters+    Kr -> allocBy krRegisters setKrRegisters+    _  -> pure v   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+    allocBy extract update = do+      ids <- gets extract+      let (name, newIds) = allocId ids+      void $ update newIds+      pure (Var (varType v) name)  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+free (Var rate name) = onRegs rate (freeId name)  -------------------------------------------------------------------------- -analyse :: Traversable f => Int -> Dag f -> LivenessTable-analyse lastFreshId as = A.runSTUArray $ do-  arr <- A.newArray (0, lastFreshId) 0+analyse :: Traversable f => Int -> Dag f -> ST s (LivenessTable s)+analyse lastFreshId as = do+  arr <- UVector.replicate 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 ()+    go arr (lineNum, (_, rhs)) = mapM_ (countVar arr lineNum) rhs      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 arr lineNum v+      | isAOrK v  = UVector.write arr (varId v) lineNum+      | otherwise = pure () +onlyForAK :: Monad f => (Var -> f Var) -> Var -> f Var+onlyForAK go v+  | isAOrK v  = go v+  | otherwise = pure v++-- we optimise for livenes only for Ar and Kr variables+isAOrK :: Var -> Bool+isAOrK v =+  case varType v of+    Ar -> True+    Kr -> True+    _  -> False+ 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) -initSt :: Int -> LivenessTable -> ST s (Registers s)-initSt lastFreshId livenessTab = fmap (Registers initRegs livenessTab) (initSubstTable lastFreshId)+initSt :: Int -> LivenessTable s -> ST s (Registers s)+initSt lastFreshId livenessTab = fmap (Registers initIdList initIdList livenessTab) (initSubstTable lastFreshId)  initSubstTable :: Int ->  ST s (SubstTable s)-initSubstTable n = A.newListArray (0, n+1) [0 .. n + 1]+initSubstTable n = UVector.generate (n + 1) id 

@@ -1,70 +1,86 @@ {-# Language TupleSections #-} module Csound.Dynamic.Tfm.UnfoldMultiOuts(-    unfoldMultiOuts, UnfoldMultiOuts(..), Selector(..)+  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 qualified Data.IntMap.Strict as IM+import Data.Either (partitionEithers) -import Csound.Dynamic.Tfm.DeduceTypes(Var(..))+import Csound.Dynamic.Tfm.InferTypes(Var(..), Stmt(..), InferenceResult(..))+import Csound.Dynamic.Types.Exp hiding (Var (..))+import Csound.Dynamic.Build(getRates, isMultiOutSignature)  type ChildrenMap = IM.IntMap [Port] -lookupChildren :: ChildrenMap -> Var a -> [Port]+lookupChildren :: ChildrenMap -> Var -> [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, +mkChildrenMap :: [(Var, Selector)] -> ChildrenMap+mkChildrenMap = IM.fromListWith (++) . fmap extract+    where extract (var, sel) = (varId $ selectorParent sel,                                 return $ Port (varId var) (selectorOrder sel)) -data Port = Port +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 }+type SingleStmt = Stmt Var+type MultiStmt  = ([Var], RatedExp Var) -data UnfoldMultiOuts f a = UnfoldMultiOuts {-    getSelector    :: f (Var a) -> Maybe (Selector a),-    getParentTypes :: f (Var a) -> Maybe [a] }+data Selector = Selector+    { selectorParent  :: Var+    , selectorOrder   :: Int+    } -unfoldMultiOuts :: UnfoldMultiOuts f a -> Int -> [SingleStmt f a] -> ([MultiStmt f a], Int)-unfoldMultiOuts algSpec lastFreshId stmts = runState 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)+unfoldMultiOuts :: InferenceResult -> ([MultiStmt], Int)+unfoldMultiOuts InferenceResult{..} = runState st programLastFreshId+    where+      (noSelectorStmts, selectors) = partitionEithers $+        fmap (\stmt@(Stmt lhs rhs) -> maybe (Left stmt) (Right . (lhs, )) $ getSelector rhs) typedProgram+      st = mapM (unfoldStmt $ mkChildrenMap selectors) $ noSelectorStmts -unfoldStmt :: UnfoldMultiOuts f a -> ChildrenMap -> SingleStmt f a -> State Int (MultiStmt f a)-unfoldStmt algSpec childrenMap (lhs, rhs) = case getParentTypes algSpec rhs of+unfoldStmt :: ChildrenMap -> SingleStmt -> State Int MultiStmt+unfoldStmt childrenMap (Stmt lhs rhs) = case getParentTypes 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 -> +formLhs :: [Port] -> [Rate] -> State Int [Var]+formLhs ports types = fmap (zipWith 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  -                                +          outputArity = length types+          inUsePortsSize = length ports+           fillMissingPorts :: Int -> Port -> State Int [Int]           fillMissingPorts lastFreshId port = state $ \s ->                 if s == order-                then ([e], next) +                then ([e], next)                 else (fmap (+ lastFreshId) [s .. order - 1] ++ [e], next)             where e = portId port-                  order = portOrder port                  +                  order = portOrder port                   next = order + 1 +-----------------------------------------------------------------------+-- unfolds multiple rates generic functions++getSelector :: RatedExp Var -> Maybe Selector+getSelector x =+  case ratedExpExp x of+    Select _ order (PrimOr (Right parent)) -> Just $ Selector parent order+    _ -> Nothing++getParentTypes :: RatedExp Var -> Maybe [Rate]+getParentTypes x =+  case ratedExpExp x of+    Tfm i _ -> if (isMultiOutSignature $ infoSignature i)+                then Just (getRates $ ratedExpExp x)+                else Nothing+    _ -> Nothing

@@ -11,4 +11,3 @@ import Csound.Dynamic.Types.Dep import Csound.Dynamic.Types.Flags import Csound.Dynamic.Types.CsdFile-

@@ -7,34 +7,35 @@  import Csound.Dynamic.Types.Exp import Csound.Dynamic.Types.Flags+import Data.Text (Text)  data Csd = Csd-    { csdFlags   :: Flags-    , csdOrc     :: Orc-    , csdSco     :: Sco-    , csdPlugins :: [Plugin]+    { csdFlags   :: !Flags+    , csdOrc     :: !Orc+    , csdSco     :: !Sco+    , csdPlugins :: ![Plugin]     }  data Orc = Orc-    { orcHead           :: InstrBody-    , orcInstruments    :: [Instr]+    { orcHead           :: !InstrBody+    , orcInstruments    :: ![Instr]     }  type InstrBody = E  data Instr = Instr-    { instrName :: InstrId-    , instrBody :: InstrBody+    { instrName :: !InstrId+    , instrBody :: !InstrBody     }  data Sco = Sco-    { scoTotalDur   :: Maybe Double-    , scoGens       :: [(Int, Gen)]-    , scoNotes      :: [(InstrId, [CsdEvent])]  }+    { scoTotalDur   :: !(Maybe Double)+    , scoGens       :: ![(Int, Gen)]+    , scoNotes      :: ![(InstrId, [CsdEvent])]  }  data Plugin = Plugin-    { pluginName    :: String-    , pluginContent :: String+    { pluginName    :: !Text+    , pluginContent :: !Text     }  ----------------------------------------------------------------@@ -48,7 +49,6 @@  alwaysOn :: InstrId -> (InstrId, [CsdEvent]) alwaysOn instrId = (instrId, [(0, -1, [])])-  -- | The Csound note. It's a triple of --

@@ -3,7 +3,7 @@ module Csound.Dynamic.Types.Dep(     DepT(..), LocalHistory(..), runDepT, execDepT, evalDepT,     -- * Dependencies-    depT, depT_, mdepT, stripDepT, stmtOnlyT,+    depT, depT_, mdepT, stripDepT, stmtOnlyT, toBlock, depends,      -- * Variables     newLocalVar, newLocalVars,@@ -28,6 +28,8 @@ import Data.Default  import Data.Fix(Fix(..))+import Data.Text (Text)+import Data.Text qualified as Text  import Csound.Dynamic.Types.Exp @@ -39,24 +41,52 @@ newtype DepT m a = DepT { unDepT :: StateT LocalHistory m a }  data LocalHistory = LocalHistory-    { expDependency :: E-    , newLineNum    :: Int-    , newLocalVarId :: Int }+    { expDependency :: !E+    , newLineNum    :: !Int+    , newLocalVarId :: !Int }  instance Default LocalHistory where-    def = LocalHistory start 0 0+    def = LocalHistory (noRate Starts) 0 0  instance Monad m => Functor (DepT m) where     fmap = liftM  instance Monad m => Applicative (DepT m) where-    pure = return+    pure = DepT . return     (<*>) = ap  instance Monad m => Monad (DepT m) where-    return = DepT . return-    ma >>= mf = DepT $ unDepT ma >>= unDepT . mf+    ma >>= mf = -- DepT $ unDepT ma >>= unDepT . mf+      DepT $ StateT $ \s -> do+        (aE, aS) <- runStateT (unDepT ma) (startSt s)+        (bE, bS) <- runStateT (unDepT (mf aE)) (startSt aS)+        pure (bE, setDeps bS aS)+      where+        startSt s = s+          { expDependency = rehashE $ Fix $ (unFix $ noRate Starts) { ratedExpDepends = Just (newLineNum s) }+          , newLineNum = succ $ newLineNum s+          } +        setDeps bS aS = bS+          { expDependency = depends (expDependency aS) (expDependency bS)+          , newLineNum = succ $ newLineNum bS+          }+++{-+ifT1 :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m E+ifT1 ifRate check (DepT th) = DepT $ StateT $ \s -> do+  (_thE, thS)  <- runStateT th s+  let thDeps = expDependency thS+      a  = noRate $ IfBlock ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thDeps)+      a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum thS) }+      s1 = thS+            { newLineNum = succ $ newLineNum thS+            , expDependency = a1+            -- depends (expDependency thS) (depends (expDependency elS) a1)+            }+  pure (a1, s1)+-} instance MonadTrans DepT where     lift ma = DepT $ lift ma @@ -71,24 +101,42 @@  -- dependency tracking -start :: E-start = noRate Starts- depends :: E -> E -> E-depends a1 a2 = noRate $ Seq (toPrimOr a1) (toPrimOr a2)+depends a1 a2 =+  case ratedExpExp (unFix a2) of+    Starts -> a1+    _ ->+      case ratedExpExp (unFix a1) of+        Starts -> a2+        _      -> noRate $ Seq (toPrimOr a1) (toPrimOr a2)  depT :: Monad m => E -> DepT m E depT a = DepT $ do     s <- get-    let a1 = Fix $ (unFix a) { ratedExpDepends = Just (newLineNum s) }+    let a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum s) }     put $ s {-        newLineNum = succ $ newLineNum s,-        expDependency = depends (expDependency s) a1 }+        newLineNum = succ $ newLineNum s -- ,+        -- expDependency = depends (expDependency s) a1+        }     return a1  depT_ :: (Monad m) => E -> DepT m ()-depT_ = fmap (const ()) . depT+depT_ a = -- fmap (const ()) . depT+  DepT $ do+    s <- get+    let a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum s) }+    put $ s {+        newLineNum = succ $ newLineNum s,+        expDependency = depends (expDependency s) a1+        }+    return () ++toBlock :: Monad m => DepT m () -> DepT m (CodeBlock E)+toBlock (DepT act) = DepT $ do+  act+  CodeBlock <$> gets expDependency+ mdepT :: (Monad m) => MultiOut [E] -> MultiOut (DepT m [E]) mdepT mas = \n -> mapM depT $ ( $ n) mas @@ -115,7 +163,7 @@ newVar :: Monad m => Rate -> DepT m Var newVar rate = DepT $ do     s <- get-    let v = Var LocalVar rate (show $ newLocalVarId s)+    let v = Var LocalVar rate (Text.pack $ show $ newLocalVarId s)     put $ s { newLocalVarId = succ $ newLocalVarId s }     return v @@ -134,7 +182,7 @@ readOnlyVar v = noRate $ ReadVar v  initVar :: Monad m => Var -> E -> DepT m ()-initVar v x = depT_ $ setRate Ir $ noRate $ InitVar v $ toPrimOr x+initVar v x = depT_ $ noRate $ InitVar v $ toPrimOr $ setRate Ir x  appendVarBy :: Monad m => (E -> E -> E) -> Var -> E -> DepT m () appendVarBy op v x = writeVar v . op x =<< readVar v@@ -176,28 +224,28 @@ -------------------------------------------------- -- read global macros arguments -readMacrosDouble :: String -> E+readMacrosDouble :: Text -> E readMacrosDouble = readMacrosBy ReadMacrosDouble Ir -readMacrosInt :: String -> E+readMacrosInt :: Text -> E readMacrosInt = readMacrosBy ReadMacrosInt Ir -readMacrosString :: String -> E+readMacrosString :: Text -> E readMacrosString = readMacrosBy ReadMacrosString Sr -initMacrosDouble :: Monad m => String -> Double -> DepT m ()+initMacrosDouble :: Monad m => Text -> Double -> DepT m () initMacrosDouble = initMacrosBy InitMacrosDouble -initMacrosString :: Monad m => String -> String -> DepT m ()+initMacrosString :: Monad m => Text -> Text -> DepT m () initMacrosString = initMacrosBy InitMacrosString -initMacrosInt :: Monad m => String -> Int -> DepT m ()+initMacrosInt :: Monad m => Text -> Int -> DepT m () initMacrosInt = initMacrosBy InitMacrosInt -readMacrosBy :: (String -> Exp E) -> Rate -> String -> E+readMacrosBy :: (Text -> Exp E) -> Rate -> Text -> E readMacrosBy readMacro rate name = withRate rate $ readMacro name -initMacrosBy :: Monad m => (String -> a -> Exp E) -> String -> a -> DepT m ()+initMacrosBy :: Monad m => (Text -> a -> Exp E) -> Text -> a -> DepT m () initMacrosBy maker name value = depT_ $ noRate $ maker name value  

@@ -8,51 +8,55 @@         TemplateHaskell,         CPP #-} module Csound.Dynamic.Types.Exp(-    E, RatedExp(..), isEmptyExp, RatedVar, ratedVar, ratedVarRate, ratedVarId,+    E, RatedExp(..), isEmptyExp,     ratedExp, noRate, withRate, setRate,+    toArrRate, removeArrRate,     Exp, toPrimOr, toPrimOrTfm, PrimOr(..), MainExp(..), Name,     InstrId(..), intInstrId, ratioInstrId, stringInstrId,     VarType(..), Var(..), Info(..), OpcFixity(..), Rate(..),+    CodeBlock (..),     Signature(..), isInfix, isPrefix,     Prim(..), Gen(..), GenId(..),     Inline(..), InlineExp(..), PreInline(..),     BoolExp, CondInfo, CondOp(..), isTrue, isFalse,     NumExp, NumOp(..), Note,     MultiOut,-    IsArrInit, ArrSize, ArrIndex+    IsArrInit, ArrSize, ArrIndex,+    IfRate(..), fromIfRate,+    hashE,+    rehashE, ) where  #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif+import Crypto.Hash.SHA256 qualified as Crypto  import GHC.Generics (Generic, Generic1) import Data.Traversable-import Data.Foldable hiding (concat)--import Data.Hashable+import Data.ByteString (ByteString) -import Data.Map(Map)+import Data.Map.Strict (Map) import Data.Maybe(isNothing)-import qualified Data.IntMap as IM+import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Internal as IM import Data.Fix import Data.Eq.Deriving import Data.Ord.Deriving import Text.Show.Deriving-import Data.Hashable.Lifted--import qualified Csound.Dynamic.Tfm.DeduceTypes as R(Var(..))+import Data.Text (Text)+import Data.Serialize qualified as Cereal+import Data.Serialize.Text () -type Name = String+type Name = Text type LineNum = Int  -- | An instrument identifier data InstrId     = InstrId-    { instrIdFrac :: Maybe Int-    , instrIdCeil :: Int }-    | InstrLabel String+    { instrIdFrac :: !(Maybe Int)+    , instrIdCeil :: !Int }+    | InstrLabel Text     deriving (Show, Eq, Ord, Generic)  -- | Constructs an instrument id with the integer.@@ -64,40 +68,35 @@ ratioInstrId beforeDot afterDot = InstrId (Just $ afterDot) beforeDot  -- | Constructs an instrument id with the string label.-stringInstrId :: String -> InstrId+stringInstrId :: Text -> InstrId stringInstrId = InstrLabel  -- | The inner representation of csound expressions. type E = Fix RatedExp  data RatedExp a = RatedExp-    { ratedExpRate      :: Maybe Rate+    { ratedExpHash      :: !ByteString+       -- ^ expression hash for fast comparison+    , ratedExpRate      :: !(Maybe Rate)         -- ^ Rate (can be undefined or Nothing,         -- it means that rate should be deduced automatically from the context)-    , ratedExpDepends   :: Maybe LineNum+    , ratedExpDepends   :: !(Maybe LineNum)         -- ^ Dependency (it is used for expressions with side effects,         -- value contains the privious statement)-    , ratedExpExp       :: Exp a+    , ratedExpExp       :: !(Exp a)         -- ^ Main expression-    } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1)---- | 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+    } deriving (Show, Functor, Foldable, Traversable, Generic, Generic1) --- | Querries a rate.-ratedVarRate :: RatedVar -> Rate-ratedVarRate = R.varType+instance Eq (RatedExp a) where+  (==) a b = ratedExpHash a == ratedExpHash b --- | Querries an integral identifier.-ratedVarId :: RatedVar -> Int-ratedVarId   = R.varId+instance Ord (RatedExp a) where+  compare a b = ratedExpHash a `compare` ratedExpHash b  ratedExp :: Maybe Rate -> Exp E -> E-ratedExp r = Fix . RatedExp r Nothing+ratedExp r expr = Fix $ RatedExp h r Nothing expr+  where+    h = Crypto.hash $ Cereal.encode $ fmap (fmap hashE) expr  noRate :: Exp E -> E noRate = ratedExp Nothing@@ -105,16 +104,40 @@ withRate :: Rate -> Exp E -> E withRate r = ratedExp (Just r) +hashE :: E -> ByteString+hashE (Fix expr) = ratedExpHash expr++-- | Call it on every change in underlying expression+rehashE :: E -> E+rehashE (Fix expr) = Fix $+  expr+    { ratedExpHash = Crypto.hash $ Cereal.encode $ fmap hashE expr+    }+ -- rate coversion  setRate :: Rate -> E -> E-setRate r a = Fix $ (\x -> x { ratedExpRate = Just r }) $ unFix a+setRate r a =+  case ratedExpExp $ unFix a of+    -- for Tfm we add rate to ratedExpRate hint+    Tfm _ _    -> Fix $ (unFix a) { ratedExpRate = Just r }+    -- conversion set's the rate for constants+    -- ExpPrim _  -> a+    ExpPrim _  -> Fix $ (unFix a) { ratedExpRate = Just r }+    -- don't convert rate twice+    ConvertRate _ b arg -> withRate r $ ConvertRate r b arg+    -- for booleans pass conversion over boolean operators+    ExpBool boolArg -> noRate $ ExpBool $ fmap (fmap (setRate r)) boolArg+    -- for other cases we insert rate conversion+    _          -> withRate r $ ConvertRate r Nothing (PrimOr $ Right a)  -- | 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, Generic, Generic1) +instance Cereal.Serialize a => Cereal.Serialize (PrimOr a)+ -- | Constructs PrimOr values from the expressions. It does inlining in -- case of primitive values. toPrimOr :: E -> PrimOr E@@ -141,72 +164,121 @@ -- Expressions with inlining. type Exp a = MainExp (PrimOr a) +newtype CodeBlock a = CodeBlock a+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1)+ -- Csound expressions data MainExp a     = EmptyExp     -- | Primitives-    | ExpPrim Prim+    | ExpPrim !Prim     -- | Application of the opcode: we have opcode information (Info) and the arguments [a]-    | Tfm Info [a]+    | Tfm Info ![a]     -- | Rate conversion-    | ConvertRate Rate Rate a+    | ConvertRate !Rate !(Maybe 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+    | Select !Rate !Int !a     -- | if-then-else-    | If (CondInfo a) a a+    | If !IfRate !(CondInfo a) !a !a     -- | Boolean expressions (rendered in infix notation in the Csound)-    | ExpBool (BoolExp a)+    | ExpBool !(BoolExp a)     -- | Numerical expressions (rendered in infix notation in the Csound)-    | ExpNum (NumExp a)+    | ExpNum !(NumExp a)     -- | Reading/writing a named variable-    | InitVar Var a-    | ReadVar Var-    | WriteVar Var a+    | InitVar !Var !a+    | ReadVar !Var+    | 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]+    | InitArr !Var !(ArrSize a)+    | ReadArr !Var !(ArrIndex a)+    | WriteArr !Var !(ArrIndex a) !a+    | WriteInitArr !Var !(ArrIndex a) !a+    | TfmArr !IsArrInit !Var !Info ![a]+    -- | inits 1-dimensional read only array (uses fillaray)+    -- args: rateOfTheOutput processingRate initValues+    | InitPureArr !Rate !IfRate ![a]+    -- | Reads read only array with index+    -- args: rateOfTheOutput processingRate array index+    | ReadPureArr !Rate !IfRate !a !a     -- | Imperative If-then-else-    | IfBegin Rate (CondInfo a)---  | ElseIfBegin (CondInfo a) -- It's expressed with nested if-else+    | IfBlock !IfRate !(CondInfo a) (CodeBlock a)+    | IfElseBlock !IfRate !(CondInfo a) (CodeBlock a) (CodeBlock a)+    | IfBegin !IfRate !(CondInfo a)     | ElseBegin     | IfEnd     -- | looping constructions-    | UntilBegin (CondInfo a)+    | UntilBlock !IfRate !(CondInfo a) (CodeBlock a)+    | UntilBegin !IfRate !(CondInfo a)     | UntilEnd-    | WhileBegin (CondInfo a)-    | WhileRefBegin Var+    | WhileBlock !IfRate !(CondInfo a) (CodeBlock a)+    | WhileBegin !IfRate !(CondInfo a)+    | WhileRefBlock !Var !(CodeBlock a)+    | WhileRefBegin !Var     | WhileEnd     -- | Verbatim stmt-    | Verbatim String+    | Verbatim !Text     -- | 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+    | InitMacrosInt !Text !Int+    | InitMacrosDouble !Text !Double+    | InitMacrosString !Text !Text+    | ReadMacrosInt !Text+    | ReadMacrosDouble !Text+    | ReadMacrosString !Text     deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1) +-- | Rate of if-then-else conditional.+-- It can run at Ir or Kr+data IfRate = IfIr | IfKr+  deriving (Show, Eq, Ord, Generic)++fromIfRate :: IfRate -> Rate+fromIfRate = \case+  IfKr -> Kr+  IfIr -> Ir++-- | Can be infinite so fe just ignore the value+instance Cereal.Serialize Signature where+  put = \_a -> pure ()+  get = undefined++instance Cereal.Serialize a => Cereal.Serialize (RatedExp a)+instance Cereal.Serialize Prim+instance Cereal.Serialize Rate+instance Cereal.Serialize IfRate+instance Cereal.Serialize Info+instance Cereal.Serialize OpcFixity+instance Cereal.Serialize InstrId+instance Cereal.Serialize CondOp+instance Cereal.Serialize NumOp+instance Cereal.Serialize Var+instance Cereal.Serialize VarType+instance Cereal.Serialize a => Cereal.Serialize (CodeBlock a)+instance Cereal.Serialize a => Cereal.Serialize (MainExp a)+instance (Cereal.Serialize a, Cereal.Serialize b) => Cereal.Serialize (Inline a b)+instance (Cereal.Serialize a, Cereal.Serialize b) => Cereal.Serialize (PreInline a b)+instance (Cereal.Serialize a) => Cereal.Serialize (InlineExp a)+ type IsArrInit = Bool++-- | Array sizes by demensions type ArrSize a = [a]++-- | Array multi index type ArrIndex a = [a]  -- Named variable data Var     = Var-        { varType :: VarType    -- global / local-        , varRate :: Rate-        , varName :: Name }+        { varType :: !VarType    -- global / local+        , varRate :: !Rate+        , varName :: !Name }     | VarVerbatim-        { varRate :: Rate-        , varName :: Name+        { varRate :: !Rate+        , varName :: !Name         } deriving (Show, Eq, Ord, Generic)  -- Variables can be global (then we have to prefix them with `g` in the rendering) or local.@@ -216,11 +288,11 @@ -- Opcode information. data Info = Info     -- Opcode name-    { infoName          :: Name+    { infoName          :: !Name     -- Opcode type signature-    , infoSignature     :: Signature+    , infoSignature     :: !Signature     -- Opcode can be infix or prefix-    , infoOpcFixity     :: OpcFixity+    , infoOpcFixity     :: !OpcFixity     } deriving (Show, Eq, Ord, Generic)  isPrefix, isInfix :: Info -> Bool@@ -243,8 +315,28 @@     | Fr    -- spectrum (for pvs opcodes)     | Wr    -- special spectrum     | Tvar  -- I don't understand what it is (fix me) used with Fr+    | ArArr -- array rates+    | KrArr+    | IrArr+    | SrArr     deriving (Show, Eq, Ord, Enum, Bounded, Generic) +toArrRate :: Rate -> Rate+toArrRate = \case+  Ar -> ArArr+  Kr -> KrArr+  Ir -> IrArr+  Sr -> SrArr+  other -> other++removeArrRate :: Rate -> Rate+removeArrRate = \case+  ArArr -> Ar+  KrArr -> Kr+  IrArr -> Ir+  SrArr -> Sr+  other -> other+ -- 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@@ -252,46 +344,37 @@ 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])+    = 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)--instance Hashable Signature where-    hashWithSalt s x = case x of-        SingleRate m -> s `hashWithSalt` (0 :: Int) `hashWithSalt` (hash $ fmap (\b -> (take 5 b)) $ head' $ toList m)-        MultiRate a b -> s `hashWithSalt` (1 :: Int) `hashWithSalt` (hash $ take 5 a) `hashWithSalt` (hash $ take 5 b)-        where-            head' xs = case xs of-                [] -> Nothing-                value:_ -> Just value+        { outMultiRate :: ![Rate]+        , inMultiRate  :: ![Rate] }+    deriving (Show, Eq, Ord, Generic)  -- Primitive values data Prim     -- instrument p-arguments-    = P Int-    | PString Int       -- >> p-string (read p-string notes at the bottom of the file):-    | PrimInt Int-    | PrimDouble Double-    | PrimString String-    | PrimInstrId InstrId+    = P !Int+    | PString !Int       -- >> p-string (read p-string notes at the bottom of the file):+    | PrimInt !Int+    | PrimDouble !Double+    | PrimString !Text+    | PrimInstrId !InstrId     | PrimVar-        { primVarTargetRate :: Rate-        , primVar           :: Var }+        { primVarTargetRate :: !Rate+        , primVar           :: !Var }     deriving (Show, Eq, Ord, Generic)  -- Gen routine. data Gen = Gen-    { genSize    :: Int-    , genId      :: GenId-    , genArgs    :: [Double]-    , genFile    :: Maybe String+    { genSize    :: !Int+    , genId      :: !GenId+    , genArgs    :: ![Double]+    , genFile    :: !(Maybe Text)     } deriving (Show, Eq, Ord, Generic) -data GenId = IntGenId Int | StringGenId String+data GenId = IntGenId !Int | StringGenId !Text     deriving (Show, Eq, Ord, Generic)  -- Csound note@@ -300,22 +383,19 @@ ------------------------------------------------------------ -- 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, Generic1)--instance (Hashable a, Hashable b) => Hashable (Inline a b) where-    hashWithSalt s (Inline a m) = s `hashWithSalt` (hash a) `hashWithSalt` (hash $ IM.toList m)+data Inline op arg = Inline+    { inlineExp :: !(InlineExp op)+    , inlineEnv :: !(IM.IntMap arg)+    } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic1, Generic)  -- Inlined expression.-data InlineExp a-    = InlinePrim Int-    | InlineExp a [InlineExp a]+data InlineExp op+    = InlinePrim !Int+    | InlineExp !op ![InlineExp op]     deriving (Show, Eq, Ord, Generic)  -- Expression as a tree (to be inlined)-data PreInline a b = PreInline a [b]+data PreInline a b = PreInline !a ![b]     deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1)  -- booleans@@ -364,62 +444,38 @@ -- | Multiple output. Specify the number of outputs to get the result. type MultiOut a = Int -> a - ------------------------------------------------------ -- hashable instances --instance (Hashable a, Hashable b) => Hashable (PreInline a b)-instance (Hashable a) => Hashable (InlineExp a)-instance Hashable CondOp-instance Hashable NumOp--instance Hashable Gen-instance Hashable GenId-instance Hashable Prim-instance Hashable Rate--instance Hashable OpcFixity-instance Hashable Info-instance Hashable VarType-instance Hashable Var--instance Hashable a => Hashable (MainExp a)-instance Hashable a => Hashable (PrimOr a)-instance Hashable a => Hashable (RatedExp a)-instance Hashable InstrId---#if !MIN_VERSION_hashable(1,3,4)-instance Hashable1 IM.IntMap-#endif-deriving instance Generic1 IM.IntMap-instance Hashable a => Hashable1 (PreInline a)-instance Hashable a => Hashable1 (Inline a)-instance Hashable1 RatedExp-instance Hashable1 MainExp-instance Hashable1 PrimOr- $(deriveEq1 ''PrimOr) $(deriveEq1 ''PreInline) $(deriveEq1 ''Inline)+$(deriveEq1 ''CodeBlock) $(deriveEq1 ''MainExp) $(deriveEq1 ''RatedExp)  $(deriveOrd1 ''PrimOr) $(deriveOrd1 ''PreInline) $(deriveOrd1 ''Inline)+$(deriveOrd1 ''CodeBlock) $(deriveOrd1 ''MainExp) $(deriveOrd1 ''RatedExp)  $(deriveShow1 ''PrimOr) $(deriveShow1 ''PreInline) $(deriveShow1 ''Inline)+$(deriveShow1 ''CodeBlock) $(deriveShow1 ''MainExp) $(deriveShow1 ''RatedExp) +deriving instance Generic1 IM.IntMap+ isEmptyExp :: E -> Bool-isEmptyExp (Fix re) = isNothing (ratedExpDepends re) && (ratedExpExp re == EmptyExp)+isEmptyExp (Fix re) = isNothing (ratedExpDepends re) &&+  (case ratedExpExp re of+    EmptyExp -> True+    _ -> False+  )  -------------------------------------------------------------- -- comments

@@ -30,8 +30,10 @@ import Data.Default import Data.Maybe import Data.Monoid+import Data.Text (Text)+import Data.Text qualified as Text -import Text.PrettyPrint.Leijen+import Text.PrettyPrint.Leijen.Text  mappendBool :: Bool -> Bool -> Bool mappendBool a b = getAny $ mappend (Any a) (Any b)@@ -46,7 +48,7 @@     , rtmidi            :: Maybe Rtmidi     , displays          :: Displays     , config            :: Config-    , flagsVerbatim     :: Maybe String+    , flagsVerbatim     :: Maybe Text     } deriving (Eq, Show, Read)  instance Default Flags where@@ -88,8 +90,8 @@ data AudioFileOutput = AudioFileOutput     { formatSamples     :: Maybe FormatSamples     , formatType        :: Maybe FormatType-    , output            :: Maybe String-    , input             :: Maybe String+    , output            :: Maybe Text+    , input             :: Maybe Text     , nosound           :: Bool     , nopeaks           :: Bool     , dither            :: Maybe Dither@@ -144,12 +146,12 @@ -- 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+    { idArtist      :: Maybe Text+    , idComment     :: Maybe Text+    , idCopyright   :: Maybe Text+    , idDate        :: Maybe Text+    , idSoftware    :: Maybe Text+    , idTitle       :: Maybe Text     } deriving (Eq, Show, Read)  instance Default IdTags where@@ -184,25 +186,25 @@ data Rtaudio     = PortAudio | Alsa     | Jack-        { jackClient    :: String-        , jackInport    :: String-        , jackOutport   :: String }+        { jackClient    :: Text+        , jackInport    :: Text+        , jackOutport   :: Text }     | Mme | CoreAudio     | NoRtaudio     deriving (Eq, Show, Read)  data PulseAudio = PulseAudio-    { paServer  :: String-    , paOutput  :: String-    , paInput   :: String+    { paServer  :: Text+    , paOutput  :: Text+    , paInput   :: Text     } deriving (Eq, Show, Read)  -- MIDI File Input/Ouput  data MidiIO = MidiIO-    { midiFile          :: Maybe String-    , midiOutFile       :: Maybe String-    , muteTracks        :: Maybe String+    { midiFile          :: Maybe Text+    , midiOutFile       :: Maybe Text+    , muteTracks        :: Maybe Text     , rawControllerMode :: Bool     , terminateOnMidi   :: Bool     } deriving (Eq, Show, Read)@@ -237,14 +239,14 @@ -- MIDI Realtime Input/Ouput  data MidiRT = MidiRT-    { midiDevice        :: Maybe String+    { midiDevice        :: Maybe Text     , midiKey           :: Maybe Int     , midiKeyCps        :: Maybe Int     , midiKeyOct        :: Maybe Int     , midiKeyPch        :: Maybe Int     , midiVelocity      :: Maybe Int     , midiVelocityAmp   :: Maybe Int-    , midiOutDevice     :: Maybe String+    , midiOutDevice     :: Maybe Text     } deriving (Eq, Show, Read)  instance Default MidiRT where@@ -347,12 +349,12 @@     , ioBuf         :: Maybe Int     , newKr         :: Maybe Int     , newSr         :: Maybe Int-    , scoreIn       :: Maybe String-    , omacro        :: Maybe (String, String)-    , smacro        :: Maybe (String, String)+    , scoreIn       :: Maybe Text+    , omacro        :: Maybe (Text, Text)+    , smacro        :: Maybe (Text, Text)     , setSched      :: Bool     , schedNum      :: Maybe Int-    , strsetN       :: Maybe (Int, String)+    , strsetN       :: Maybe (Int, Text)     , skipSeconds   :: Maybe Double     , setTempo      :: Maybe Int     } deriving (Eq, Show, Read)@@ -406,28 +408,25 @@             | otherwise         = Just res             where res = pretty x -bo :: String -> (a -> Bool) -> (a -> Maybe Doc)+bo :: Text -> (a -> Bool) -> (a -> Maybe Doc) bo property extract a-    | extract a = Just $ text property+    | extract a = Just $ textStrict 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)+mp :: Pretty b => (Doc -> Doc) -> (a -> Maybe b) -> (a -> Maybe Doc)+mp f a = fmap (f . pretty) . a -p1 :: String -> String -> String-p1 pref x = ('-' : pref) ++ (' ' : x)+p1 :: Doc -> Doc -> Doc+p1 pref x = hcat [char '-', pref, char ' ', x] -p2 :: String -> String -> String-p2 pref x = ('-' : '-' : pref) ++ ('=' : x)+p2 :: Doc -> Doc -> Doc+p2 pref x = hcat [char '-', char '-', pref, char '=', x] -p3 :: String -> String -> String-p3 pref x = ('-' : '+' : pref) ++ ('=' : x)+p3 :: Doc -> Doc -> Doc+p3 pref x = hcat [char '-', char '+', pref, char '=', x]  fields :: [a -> Maybe Doc] -> a -> Doc-fields fs a = hsep $ catMaybes $ fmap ( $ a) fs+fields fs a = hsep $ mapMaybe ( $ a) fs  instance Pretty Flags where     pretty = fields@@ -449,7 +448,7 @@         , mp (p2 "input")  input         , bo "--nosound" nosound         , bo "--nopeaks" nopeaks-        , mp (p2 "d/Mither") $ fmap (firstToLower . show) . dither ]+        , mp (p2 "d/Mither") $ fmap (firstToLower . Text.pack . show) . dither ]  pSamplesAndType :: (Maybe FormatSamples, Maybe FormatType) -> Maybe Doc pSamplesAndType (ma, mb) = fmap pretty $ case (ma, mb) of@@ -461,25 +460,26 @@         samplesToStr x = case x of             Bit24   -> "24bit"             FloatSamples -> "float"-            _   -> firstToLower $ show x+            _   -> textStrict $ firstToLower $ Text.pack $ show x -        typeToStr = firstToLower . show+        typeToStr = textStrict . firstToLower . Text.pack . show -        samplesAndTypeToStr a b = samplesToStr a ++ ":" ++ typeToStr b+        samplesAndTypeToStr a b = hcat [samplesToStr a, ":", typeToStr b]  instance Pretty Dither where-    pretty = pretty . p2 "dither" . show+    pretty = p2 "dither" . textStrict . Text.pack . 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 ]+        [ mp (p3 "id_artist")       (subst idArtist)+        , mp (p3 "id_comment")      (subst idComment)+        , mp (p3 "id_copyright")    (subst idCopyright)+        , mp (p3 "id_date")         (subst idDate)+        , mp (p3 "id_software")     (subst idSoftware)+        , mp (p3 "id_title")        (subst idTitle) ]         where-            p3' a b = fmap substSpaces $ p3 a b+            subst f = fmap (Text.map substSpaces) . f+             substSpaces x                 | isSpace x = '_'                 | otherwise = x@@ -493,17 +493,21 @@         CoreAudio -> rt "auhal"         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 ]+            rt = p3 "rtaudio" +            jackFields name ins outs =+              hsep+                [ p3 "jack_client" (textStrict name)+                , p3 "jack_inportname" (textStrict ins)+                , p3 "jack_outportname" (textStrict outs) ]+ instance Pretty PulseAudio where-    pretty a = hsep $ fmap text $-        [ p3 "server" $ paServer a-        , p3 "output_stream" $ paOutput a-        , p3 "input_stream" $ paInput a ]+    pretty a =+      hsep+        [ p3 "server" $ textStrict (paServer a)+        , p3 "output_stream" $ textStrict (paOutput a)+        , p3 "input_stream" $ textStrict (paInput a)+        ]  instance Pretty MidiIO where     pretty = fields@@ -516,16 +520,16 @@ 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 (p2 "midi-key")            midiKey+        , mp (p2 "midi-key-cps")        midiKeyCps+        , mp (p2 "midi-key-oct")        midiKeyOct+        , mp (p2 "midi-key-pch")        midiKeyPch+        , mp (p2 "midi-velocity")       midiVelocity+        , mp (p2 "midi-velocity-amp")   midiVelocityAmp         , mp (p1 "Q")                   midiOutDevice ]  instance Pretty Rtmidi where-    pretty x = text $ p3 "rtmidi" $ case x of+    pretty x = p3 "rtmidi" $ case x of         VirtualMidi -> "virtual"         PortMidi    -> "PortMidi"         AlsaMidi    -> "alsa"@@ -537,51 +541,52 @@  instance Pretty Displays where     pretty = fields-        [ mi (p2 "csd-line-nums")   csdLineNums+        [ mp (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+        , mp (p2 "heartbeat")       displayHeartbeat+        , mp (p2 "messagelevel")    messageLevel+        , mp (p2 "m-amps")          mAmps+        , mp (p2 "m-range")         mRange+        , mp (p2 "m-warnings")      mWarnings+        , mp (p2 "m-dB")            mDb+        , mp (p2 "m-colours")       mColours+        , mp (p2 "m-benchmarks")    mBenchmarks         , bo "-+msg_color"          msgColor         , bo "--verbose"            displayVerbose-        , mi (p2 "list-opcodes")    listOpcodes ]+        , mp (p2 "list-opcodes")    listOpcodes ]  instance Pretty DisplayMode where-    pretty x = text $ case x of+    pretty x = 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 "hardwarebufsamps")    hwBuf+        , mp (p2 "iobufsamps")          ioBuf+        , mp (p2 "control-rate")        newKr+        , mp (p2 "sample-rate")         newSr         , mp (p2 "score-in")            scoreIn         , macro "omacro"                omacro         , macro "smacro"                smacro         , bo "--sched"                  setSched-        , mi (p2 "sched")               schedNum+        , mp (p2 "sched")               schedNum         , strset                        strsetN-        , mp (p3 "skip_seconds")        (fmap show . skipSeconds)-        , mi (p2 "tempo")               setTempo ]+        , mp (p3 "skip_seconds")        skipSeconds+        , mp (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+            macro :: Doc -> (a -> Maybe (Text, Text)) -> a -> Maybe Doc+            macro name f = fmap phi . f+                where phi (a, b) = hcat ["--", pretty name, ":", textStrict a, "=", textStrict b] +            strset f = fmap phi . f+                where phi (n, a) = hcat ["--strset", int n,"=", textStrict a]+ --------------------------------------------------- -- utilities -firstToLower :: String -> String-firstToLower x = case x of-    a:as -> toLower a : as-    []   -> []-+firstToLower :: Text -> Text+firstToLower x = case Text.uncons x of+    Just (a, as) -> Text.cons (toLower a) as+    Nothing      -> x