{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language
        TypeFamilies,
        FlexibleContexts,
        FlexibleInstances #-}
module Csound.Typed.Types.Tuple(
    -- ** Tuple
    Tuple(..), TupleMethods, makeTupleMethods,
    fromTuple, toTuple, tupleArity, tupleRates, defTuple, mapTuple,

    -- ** Outs
    Sigs, outArity, Sig2s,

    -- *** Multiple outs
    multiOuts,
    ar1, ar2, ar4, ar6, ar8,

    -- ** Arguments
    Arg, arg, toNote, argArity, toArg,

    -- ** Logic functions
    ifTuple, guardedTuple, caseTuple,
    ifArg, guardedArg, caseArg,

    -- ** Constructors
    pureTuple, dirtyTuple
) where


import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Data.Default
import Data.Boolean

import Data.NumInstances.Tuple

import Csound.Dynamic
import Csound.Typed.Types.Prim
import Csound.Typed.Types.SigSpace
import Csound.Typed.GlobalState.GE
import Csound.Typed.GlobalState.SE
import Csound.Typed.Types.TupleHelpers

-- | A tuple of Csound values.
class Tuple a where
    tupleMethods :: TupleMethods a

data TupleMethods a = TupleMethods
    { fromTuple_  :: a -> GE [E]
    , toTuple_    :: GE [E] -> a
    , tupleArity_ :: a -> Int
    , tupleRates_ :: a -> [Rate]
    , defTuple_   :: a }

fromTuple :: Tuple a => a -> GE [E]
fromTuple = fromTuple_ tupleMethods

toTuple :: Tuple a => GE [E] -> a
toTuple = toTuple_ tupleMethods

tupleArity :: Tuple a => a -> Int
tupleArity = tupleArity_ tupleMethods

tupleRates :: Tuple a => a -> [Rate]
tupleRates = tupleRates_ tupleMethods

defTuple :: Tuple a => a
defTuple = defTuple_ tupleMethods

mapTuple :: Tuple a => (E -> E) -> a -> a
mapTuple f a = toTuple (fmap (fmap f) $ fromTuple a)

-- | Defines instance of type class 'Tuple' for a new type in terms of an already defined one.
makeTupleMethods :: (Tuple a) => (a -> b) -> (b -> a) -> TupleMethods b
makeTupleMethods to from = TupleMethods
    { fromTuple_  = fromTuple . from
    , toTuple_    = to . toTuple
    , tupleArity_ = const $ tupleArity $ proxy to
    , tupleRates_ = tupleRates . from
    , defTuple_   = to defTuple }
    where proxy :: (a -> b) -> a
          proxy = undefined

-- Tuple instances

primTupleMethods :: (Val a, Default a) => Rate -> TupleMethods a
primTupleMethods rate = TupleMethods
        { fromTuple_ = fmap return . toGE
        , toTuple_ = fromGE . fmap head
        , tupleArity_ = const 1
        , tupleRates_ = const [rate]
        , defTuple_   = def }

instance Tuple Unit where
    tupleMethods = TupleMethods
        { fromTuple_  = \x -> unUnit x >> (return [])
        , toTuple_    = \es -> Unit $ es >> return ()
        , tupleArity_ = const 0
        , tupleRates_ = const []
        , defTuple_   = Unit $ return () }

instance Tuple Sig   where tupleMethods = primTupleMethods Ar
instance Tuple D     where tupleMethods = primTupleMethods Kr
instance Tuple Tab   where tupleMethods = primTupleMethods Kr
instance Tuple Str   where tupleMethods = primTupleMethods Sr
instance Tuple Spec  where tupleMethods = primTupleMethods Fr

instance Tuple TabList where tupleMethods = primTupleMethods Kr

instance (Tuple a, Tuple b) => Tuple (a, b) where
    tupleMethods = TupleMethods fromTuple' toTuple' tupleArity' tupleRates' defTuple'
        where
            fromTuple' (a, b) = liftA2 (++) (fromTuple a) (fromTuple b)
            tupleArity' x = let (a, b) = proxy x in tupleArity a + tupleArity b
                where proxy :: (a, b) -> (a, b)
                      proxy = const (undefined, undefined)
            toTuple' xs = (a, b)
                where a = toTuple $ fmap (take (tupleArity a)) xs
                      xsb = fmap (drop (tupleArity a)) xs
                      b = toTuple $ fmap (take (tupleArity b)) xsb

            tupleRates' (a, b) = tupleRates a ++ tupleRates b
            defTuple' = (defTuple, defTuple)

instance (Tuple a, Tuple b, Tuple c) => Tuple (a, b, c) where tupleMethods = makeTupleMethods cons3 split3
instance (Tuple a, Tuple b, Tuple c, Tuple d) => Tuple (a, b, c, d) where tupleMethods = makeTupleMethods cons4 split4
instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e) => Tuple (a, b, c, d, e) where tupleMethods = makeTupleMethods cons5 split5
instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e, Tuple f) => Tuple (a, b, c, d, e, f) where tupleMethods = makeTupleMethods cons6 split6
instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e, Tuple f, Tuple g) => Tuple (a, b, c, d, e, f, g) where tupleMethods = makeTupleMethods cons7 split7
instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e, Tuple f, Tuple g, Tuple h) => Tuple (a, b, c, d, e, f, g, h) where tupleMethods = makeTupleMethods cons8 split8

