synthesizer-llvm-1.2: src/Synthesizer/LLVM/Frame/Stereo.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
Re-export functions from "Sound.Frame.Stereo"
and add (orphan) instances for various LLVM type classes.
If you want to use the Stereo datatype with synthesizer-llvm
we recommend to import this module instead of
"Sound.Frame.Stereo" or "Sound.Frame.NumericPrelude.Stereo".
-}
module Synthesizer.LLVM.Frame.Stereo (
   Stereo.T, Stereo.cons, Stereo.left, Stereo.right,
   Stereo.Channel(Stereo.Left, Stereo.Right), Stereo.select,
   Stereo.swap,
   niceValue, unNiceValue, consNiceValue, unExpression,
   niceVector, unNiceVector,
   niceValueSerial, unNiceValueSerial,
   Stereo.arrowFromMono,
   Stereo.arrowFromMonoControlled,
   Stereo.arrowFromChannels,
   Stereo.interleave,
   Stereo.sequence,
   Stereo.liftApplicative,
   ) where

import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.Frame.Stereo as Stereo

import qualified LLVM.DSL.Expression as Expr
import qualified LLVM.DSL.Value as Value

import qualified LLVM.Extra.Nice.Vector as NiceVector
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.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.Arithmetic as A
import qualified LLVM.Extra.Control as C
import qualified LLVM.Extra.Vector as Vector
import qualified LLVM.Core as LLVM

import Type.Data.Num.Decimal (d0, d1)

import Control.Applicative (liftA2, pure, (<$>))

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

import Prelude hiding (Either(Left, Right), sequence)


instance (Tuple.Zero a) => Tuple.Zero (Stereo.T a) where
   zero = Stereo.cons Tuple.zero Tuple.zero

instance (Tuple.Undefined a) => Tuple.Undefined (Stereo.T a) where
   undef = Stereo.cons Tuple.undef Tuple.undef

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

instance (Tuple.Value h) => Tuple.Value (Stereo.T h) where
   type ValueOf (Stereo.T h) = Stereo.T (Tuple.ValueOf h)
   valueOf = fmap Tuple.valueOf

instance (Tuple.Phi a) => Tuple.Phi (Stereo.T a) where
   phi bb v =
      liftA2 Stereo.cons
         (Tuple.phi bb (Stereo.left v))
         (Tuple.phi bb (Stereo.right v))
   addPhi bb x y = do
      Tuple.addPhi bb (Stereo.left  x) (Stereo.left  y)
      Tuple.addPhi bb (Stereo.right x) (Stereo.right y)

instance (NiceValue.C a) => NiceValue.C (Stereo.T a) where
   type Repr (Stereo.T a) = Stereo.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 (NiceValue.Compose a) => NiceValue.Compose (Stereo.T a) where
   type Composed (Stereo.T a) = Stereo.T (NiceValue.Composed a)
   compose = niceValue . fmap NiceValue.compose

instance (NiceValue.Decompose p) => NiceValue.Decompose (Stereo.T p) where
   decompose p = liftA2 NiceValue.decompose p . unNiceValue

type instance NiceValue.Decomposed f (Stereo.T pa) =
                  Stereo.T (NiceValue.Decomposed f pa)
type instance NiceValue.PatternTuple (Stereo.T pa) =
                  Stereo.T (NiceValue.PatternTuple pa)

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

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

consNiceValue :: NiceValue.T a -> NiceValue.T a -> NiceValue.T (Stereo.T a)
consNiceValue l r = niceValue $ Stereo.cons l r


unExpression :: Expr.Exp (Stereo.T a) -> Stereo.T (Expr.Exp a)
unExpression x =
   Stereo.cons
      (Expr.lift1 (NiceValue.lift1 Stereo.left) x)
      (Expr.lift1 (NiceValue.lift1 Stereo.right) x)


instance (NiceVector.C a) => NiceVector.C (Stereo.T a) where
   type Repr n (Stereo.T a) = Stereo.T (NiceVector.Repr n a)
   cons = niceVector . fmap NiceVector.cons . Stereo.sequence
   undef = niceVector $ pure NiceVector.undef
   zero = niceVector $ pure NiceVector.zero
   phi bb =
      fmap niceVector . Trav.traverse (NiceVector.phi bb) . unNiceVector
   addPhi bb a b =
      Fold.sequence_ $
      liftA2 (NiceVector.addPhi bb) (unNiceVector a) (unNiceVector b)

   shuffle is u v =
      niceVector <$>
      traverse2 (NiceVector.shuffle is) (unNiceVector u) (unNiceVector v)
   extract k =
      fmap niceValue . Trav.traverse (NiceVector.extract k) . unNiceVector
   insert k a v =
      niceVector <$>
      traverse2 (NiceVector.insert k) (unNiceValue a) (unNiceVector v)

