{-# Language
DeriveFunctor, DeriveFoldable, DeriveTraversable,
DeriveGeneric,
TypeSynonymInstances, FlexibleInstances,
TemplateHaskell,
CPP #-}
module Csound.Dynamic.Types.Exp(
E, RatedExp(..), isEmptyExp, RatedVar, ratedVar, ratedVarRate, ratedVarId,
ratedExp, noRate, withRate, setRate,
Exp, toPrimOr, toPrimOrTfm, PrimOr(..), MainExp(..), Name,
InstrId(..), intInstrId, ratioInstrId, stringInstrId,
VarType(..), Var(..), Info(..), OpcFixity(..), Rate(..),
Signature(..), isInfix, isPrefix,
Prim(..), Gen(..), GenId(..),
Inline(..), InlineExp(..), PreInline(..),
BoolExp, CondInfo, CondOp(..), isTrue, isFalse,
NumExp, NumOp(..), Note,
MultiOut,
IsArrInit, ArrSize, ArrIndex
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import GHC.Generics (Generic)
import Data.Traversable
import Data.Foldable hiding (concat)
import Data.Hashable
import Data.Map(Map)
import Data.Maybe(isNothing)
import qualified Data.IntMap as IM
import Data.Fix
import Data.Eq.Deriving
import Data.Ord.Deriving
import qualified Csound.Dynamic.Tfm.DeduceTypes as R(Var(..))
type Name = String
type LineNum = Int
data InstrId
= InstrId
{ instrIdFrac :: Maybe Int
, instrIdCeil :: Int }
| InstrLabel String
deriving (Show, Eq, Ord, Generic)
intInstrId :: Int -> InstrId
intInstrId n = InstrId Nothing n
ratioInstrId :: Int -> Int -> InstrId
ratioInstrId beforeDot afterDot = InstrId (Just $ afterDot) beforeDot
stringInstrId :: String -> InstrId
stringInstrId = InstrLabel
type E = Fix RatedExp
data RatedExp a = RatedExp
{ ratedExpRate :: Maybe Rate
, ratedExpDepends :: Maybe LineNum
, ratedExpExp :: Exp a
} deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
type RatedVar = R.Var Rate
ratedVar :: Rate -> Int -> RatedVar
ratedVar = flip R.Var
ratedVarRate :: RatedVar -> Rate
ratedVarRate = R.varType
ratedVarId :: RatedVar -> Int
ratedVarId = R.varId
ratedExp :: Maybe Rate -> Exp E -> E
ratedExp r = Fix . RatedExp r Nothing
noRate :: Exp E -> E
noRate = ratedExp Nothing
withRate :: Rate -> Exp E -> E
withRate r = ratedExp (Just r)
setRate :: Rate -> E -> E
setRate r a = Fix $ (\x -> x { ratedExpRate = Just r }) $ unFix a
newtype PrimOr a = PrimOr { unPrimOr :: Either Prim a }
deriving (Show, Eq, Ord, Functor, Generic)
toPrimOr :: E -> PrimOr E
toPrimOr a = PrimOr $ case ratedExpExp $ unFix a of
ExpPrim (PString _) -> Right a
ExpPrim p -> Left p
ReadVar v | noDeps -> Left (PrimVar (varRate v) v)
_ -> Right a
where
noDeps = isNothing $ ratedExpDepends $ unFix a
toPrimOrTfm :: Rate -> E -> PrimOr E
toPrimOrTfm r a = PrimOr $ case ratedExpExp $ unFix a of
ExpPrim (PString _) -> Right a
ExpPrim p | (r == Ir || r == Sr) -> Left p
ReadVar v | noDeps -> Left (PrimVar (varRate v) v)
_ -> Right a
where
noDeps = isNothing $ ratedExpDepends $ unFix a
type Exp a = MainExp (PrimOr a)
data MainExp a
= EmptyExp
| ExpPrim Prim
| Tfm Info [a]
| ConvertRate Rate Rate a
| Select Rate Int a
| If (CondInfo a) a a
| ExpBool (BoolExp a)
| ExpNum (NumExp a)
| InitVar Var a
| ReadVar Var
| WriteVar Var a
| InitArr Var (ArrSize a)
| ReadArr Var (ArrIndex a)
| WriteArr Var (ArrIndex a) a
| WriteInitArr Var (ArrIndex a) a
| TfmArr IsArrInit Var Info [a]
| IfBegin Rate (CondInfo a)
| ElseBegin
| IfEnd
| UntilBegin (CondInfo a)
| UntilEnd
| WhileBegin (CondInfo a)
| WhileRefBegin Var
| WhileEnd
| Verbatim String
| Starts
| Seq a a
| Ends a
| InitMacrosInt String Int
| InitMacrosDouble String Double
| InitMacrosString String String
| ReadMacrosInt String
| ReadMacrosDouble String
| ReadMacrosString String
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
type IsArrInit = Bool
type ArrSize a = [a]
type ArrIndex a = [a]
isEmptyExp :: E -> Bool
isEmptyExp e = isNothing (ratedExpDepends re) && (ratedExpExp re == EmptyExp)
where re = unFix e
data Var
= Var
{ varType :: VarType
, varRate :: Rate
, varName :: Name }
| VarVerbatim
{ varRate :: Rate
, varName :: Name
} deriving (Show, Eq, Ord, Generic)
data VarType = LocalVar | GlobalVar
deriving (Show, Eq, Ord, Generic)
data Info = Info
{ infoName :: Name
, infoSignature :: Signature
, infoOpcFixity :: OpcFixity
} deriving (Show, Eq, Ord, Generic)
isPrefix, isInfix :: Info -> Bool
isPrefix = (Prefix ==) . infoOpcFixity
isInfix = (Infix ==) . infoOpcFixity
data OpcFixity = Prefix | Infix | Opcode
deriving (Show, Eq, Ord, Generic)
data Rate
= Xr
| Ar
| Kr
| Ir
| Sr
| Fr
| Wr
| Tvar
deriving (Show, Eq, Ord, Enum, Bounded, Generic)
data Signature
= SingleRate (Map Rate [Rate])
| 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
data Prim
= P Int
| PString Int
| PrimInt Int
| PrimDouble Double
| PrimString String
| PrimInstrId InstrId
| PrimVar
{ primVarTargetRate :: Rate
, primVar :: Var }
deriving (Show, Eq, Ord, Generic)
data Gen = Gen
{ genSize :: Int
, genId :: GenId
, genArgs :: [Double]
, genFile :: Maybe String
} deriving (Show, Eq, Ord, Generic)
data GenId = IntGenId Int | StringGenId String
deriving (Show, Eq, Ord, Generic)
type Note = [Prim]
data Inline a b = Inline
{ inlineExp :: InlineExp a
, inlineEnv :: IM.IntMap b
} deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
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 InlineExp a
= InlinePrim Int
| InlineExp a [InlineExp a]
deriving (Show, Eq, Ord, Generic)
data PreInline a b = PreInline a [b]
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
type BoolExp a = PreInline CondOp a
type CondInfo a = Inline CondOp a
data CondOp
= TrueOp | FalseOp | And | Or
| Equals | NotEquals | Less | Greater | LessEquals | GreaterEquals
deriving (Show, Eq, Ord, Generic)
isTrue, isFalse :: CondInfo a -> Bool
isTrue = isCondOp TrueOp
isFalse = isCondOp FalseOp
isCondOp :: CondOp -> CondInfo a -> Bool
isCondOp op = maybe False (op == ) . getCondInfoOp
getCondInfoOp :: CondInfo a -> Maybe CondOp
getCondInfoOp x = case inlineExp x of
InlineExp op _ -> Just op
_ -> Nothing
type NumExp a = PreInline NumOp a
data NumOp = Add | Sub | Neg | Mul | Div | Pow | Mod
deriving (Show, Eq, Ord, Generic)
instance Foldable PrimOr where foldMap = foldMapDefault
instance Traversable PrimOr where
traverse f x = case unPrimOr x of
Left p -> pure $ PrimOr $ Left p
Right a -> PrimOr . Right <$> f a
type MultiOut a = Int -> a
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
$(deriveEq1 ''PrimOr)
$(deriveEq1 ''PreInline)
$(deriveEq1 ''Inline)
$(deriveEq1 ''MainExp)
$(deriveEq1 ''RatedExp)
$(deriveOrd1 ''PrimOr)
$(deriveOrd1 ''PreInline)
$(deriveOrd1 ''Inline)
$(deriveOrd1 ''MainExp)
$(deriveOrd1 ''RatedExp)