BendModulation.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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,
   niceValue,
   unNiceValue,
   ) where

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

import qualified LLVM.DSL.Expression as Expr

import qualified LLVM.Extra.Nice.Value.Storable as StorableNice
import qualified LLVM.Extra.Nice.Value.Marshal as MarshalNice
import qualified LLVM.Extra.Nice.Value as NiceValue
import qualified LLVM.Extra.Vector as Vector
import qualified LLVM.Extra.Tuple as Tuple
import qualified LLVM.Extra.Storable as Storable
import qualified LLVM.Extra.Marshal as Marshal
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Control as C
import qualified LLVM.Core as LLVM

import qualified Type.Data.Num.Decimal as TypeNum

import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold

import Control.Applicative (liftA2)


instance (Tuple.Zero a) => Tuple.Zero (BM.T a) where
   zero = Tuple.zeroPointed

instance (Tuple.Undefined a) => Tuple.Undefined (BM.T a) where
   undef = Tuple.undefPointed

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

instance Tuple.Value h => Tuple.Value (BM.T h) where
   type ValueOf (BM.T h) = BM.T (Tuple.ValueOf h)
   valueOf = Tuple.valueOfFunctor


instance (Expr.Aggregate e nv) => Expr.Aggregate (BM.T e) (BM.T nv) where
   type NiceValuesOf (BM.T e) = BM.T (Expr.NiceValuesOf e)
   type ExpressionsOf (BM.T nv) = BM.T (Expr.ExpressionsOf nv)
   bundle = Trav.traverse Expr.bundle
   dissect = fmap Expr.dissect

instance (NiceValue.C a) => NiceValue.C (BM.T a) where
   type Repr (BM.T a) = BM.T (NiceValue.Repr a)
   cons = niceValue . fmap NiceValue.cons
   undef = niceValue $ pure NiceValue.undef
   zero = niceValue $ pure NiceValue.zero
   phi bb = fmap niceValue . Trav.traverse (NiceValue.phi bb) . unNiceValue
   addPhi bb a b =
      Fold.sequence_ $
      liftA2 (NiceValue.addPhi bb) (unNiceValue a) (unNiceValue b)

instance (MarshalNice.C l) => MarshalNice.C (BM.T l) where
   pack (BM.Cons bend depth) = MarshalNice.pack (bend, depth)
   unpack = uncurry BM.Cons . MarshalNice.unpack

instance (StorableNice.C l) => StorableNice.C (BM.T l) where
   load = StorableNice.loadApplicative
   store = StorableNice.storeFoldable

niceValue :: BM.T (NiceValue.T a) -> NiceValue.T (BM.T a)
niceValue = NiceValue.Cons . fmap (\(NiceValue.Cons a) -> a)

unNiceValue :: NiceValue.T (BM.T a) -> BM.T (NiceValue.T a)
unNiceValue (NiceValue.Cons x) = fmap NiceValue.Cons x


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 (Marshal.C l) => Marshal.C (BM.T l) where
   pack (BM.Cons bend depth) = Marshal.pack (bend, depth)
   unpack = uncurry BM.Cons . Marshal.unpack

instance (Storable.C l) => Storable.C (BM.T l) where
   load = Storable.loadApplicative
   store = Storable.storeFoldable

instance (Tuple.Phi a) => Tuple.Phi (BM.T a) where
   phi = Tuple.phiTraversable
   addPhi = Tuple.addPhiFoldable


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