hsc3-rw 0.14 → 0.15

raw patch · 6 files changed

+274/−27 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README +6/−1
• Sound/SC3/RW/HA.hs +53/−0
• Sound/SC3/RW/ID.hs +1/−1
• Sound/SC3/RW/PSynth.hs +187/−0
• Sound/SC3/RW/Tag.hs +21/−21
• hsc3-rw.cabal +6/−4

@@ -3,12 +3,17 @@  [hsc3-rw][hsc3-rw] provides re-writing functions for use with [hsc3][hsc3]. +- `Sound.SC3.RW.HA` re-writes `#@` notation with `hash` of line and column numbers+- `Sound.SC3.RW.HP` re-writes `#()` notation+- `Sound.SC3.RW.ID` re-writes single character uniqueness identifiers+- `Sound.SC3.RW.PSynth` re-writes both [uparam](?t=hsc3-rw&e=md/uparam.md)+                        and [psynth](?t=hsc3-rw&e=md/psynth.md) notations - `Sound.SC3.RW.Tag` tags numeric literals with identifiers.  [hsc3]: http://rd.slavepianos.org/?t=hsc3 [hsc3-rw]: http://rd.slavepianos.org/?t=hsc3-rw -© [rohan drape][rd], 2013, [gpl][gpl].+© [rohan drape][rd], 2013-2014, [gpl][gpl].  [rd]: http://rd.slavepianos.org/ [gpl]: http://gnu.org/copyleft/

@@ -0,0 +1,53 @@+-- | Hash at-sign.  A simple minded haskell pre-processor that extends+-- the haskell syntax by rewriting @#\@@ sequences with a string+-- indicating the line and column number of the occurence.  The basic+-- pre-processor is 'ha_rewrite'.+module Sound.SC3.RW.HA where++import System.Environment {- base -}++-- * Hash At-Sign++-- | Find next /hash-at/, if there is one.+--+-- > ha_split 0 "let o = sinOsc AR (rand #@ 220 440) 0 * 0.1"+ha_split :: Integer -> String -> (Integer, String, String)+ha_split =+    let recur r n s =+            case s of+              [] -> (n,reverse r,[])+              '#' : '@' : s' -> (n + 2,reverse r,s')+              c : s' -> recur (c : r) (n + 1) s'+    in recur []++-- | Generate replacement for /hash-at/ given line and column numbers.+--+-- > ha_insert 14 23 == "(hash \"14:21\")"+ha_insert :: Integer -> Integer -> String+ha_insert ln cn = concat ["(hash \"",show ln,":",show (cn - 2),"\")"]++-- | Process line given line number.+--+-- > putStrLn$ha_process_ln 1 "let o = sinOsc AR (rand #@ 220 440) (rand2 #@ pi) * 0.1"+ha_process_ln :: Integer -> String -> String+ha_process_ln ln =+    let recur cn s =+            case ha_split cn s of+              (_,_,[]) -> s+              (cn',pre,post) -> pre ++ ha_insert ln cn' ++ recur cn' post+    in recur 0++-- | Re-write lines, starting at @1@.+ha_rewrite :: [String] -> [String]+ha_rewrite = zipWith ha_process_ln [1..]++-- | Arguments as required by @ghc -F -pgmF@.+ha_rewrite_ghcF :: IO ()+ha_rewrite_ghcF = do+  a <- getArgs+  case a of+    [_,i_fn,o_fn] -> do+           i <- readFile i_fn+           let f = unlines . ha_rewrite . lines+           writeFile o_fn (f i)+    _ -> error "initial-file input-file output-file"

@@ -1,4 +1,4 @@--- | Rewrite character ifdentifiers for @UGen.ID@ graphs.+-- | Rewrite character identifiers for @UGen.ID@ graphs. module Sound.SC3.RW.ID where  import Data.Char {- base -}

@@ -0,0 +1,187 @@+-- | 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"

