Bindings.hs

-- | Generate (approximate) UGen binding functions from DB.
module Sound.SC3.UGen.DB.Bindings where

import Data.List {- base -}
import Data.Maybe {- base -}
import Text.Printf {- base -}

import Sound.SC3.UGen.Rate {- hsc3 -}
import Sound.SC3.UGen.UGen (sep_last) {- hsc3 -}

import Sound.SC3.UGen.DB
import Sound.SC3.UGen.DB.Rename
import Sound.SC3.UGen.DB.Record

bindings_mce :: U -> [String] -> ([String],Maybe String)
bindings_mce u i =
    if ugen_std_mce u
    then case sep_last i of
           Just (lhs,rhs) -> (lhs,Just rhs)
           Nothing -> error "bindings_mce: halt mce transform?"
    else (i,Nothing)

-- | Give name of 'Enum' give name of function to map to UGen input.
--
-- > unenumerator "Warp" == "from_warp"
-- > import Sound.SC3.UGen.Enum {- hsc3 -}
-- > from_warp Linear == 0
unenumerator :: String -> String
unenumerator en =
    case en of
      "Envelope UGen" -> "envelope_to_ugen"
      "Loop" -> "from_loop"
      "Interpolation" -> "from_interpolation"
      "DoneAction" -> "from_done_action"
      "Warp" -> "from_warp"
      _ -> error "unenumerator"

-- | If input is an enumeration add 'unenumerator' as prefix.
input_name_proc :: U -> (String,Int) -> String
input_name_proc u (nm,ix) =
    case input_enumeration u ix of
      Just en -> printf "(%s %s)" (unenumerator en) nm
      Nothing -> nm

-- | 'input_name_proc' of 'ugen_inputs'
--
-- > let r = ["start","end","dur","from_done_action doneAction"]
-- > in fmap u_input_names_proc (uLookup "Line") == Just r
u_input_names_proc :: U -> [String] -> [String]
u_input_names_proc u nms = map (input_name_proc u) (zip nms [0..])

-- | Bracket list.
--
-- > about ('[',']') "a,b" == "[a,b]"
about :: (a, a) -> [a] -> [a]
about (p,q) s = p : s ++ [q]

-- | 'about' of @[]@.
--
-- > brckt "a,b" == "[a,b]"
brckt :: String -> String
brckt = about ('[',']')

-- | 'about' of @""@.
quote :: [Char] -> [Char]
quote = about ('"','"')

-- | Variant that 'delete's empty inputs, useful for pretty printing.
--
-- > unwords ["a","","b"] == "a  b"
-- > unwords' ["a","","b"] == "a b"
unwords' :: [String] -> String
unwords' = unwords . filter (not . null)

-- | Alias for 'unwords''.
--
-- > ppl_space ["freq","phase"] == "freq phase"
ppl_space :: [String] -> String
ppl_space = unwords'

-- | Haskel list PP.
--
-- > ppl_list ["freq","phase"] == "[freq,phase]"
ppl_list :: [String] -> String
ppl_list = brckt . intercalate ","