-------------------------------------------------------------------------------
-- multiple outs

multiOuts :: Tuple a => E -> a
multiOuts expr = res
    where res = toTuple $ return $ mo (tupleArity res) expr

ar1 :: Sig -> Sig
ar2 :: (Sig, Sig) -> (Sig, Sig)
ar4 :: (Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig)
ar6 :: (Sig, Sig, Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig, Sig, Sig)
ar8 :: (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)

ar1 = id;   ar2 = id;   ar4 = id;   ar6 = id;   ar8 = id

---------------------------------------------------------------------------------
-- out instances

-- | The tuples of signals.
class (Tuple a, Num a, Fractional a, SigSpace a, BindSig a) => Sigs a where
class (Sigs a, SigSpace2 a, BindSig2 a) => Sig2s a where

instance Sigs Sig
instance (Sigs a1, Sigs a2) => Sigs (a1, a2)
instance (Sigs a1, Sigs a2, Sigs a3) => Sigs (a1, a2, a3)
instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4) => Sigs (a1, a2, a3, a4)
instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5) => Sigs (a1, a2, a3, a4, a5)
instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6) => Sigs (a1, a2, a3, a4, a5, a6)
instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6, Sigs a7) => Sigs (a1, a2, a3, a4, a5, a6, a7)
instance (Sigs a1, Sigs a2, Sigs a3, Sigs a4, Sigs a5, Sigs a6, Sigs a7, Sigs a8) => Sigs (a1, a2, a3, a4, a5, a6, a7, a8)

instance Sig2s Sig
instance Sig2s Sig2
instance Sig2s Sig4
instance Sig2s Sig6
instance Sig2s Sig8

outArity :: Tuple a => SE a -> Int
outArity = tupleArity . proxy
    where
        proxy :: SE a -> a
        proxy = const undefined

---------------------------------------------------------------------------
-- Arguments

class (Tuple a) => Arg a where

instance Arg Unit
instance Arg D
instance Arg Str
instance Arg Tab
instance Arg TabList

instance (Arg a, Arg b) => Arg (a, b)
instance (Arg a, Arg b, Arg c) => Arg (a, b, c)
instance (Arg a, Arg b, Arg c, Arg d) => Arg (a, b, c, d)
instance (Arg a, Arg b, Arg c, Arg d, Arg e) => Arg (a, b, c, d, e)
instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f) => Arg (a, b, c, d, e, f)
instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f, Arg h) => Arg (a, b, c, d, e, f, h)
instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f, Arg h, Arg g) => Arg (a, b, c, d, e, f, h, g)

