-- | Rewriter for @psynth@ directives and related functions.
module Sound.SC3.RW.PSynth where

import Data.Char
import Data.Functor.Identity
import Data.List
import System.Environment {- base -}
import Text.Parsec
import qualified Text.Parsec.Token as P
import qualified Text.Parsec.Language as P

-- * Types

-- | A SynthDef parameter.
type Param = (String,Double)

-- | Name of 'SynthDef' and associated 'Param'.
type PSynth = (String,[Param])

-- * Pretty printer

-- | Printer for control and trigger parameters.
--
-- > map param_pp [("freq",440),("t_gate",1)]
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"]

-- * Parser

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' pre-amble.
--
-- > parse_psynth "gr = psynth {freq = 440,phase = 0,amp = 0.1,loc = 0} where"
parse_psynth :: String -> PSynth
parse_psynth s =
    case parse psynth "parse_psynth" s of
      Left e -> error (show e)
      Right r -> r

-- | Rewrite 'PSynth' pre-amble.
--
-- > rewrite_psynth "gr = psynth {freq = 440,phase = 0,amp = 0.1,loc = 0} where"
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 plaine 'Param' list, ie. SC3 argument list.
--
-- > rewrite_param_list "freq=440,amp=0.1,t_gate=1"
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

-- * Re-write processor

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']

-- | Arguments as required by @ghc -F -pgmF@.
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"

-- | Rewrite uparam pre-amble.
--
-- > uparam_rewrite "    let uparam = {amp = 0.1, freq = 129.897, rise = 0.1, fall = 0.5}"
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

-- | Arguments as required by @ghc -F -pgmF@.
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"