ToSig.hs

{-# OPTIONS_HADDOCK show-extensions #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

{-# LANGUAGE

     CPP

   , FlexibleInstances

   , DataKinds
   , InstanceSigs
   , KindSignatures
   , MultiParamTypeClasses
   , TypeFamilies, NoMonoLocalBinds
   , TypeSynonymInstances
   , UndecidableInstances

   , NoMonomorphismRestriction
   #-}

module Vivid.SynthDef.ToSig (
     ToSig(..)
   ) where

import Vivid.SC.Server.Types (BufferId(..))
import Vivid.SynthDef.Types

import qualified Data.ByteString.UTF8 as UTF8
-- import Data.Proxy
import GHC.TypeLits

class ToSig s (args :: [Symbol]) where
   toSig :: s -> SDBody' args Signal

instance ToSig Signal args where
   toSig :: Signal -> SDBody' args Signal
   toSig = pure

instance (KnownSymbol a, Subset '[a] args) => ToSig (Variable a) args where
   toSig a = (return . Param . UTF8.fromString . symbolVal) a

#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 801

instance ToSig Integer args where
   toSig = pure . Constant . realToFrac

instance ToSig Int args where
   toSig = pure . Constant . realToFrac

instance ToSig Double args where
   toSig = pure . Constant . realToFrac

instance ToSig Float args where
   toSig = pure . Constant . realToFrac

#else


-- Incoherent is to get numbers defaulting to Floats in a useful way in
-- SynthDefs. The type resolution algorithm should rarely (discovery: not
-- never!) give weird behavior as long as other instances aren't defined:

-- | For 'Constant' (Float) values
instance {-# INCOHERENT #-} (Num n, Real n) => ToSig n args where
   toSig :: n -> SDBody' args Signal
   toSig = return . Constant . realToFrac

#endif

-- This way instead of e.g.
-- > BufferId b <- makeBuffer 1
-- > playBuf (buf_ $ toEnum $ fromEnum b
--
-- we can say:
-- > b <- makeBuffer 1
-- > playBuf (buf_ b
-- instance ToSomeSig BufferId where
instance ToSig BufferId args where
   toSig :: BufferId -> SDBody' args Signal
   toSig (BufferId n) = (return . Constant . realToFrac) n

instance (a ~ args) => ToSig (SDBody' a Signal) args where
   toSig :: SDBody' args Signal -> SDBody' args Signal
   toSig x = x