{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
Various LLVM related instances of the BendModulation type.
I have setup a separate module since these instances are orphan
and need several language extensions.
-}
module Synthesizer.LLVM.ALSA.BendModulation where

import Synthesizer.PiecewiseConstant.ALSA.MIDI
   (BendModulation(BendModulation), )


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

import Foreign.Storable (Storable(sizeOf, alignment, peek, poke), )
import Foreign.Storable.Traversable as Store

import qualified Control.Applicative as App
import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav

import Control.Applicative (Applicative, (<*>), pure, liftA2, )
import qualified Data.TypeLevel.Num as TypeNum



-- 'fmap' is lazy which is important for the Store functions
instance Functor BendModulation where
   {-# INLINE fmap #-}
   fmap f ~(BendModulation b m) = BendModulation (f b) (f m)

-- useful for defining Additive instance
instance Applicative BendModulation where
   {-# INLINE pure #-}
   pure a = BendModulation a a
   {-# INLINE (<*>) #-}
   ~(BendModulation fb fm) <*> ~(BendModulation b m) =
      BendModulation (fb b) (fm m)

instance Fold.Foldable BendModulation where
   {-# INLINE foldMap #-}
   foldMap = Trav.foldMapDefault

-- this allows for kinds of generic programming
instance Trav.Traversable BendModulation where
   {-# INLINE sequenceA #-}
   sequenceA ~(BendModulation b m) =
      liftA2 BendModulation b m


instance (Storable a) => Storable (BendModulation a) where
   {-# INLINE sizeOf #-}
   sizeOf = Store.sizeOf
   {-# INLINE alignment #-}
   alignment = Store.alignment
   {-# INLINE peek #-}
   peek = Store.peekApplicative
   {-# INLINE poke #-}
   poke = Store.poke


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

instance (LLVM.ValueTuple a) => LLVM.ValueTuple (BendModulation a) where
   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)

instance LLVM.IsTuple a => LLVM.IsTuple (BendModulation a) where
   tupleDesc = Class.tupleDescFoldable

instance (LLVM.Undefined a) => LLVM.Undefined (BendModulation a) where
   undefTuple = Class.undefTuplePointed

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

instance LLVM.CmpRet a b =>
      LLVM.CmpRet (BendModulation a) (BendModulation b) where

instance LLVM.MakeValueTuple h l =>
      LLVM.MakeValueTuple (BendModulation h) (BendModulation l) where
   valueTupleOf = Class.valueTupleOfFunctor

memory ::
   (Rep.Memory l s, LLVM.IsSized s ss) =>
   Rep.MemoryRecord r (LLVM.Struct (s, (s, ()))) (BendModulation l)
memory =
   liftA2 BendModulation
      (Rep.memoryElement (\(BendModulation b _) -> b) TypeNum.d0)
      (Rep.memoryElement (\(BendModulation _ m) -> m) TypeNum.d1)

instance
      (Rep.Memory l s, LLVM.IsSized s ss) =>
      Rep.Memory (BendModulation l) (LLVM.Struct (s, (s, ()))) where
   load = Rep.loadRecord memory
   store = Rep.storeRecord memory
   decompose = Rep.decomposeRecord memory
   compose = Rep.composeRecord memory


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


instance (Vector.ShuffleMatch n v) =>
      Vector.ShuffleMatch n (BendModulation v) where
   shuffleMatch = Vector.shuffleMatchTraversable

instance (Vector.Access n a v) =>
      Vector.Access n (BendModulation a) (BendModulation v) where
   insert  = Vector.insertTraversable
   extract = Vector.extractTraversable