module Sound.SC3.RW.Tag where
import Control.Monad.Trans.State
import Data.Functor.Identity
import Data.Generics
import Language.Haskell.Exts
mk_var :: String -> Exp
mk_var = Var . UnQual . Ident
mk_str_lit :: String -> Exp
mk_str_lit = Lit . String
mk_int_lit :: Integral n => n -> Exp
mk_int_lit = Lit . Int .toInteger
mk_frac_lit :: Real n => n -> Exp
mk_frac_lit = Lit . Frac . toRational
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_exp :: String -> Exp -> Exp
tag_exp k e = (mk_var "tag" `App` mk_str_lit k) `App` e
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
untag_exp :: Exp -> Exp
untag_exp = at_tagged (\_ e -> e) id
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
tag_to_span :: Exp -> Exp
tag_to_span =
let f k e = mk_span_id k [e]
in at_tagged f id
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])
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
tag_num_lit :: Exp -> State Int Exp
tag_num_lit = at_num_lit tag_exp_auto return
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)
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
exp_rw :: String -> String
exp_rw =
let f = everywhereM (mkM tag_num_lit)
in apply_rw_st (PPNoLayout,80) parseExp f
module_rw :: String -> String
module_rw =
let f = everywhereM (mkM tag_num_lit)
in apply_rw_st (PPNoLayout,80) parseModule f
exp_un_rw :: String -> String
exp_un_rw =
let f = everywhere (mkT untag_exp)
in apply_rw_pure (PPNoLayout,80) parseExp f
rw_html_opt :: RW_Opt
rw_html_opt = (PPOffsideRule,640)
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_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 :: String -> String
exp_html =
let f = everywhereM (mkM span_num_lit)
in apply_rw_st rw_html_opt parseExp f
module_html :: String -> String
module_html =
let f = everywhereM (mkM span_num_lit)
in apply_rw_st rw_html_opt parseModule f
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>"]