arg :: Arg a => Int -> a
arg n = toTuple $ return $ fmap pn [n ..]

toArg :: Arg a => a
toArg = arg 4

argArity :: Arg a => a -> Int
argArity = tupleArity

toNote :: Arg a => a -> GE [E]
toNote a = zipWithM phi (tupleRates a) =<< fromTuple a
    where
        phi rate x = case rate of
            Sr -> saveStr $ getStringUnsafe x
            _  -> return x

        getStringUnsafe x = case getPrimUnsafe x of
            PrimString y    -> y
            _               -> error "Arg(Str):getStringUnsafe value is not a string"

-------------------------------------------------------------------------
-- logic functions

-- tuples

newtype BoolTuple = BoolTuple { unBoolTuple :: GE [E] }

toBoolTuple :: Tuple a => a -> BoolTuple
toBoolTuple   = BoolTuple . fromTuple

fromBoolTuple :: Tuple a => BoolTuple -> a
fromBoolTuple = toTuple . unBoolTuple

type instance BooleanOf BoolTuple = BoolSig

instance IfB BoolTuple where
    ifB mp (BoolTuple mas) (BoolTuple mbs) = BoolTuple $
        liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs

-- | @ifB@ for tuples of csound values.
ifTuple :: (Tuple a) => BoolSig -> a -> a -> a
ifTuple p a b = fromBoolTuple $ ifB p (toBoolTuple a) (toBoolTuple b)

-- | @guardedB@ for tuples of csound values.
guardedTuple :: (Tuple b) => [(BoolSig, b)] -> b -> b
guardedTuple bs b = fromBoolTuple $ guardedB undefined (fmap (second toBoolTuple) bs) (toBoolTuple b)

-- | @caseB@ for tuples of csound values.
caseTuple :: (Tuple b) => a -> [(a -> BoolSig, b)] -> b -> b
caseTuple a bs other = fromBoolTuple $ caseB a (fmap (second toBoolTuple) bs) (toBoolTuple other)

-- arguments

newtype BoolArg = BoolArg { unBoolArg :: GE [E] }

toBoolArg :: (Arg a, Tuple a) => a -> BoolArg
toBoolArg   = BoolArg . fromTuple

fromBoolArg :: (Arg a, Tuple a) => BoolArg -> a
fromBoolArg = toTuple . unBoolArg

type instance BooleanOf BoolArg = BoolD

instance IfB BoolArg where
    ifB mp (BoolArg mas) (BoolArg mbs) = BoolArg $
        liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs

-- | @ifB@ for constants.
ifArg :: (Arg a, Tuple a) => BoolD -> a -> a -> a
ifArg p a b = fromBoolArg $ ifB p (toBoolArg a) (toBoolArg b)

-- | @guardedB@ for constants.
guardedArg :: (Tuple b, Arg b) => [(BoolD, b)] -> b -> b
guardedArg bs b = fromBoolArg $ guardedB undefined (fmap (second toBoolArg) bs) (toBoolArg b)

-- | @caseB@ for constants.
caseArg :: (Tuple b, Arg b) => a -> [(a -> BoolD, b)] -> b -> b
caseArg a bs other = fromBoolArg $ caseB a (fmap (second toBoolArg) bs) (toBoolArg other)

-----------------------------------------------------------
-- tuple constructors

pureTuple :: Tuple a => GE (MultiOut [E]) -> a
pureTuple a = res
    where res = toTuple $ fmap ($ tupleArity res) a

dirtyTuple :: Tuple a => GE (MultiOut [E]) -> SE a
dirtyTuple a = res
    where
        res = fmap (toTuple . return) $ SE
                $ mapM depT =<< (lift $ fmap ($ (tupleArity $ proxy res)) a)

        proxy :: SE a -> a
        proxy = const undefined