{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Web.Audio
(
webAudio
, WAOptions(..)
, send
, connect
, (.|.)
, (.||.)
, connector
, connectorLast
, eNode
, eParam
, eCtx
, WebAudio(..)
, AudioNode(..)
, OscillatorNode(..)
, OscillatorNodeType(..)
, GainNode(..)
, AudioParam(..)
, ChannelCountMode(..)
, AudioParamType(..)
, createOscillator
, createGain
, audioContext
, maxValue
, minValue
, value
, currentTime
, start
, startWhen
, stop
, stopWhen
, disconnect
, disconnectOutput
, disconnectOutputInput
, disconnectDestNode
, disconnectDestNodeSpec
, disconnectDestParam
, disconnectDestParamSpec
, setValue
, setValueAtTime
, linearRampToValueAtTime
, exponentialRampToValueAtTime
, setTargetAtTime
, cancelScheduledValues
) where
import Control.Concurrent.STM
import Control.Natural
import qualified Control.Remote.Applicative as APP
import Control.Remote.Monad
import Control.Remote.Monad.Packet.Applicative as AP
import Data.Aeson (FromJSON(..),Value(..),withText)
import Data.Aeson.Types (Parser,parse,Result(..))
import Data.Monoid ((<>))
import qualified Data.Text as T
import Network.Wai.Middleware.Static
import Paths_wahsp
import System.IO.Unsafe (unsafePerformIO)
import Web.Audio.JavaScript
import Web.Audio.Packets
import Web.Audio.WebAudio
import qualified Web.Scotty.Comet as KC
import Web.Scotty
webAudio :: WAOptions -> (KC.Document -> IO ()) -> IO ()
webAudio opts actions = do
kcomet <- KC.kCometPlugin
dataDir <- getDataDir
let pol = only [ ("",dataDir ++ "/index.html")
, ("js/kansas-comet.js",kcomet)
, ("js/jquery.js",dataDir ++ "/js/jquery.js")
, ("js/jquery-json.js",dataDir ++ "/js/jquery-json.js")
]
<|> (hasPrefix "js/") >-> addBase "."
let kcopts = KC.Options {KC.prefix = "/example", KC.verbose = if debug opts then 3 else 0}
connectApp <- KC.connect kcopts $ \kc_doc -> do
actions kc_doc
scotty (port opts) $ do
middleware $ staticPolicy pol
connectApp
return()
(.|.) :: forall b a. AudioNode a => a -> AudioGraph AudNode b -> AudioGraph AudNode b
(.|.) a b = connector a b
infix 7 .|.
(.||.) :: forall b a. AudioNode a => a -> AudioGraph AudNode b -> AudioGraph AudNode b
(.||.) = connectorLast
connector :: forall b a. AudioNode a => a -> AudioGraph AudNode b -> AudioGraph AudNode b
connector node = Node (AudNode node)
connectorLast :: forall b a. AudioNode a => a -> AudioGraph AudNode b -> AudioGraph AudNode b
connectorLast a b = Node (AudNode a) b
infix 8 .||.
eNode :: AudioNode a => a -> AudioGraph AudNode AudNode
eNode a = EndNode (AudNode a)
eParam :: AudioParam -> AudioGraph AudNode AudioParam
eParam = EndParam
eCtx :: AudioGraph AudNode AudioContext
eCtx = EndCtx AudioContext
audioContext = AudioContext
createOscillator :: Double
-> Double
-> OscillatorNodeType
-> WebAudio OscillatorNode
createOscillator freq det osctype = WebAudio $ procedure (CreateOscillator freq det osctype)
createGain :: Double -> WebAudio GainNode
createGain val = WebAudio $ procedure (CreateGain val)
defaultValue :: AudioParam -> WebAudio Double
defaultValue p = WebAudio $ procedure (DefaultValue p)
maxValue :: AudioParam -> WebAudio Double
maxValue p = WebAudio $ procedure (MaxValue p)
minValue :: AudioParam -> WebAudio Double
minValue p = WebAudio $ procedure (MinValue p)
value :: AudioParam -> WebAudio Double
value p = WebAudio $ procedure (Value p)
currentTime :: WebAudio Double
currentTime = WebAudio $ procedure (CurrentTime)
start :: OscillatorNode -> WebAudio ()
start = WebAudio . command . Start
startWhen :: OscillatorNode -> Double -> WebAudio ()
startWhen o t = WebAudio . command $ StartWhen o t
stop :: OscillatorNode -> WebAudio ()
stop = WebAudio . command . Stop
stopWhen :: OscillatorNode -> Double -> WebAudio ()
stopWhen o t = WebAudio . command $ StopWhen o t
disconnect :: AudioNode a => a -> WebAudio ()
disconnect src = WebAudio . command $ Disconnect src
disconnectOutput :: AudioNode a => a -> Int -> WebAudio ()
disconnectOutput src idx = WebAudio . command $ DisconnectOutput src idx
disconnectOutputInput :: AudioNode a => a -> a -> Int -> Int -> WebAudio ()
disconnectOutputInput src dest output input = WebAudio . command $
DisconnectOutputInput src dest output input
disconnectDestNode :: AudioNode a => a -> a -> WebAudio ()
disconnectDestNode src dest = WebAudio . command $ DisconnectDestNode src dest
disconnectDestNodeSpec :: AudioNode a => a -> a -> Int -> WebAudio ()
disconnectDestNodeSpec src dest idx = WebAudio . command $ DisconnectDestNodeSpec src dest idx
disconnectDestParam :: AudioNode a => a -> AudioParam -> WebAudio ()
disconnectDestParam src dest = WebAudio . command $ DisconnectDestParam src dest
disconnectDestParamSpec :: AudioNode a => a -> AudioParam -> Int -> WebAudio ()
disconnectDestParamSpec src dest idx = WebAudio . command $ DisconnectDestParamSpec src dest idx
connect :: AudioGraph AudNode b -> WebAudio ()
connect g = WebAudio . command $ Connect g
setValue :: AudioParam -> Double -> WebAudio ()
setValue p val = WebAudio . command $ SetValue p val
setValueAtTime :: AudioParam -> Double -> Double -> WebAudio ()
setValueAtTime p val startTime = WebAudio . command $ SetValueAtTime p val startTime
linearRampToValueAtTime :: AudioParam -> Double -> Double -> WebAudio ()
linearRampToValueAtTime p val endTime = WebAudio . command $ LinearRampToValueAtTime p val endTime
exponentialRampToValueAtTime :: AudioParam -> Double -> Double -> WebAudio ()
exponentialRampToValueAtTime p val endTime = WebAudio . command $
ExponentialRampToValueAtTime p val endTime
setTargetAtTime :: AudioParam -> Double -> Double -> Double -> WebAudio ()
setTargetAtTime p target startTime timeConstant =
WebAudio . command $ SetTargetAtTime p target startTime timeConstant
cancelScheduledValues :: AudioParam -> Double -> WebAudio ()
cancelScheduledValues p startTime = WebAudio . command $ CancelScheduledValues p startTime
send :: KC.Document -> WebAudio a -> IO a
send = sendApp
sendApp :: KC.Document -> WebAudio a -> IO a
sendApp d (WebAudio m) = (run $ runMonad $ nat (runAP d)) m
runAP :: KC.Document -> ApplicativePacket Command Procedure a -> IO a
runAP d pkt =
case AP.superCommand pkt of
Just a -> do
cmds <- handlePacket d pkt ""
KC.send d cmds
return a
Nothing -> case pkt of
AP.Command cmd -> do
putStrLn ""
cmds <- formatCommand cmd ""
KC.send d cmds
AP.Procedure p -> sendProcedure d p ""
AP.Zip f g h -> f <$> runAP d g <*> runAP d h
AP.Pure p -> pure p
where
handlePacket :: KC.Document -> ApplicativePacket Command Procedure a -> T.Text -> IO T.Text
handlePacket doc pkt cmds =
case pkt of
AP.Command cmd -> formatCommand cmd cmds
AP.Procedure p -> return cmds
AP.Pure a -> return cmds
AP.Zip f g h -> do
gcmds <- handlePacket doc g cmds
hcmds <- handlePacket doc h gcmds
return hcmds
sendProcedure :: KC.Document -> Procedure a -> T.Text -> IO a
sendProcedure d p@(CreateOscillator freq det nodetype) _ =
formatProcedure d p $ "CreateOscillator(" <> tshow freq <> "," <> tshow det <> ",'" <>
tshow nodetype <> "')"
sendProcedure d p@(CreateGain val) _ = formatProcedure d p $ "CreateGain(" <> tshow val <> ")"
sendProcedure d p@(DefaultValue audioParam) _ =
formatProcedure d p $ "DefaultValue(" <> showtJS audioParam <> ")"
sendProcedure d p@(MaxValue audioParam) _ =
formatProcedure d p $ "MaxValue(" <> showtJS audioParam <> ")"
sendProcedure d p@(MinValue audioParam) _ =
formatProcedure d p $ "MinValue(" <> showtJS audioParam <> ")"
sendProcedure d p@(Value audioParam) _ =
formatProcedure d p $ "Value(" <> showtJS audioParam <> ")"
sendProcedure d p@(CurrentTime) _ = formatProcedure d p "GetCurrentTime()"
formatProcedure :: KC.Document -> Procedure a -> T.Text -> IO a
formatProcedure d p call = do
uq <- atomically getUniq
KC.send d $ call <> "(" <> tshow uq <> ");"
v <- KC.getReply d uq
case parse (parseProcedure p) v of
Error msg -> fail msg
Success a -> return a
parseProcedure :: Procedure a -> Value -> Parser a
parseProcedure (CreateOscillator {}) o = uncurry9 OscillatorNode <$> parseJSON o
parseProcedure (CreateGain {}) o = uncurry7 GainNode <$> parseJSON o
parseProcedure (DefaultValue {}) o = parseJSON o
parseProcedure (MaxValue {}) o = parseJSON o
parseProcedure (MinValue {}) o = parseJSON o
parseProcedure (Value {}) o = parseJSON o
parseProcedure (CurrentTime {}) o = parseJSON o
formatCommand :: Command -> T.Text -> IO T.Text
formatCommand (Start osc) cmds = return $ cmds <> showtJS osc <> ".start();"
formatCommand (StartWhen osc t) cmds = return $ cmds <> showtJS osc <> ".start(" <> tshow t <> ");"
formatCommand (Stop osc) cmds = return $ cmds <> showtJS osc <> ".stop();"
formatCommand (StopWhen osc t) cmds = return $ cmds <> showtJS osc <> ".stop(" <> tshow t <> ");"
formatCommand (Connect g) cmds = return $ cmds <> audioGraphConnect g <> ";"
formatCommand (Disconnect src) cmds = return $ cmds <> showtJS src <> ".disconnect();"
formatCommand (DisconnectOutput src idx) cmds = return $ cmds <> showtJS src <>
".disconnect(" <> showtJS idx <> ");"
formatCommand (DisconnectOutputInput src dest output input) cmds = return $
cmds <> showtJS src <> ".disconnect(" <> showtJS dest <> "," <> showtJS output <> "," <>
showtJS input <> ");"
formatCommand (DisconnectDestNode src dest) cmds = return $
cmds <> showtJS src <> ".disconnect(" <> showtJS dest <> ");"
formatCommand (DisconnectDestNodeSpec src dest idx) cmds = return $
cmds <> showtJS src <> ".disconnect(" <> showtJS dest <> "," <> showtJS idx <> ");"
formatCommand (DisconnectDestParam src dest) cmds = return $
cmds <> showtJS src <> ".disconnect(" <> showtJS dest <> ");"
formatCommand (DisconnectDestParamSpec src dest idx) cmds = return $
cmds <> showtJS src <> ".disconnect(" <> showtJS dest <> "," <> showtJS idx <> ");"
formatCommand (SetValue p val) cmds = return $ cmds <> showtJS p <> ".value = " <> showtJS val <> ";"
formatCommand (SetValueAtTime p val startTime) cmds = return $ cmds <> showtJS p <>
".setValueAtTime(" <> showtJS val <> "," <> showtJS startTime <> ");"
formatCommand (LinearRampToValueAtTime p val endTime) cmds = return $ cmds <>
showtJS p <> ".linearRampToValueAtTime(" <> showtJS val <> "," <> showtJS endTime <> ");"
formatCommand (ExponentialRampToValueAtTime p val endTime) cmds = return $ cmds <>
showtJS p <> ".exponentialRampToValueAtTime(" <> showtJS val <> "," <> showtJS endTime <> ");"
formatCommand (SetTargetAtTime p target startTime timeConstant) cmds = return $ cmds <>
showtJS p <> ".setTargetAtTime(" <> showtJS target <> "," <> showtJS startTime <> "," <>
showtJS timeConstant <> ");"
formatCommand (CancelScheduledValues p startTime ) cmds = return $ cmds <>
showtJS p <> ".cancelScheduledValues(" <> showtJS startTime <> ");"
{-# NOINLINE uniqVar #-}
uniqVar :: TVar Int
uniqVar = unsafePerformIO $ newTVarIO 0
getUniq :: STM Int
getUniq = do
u <- readTVar uniqVar
writeTVar uniqVar (u + 1)
return u