module CsoundExpr.Translator.Cs.CsTree (
CsTree,
Rate(..), CsExpr(..),
Value(..), OprType(..), Ftable(..), GEN(..), Name, Label,
opc, oprPrefix, oprInfix,
int, double, string, ftable, param,
argIn, argOut,
isArg, isFtable,
isVal, isOpc, isOpr, isParam, isString,
equalStructure, equalStructureByParams,
toFtable, ftableGENArgs, ftableSize, ftableGENId, getFtable,
mapFtable, toDouble, opcName, oprName, oprType, paramId, value,
argName, argRate
)
where
import Data.Function
import CsoundExpr.Translator.ExprTree.ExprTree
import CsoundExpr.Translator.ExprTree.Tree
import CsoundExpr.Translator.Cs.IM
import CsoundExpr.Translator.Cs.Utils
import CsoundExpr.Translator.ExprTree.Tree
type CsTree = ExprTree Label Rate CsExpr
data Rate = A | K | I | S | GA | GK | GI | GS | SetupRate
deriving (Show, Eq, Ord)
data CsExpr = Val Value
| Param Id
| Arg Rate Name
| Opc Name
| Opr Name OprType
deriving (Show, Eq, Ord)
data Value = ValueInt Int
| ValueDouble Double
| ValueString String
| ValueFtable Ftable
deriving (Show, Eq, Ord)
data OprType = Infix | Prefix
deriving (Show, Eq, Ord)
data Ftable = EmptyFtable
| Ftable Size GEN
deriving (Show, Eq, Ord)
data GEN = GEN Id [CsTree]
deriving (Show, Eq, Ord)
type Name = String
type Label = Int
instance IM CsTree CsTree where
from = id
to = id
val :: CsExpr -> CsTree
val x = pure x []
param :: IM CsTree a => Id -> a
param = from . val . Param
int :: IM CsTree a => Int -> a
int = from . val . Val . ValueInt
double :: IM CsTree a => Double -> a
double = from . val . Val . ValueDouble
ftable :: IM CsTree a => Ftable -> a
ftable = from . val . Val . ValueFtable
string :: IM CsTree a => String -> a
string = from . mapType (const [S]) . val . Val . ValueString
argIn :: IM CsTree a => Rate -> Name -> a
argIn rate = from . val . Arg rate
argOut :: IM CsTree a => Rate -> Name -> a -> CsTree
argOut rate name = mapType (const [rate]) . pure' (Arg rate name) . return . to
where pure' :: CsExpr -> [CsTree] -> CsTree
pure' = pure
opc :: Name -> CsExpr
opc = Opc
oprPrefix :: Name -> CsExpr
oprPrefix = flip Opr Prefix
oprInfix :: Name -> CsExpr
oprInfix = flip Opr Infix
mapFtable :: (Ftable -> Ftable) -> CsTree -> CsTree
mapFtable f = mapTag (mapSnd $ phi f)
where phi f x = case x of
(Val (ValueFtable x)) -> Val (ValueFtable $ f x)
_ -> error "value is not ftable"
getFtable :: CsTree -> Ftable
getFtable = select . exprOp . exprTreeTag
where select x = case x of
(Val (ValueFtable x)) -> x
_ -> error "value is not ftable"
paramId :: CsExpr -> Id
paramId x = case x of
(Param x) -> x
_ -> error "expr is no Param"
value :: CsExpr -> Value
value x = case x of
(Val x) -> x
_ -> error "expr is no Val"
opcName :: CsExpr -> Name
opcName x = case x of
(Opc x) -> x
_ -> error "expr is no Opc"
oprName :: CsExpr -> Name
oprName x = case x of
(Opr x _) -> x
_ -> error "expr is no Opr"
oprType :: CsExpr -> OprType
oprType x = case x of
(Opr _ x) -> x
_ -> error "expr is no Opr"
argName :: CsExpr -> Name
argName x = case x of
(Arg _ x) -> x
_ -> error "expr is not Arg"
argRate :: CsExpr -> Rate
argRate x = case x of
(Arg x _) -> x
_ -> error "expr is not Arg"
ftableSize :: Ftable -> Size
ftableSize x = case x of
EmptyFtable -> 0
(Ftable x _) -> x
ftableGENId :: Ftable -> Id
ftableGENId x = case x of
EmptyFtable -> 0
(Ftable _ (GEN x _ )) -> x
ftableGENArgs :: Ftable -> [CsTree]
ftableGENArgs x = case x of
EmptyFtable -> []
(Ftable _ (GEN _ ts)) -> ts
isParam :: CsExpr -> Bool
isParam x = case x of
(Param _) -> True
_ -> False
isVal :: CsExpr -> Bool
isVal x = case x of
(Val _) -> True
_ -> False
isOpc :: CsExpr -> Bool
isOpc x = case x of
(Opc _) -> True
_ -> False
isOpr :: CsExpr -> Bool
isOpr x = case x of
(Opr _ _) -> True
_ -> False
isArg :: CsExpr -> Bool
isArg x = case x of
(Arg _ _) -> True
_ -> False
isFtable :: Value -> Bool
isFtable x = case x of
(ValueFtable _) -> True
_ -> False
toFtable :: Value -> Ftable
toFtable x = case x of
(ValueFtable q) -> q
_ -> error "value is not ftable"
isDouble :: Value -> Bool
isDouble x = case x of
ValueDouble q -> True
_ -> False
toDouble :: Value -> Maybe Double
toDouble x = case x of
ValueDouble q -> Just q
_ -> Nothing
isString :: Value -> Bool
isString x = case x of
(ValueString _) -> True
_ -> False
equalStructure :: CsTree -> CsTree -> Bool
equalStructure = equalTreeStructureBy pred
where pred a b
| isVal' a && isVal' b = eqVal a b
| otherwise = a == b
isVal' = isVal . exprOp . exprTag
value' = value . exprOp . exprTag
eqVal = equalValueStructure `on` value'
equalStructureByParams :: CsTree -> CsTree -> Bool
equalStructureByParams = equalTreeStructureBy pred
where pred a b
| isVal' a && isVal' b = eqVal a b
| isParam' a && isVal' b && paramId' a > 3 = True
| isVal' a && isParam' b && paramId' b > 3 = True
| otherwise = a == b
isVal' = isVal . exprOp . exprTag
value' = value . exprOp . exprTag
isParam' = isParam . exprOp . exprTag
paramId' = paramId . exprOp . exprTag
eqVal = equalValueStructure `on` value'
equalValueStructure :: Value -> Value -> Bool
equalValueStructure a b =
case (a, b) of
((ValueInt _) , (ValueInt _)) -> True
((ValueString _), (ValueString _)) -> True
((ValueDouble _), (ValueDouble _)) -> True
((ValueFtable _), (ValueFtable _)) -> True
_ -> False