{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
Various LLVM related instances of the BM.T type.
I have setup a separate module since these instances are orphan
and need several language extensions.
-}
module Synthesizer.LLVM.MIDI.BendModulation (
   BM.T(..),
   BM.deflt,
   BM.shift,
   ) where

import qualified Synthesizer.MIDI.Value.BendModulation as BM
import qualified Synthesizer.LLVM.CausalParameterized.Functional as F

import qualified LLVM.Extra.Vector as Vector
import qualified LLVM.Extra.Class as Class
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Control as C
import qualified LLVM.Util.Loop as Loop
import qualified LLVM.Core as LLVM

import Control.Applicative (liftA2, )
import qualified Type.Data.Num.Decimal as TypeNum


instance (Class.Zero a) => Class.Zero (BM.T a) where
   zeroTuple = Class.zeroTuplePointed

{-
instance (LLVM.ValueTuple a) => LLVM.ValueTuple (BM.T a) where
   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)

instance LLVM.IsTuple a => LLVM.IsTuple (BM.T a) where
   tupleDesc = Class.tupleDescFoldable
-}

instance (Class.Undefined a) => Class.Undefined (BM.T a) where
   undefTuple = Class.undefTuplePointed

instance (C.Select a) => C.Select (BM.T a) where
   select = C.selectTraversable

{-
instance LLVM.CmpRet a, LLVM.CmpResult a ~ b =>
      LLVM.CmpRet (BM.T a) (BM.T b) where
-}

instance Class.MakeValueTuple h => Class.MakeValueTuple (BM.T h) where
   type ValueTuple (BM.T h) = BM.T (Class.ValueTuple h)
   valueTupleOf = Class.valueTupleOfFunctor


type Struct a = LLVM.Struct (a, (a, ()))

memory :: (Memory.C l) => Memory.Record r (Struct (Memory.Struct l)) (BM.T l)
memory =
   liftA2 BM.Cons
      (Memory.element BM.bend  TypeNum.d0)
      (Memory.element BM.depth TypeNum.d1)

instance (Memory.C l) => Memory.C (BM.T l) where
   type Struct (BM.T l) = Struct (Memory.Struct l)
   load = Memory.loadRecord memory
   store = Memory.storeRecord memory
   decompose = Memory.decomposeRecord memory
   compose = Memory.composeRecord memory


instance (Loop.Phi a) => Loop.Phi (BM.T a) where
   phis = Class.phisTraversable
   addPhis = Class.addPhisFoldable


instance (Vector.Simple v) => Vector.Simple (BM.T v) where
   type Element (BM.T v) = BM.T (Vector.Element v)
   type Size (BM.T v) = Vector.Size v
   shuffleMatch = Vector.shuffleMatchTraversable
   extract = Vector.extractTraversable

instance (Vector.C v) => Vector.C (BM.T v) where
   insert  = Vector.insertTraversable


type instance F.Arguments f (BM.T a) = f (BM.T a)
instance F.MakeArguments (BM.T a) where
   makeArgs = id