{-# LANGUAGE 
        MultiParamTypeClasses, 
        TypeSynonymInstances, 
        FlexibleContexts #-}

module CsoundExpr.Translator.Cs.CsTree (
  -- types
     CsTree, 
     Rate(..), CsExpr(..),
     Value(..), Ftable(..), GEN(..), Name, Label,
  -- constructors
     opc, opr, 
     int, double, string, ftable, param,
     argIn, argOut,
  -- predicates
     isArg, isFtable,
     isVal, isOpc, isOpr, isParam, isString,
     equalStructure, equalStructureByParams, 
  -- selectors
     toFtable, ftableGENArgs, ftableSize, ftableGENId, getFtable, 
     mapFtable, toDouble, opcName, oprName, 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

-----------------------------------------------
-- types

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] 
		deriving (Show, Eq, Ord)


data Value = ValueInt Int
           | ValueDouble Double
           | ValueString String
	       | ValueFtable Ftable
		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

------------------------------------------
-- instances

instance IM CsTree CsTree where
    from = id
    to   = id

-----------------
-- Lists

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 

opr :: [Name] -> CsExpr
opr = Opr

------------------------------------------
-- CsTree Selectors

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"

-----------------------------------------------------------
-- CsExpr selectors

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" 


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

--------------------------------------------------


--------------------------------------------------
-- predicates


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

-------------
-- value predicates

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



----------------------
-- tree predicates


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