-- Copyright 2020 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Low level binding to faust dsps, specialized for ones that process
-- audio, rather than generating it.
module Synth.Faust.EffectC (
    EffectT(_name, _doc, _controls)
    , Patch, Effect
    , State
    -- * Patch
    , get, patches
    -- * Effect
    , allocate, destroy
    , render
    -- ** state
    , getState, unsafeGetState, putState
) where
import qualified Data.ByteString as ByteString
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector.Storable as V

import qualified System.IO.Unsafe as Unsafe

import qualified Util.Audio.Audio as Audio
import qualified Util.Serialize as Serialize
import qualified Synth.Faust.PatchC as PatchC
import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Note as Note

import           ForeignC
import           Global


data EffectT ptr cptr = EffectT {
    forall ptr cptr. EffectT ptr cptr -> Text
_name :: !Text
    , forall ptr cptr. EffectT ptr cptr -> Text
_doc :: !Text
    , forall ptr cptr. EffectT ptr cptr -> Map Control (cptr, Text)
_controls :: !(Map Control.Control (cptr, Text))
    , forall ptr cptr. EffectT ptr cptr -> ptr
_ptr :: !ptr
    } deriving (Int -> EffectT ptr cptr -> ShowS
[EffectT ptr cptr] -> ShowS
EffectT ptr cptr -> String
(Int -> EffectT ptr cptr -> ShowS)
-> (EffectT ptr cptr -> String)
-> ([EffectT ptr cptr] -> ShowS)
-> Show (EffectT ptr cptr)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall ptr cptr.
(Show cptr, Show ptr) =>
Int -> EffectT ptr cptr -> ShowS
forall ptr cptr.
(Show cptr, Show ptr) =>
[EffectT ptr cptr] -> ShowS
forall ptr cptr.
(Show cptr, Show ptr) =>
EffectT ptr cptr -> String
showList :: [EffectT ptr cptr] -> ShowS
$cshowList :: forall ptr cptr.
(Show cptr, Show ptr) =>
[EffectT ptr cptr] -> ShowS
show :: EffectT ptr cptr -> String
$cshow :: forall ptr cptr.
(Show cptr, Show ptr) =>
EffectT ptr cptr -> String
showsPrec :: Int -> EffectT ptr cptr -> ShowS
$cshowsPrec :: forall ptr cptr.
(Show cptr, Show ptr) =>
Int -> EffectT ptr cptr -> ShowS
Show)

-- | A patch can be used to create 'Effect's.
type Patch = EffectT PatchC.PatchP ()

-- | An allocated patch.
type Effect = EffectT PatchC.InstrumentP (Ptr Float)


-- * Patch

get :: Text -> IO Patch
get :: Text -> IO Patch
get Text
name = case Text -> Map Text (Either Text Patch) -> Maybe (Either Text Patch)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text (Either Text Patch)
patches of
    Just (Right Patch
patch) -> Patch -> IO Patch
forall (m :: * -> *) a. Monad m => a -> m a
return Patch
patch
    Just (Left Text
err) -> Text -> IO Patch
forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO (Text -> IO Patch) -> Text -> IO Patch
forall a b. (a -> b) -> a -> b
$ Text
"effect " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
    Maybe (Either Text Patch)
Nothing -> Text -> IO Patch
forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO (Text -> IO Patch) -> Text -> IO Patch
forall a b. (a -> b) -> a -> b
$ Text
"no effect: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name

-- | All configured effects.
patches :: Map Text (Either Text Patch)
patches :: Map Text (Either Text Patch)
patches = IO (Map Text (Either Text Patch)) -> Map Text (Either Text Patch)
forall a. IO a -> a
Unsafe.unsafePerformIO (IO (Map Text (Either Text Patch)) -> Map Text (Either Text Patch))
-> IO (Map Text (Either Text Patch))
-> Map Text (Either Text Patch)
forall a b. (a -> b) -> a -> b
$ do
    [(Text, PatchP)]
namePatches <- ((Text, PatchP) -> Bool) -> [(Text, PatchP)] -> [(Text, PatchP)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text
"effect-" `Text.isPrefixOf`) (Text -> Bool)
-> ((Text, PatchP) -> Text) -> (Text, PatchP) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, PatchP) -> Text
forall a b. (a, b) -> a
fst) ([(Text, PatchP)] -> [(Text, PatchP)])
-> IO [(Text, PatchP)] -> IO [(Text, PatchP)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        IO [(Text, PatchP)]
PatchC.patches
    Map Text (Either Text Patch) -> IO (Map Text (Either Text Patch))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Text (Either Text Patch) -> IO (Map Text (Either Text Patch)))