@@ -1,9 +1,9 @@ -- | Rewrite expressions and modules attaching tags to numeric literals. module Sound.SC3.RW.Tag where -import Control.Monad.Trans.State {- transformers -}-import Data.Functor.Identity {- transformers -}-import Data.Generics {- syb -}+import qualified Control.Monad.Trans.State as T {- transformers -}+import qualified Data.Functor.Identity as T {- transformers -}+import qualified Data.Generics as G {- syb -} import Language.Haskell.Exts {- haskell-src-exts -}  -- | Make 'Var' 'Exp' for 'String'.@@ -75,18 +75,18 @@  -- | Variant of 'tag_exp' that derives the the tag name using a -- 'State' counter.-tag_exp_auto :: Exp -> State Int Exp+tag_exp_auto :: Exp -> T.State Int Exp tag_exp_auto e = do-  i <- get+  i <- T.get   let k = 'c' : show i-  put (i + 1)+  T.put (i + 1)   return (tag_exp k e) -span_exp_auto :: Exp -> State Int Exp+span_exp_auto :: Exp -> T.State Int Exp span_exp_auto e = do-  i <- get+  i <- T.get   let k = 'c' : show i-  put (i + 1)+  T.put (i + 1)   return (mk_span_id k [e])  -- | Apply /f/ at numeric literals, else /g/.@@ -98,16 +98,16 @@       _ -> g e  -- | 'at_num_lit' of 'tag_exp_auto'.-tag_num_lit :: Exp -> State Int Exp+tag_num_lit :: Exp -> T.State Int Exp tag_num_lit = at_num_lit tag_exp_auto return  -- | 'at_num_lit' of 'tag_exp_auto'.-span_num_lit :: Exp -> State Int Exp+span_num_lit :: Exp -> T.State Int Exp span_num_lit = at_num_lit span_exp_auto return  type Parser r = String -> ParseResult r type RW t m a = t -> m a-type RW_st t a = t -> State Int a+type RW_st t a = t -> T.State Int a type Tr = String -> String type Tr_m m = String -> m String type RW_Opt = (PPLayout,Int)@@ -122,10 +122,10 @@   return (prettyPrintStyleMode sty m r')  apply_rw_pure :: Pretty a => RW_Opt -> Parser t -> (t -> a) -> Tr-apply_rw_pure o p f = runIdentity . apply_rw o p (return . f)+apply_rw_pure o p f = T.runIdentity . apply_rw o p (return . f)  apply_rw_st :: Pretty a => RW_Opt -> Parser t -> RW_st t a -> Tr-apply_rw_st o p f = flip evalState 1 . apply_rw o p f+apply_rw_st o p f = flip T.evalState 1 . apply_rw o p f  -- | Rewrite 'Exp'. --@@ -133,7 +133,7 @@ -- > in exp_rw "sinOsc AR 440 0 * 0.1" == r exp_rw :: String -> String exp_rw =-    let f = everywhereM (mkM tag_num_lit)+    let f = G.everywhereM (G.mkM tag_num_lit)     in apply_rw_st (PPNoLayout,80) parseExp f  -- | Rewrite 'Module'.@@ -145,13 +145,13 @@ -- > in module_rw (unlines m) module_rw :: String -> String module_rw =-    let f = everywhereM (mkM tag_num_lit)+    let f = G.everywhereM (G.mkM tag_num_lit)     in apply_rw_st (PPNoLayout,80) parseModule f  -- | Inverse of 'exp_rw'. exp_un_rw :: String -> String exp_un_rw =-    let f = everywhere (mkT untag_exp)+    let f = G.everywhere (G.mkT untag_exp)     in apply_rw_pure (PPNoLayout,80) parseExp f  -- | 'RW_Opt' for html.  The /span/ code generates long lines...@@ -164,7 +164,7 @@ -- > in exp_rw_html (exp_rw e) exp_rw_html :: String -> String exp_rw_html =-    let f = everywhere' (mkT tag_to_span)+    let f = G.everywhere' (G.mkT tag_to_span)     in apply_rw_pure rw_html_opt parseExp f  -- | 'Module' variant of 'exp_rw_html'.@@ -173,19 +173,19 @@ -- > in module_rw_html (module_rw m) module_rw_html :: String -> String module_rw_html =-    let f = everywhere' (mkT tag_to_span)+    let f = G.everywhere' (G.mkT tag_to_span)     in apply_rw_pure rw_html_opt parseModule f  -- > exp_html "sinOsc AR 440 0 * 0.1" exp_html :: String -> String exp_html =-    let f = everywhereM (mkM span_num_lit)+    let f = G.everywhereM (G.mkM span_num_lit)     in apply_rw_st rw_html_opt parseExp f  -- > module_html "o = sinOsc AR 440 0 * 0.1;main = audition (out 0 o)" module_html :: String -> String module_html =-    let f = everywhereM (mkM span_num_lit)+    let f = G.everywhereM (G.mkM span_num_lit)     in apply_rw_st rw_html_opt parseModule f  -- > let e = "let o = sinOsc AR 440 0 * 0.1 in audition (out 0.00 o)"

@@ -1,15 +1,15 @@ Name:              hsc3-rw-Version:           0.14+Version:           0.15 Synopsis:          hsc3 re-writing Description:       hsc3 re-writing License:           GPL Category:          Sound-Copyright:         (c) Rohan Drape and others, 2013+Copyright:         (c) Rohan Drape and others, 2013-2014 Author:            Rohan Drape Maintainer:        rd@slavepianos.org Stability:         Experimental Homepage:          http://rd.slavepianos.org/?t=hsc3-rw-Tested-With:       GHC == 7.6.1+Tested-With:       GHC == 7.6.3 Build-Type:        Simple Cabal-Version:     >= 1.8 @@ -25,10 +25,12 @@                    transformers,                    haskell-src-exts   GHC-Options:     -Wall -fwarn-tabs-  Exposed-modules: Sound.SC3.RW.HP+  Exposed-modules: Sound.SC3.RW.HA+                   Sound.SC3.RW.HP                    Sound.SC3.RW.HP.Parsec                    Sound.SC3.RW.HP.Polyparse                    Sound.SC3.RW.ID+                   Sound.SC3.RW.PSynth                    Sound.SC3.RW.Tag  Source-Repository  head