module Sound.SC3.RW.PSynth where
import Data.Char
import Data.Functor.Identity
import Data.List
import System.Environment
import Text.Parsec
import qualified Text.Parsec.Token as P
import qualified Text.Parsec.Language as P
type Param = (String,Double)
type PSynth = (String,[Param])
param_pp :: Param -> String
param_pp (nm,def) =
let fn = if "t_" `isPrefixOf` nm
then "tr_control"
else "control KR"
in concat [nm," = ",fn," \"",nm,"\" ",show def]
add_braces :: String -> String
add_braces s = concat ["{",s,"}"]
params_pp :: [Param] -> String
params_pp = intercalate ";" . map param_pp
uparam_pp :: [Param] -> String
uparam_pp p = "let " ++ params_pp p
psynth_pp :: PSynth -> String
psynth_pp (nm,pp) = concat [nm," = synthdef \"",nm,"\" (let ",add_braces (params_pp pp)," in"]
type P a = ParsecT String () Identity a
promote :: Either Integer Double -> Double
promote = either fromIntegral id
assign :: P Param
assign = do
lhs <- identifier
_ <- equals
rhs <- naturalOrFloat
return (lhs,promote rhs)
param_list :: P [Param]
param_list = sepBy1 assign comma
uparam :: P [Param]
uparam = symbol "let" >> symbol "uparam" >> equals >> braces param_list
psynth :: P PSynth
psynth = do
nm <- identifier
_ <- equals
_ <- symbol "psynth"
pp <- braces param_list
_ <- symbol "where"
return (nm,pp)
parse_psynth :: String -> PSynth
parse_psynth s =
case parse psynth "parse_psynth" s of
Left e -> error (show e)
Right r -> r
rewrite_psynth :: String -> String
rewrite_psynth = psynth_pp . parse_psynth
parse_param_list :: String -> [Param]
parse_param_list s =
case parse param_list "parse_param_list" s of
Left e -> error (show e)
Right r -> r
rewrite_param_list :: String -> String
rewrite_param_list s = unlines (map param_pp (parse_param_list s))
parse_uparam :: String -> [Param]
parse_uparam s =
case parse uparam "parse_uparam" s of
Left e -> error (show e)
Right r -> r
rewrite_uparam :: String -> String
rewrite_uparam = uparam_pp . parse_uparam
lexer :: P.GenTokenParser String u Identity
lexer = P.makeTokenParser P.haskellDef
braces :: P a -> P a
braces = P.braces lexer
identifier :: P String
identifier = P.identifier lexer
symbol :: String -> P String
symbol = P.symbol lexer
naturalOrFloat :: P (Either Integer Double)
naturalOrFloat = P.naturalOrFloat lexer
equals :: P String
equals = P.lexeme lexer (string "=")
comma :: P String
comma = P.comma lexer
semi :: P String
semi = P.semi lexer
begins_psynth :: String -> Bool
begins_psynth = isInfixOf " = psynth {"
ends_psynth :: String -> Bool
ends_psynth s =
case s of
[] -> True
c:_ -> not (isSpace c)
psynth_rewrite :: [String] -> [String]
psynth_rewrite l =
case break begins_psynth l of
([],rhs) -> rhs
(lhs,[]) -> lhs
(lhs,p:rhs) -> case break ends_psynth rhs of
(lhs',rhs') -> concat [lhs
,[rewrite_psynth p]
,lhs'
,[" )"]
,psynth_rewrite rhs']
psynth_rewrite_ghcF :: IO ()
psynth_rewrite_ghcF = do
a <- getArgs
case a of
[_,i_fn,o_fn] -> do
i <- readFile i_fn
let f = unlines . psynth_rewrite . lines
writeFile o_fn (f i)
_ -> error "initial-file input-file output-file"
uparam_rewrite :: String -> String
uparam_rewrite s =
if "let uparam = {" `isInfixOf` s
then case span isSpace s of
([],_) -> error "uparam_rewrite"
(lhs,rhs) -> lhs ++ rewrite_uparam rhs
else s
uparam_rewrite_ghcF :: IO ()
uparam_rewrite_ghcF = do
a <- getArgs
case a of
[_,i_fn,o_fn] -> do
i <- readFile i_fn
let f = unlines . map uparam_rewrite . lines
writeFile o_fn (f i)
_ -> error "initial-file input-file output-file"