module Csound.Dynamic.Render.Instr(
  renderInstr,
  renderInstrBody
) where

import Control.Arrow(second)
import Control.Monad.Trans.State.Strict

import Data.Fix(Fix(..), foldFix)
import Data.Fix.Cse(fromDag, cse {-cseFramed, FrameInfo(..)-})

import qualified Text.PrettyPrint.Leijen.Text as P

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.Render.Pretty
-- import Debug.Trace

type Dag f = [(Int, f Int)]

renderInstr :: InferenceOptions -> Instr -> Doc
renderInstr :: InferenceOptions -> Instr -> Doc
renderInstr InferenceOptions
opts Instr
a = InstrId -> Doc -> Doc
ppInstr (Instr -> InstrId
instrName Instr
a) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ InferenceOptions -> E -> Doc
renderInstrBody InferenceOptions
opts (Instr -> E
instrBody Instr
a)

renderInstrBody :: InferenceOptions -> E -> Doc
renderInstrBody :: InferenceOptions -> E -> Doc
renderInstrBody InferenceOptions
opts E
a
  | [(Int, RatedExp Int)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, RatedExp Int)]
dag  = Doc
P.empty
  | Bool
otherwise = [(Int, RatedExp Int)] -> Doc
render [(Int, RatedExp Int)]
dag
    where
      dag :: [(Int, RatedExp Int)]
dag = E -> [(Int, RatedExp Int)]
toDag E
a
      render :: [(Int, RatedExp Int)] -> Doc
render = [Doc] -> Doc
P.vcat ([Doc] -> Doc)
-> ([(Int, RatedExp Int)] -> [Doc]) -> [(Int, RatedExp Int)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State Int [Doc] -> Int -> [Doc])
-> Int -> State Int [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int [Doc] -> Int -> [Doc]
forall s a. State s a -> s -> a
evalState Int
0 (State Int [Doc] -> [Doc])
-> ([(Int, RatedExp Int)] -> State Int [Doc])
-> [(Int, RatedExp Int)]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Var], Exp Var) -> StateT Int Identity Doc)
-> [([Var], Exp Var)] -> State Int [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([Var] -> Exp Var -> StateT Int Identity Doc)
-> ([Var], Exp Var) -> StateT Int Identity Doc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Var] -> Exp Var -> StateT Int Identity Doc
ppStmt (([Var], Exp Var) -> StateT Int Identity Doc)
-> (([Var], Exp Var) -> ([Var], Exp Var))
-> ([Var], Exp Var)
-> StateT Int Identity Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Var], Exp Var) -> ([Var], Exp Var)
clearEmptyResults) ([([Var], Exp Var)] -> State Int [Doc])
-> ([(Int, RatedExp Int)] -> [([Var], Exp Var)])
-> [(Int, RatedExp Int)]
-> State Int [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InferenceOptions -> [(Int, RatedExp Int)] -> [([Var], Exp Var)]
collectRates InferenceOptions
opts

-------------------------------------------------------------
-- E -> Dag

toDag :: E -> Dag RatedExp
toDag :: E -> [(Int, RatedExp Int)]
toDag E
expr = Dag RatedExp -> [(Int, RatedExp Int)]
forall (f :: * -> *). Dag f -> [(Int, f Int)]
fromDag (Dag RatedExp -> [(Int, RatedExp Int)])
-> Dag RatedExp -> [(Int, RatedExp Int)]
forall a b. (a -> b) -> a -> b
$ E -> Dag RatedExp
forall (f :: * -> *).
(Eq (f Int), Ord (f Int), Traversable f) =>
Fix f -> Dag f
cse (E -> Dag RatedExp) -> E -> Dag RatedExp
forall a b. (a -> b) -> a -> b
$ E -> E
trimByArgLength E
expr

trimByArgLength :: E -> E
trimByArgLength :: E -> E
trimByArgLength = (RatedExp E -> E) -> E -> E
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix ((RatedExp E -> E) -> E -> E) -> (RatedExp E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ \RatedExp E
x -> RatedExp E -> E
forall (f :: * -> *). f (Fix f) -> Fix f
Fix RatedExp E
x{ ratedExpExp = phi $ ratedExpExp x }
  where
    phi :: MainExp a -> MainExp a
phi MainExp a
x = case MainExp a
x of
      Tfm Info
info [a]
xs -> Info -> [a] -> MainExp a
forall a. Info -> [a] -> MainExp a
Tfm (Info
info{infoSignature = trimInfo (infoSignature info) xs}) [a]
xs
      MainExp a
_ -> MainExp a
x

    trimInfo :: Signature -> t a -> Signature
trimInfo Signature
signature t a
args = case Signature
signature of
      SingleRate Map Rate [Rate]
tab -> Map Rate [Rate] -> Signature
SingleRate (Map Rate [Rate] -> Signature) -> Map Rate [Rate] -> Signature
forall a b. (a -> b) -> a -> b
$ ([Rate] -> [Rate]) -> Map Rate [Rate] -> Map Rate [Rate]
forall a b. (a -> b) -> Map Rate a -> Map Rate b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Rate] -> [Rate]
forall {a}. [a] -> [a]
trim Map Rate [Rate]
tab
      MultiRate [Rate]
outs [Rate]
ins -> [Rate] -> [Rate] -> Signature
MultiRate [Rate]
outs ([Rate] -> [Rate]
forall {a}. [a] -> [a]
trim [Rate]
ins)
      where
        trim :: [a] -> [a]
trim = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args)