-> Map Text (Either Text Patch)
-> IO (Map Text (Either Text Patch))
forall a b. (a -> b) -> a -> b
$ [(Text, Either Text Patch)] -> Map Text (Either Text Patch)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Either Text Patch)] -> Map Text (Either Text Patch))
-> [(Text, Either Text Patch)] -> Map Text (Either Text Patch)
forall a b. (a -> b) -> a -> b
$
        [Text] -> [Either Text Patch] -> [(Text, Either Text Patch)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Text, PatchP) -> Text) -> [(Text, PatchP)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
Text.drop (Text -> Int
Text.length Text
"effect-") (Text -> Text)
-> ((Text, PatchP) -> Text) -> (Text, PatchP) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, PatchP) -> Text
forall a b. (a, b) -> a
fst) [(Text, PatchP)]
namePatches)
            (((Text, PatchP) -> Either Text Patch)
-> [(Text, PatchP)] -> [Either Text Patch]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> PatchP -> Either Text Patch)
-> (Text, PatchP) -> Either Text Patch
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> PatchP -> Either Text Patch
getPatchP) [(Text, PatchP)]
namePatches)
    -- unsafePerformIO is ok for these since they are just looking up static
    -- data from C.

getPatchP :: Text -> PatchC.PatchP -> Either Text Patch
getPatchP :: Text -> PatchP -> Either Text Patch
getPatchP Text
name PatchP
patch = IO (Either Text Patch) -> Either Text Patch
forall a. IO a -> a
Unsafe.unsafePerformIO (IO (Either Text Patch) -> Either Text Patch)
-> IO (Either Text Patch) -> Either Text Patch
forall a b. (a -> b) -> a -> b
$ do
    Map Text Text
meta <- PatchP -> IO (Map Text Text)
PatchC.getMetadata PatchP
patch
    [(([Text], Control), Text)]
ui <- PatchP -> IO [(([Text], Control), Text)]
PatchC.getUiControls PatchP
patch
    let inputs :: Int
inputs = PatchP -> Int
PatchC.patchInputs PatchP
patch
        outputs :: Int
outputs = PatchP -> Int
PatchC.patchOutputs PatchP
patch
    Either Text Patch -> IO (Either Text Patch)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Patch -> IO (Either Text Patch))
-> Either Text Patch -> IO (Either Text Patch)
forall a b. (a -> b) -> a -> b
$ Text
-> Map Text Text
-> [(Control, Text)]
-> Int
-> Int
-> PatchP
-> Either Text Patch
makePatch Text
name Map Text Text
meta (((([Text], Control), Text) -> (Control, Text))
-> [(([Text], Control), Text)] -> [(Control, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((([Text], Control) -> Control)
-> (([Text], Control), Text) -> (Control, Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Text], Control) -> Control
forall a b. (a, b) -> b
snd) [(([Text], Control), Text)]
ui) Int
inputs Int
outputs PatchP
patch

makePatch :: Text -> Map Text Text -> [(Control.Control, Text)]
    -> Int -> Int -> PatchC.PatchP -> Either Text Patch
makePatch :: Text
-> Map Text Text
-> [(Control, Text)]
-> Int
-> Int
-> PatchP
-> Either Text Patch
makePatch Text
name Map Text Text
meta [(Control, Text)]
uis Int
inputs Int
outputs PatchP
ptr = (Text -> Text) -> Either Text Patch -> Either Text Patch
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) (Either Text Patch -> Either Text Patch)
-> Either Text Patch -> Either Text Patch
forall a b. (a -> b) -> a -> b
$ do
    Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
inputs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
        Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"expected 2 inputs, got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
inputs
    Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
outputs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
        Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"expected 2 outputs, got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
outputs
    Patch -> Either Text Patch
forall (m :: * -> *) a. Monad m => a -> m a
return (Patch -> Either Text Patch) -> Patch -> Either Text Patch
forall a b. (a -> b) -> a -> b
$ EffectT
        { _name :: Text
_name = Text
name
        , _doc :: Text
_doc = Map Text Text -> Text
PatchC.parseDescription Map Text Text
meta
        , _controls :: Map Control ((), Text)
_controls =
            [(Control, ((), Text))] -> Map Control ((), Text)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Control
control, ((), Text
doc)) | (Control
control, Text
doc) <- [(Control, Text)]
uis]
        , _ptr :: PatchP
_ptr = PatchP
ptr
        }

-- * Effect

allocate :: Patch -> IO Effect
allocate :: Patch -> IO Effect
allocate Patch
patch = do
    (InstrumentP
ptr, [(([Text], Control), Ptr Float)]
controls) <- PatchP -> IO (InstrumentP, [(([Text], Control), Ptr Float)])
PatchC.allocate (Patch -> PatchP
forall ptr cptr. EffectT ptr cptr -> ptr
_ptr Patch
patch)
    Effect -> IO Effect
