Tag.hs

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