packages feed

hsc3-rw (empty) → 0.14

raw patch · 8 files changed

+772/−0 lines, 8 filesdep +basedep +directorydep +haskell-src-extssetup-changed

Dependencies added: base, directory, haskell-src-exts, parsec, polyparse, split, syb, transformers

Files

+ README view
@@ -0,0 +1,14 @@+hsc3-rw - hsc3 re-writing+-------------------------++[hsc3-rw][hsc3-rw] provides re-writing functions for use with [hsc3][hsc3].++- `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].++[rd]: http://rd.slavepianos.org/+[gpl]: http://gnu.org/copyleft/
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Sound/SC3/RW/HP.hs view
@@ -0,0 +1,202 @@+-- | Hash parentheses.  A simple minded haskell pre-processor that+-- extends the haskell /do/ syntax by rewriting @#@ parenthesised+-- elements of a right hand side expression as monadic bindings.+-- The basic pre-processor is 'hp_rewrite'.+module Sound.SC3.RW.HP where++import Data.Char {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import qualified Data.List.Split as S {- split -}+import System.Environment {- base -}++import Sound.SC3.RW.HP.Parsec++-- * String++-- | Return indentation of line.+--+-- > indent_of "  a <- b" == "  "+indent_of :: String -> String+indent_of = takeWhile isSpace++-- | Delete indentation of line.+--+-- > remove_indent "  a <- b"  == "a <- b"+remove_indent :: String -> String+remove_indent = dropWhile isSpace++-- * List++-- | Variant of 'splitOn' requiring one match only.+--+-- > split_on_1 " <- " "  a <- f #(b) #(c)" == Just ("  a","f #(b) #(c)")+-- > split_on_1 " do " "  let a = do f #(b) #(c)" == Just ("  let a =","f #(b) #(c)")+split_on_1 :: Eq a => [a] -> [a] -> Maybe ([a],[a])+split_on_1 p q =+    case S.splitOn p q of+      [r,s] -> Just (r,s)+      _ -> Nothing++-- * Inline do++-- | Split inline /do/ line into separate lines.+--+-- > let r = ["  let a = do "+-- >         ,"             f #(b) #(c)"]+-- > in hp_remove_inline_do "  let a = do f #(b) #(c)" == r+hp_remove_inline_do :: String -> [String]+hp_remove_inline_do s =+    let q = " do "+    in case split_on_1 q s of+         Just (p,r) -> let s0 = p ++ q+                           s1 = replicate (length s0) ' ' ++ r+                       in [s0,s1]+         _ -> [s]++-- * Continuation lines++-- | Return indent of /s/ if it 'has_hash_paren'.+--+-- > hp_indent "  a <- f #(b) #(c)" == Just 2+hp_indent :: String -> Maybe Int+hp_indent s =+    if has_hash_paren s+    then Just (length (indent_of s))+    else Nothing++-- | Note which lines are /continued/ hash parenethsis lines.+--+-- > hp_non_inline ["f = do"+-- >               ,"  a #(b)"+-- >               ,"    #(c)"+-- >               ,"    #(d)"+-- >               ,"  p #(q) #(r)"] == [False,False,True,True,False]+hp_non_inline :: [String] -> [Bool]+hp_non_inline l =+    let f (o,n') n = case (n',n) of+                       (Just x',Just x) -> case compare x x' of+                                             LT -> ((False,n),False)+                                             EQ -> ((o,n),o)+                                             GT -> ((True,n),True)+                       _ -> ((False,n),False)+    in snd (mapAccumL f (False,Nothing) (map hp_indent l))++-- | Re-layout to put broken /hash parenthesis/ lines onto one line.+--+-- > let r = ["f = do"+-- >         ,"  a #(b) #(c) #(d)"+-- >         ,"  p #(q) #(r)"]+-- > in hp_uncontinue ["f = do"+-- >                  ,"  a #(b)"+-- >                  ,"    #(c)"+-- >                  ,"    #(d)"+-- >                  ,"  p #(q) #(r)"] == r+hp_uncontinue :: [String] -> [String]+hp_uncontinue l =+    let f st (e,c,k) = let e' = if c then ' ' : remove_indent e else e+                       in if k+                          then (st ++ e',Nothing)+                          else ("",Just (st ++ e'))+        i = hp_non_inline l+        (z,l') = mapAccumL f "" (zip3 l i (tail i ++ [False]))+        z' = if null z then [] else [z]+    in catMaybes l' ++ z'++-- * Hash Parentheses++-- | Name supply for introduced variables.+--+-- > hp_names !! 9 == "_hp_9"+hp_names :: Name_Supply+hp_names = map (\n -> "_hp_" ++ show n) [0::Integer ..]++-- | Does /s/ have a /hash parenthesis/ expression.+--+-- > has_hash_paren "  a <- f #(b) #(c)" == True+has_hash_paren :: String -> Bool+has_hash_paren = isInfixOf "#("++-- | Process one line of /hash-parenthesis/ re-writes.+hp_analyse :: Name_Supply -> String -> (Name_Supply,([Binding],HP))+hp_analyse nm =+    let rec n b s = case hp_do_next_binding n s of+                      Nothing -> (n,(reverse b,s))+                      Just (n',b',s') -> rec n' (b':b) s'+    in rec nm [] . hp_parse++-- | Variant of 'hp_analyse' for examining intermediate state.+--+-- > let r = ([("_hp_0","b"),("_hp_1","c (d e)")],"  a <- f _hp_0 _hp_1")+-- > in hp_analyse' hp_names "  a <- f #(b) #(c (d e))" == r+--+-- > let r = ([("_hp_0","a")],"  return (f _hp_0)")+-- > in hp_analyse' hp_names "  return (f #(a))" == r+--+-- > let r = ([("_hp_0","a"),("_hp_1","d e"),("_hp_2","c _hp_1 f"),("_hp_3","b _hp_2 g")]+-- >         ,"c <- f (_hp_0,_hp_3) h")+-- > in hp_analyse' hp_names "c <- f (#(a),#(b #(c #(d e) f) g)) h" == r+--+-- > let r = ([("_hp_0","v w")],"  return (h (_hp_0 * 2))")+-- > in hp_analyse' hp_names "  return (h (#(v w) * 2))" == r+hp_analyse' :: Name_Supply -> String -> ([Binding],String)+hp_analyse' nm s =+    let (_,(n,h)) = hp_analyse nm s+    in (n,hp_print h)++-- | Re-construct 'hp_analyse' output.+hp_build :: ([Binding],HP) -> [String]+hp_build (b,e) =+    let e' = hp_print e+        f (i,j) = concat [i," <- ",j]+        ind = indent_of e'+        b' = map ((ind ++) . f) b+    in b' ++ [e']++-- | Process a line for /hash parentheses/.+hp_process :: Name_Supply -> String -> (Name_Supply, [String])+hp_process n s =+    if has_hash_paren s+    then let (n',r) = hp_analyse n s+             r' = hp_build r+         in (n',r')+    else (n,[s])++-- | Run /hash parenthesis/ rewriter.+--+-- > let {i = ["main = do"+-- >          ,"  let a = f #(b) (#(c) * 2)"+-- >          ,"  d <- e"+-- >          ,"  p <- g #(q r)"+-- >          ,"         #(s #(t u))"+-- >          ,"  return (h (#(v w) * 2))"]+-- >     ;r = ["main = do"+-- >          ,"  _hp_0 <- b"+-- >          ,"  _hp_1 <- c"+-- >          ,"  let a = f _hp_0 (_hp_1 * 2)"+-- >          ,"  d <- e"+-- >          ,"  _hp_2 <- q r"+-- >          ,"  _hp_3 <- t u"+-- >          ,"  _hp_4 <- s _hp_3"+-- >          ,"  p <- g _hp_2 _hp_4"+-- >          ,"  _hp_5 <- v w"+-- >          ,"  return (h (_hp_5 * 2))"]}+-- > in hp_rewrite i == r+hp_rewrite :: [String] -> [String]+hp_rewrite =+    concat .+    snd .+    mapAccumL hp_process hp_names .+    concatMap hp_remove_inline_do .+    hp_uncontinue++-- | Arguments as required by @ghc -F -pgmF@.+hp_rewrite_ghcF :: IO ()+hp_rewrite_ghcF = do+  a <- getArgs+  case a of+    [_,i_fn,o_fn] -> do+           i <- readFile i_fn+           let f = unlines . hp_rewrite . lines+           writeFile o_fn (f i)+    _ -> error "initial-file input-file output-file"
+ Sound/SC3/RW/HP/Parsec.hs view
@@ -0,0 +1,111 @@+module Sound.SC3.RW.HP.Parsec where++import Text.ParserCombinators.Parsec {- parsec -}++data HP = S String | H HP | J HP HP deriving (Eq,Show)++type Binding = (String,String)+type Name_Supply = [String]++-- | Simplifying constructor (do not use 'J' directly).+hp_cons :: HP -> HP -> HP+hp_cons p q =+    case (p,q) of+      (S s1,S s2) -> S (s1 ++ s2)+      (S s1,J (S s2) r) -> S (s1 ++ s2) `hp_cons` r+      (J l r,_) -> l `hp_cons` (r `hp_cons` q)+      _ -> J p q++from_list1 :: [HP] -> HP+from_list1 l =+    case l of+      [] -> error "from_list1: []"+      [h] -> h+      p:l' -> p `hp_cons` (from_list1 l')++hp_parser :: Parser HP+hp_parser =+    let p_node l = from_list1 [S "(",from_list1 l,S ")"]+        in_paren = between (char '(') (char ')')+        s = fmap S (many1 (noneOf "#()"))+        p = fmap p_node (in_paren (many1 hp_parser))+        h = char '#' >> fmap (H . from_list1) (in_paren (many1 hp_parser))+    in fmap from_list1 (many1 (choice [h,p,s]))++-- > hp_parse "a"+-- > hp_parse "a b"+-- > hp_parse "a (b c)"+-- > hp_parse "a #(b (#(c d) e))"+-- > hp_parse "c <- f (#(a),#(b #(c #(d e) f) g)) h"+-- > let r = hp_parse "c <- f (#(a),#(b #(c #(d e) f) g)) h"+-- > hp_print r+hp_parse :: String -> HP+hp_parse s =+    case parse hp_parser "" s of+      Right t -> hp_simplify t+      Left e -> error (show e)++hp_print :: HP -> String+hp_print h =+    case h of+      S s -> s+      H h' -> "#(" ++ hp_print h' ++ ")"+      J p q -> hp_print p ++ hp_print q++-- > let r = hp_parse "c <- f (a,#(b #(c de f) g)) h"+-- > in hp_simplify r+hp_simplify :: HP -> HP+hp_simplify h =+    case h of+      S s -> S s+      H (S s) -> H (S s)+      J (S _) (S _) -> error "J S S"+      J (S _) (J (S _) _) -> error "J S (J S ..)"+      J (J _ _) _ -> error "J (J .. ..) .."+      J p q -> let (p',q') = (hp_simplify p,hp_simplify q)+               in if p /= p' || q /= q'+                  then hp_simplify (p' `hp_cons` q')+                  else p `hp_cons` q+      H h' -> let h'' = hp_simplify h'+              in if h' /= h'' then hp_simplify (H h'') else H h'++next_nm :: Name_Supply -> (String,Name_Supply)+next_nm nm =+    case nm of+      n:nm' -> (n,nm')+      _ -> error "next_nm"++-- > let r = hp_parse "c <- f (#(a),#(b #(c #(d e) f) g)) h"+-- > in hp_find_next_binding ["_hp_0"] r+--+-- > let r = hp_parse "c <- f (_hp_0,#(b #(c _hp_1 f) g)) h"+-- > in hp_find_next_binding ["_hp_2"] r+hp_find_next_binding :: Name_Supply -> HP -> Maybe (Name_Supply,Binding)+hp_find_next_binding nm h =+    let (n,nm') = next_nm nm+    in case h of+         S _ -> Nothing+         H (S s) -> Just (nm',(n,s))+         H h' -> hp_find_next_binding nm h'+         J l r -> maybe+                  (hp_find_next_binding nm r)+                  Just+                  (hp_find_next_binding nm l)++-- > let r = hp_parse "c <- f (#(a),#(b #(c #(d e) f) g)) h"+-- > in hp_print (hp_simplify (hp_replace ("_hp_0","a") r))+hp_replace :: Binding -> HP -> HP+hp_replace (p,q) h =+    case h of+      S _ -> h+      H (S s) -> if s == q then S p else h+      H h' -> H (hp_replace (p,q) h')+      J l r -> let l' = hp_replace (p,q) l+               in if l /= l'+                  then l' `hp_cons` r+                  else l `hp_cons` hp_replace (p,q) r++hp_do_next_binding :: Name_Supply -> HP -> Maybe (Name_Supply,Binding,HP)+hp_do_next_binding nm h =+    let f (nm',b) = (nm',b,hp_simplify (hp_replace b h))+    in fmap f (hp_find_next_binding nm h)
+ Sound/SC3/RW/HP/Polyparse.hs view
@@ -0,0 +1,99 @@+module Sound.SC3.RW.HP.Polyparse where++import Data.Function+import Data.List+import Data.Maybe+import Text.ParserCombinators.Poly.State {- polyparse -}++type Binding = (String,String)+type Name_Supply = [String]++type HP_Char = (Char,Maybe Int)+type HP_String = [HP_Char]++type ST = (Int,[Int])+type HP = Parser ST Char++hp_st :: ST+hp_st = (0,[])++safe_head :: [a] -> Maybe a+safe_head l =+    case l of+      [] -> Nothing+      e:_ -> Just e++-- | Only count parens in #().+hp_next :: HP (Char,Maybe Int)+hp_next = do+  let stPut st = stUpdate (const st)+  c <- next+  (n,h) <- stGet+  case c of+    '#' -> stPut (n,n : h) >> return (c,Just n)+    '(' -> stPut (if null h then (n,h) else (n + 1,h)) >> return (c,safe_head h)+    ')' -> let n' = n - 1+               (st',e) = case h of+                           [] -> ((n,[]),Nothing)+                           x:h' -> if x == n'+                                   then ((n',h'),Just x)+                                   else ((n',h),safe_head h)+           in stPut st' >> return (c,e)+    _ -> return (c,safe_head h)++-- > runParser hp_hash_paren hp_st "r <- #(a)"+-- > runParser hp_hash_paren hp_st "#(a (b)) (c (d))"+-- > runParser hp_hash_paren hp_st "#(a (b) (c (d)))"+-- > runParser hp_hash_paren hp_st "#a"+-- > runParser hp_hash_paren hp_st "a"+-- > runParser hp_hash_paren hp_st "c <- f #(a) #(b c) d"+-- > runParser hp_hash_paren hp_st "c <- f #(a) #(b #(c)) d"+-- > runParser hp_hash_paren hp_st "c <- f #(a) #(b #(c #(d e) f) #(g)) #(h) i"+hp_hash_paren :: HP HP_String+hp_hash_paren = many1 hp_next++-- > hp_parse "c <- f #(a) #(b #(c #(d e) f) g) h"+hp_parse :: String -> HP_String+hp_parse s =+    case runParser hp_hash_paren hp_st s of+      (Right r,(0,[]),[]) -> r+      _ -> error "hp_parse"++-- | Left biased 'max' variant.+--+-- > max_by last "cat" "mouse" == "cat"+-- > max_by last "aa" "za" == "aa"+max_by :: Ord a => (t -> a) -> t -> t -> t+max_by f p q = if f q > f p then q else p++-- > replace_first 1 (-1) [-2,1,0,1] == [-2 .. 1]+replace_first :: Eq a => a -> a -> [a] -> [a]+replace_first p q =+    let rec r l = case l of+                  [] -> reverse r+                  e:l' -> if e == p then reverse (q : r) ++ l' else rec (e : r) l'+    in rec []++-- > un_hash_paren "#(a)" == "a"+-- > un_hash_paren "b" == "b"+un_hash_paren :: String -> String+un_hash_paren s =+    let f = reverse . drop 1 . reverse+    in case s of+         '#' : '(' : s' -> f s'+         _ -> s++hp_next_binding :: Name_Supply -> HP_String -> Maybe (Name_Supply,Binding,HP_String)+hp_next_binding n s =+    if null s || all ((== Nothing) . snd) s+    then Nothing+    else let nm:n' = n+             s' = groupBy ((==) `on` snd) s+             e = foldl1 (max_by (fromMaybe (-1) . snd . head)) s'+             x = fromJust (snd (head e)) - 1+             x' = if x >= 0 then Just x else Nothing+             s'' = replace_first e (map (\c -> (c,x')) nm) s'+         in Just (n',(nm,un_hash_paren (map fst e)),concat s'')++hp_print :: HP_String -> String+hp_print = map fst
+ Sound/SC3/RW/ID.hs view
@@ -0,0 +1,100 @@+-- | Rewrite character ifdentifiers for @UGen.ID@ graphs.+module Sound.SC3.RW.ID where++import Data.Char {- base -}+import System.Directory {- directory -}++-- * Greek letters++-- | Table of greek letters (upper-case,lower-case,name).+--+-- > length greek_letters == 24+-- > (['Α' .. 'Ρ'] ++ ['Σ' .. 'Ω']) == map (\(c,_,_) -> c) greek_letters+-- > (['α' .. 'ρ'] ++ ['σ' .. 'ω']) == map (\(_,c,_) -> c) greek_letters+greek_letters :: [(Char,Char,String)]+greek_letters =+    [('Α','α',"Alpha")+    ,('Β','β',"Beta")+    ,('Γ','γ',"Gamma")+    ,('Δ','δ',"Delta")+    ,('Ε','ε',"Epsilon")+    ,('Ζ','ζ',"Zeta")+    ,('Η','η',"Eta")+    ,('Θ','θ',"Theta")+    ,('Ι','ι',"Iota")+    ,('Κ','κ',"Kappa")+    ,('Λ','λ',"Lambda")+    ,('Μ','μ',"Mu")+    ,('Ν','ν',"Nu")+    ,('Ξ','ξ',"Xi")+    ,('Ο','ο',"Omicron")+    ,('Π','π',"Pi")+    ,('Ρ','ρ',"Rho")+    ,('Σ','σ',"Sigma")+    ,('Τ','τ',"Tau")+    ,('Υ','υ',"Upsilon")+    ,('Φ','φ',"Phi")+    ,('Χ','χ',"Chi")+    ,('Ψ','ψ',"Psi")+    ,('Ω','ω',"Omega")]++-- | Indefinite sequence of character identifiers.+type Name_Supply = [Char]++-- | 'greek_letters' as 'Name_Supply'.+--+-- > take 4 greek_letters_nm == ['α' .. 'δ']+greek_letters_nm :: Name_Supply+greek_letters_nm =+    let uc = map (\(c,_,_) -> c) greek_letters+        lc = map (\(_,c,_) -> c) greek_letters+    in lc ++ uc++-- * Rewriters++-- | Rewrite each haskell /letter/ character literal at string /l/+-- with values from the character supply /s/.+--+-- > rewrite ['α'..] "'a',' ',foldl','a'" == "'α',' ',foldl','β'"+rewrite :: Name_Supply -> String -> String+rewrite s l =+    case s of+      k:s' -> case l of+                [] -> []+                '\'' : c : '\'' : l' ->+                    if isLetter c+                    then '\'' : k : '\'' : rewrite s' l'+                    else '\'' : c : rewrite s ('\'' : l')+                c : l' -> c : rewrite s l'+      _ -> undefined++-- | 'rewrite' 'greek_letters_nm'.+--+-- > hsc3_id_rewrite "'a','.','a'" == "'α','.','β'"+hsc3_id_rewrite :: String -> String+hsc3_id_rewrite = rewrite greek_letters_nm++-- | 'rewrite' 'repeat' @α@.+--+-- > hsc3_id_clear "'α','.','β'" == "'α','.','α'"+hsc3_id_clear :: String -> String+hsc3_id_clear = rewrite (repeat 'α')++-- * IO++-- | File based (haskell pre-processor) variant of 'hsc3_id_rewrite'.+hsc3_id_rewrite_preprocessor :: FilePath -> FilePath -> FilePath -> IO ()+hsc3_id_rewrite_preprocessor _ i_fn o_fn = do+  s <- readFile i_fn+  writeFile o_fn (hsc3_id_rewrite s)++-- | File based (inplace) variant of 'hsc3_id_rewrite'.  Copies file+-- to @~@ suffix and replaces initial file.+--+-- > let fn = "/home/rohan/sw/hsc3-graphs/gr/resonant-dust.hs"+-- > in hsc3_id_rewrite_file fn+hsc3_id_rewrite_inplace :: FilePath -> IO ()+hsc3_id_rewrite_inplace fn = do+  let fn' = fn ++ "~"+  copyFile fn fn'+  hsc3_id_rewrite_preprocessor fn fn' fn
+ Sound/SC3/RW/Tag.hs view
@@ -0,0 +1,208 @@+-- | 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 Language.Haskell.Exts {- haskell-src-exts -}++-- | Make 'Var' 'Exp' for 'String'.+--+-- > mk_var "tag" == Var (UnQual (Ident "tag"))+mk_var :: String -> Exp+mk_var = Var . UnQual . Ident++-- | Make 'String' 'Lit'.+--+-- > mk_str_lit "c1" == Lit (String "c1")+mk_str_lit :: String -> Exp+mk_str_lit = Lit . String++-- | Make 'Int' 'Lit'.+mk_int_lit :: Integral n => n -> Exp+mk_int_lit = Lit . Int .toInteger++-- | Make 'Frac' 'Lit'.+mk_frac_lit :: Real n => n -> Exp+mk_frac_lit = Lit . Frac . toRational++-- | Numeric literal at 'Exp' else 'Nothing'+exp_num_lit :: Exp -> Maybe Literal+exp_num_lit e =+    case e of+      Lit (Int n) -> Just (Int n)+      Lit (Frac n) -> Just (Frac n)+      _ -> Nothing++-- | Tag an 'Exp' with 'String'.+tag_exp :: String -> Exp -> Exp+tag_exp k e = (mk_var "tag" `App` mk_str_lit k) `App` e++-- | Apply /f/ at 'Exp' /e/ if it is tagged, else /g/.  If the tag is+-- within a 'Paren' then it is discarded.+at_tagged :: (String -> Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp+at_tagged f g e =+    case e of+      Paren e' -> at_tagged f (Paren . g) e'+      App (App (Var (UnQual (Ident "tag"))) (Lit (String k))) e' -> f k e'+      _ -> g e++-- | Inverse of 'tag_exp'.+--+-- > let z = mk_int_lit (0::Integer)+-- > in untag_exp (Paren (tag_exp "c1" z)) == z+untag_exp :: Exp -> Exp+untag_exp = at_tagged (\_ e -> e) id++-- | Empty source location.+nil_src_loc :: SrcLoc+nil_src_loc = SrcLoc "" 0 0++mk_span_id :: String -> [Exp] -> Exp+mk_span_id k =+    let nm = XName "span"+        cl_a = XAttr (XName "class") (mk_str_lit "numeric-literal")+        id_a = XAttr (XName "id") (mk_str_lit k)+    in XTag nil_src_loc nm [cl_a,id_a] Nothing++-- > let {e = tag_exp "c1" (mk_int_lit 0)+-- >     ;r = "<span class = \"numeric-literal\" id = \"c1\" >0</span >"}+-- > in prettyPrint (tag_to_span (Paren e)) == r+tag_to_span :: Exp -> Exp+tag_to_span =+    let f k e = mk_span_id k [e]+    in at_tagged f id++-- | Variant of 'tag_exp' that derives the the tag name using a+-- 'State' counter.+tag_exp_auto :: Exp -> State Int Exp+tag_exp_auto e = do+  i <- get+  let k = 'c' : show i+  put (i + 1)+  return (tag_exp k e)++span_exp_auto :: Exp -> State Int Exp+span_exp_auto e = do+  i <- get+  let k = 'c' : show i+  put (i + 1)+  return (mk_span_id k [e])++-- | Apply /f/ at numeric literals, else /g/.+at_num_lit :: (Exp -> t) -> (Exp -> t) -> Exp -> t+at_num_lit f g e =+    case e of+      Lit (Int _) -> f e+      Lit (Frac _) -> f e+      _ -> g e++-- | 'at_num_lit' of 'tag_exp_auto'.+tag_num_lit :: Exp -> 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 = 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 Tr = String -> String+type Tr_m m = String -> m String+type RW_Opt = (PPLayout,Int)++-- | Parse 'String' using 'Parser' and apply 'RW'.+apply_rw :: (Monad m,Pretty a) => RW_Opt -> Parser t -> RW t m a -> Tr_m m+apply_rw (l,w) p f s = do+  let m = defaultMode {layout = l}+      r = fromParseResult (p s)+      sty = Style {mode = PageMode,lineLength = w,ribbonsPerLine = 1}+  r' <- f r+  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_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++-- | Rewrite 'Exp'.+--+-- > let r = "sinOsc AR (tag \"c1\" 440) (tag \"c2\" 0) * tag \"c3\" 0.1"+-- > in exp_rw "sinOsc AR 440 0 * 0.1" == r+exp_rw :: String -> String+exp_rw =+    let f = everywhereM (mkM tag_num_lit)+    in apply_rw_st (PPNoLayout,80) parseExp f++-- | Rewrite 'Module'.+--+-- > let m = ["import Sound.SC3"+-- >         ,"o = sinOsc AR (midiCPS 65.00) 0.00"+-- >         ,"a = dbAmp (-12.00)"+-- >         ,"main = audition (out 0.00 (o * a))"]+-- > in module_rw (unlines m)+module_rw :: String -> String+module_rw =+    let f = everywhereM (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)+    in apply_rw_pure (PPNoLayout,80) parseExp f++-- | 'RW_Opt' for html.  The /span/ code generates long lines...+rw_html_opt :: RW_Opt+rw_html_opt = (PPOffsideRule,640)++-- | Transform re-written form to @HTML@.+--+-- > let e = "sinOsc AR 440 0 * 0.1"+-- > in exp_rw_html (exp_rw e)+exp_rw_html :: String -> String+exp_rw_html =+    let f = everywhere' (mkT tag_to_span)+    in apply_rw_pure rw_html_opt parseExp f++-- | 'Module' variant of 'exp_rw_html'.+--+-- > let m = "o = sinOsc AR 440 0 * 0.1\nmain = audition (out 0 o)"+-- > in module_rw_html (module_rw m)+module_rw_html :: String -> String+module_rw_html =+    let f = everywhere' (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)+    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)+    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)"+-- > in putStrLn (html_framework "/home/rohan/sw/hosc-utils" (exp_html e))+html_framework :: String -> String -> String+html_framework d m =+    unlines+    ["<!DOCTYPE html>"+    ,"<html>"+    ," <head>"+    ,"  <script src=\"" ++ d ++ "/js/json-ws.04.js\"></script>"+    ,"  <link rel=\"stylesheet\" href=\"" ++ d ++ "/css/json-ws.04.css\" />"+    ," </head>"+    ," <body>"+    ,"  <pre>"+    ,m+    ,"  </pre>"+    ,"  <p id=\"sent\">[]</p>"+    ," </body>"+    ,"</html>"]
+ hsc3-rw.cabal view
@@ -0,0 +1,36 @@+Name:              hsc3-rw+Version:           0.14+Synopsis:          hsc3 re-writing+Description:       hsc3 re-writing+License:           GPL+Category:          Sound+Copyright:         (c) Rohan Drape and others, 2013+Author:            Rohan Drape+Maintainer:        rd@slavepianos.org+Stability:         Experimental+Homepage:          http://rd.slavepianos.org/?t=hsc3-rw+Tested-With:       GHC == 7.6.1+Build-Type:        Simple+Cabal-Version:     >= 1.8++Data-files:        README++Library+  Build-Depends:   base == 4.*,+                   directory,+                   parsec,+                   polyparse,+                   split,+                   syb,+                   transformers,+                   haskell-src-exts+  GHC-Options:     -Wall -fwarn-tabs+  Exposed-modules: Sound.SC3.RW.HP+                   Sound.SC3.RW.HP.Parsec+                   Sound.SC3.RW.HP.Polyparse+                   Sound.SC3.RW.ID+                   Sound.SC3.RW.Tag++Source-Repository  head+  Type:            darcs+  Location:        http://rd.slavepianos.org/sw/hsc3-rw