-- | Generate haskell type signature for UGen constructor.
--
-- > fmap u_gen_type_sig (uLookup "Blip") -- oscillator
-- > fmap u_gen_type_sig (uLookup "A2K") -- fixed rate
-- > fmap u_gen_type_sig (uLookup "BufRd") -- variable channel oscillator
-- > fmap u_gen_type_sig (uLookup "Resonz") -- filter
-- > fmap u_gen_type_sig (uLookup "BrownNoise") -- non-deterministic
-- > fmap u_gen_type_sig (uLookup "Dseq") -- fixed rate / non-det
-- > fmap u_gen_type_sig (uLookup "EnvGen") -- enum
u_gen_type_sig :: U -> [String]
u_gen_type_sig u =
    let i = ugen_inputs u
        i_sig = map (fromMaybe "UGen" . (input_enumeration u)) [0 .. length i - 1]
        nm = [hs_rename_ugen (ugen_name u),"::"]
        nd = if ugen_nondet u then ["ID","a","=>","a","->"] else []
        o = if ugen_nc_input u then ["Int","->"] else []
        r = case ugen_filter u of
              Nothing -> case ugen_fixed_rate u of
                           Just _ -> []
                           Nothing -> ["Rate","->"]
              Just _ -> []
        i_sig' = intersperse "->" i_sig
        arr = if null i then [] else ["->"]
    in concat [nm,nd,o,r,i_sig',arr,["UGen"]]

-- | The @outputs@ field may be fixed (ie. @SinOsc@) or variable
-- (ie. @In@ or @Demand@).  The output is a @(lhs,rhs)@ pair, either
-- @("nc","nc")@ or @("","k")@.
--
-- > fmap u_outputs (uLookup "BufRd") == Just ("numChannels","numChannels")
-- > fmap u_outputs (uLookup "SinOsc") == Just ("","1")
-- > fmap u_outputs (uLookup "Demand") == Just ("","(length (mceChannels demandUGens) + 0)")
u_outputs :: U -> (String,String)
u_outputs u =
    case u_fixed_outputs u of
      Just d -> ("",show d)
      Nothing ->
          if ugen_nc_input u
          then ("numChannels","numChannels")
          else case ugen_nc_mce u of
                 Just j -> let i = input_name (last (ugen_inputs u))
                               j' = show j
                           in ("",concat ["(length (mceChannels ",i,") + ",j',")"])
                 Nothing -> error "u_outputs?" -- rhs...

-- | Generate oscillator UGen constructor.
--
-- > let f = fmap (u_gen_fun . u_rename) . uLookup
-- > let g = mapM_ (putStrLn . unwords') . mapMaybe f
-- > g (words "Blip BufRd Dseq Rand WhiteNoise")
-- > g (words "CoinGate HPZ1 Out Resonz")
u_gen_fun :: U -> [String]
u_gen_fun u =
    let nm_sc3 = ugen_name u
        nm_hs = hs_rename_ugen nm_sc3
        i_lhs = u_renamed_inputs u
        (i_rhs,mc) = case bindings_mce u (u_input_names_proc u i_lhs) of
                       (r,Nothing) -> (ppl_list r,"Nothing")
                       (r,Just mc') -> (ppl_list r,concat ["(Just ",mc',")"])
        (nd_lhs,nd_rhs) = if ugen_nondet u then ("z","(toUId z)") else ("","NoId")
        r_set = let rr = case ugen_operating_rates u of
                           [] -> all_rates
                           r' -> r'
                in map show rr
        (o_lhs,o_rhs) = u_outputs u
        (rt_lhs,rt_rhs) = case ugen_filter u of
                            Just ix' -> ("",concat ["(Right ",ppl_list (map show ix'),")"])
                            Nothing -> case ugen_fixed_rate u of
                                         Just rt' -> ("","(Left " ++ show rt' ++ ")")
                                         Nothing -> ("rate","(Left rate)")
    in concat [[nm_hs,nd_lhs,o_lhs,rt_lhs],i_lhs
              ,["=","mkUGen","Nothing"]
              ,[ppl_list r_set,rt_rhs,quote nm_sc3,i_rhs,mc,o_rhs,"(Special 0)",nd_rhs]]

-- | Binding as @[haddock-comment,type-signature,function-definition]@ triple.
--
-- > fmap (u_gen_binding . u_rename) (uLookup "LFGauss")
-- > fmap (u_gen_binding . u_rename) (uLookup "In")
-- > fmap (u_gen_binding . u_rename) (uLookup "EnvGen")
u_gen_binding :: U -> [String]
u_gen_binding u =
    let c = ["-- |",ugen_summary u]
        s = u_gen_type_sig u
        b = u_gen_fun u
    in map unwords' [c,s,b]

-- | 'u_gen_binding' of 'ugenDB'.
u_gen_bindings :: [String]
u_gen_bindings =
    let b = map (u_gen_binding . u_rename_db ugenDB) ugenDB
    in intercalate [""] b

u_bindings_preamble :: [String]
u_bindings_preamble =
    ["module Sound.SC3.UGen.Bindings.DB where"
    ,""
    ,"import Sound.SC3.UGen.Envelope"
    ,"import Sound.SC3.UGen.Enum"
    ,"import Sound.SC3.UGen.Identifier"
    ,"import Sound.SC3.UGen.Rate"
    ,"import Sound.SC3.UGen.Type"
    ,"import Sound.SC3.UGen.UGen"
    ,""]

-- | 'writeFile' of 'u_gen_bindings'.
--
-- > let fn = "/tmp/hsc3-bindings.hs"
-- > let fn = "/home/rohan/sw/hsc3/Sound/SC3/UGen/Bindings/DB.hs"
-- > u_gen_bindings_write fn
u_gen_bindings_write :: FilePath -> IO ()
u_gen_bindings_write fn = writeFile fn (unlines (u_bindings_preamble ++ u_gen_bindings))