clearEmptyResults :: ([Infer.Var], Exp Infer.Var) -> ([Infer.Var], Exp Infer.Var)
clearEmptyResults :: ([Var], Exp Var) -> ([Var], Exp Var)
clearEmptyResults ([Var]
res, Exp Var
expr) = ((Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
/= Rate
Xr) (Rate -> Bool) -> (Var -> Rate) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Rate
Infer.varType) [Var]
res, Exp Var
expr)

collectRates :: InferenceOptions -> Dag RatedExp -> [([Infer.Var], Exp Infer.Var)]
collectRates :: InferenceOptions -> [(Int, RatedExp Int)] -> [([Var], Exp Var)]
collectRates InferenceOptions
opts [(Int, RatedExp Int)]
dag = (Exp RatedExp -> ([Var], Exp Var))
-> [Exp RatedExp] -> [([Var], Exp Var)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Rhs RatedExp -> Exp Var) -> Exp RatedExp -> ([Var], Exp Var)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Rhs RatedExp -> Exp Var
forall a. RatedExp a -> Exp a
ratedExpExp) [Exp RatedExp]
res4
  where
    res4 :: [Exp RatedExp]
res4 = Int -> [Exp RatedExp] -> [Exp RatedExp]
forall (f :: * -> *). Traversable f => Int -> Dag f -> Dag f
liveness Int
lastFreshId3 [Exp RatedExp]
res3
    ([Exp RatedExp]
res3, Int
lastFreshId3) = InferenceResult -> ([Exp RatedExp], Int)
unfoldMultiOuts InferenceResult
inferRes2
    inferRes2 :: InferenceResult
inferRes2 = InferenceResult
inferRes1 { Infer.typedProgram = filterDepCases $ Infer.typedProgram inferRes1 }
    inferRes1 :: InferenceResult
inferRes1 = InferenceResult -> InferenceResult
collectIfBlocks InferenceResult
inferRes
    inferRes :: InferenceResult
inferRes = InferenceOptions -> [Stmt Int] -> InferenceResult
Infer.inferTypes InferenceOptions
opts ([Stmt Int] -> InferenceResult) -> [Stmt Int] -> InferenceResult
forall a b. (a -> b) -> a -> b
$ ((Int, RatedExp Int) -> Stmt Int)
-> [(Int, RatedExp Int)] -> [Stmt Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> RatedExp Int -> Stmt Int)
-> (Int, RatedExp Int) -> Stmt Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> RatedExp Int -> Stmt Int
forall a. a -> RatedExp a -> Stmt a
Infer.Stmt) ([(Int, RatedExp Int)] -> [Stmt Int])
-> [(Int, RatedExp Int)] -> [Stmt Int]
forall a b. (a -> b) -> a -> b
$
        -- (\a -> trace (unlines ["DAG", unlines $ fmap (\(ls, rs) -> unwords [show ls, "=", show $ fmap (either (const (-1)) id . unPrimOr) $ ratedExpExp rs]) a]) $ a)
        [(Int, RatedExp Int)]
dag

-----------------------------------------------------------
-- Dag -> Dag

filterDepCases :: [Infer.Stmt Infer.Var] -> [Infer.Stmt Infer.Var]
filterDepCases :: [Stmt Var] -> [Stmt Var]
filterDepCases = (Stmt Var -> Bool) -> [Stmt Var] -> [Stmt Var]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Stmt Var -> Bool) -> Stmt Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rhs RatedExp -> Bool
forall {a}. RatedExp a -> Bool
isDepCase (Rhs RatedExp -> Bool)
-> (Stmt Var -> Rhs RatedExp) -> Stmt Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stmt Var -> Rhs RatedExp
forall a. Stmt a -> RatedExp a
Infer.stmtRhs)
  where isDepCase :: RatedExp a -> Bool
isDepCase RatedExp a
x = case RatedExp a -> Exp a
forall a. RatedExp a -> Exp a
ratedExpExp RatedExp a
x of
          Exp a
Starts  -> Bool
True
          Seq PrimOr a
_ PrimOr a
_ -> Bool
True
          Ends PrimOr a
_  -> Bool
True
          Exp a
_       -> Bool
False