forall (m :: * -> *) a. Monad m => a -> m a
return (Effect -> IO Effect) -> Effect -> IO Effect
forall a b. (a -> b) -> a -> b
$ Patch
patch
        { _ptr :: InstrumentP
_ptr = InstrumentP
ptr
        , _controls :: Map Control (Ptr Float, Text)
_controls = [(Control, (Ptr Float, Text))] -> Map Control (Ptr Float, Text)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (Control
control, (Ptr Float
cptr, Control -> Text
getDoc Control
control))
            | (([Text]
_, Control
control), Ptr Float
cptr) <- [(([Text], Control), Ptr Float)]
controls
            ]
        }
    where
    -- A Nothing means getUiControls returned different controls than it did
    -- when the 'Patch' was constructed, which should not happen.
    getDoc :: Control -> Text
getDoc Control
c = Text -> (((), Text) -> Text) -> Maybe ((), Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((), Text) -> Text
forall a b. (a, b) -> b
snd (Maybe ((), Text) -> Text) -> Maybe ((), Text) -> Text
forall a b. (a -> b) -> a -> b
$ Control -> Map Control ((), Text) -> Maybe ((), Text)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
c (Patch -> Map Control ((), Text)
forall ptr cptr. EffectT ptr cptr -> Map Control (cptr, Text)
_controls Patch
patch)

destroy :: Effect -> IO ()
destroy :: Effect -> IO ()
destroy = InstrumentP -> IO ()
PatchC.c_faust_destroy (InstrumentP -> IO ())
-> (Effect -> InstrumentP) -> Effect -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect -> InstrumentP
forall ptr cptr. EffectT ptr cptr -> ptr
_ptr

-- | Render chunk of time and return samples.
render :: Audio.Frames -> Audio.Frames -> Effect
    -> [(Ptr Float, Audio.Block)]
    -> [V.Vector Float] -- ^ Input signals.  The length must be equal to the
    -- the patchInputs, and each vector must have the same length.
    -> IO [V.Vector Float] -- ^ one block of samples for each output channel
render :: Frames
-> Frames
-> Effect
-> [(Ptr Float, Block)]
-> [Vector Float]
-> IO [Vector Float]
render Frames
controlSize Frames
controlsPerBlock Effect
effect =
    Frames
-> Frames
-> InstrumentP
-> [(Ptr Float, Block)]
-> [Vector Float]
-> IO [Vector Float]
PatchC.render Frames
controlSize Frames
controlsPerBlock (Effect -> InstrumentP
forall ptr cptr. EffectT ptr cptr -> ptr
_ptr Effect
effect)

-- ** state

newtype State = State ByteString.ByteString
    deriving (Get State
Putter State
Putter State -> Get State -> Serialize State
forall a. Putter a -> Get a -> Serialize a
get :: Get State
$cget :: Get State
put :: Putter State
$cput :: Putter State
Serialize.Serialize)

instance Pretty State where
    pretty :: State -> Text
pretty (State ByteString
bytes) = String -> Text
txt (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
Note.fingerprintBytes ByteString
bytes

getState :: Effect -> IO State
getState :: Effect -> IO State
getState = (ByteString -> State) -> IO ByteString -> IO State
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> State
State (IO ByteString -> IO State)
-> (Effect -> IO ByteString) -> Effect -> IO State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstrumentP -> IO ByteString
PatchC.getState (InstrumentP -> IO ByteString)
-> (Effect -> InstrumentP) -> Effect -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect -> InstrumentP
forall ptr cptr. EffectT ptr cptr -> ptr
_ptr

-- | 'getState', but without copying, if you promise to finish with the State
-- before you call 'render', which will change it.
unsafeGetState :: Effect -> IO State
unsafeGetState :: Effect -> IO State
unsafeGetState = (ByteString -> State) -> IO ByteString -> IO State
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> State
State (IO ByteString -> IO State)
-> (Effect -> IO ByteString) -> Effect -> IO State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstrumentP -> IO ByteString
PatchC.unsafeGetState (InstrumentP -> IO ByteString)
-> (Effect -> InstrumentP) -> Effect -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effect -> InstrumentP
forall ptr cptr. EffectT ptr cptr -> ptr
_ptr

putState :: Effect -> State -> IO ()
putState :: Effect -> State -> IO ()
putState Effect
effect (State ByteString
state) =
    ByteString -> Text -> InstrumentP -> IO ()
PatchC.putState ByteString
state (Effect -> Text
forall ptr cptr. EffectT ptr cptr -> Text
_name Effect
effect) (Effect -> InstrumentP
forall ptr cptr. EffectT ptr cptr -> ptr
_ptr Effect
effect)