niceVector :: Stereo.T (NiceVector.T n a) -> NiceVector.T n (Stereo.T a)
niceVector = NiceVector.Cons . fmap (\(NiceVector.Cons a) -> a)

unNiceVector :: NiceVector.T n (Stereo.T a) -> Stereo.T (NiceVector.T n a)
unNiceVector (NiceVector.Cons x) = fmap NiceVector.Cons x


niceValueSerial ::
   Stereo.T (NiceValue.T (Serial.T n a)) ->
   NiceValue.T (Serial.T n (Stereo.T a))
niceValueSerial = NiceValue.Cons . fmap (\(NiceValue.Cons a) -> a)

unNiceValueSerial ::
   NiceValue.T (Serial.T n (Stereo.T a)) ->
   Stereo.T (NiceValue.T (Serial.T n a))
unNiceValueSerial (NiceValue.Cons x) = fmap NiceValue.Cons x


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


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

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


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

memory ::
   (Memory.C l) =>
   Memory.Record r (Struct (Memory.Struct l)) (Stereo.T l)
memory =
   liftA2 Stereo.cons
      (Memory.element Stereo.left  d0)
      (Memory.element Stereo.right d1)

instance (Memory.C l) => Memory.C (Stereo.T l) where
   type Struct (Stereo.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 (Stereo.T l) where
   pack x = Marshal.pack (Stereo.left x, Stereo.right x)
   unpack = uncurry Stereo.cons . Marshal.unpack

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

instance (MarshalNice.C l) => MarshalNice.C (Stereo.T l) where
   pack x = MarshalNice.pack (Stereo.left x, Stereo.right x)
   unpack = uncurry Stereo.cons . MarshalNice.unpack

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

instance
   (StorableNice.Vector l, NiceVector.C l) =>
      StorableNice.Vector (Stereo.T l) where
   assembleVector p =
      Trav.traverse (StorableNice.assembleVector (Stereo.left<$>p)) .
      Stereo.sequence
   disassembleVector p =
      fmap (\x -> liftA2 Stereo.cons (Stereo.left x) (Stereo.right x)) .
      Trav.traverse (StorableNice.disassembleVector (Stereo.left<$>p))


{-
instance
      (Memory l s) =>
      Memory (Stereo.T l) (LLVM.Struct (s, (s, ()))) where
   load ptr =
      liftA2 Stereo.cons
         (load =<< getElementPtr0 ptr (d0, ()))
         (load =<< getElementPtr0 ptr (d1, ()))
   store y ptr = do
      store (Stereo.left  y) =<< getElementPtr0 ptr (d0, ())
      store (Stereo.right y) =<< getElementPtr0 ptr (d1, ())
-}

instance (A.Additive a) => A.Additive (Stereo.T a) where
   zero = Stereo.cons A.zero A.zero
   add x y = traverse2 A.add x y
   sub x y = traverse2 A.sub x y
   neg x   = Trav.traverse A.neg x

type instance A.Scalar (Stereo.T a) = A.Scalar a

instance (A.PseudoModule a) => A.PseudoModule (Stereo.T a) where
   scale a = Trav.traverse (A.scale a)



instance (NiceValue.Additive a) => NiceValue.Additive (Stereo.T a) where
   add x y =
      niceValue <$> traverse2 NiceValue.add (unNiceValue x) (unNiceValue y)
   sub x y =
      niceValue <$> traverse2 NiceValue.sub (unNiceValue x) (unNiceValue y)
   neg x = niceValue <$> Trav.traverse NiceValue.neg (unNiceValue x)


traverse2 ::
   (Monad m, Applicative t, Traversable t) =>
   (a -> b -> m c) -> t a -> t b -> m (t c)
traverse2 f x y = Trav.sequence $ liftA2 f x y



instance Value.Flatten a => Value.Flatten (Stereo.T a) where
   type Registers (Stereo.T a) = Stereo.T (Value.Registers a)
   flattenCode = Value.flattenCodeTraversable
   unfoldCode = Value.unfoldCodeTraversable