-- | Implementation of @Dot@ language writer.
module Sound.SC3.UGen.Dot.Internal where

import Control.Monad {- base -}
import Data.Char {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import System.Directory {- directory -}
import System.FilePath {- filepath -}
import System.Process {- process -}
import Text.Printf {- base -}

import qualified Sound.SC3 as S {- hsc3 -}
import qualified Sound.SC3.UGen.Graph as S {- hsc3 -}

import qualified Sound.SC3.UGen.Dot.Common as C {- hsc3-dot -}
import qualified Sound.SC3.UGen.Dot.Type as D {- hsc3-dot -}

-- | Key value pair.
type Attr = (String,String)

-- | Dot attributes are written @key=value@.
attr_pp :: Attr -> String
attr_pp (k,v) = k ++ "=" ++ v

-- | If @value@ is 'null' then 'Nothing'.
attr_pp_maybe :: Attr -> Maybe String
attr_pp_maybe (k,v) = if null v then Nothing else Just (attr_pp (k,v))

-- | Attribute lists are in square brackets and comma seperated.
attr_list_pp :: [Attr] -> String
attr_list_pp = C.bracket1 ('[',']') . intercalate "," . mapMaybe attr_pp_maybe

-- | Attribute sets are named and semi-colon terminated.
attr_set_pp :: String -> [Attr] -> String
attr_set_pp nm attr = concat [nm," ",attr_list_pp attr,";"]

-- | Size is given as @(width,height)@.
size_pp :: (Double,Double) -> String
size_pp (x,y) = printf "\"%f,%f\"" x y

-- | 'toLower' of 'show'.
bool_pp :: Bool -> String
bool_pp = map toLower . show

-- | Basic attribute sets given 'Dot_Options'.
std_style :: D.Dot_Options -> [String]
std_style o =
    [attr_set_pp "graph" [("splines",bool_pp (D.use_splines o))
                         ,("size",maybe "" size_pp (D.graph_size o))]
    ,attr_set_pp "node" [("fontsize",C.int_pp (D.font_size o))
                        ,("fontname",C.string_pp (D.font_name o))]
    ,attr_set_pp "edge" [("arrowhead","box")
                        ,("arrowsize","0.25")]]

-- | Generate dot representation of the provided unit generator graph.
dotGraph :: D.Dot_Options -> S.Graph -> String
dotGraph o g =
    let (S.Graph _ _ ks us) = g
        ls = concat [["digraph Anonymous {"]
                    ,std_style o
                    ,if D.inline_controls o
                     then []
                     else map (dot_node_k o) ks
                    ,map (dot_node_u o g) us
                    ,map (dot_edge o g) (S.edges us)
                    ,["}"]]
    in unlines (filter (not.null) ls)

-- | View @dot@ graph according to 'Dot_Options'.
view_with :: D.Dot_Options -> String -> IO ()
view_with o x = do
  v <- get_viewer o
  let d = D.output_directory o
      f = d </> D.output_file_name o
      f_dot = f <.> "dot"
      f_svg = f <.> "svg"
      f_svg_gz = f_svg <.> "gz"
      f_view = case D.output_format o of
                 D.DOT -> f_dot
                 D.SVG -> f_svg
                 D.SVG_GZ -> f_svg_gz
      gen_svg = rawSystem "dot" ["-T","svg",f_dot,"-o",f_svg]
  writeFile f_dot x
  when (D.output_format o `elem` [D.SVG,D.SVG_GZ]) (void gen_svg)
  when (D.output_format o == D.SVG_GZ) (void (rawSystem "gzip" ["-f",f_svg]))
  when (False && D.output_format o /= D.DOT) (removeFile f_dot)
  void (rawSystem v [f_view])

-- | Input port.
data IP = IP_Label String
        | IP_Port String Char Int
        | IP_Const (Maybe String,String,Int) S.Sample

-- | Variant of 'limit_precision' reading parameters from 'Dot_Options'.
limit_precision_o :: D.Dot_Options -> S.Sample -> String
limit_precision_o o = C.limit_precision (D.indicate_precision o) (D.numeric_precision o)

-- | IP in record form.
ip_record :: D.Dot_Options -> IP -> String
ip_record o i =
    case i of
      IP_Label l -> l
      IP_Port _ d n -> '<' : d : '_' : show n ++ ">"
      IP_Const _ n -> limit_precision_o o n

-- | Very rudimentary HTML escaping.
escape_html :: String -> String
escape_html =
    let t = [('<',"&lt;"),('>',"&gt;"),('&',"&amp;")]
        f c = fromMaybe [c] (lookup c t)
    in concatMap f

-- | 'IP' as @HTML@ string.
ip_html :: D.Dot_Options -> IP -> String
ip_html o i =
    case i of
      IP_Label l -> printf "<TD>%s</TD>" (escape_html l)
      IP_Port u c n ->
          let p = c : '_' : show n
              a = if D.use_attr_id o then printf " ID=\"%s:%s\"" u p else ""
          in printf "<TD PORT=\"%s\"%s></TD>" p a
      IP_Const (k,u,p) n ->
          let p' = "K_" ++ show p
              n' = limit_precision_o o n
              l = maybe "" (++":") k ++ n'
              a = if D.use_attr_id o then printf " ID=\"%s:%s\"" u p' else ""
          in printf "<TD%s>%s</TD>" a l

record :: D.Dot_Options -> String -> String -> ([IP],[IP]) -> String
record o nm clr (upr,lwr) =
    let f l = concat ["{",g (map (ip_record o) l),"}"]
        g = intercalate "|"
        lbl = g [f upr,f lwr]
    in attr_set_pp nm [("shape",C.string_pp "record")
                      ,("color",C.string_pp clr)
                      ,("label",C.label_pp lbl)]

table :: D.Dot_Options -> String -> String -> ([IP],[IP]) -> String
table o lbl clr (upr,lwr) =
    let k = length upr - length lwr
        e = concat (replicate k "<TD BORDER=\"0\"></TD>")
        f p l = if null l
                then ""
                else concat ["<TR>",p ++ concatMap (ip_html o) l,"</TR>"]
    in attr_set_pp
       lbl
       [("shape",C.string_pp "plaintext")
       ,("color",C.string_pp clr)
       ,("label",concat ["<<TABLE BORDER=\"0\" CELLBORDER=\"1\">"
                        ,f [] upr ++ f e lwr
                        ,"</TABLE>>"])]

dot_edge :: D.Dot_Options -> S.Graph -> S.Edge -> String
dot_edge o g (l,S.ToPort ri rn) =
    let Just ln = S.find_node g (S.port_nid l)
        s = if D.fix_edge_location o then ":s" else ""
        clr = if D.colour_edges o then S.rate_color (S.node_rate ln) else "black"
    in if S.is_node_c ln || S.is_node_k ln && D.inline_controls o
       then ""
       else concat [S.node_label ln
                   ,if S.is_node_u ln
                    then ":o_" ++ show (S.port_idx_or_zero l) ++ s
                    else if S.is_node_k ln
                         then ":o_0"
                         else ""
                   ," -> "
                   ,let Just ri_n = S.find_node g ri in S.node_label ri_n
                   ,":i_"
                   ,show rn
                   ," [color=",clr,"]"
                   ,";"]

input :: D.Dot_Options -> S.Graph -> S.Node -> S.FromPort -> Int -> IP
input o g u fp k =
    case fp of
      S.FromPort_C i ->
          let Just n = S.find_node g i
          in IP_Const (Nothing,S.node_label u,k) (S.node_c_value n)
      S.FromPort_K i _ ->
          if D.inline_controls o
          then let Just n = S.find_node g i
                   l = if D.display_control_names o
                       then Just (S.node_k_name n)
                       else Nothing
               in IP_Const (l,S.node_label u,k) (S.node_k_default n)
          else IP_Port (S.node_label u) 'i' k
      _ -> IP_Port (S.node_label u) 'i' k

dot_node_u :: D.Dot_Options -> S.Graph -> S.Node -> String
dot_node_u o g u =
    let lbl = S.node_label u
        clr = S.rate_color (S.node_rate u)
        i = S.node_u_inputs u
        i' = length i - 1
        s = S.node_u_special u
        upr = IP_Label (S.ugen_user_name (S.node_u_name u) s) :
              zipWith (input o g u) i [0..i']
        lwr = let n = length (S.node_u_outputs u) - 1
              in map (IP_Port (S.node_label u) 'o') [0 .. n]
        f = if D.use_tables o then table o else record o
    in if S.is_implicit_control u
       then ""
       else f lbl clr (upr,lwr)

dot_node_k_color :: S.Node -> Attr
dot_node_k_color k =
    let c = if S.node_k_type k == S.K_TR
            then "cyan"
            else S.rate_color (S.node_k_rate k)
    in ("color",C.string_pp c)

dot_node_k_rec :: D.Dot_Options -> S.Node -> String
dot_node_k_rec o u =
    attr_set_pp
    (S.node_label u)
    [("shape",C.string_pp "rect")
    ,dot_node_k_color u
    ,("label",C.string_pp (S.node_k_name u ++ ":" ++ limit_precision_o o (S.node_k_default u)))]

dot_node_k_html :: D.Dot_Options -> S.Node -> String
dot_node_k_html o u =
    attr_set_pp
    (S.node_label u)
    [("shape",C.string_pp "plaintext")
    ,dot_node_k_color u
    ,("label",concat ["<<TABLE BORDER=\"0\" CELLBORDER=\"1\">"
                     ,"<TR><TD PORT=\"o_0\">"
                     ,S.node_k_name u,":",limit_precision_o o (S.node_k_default u)
                     ,"</TD></TR>"
                     ,"</TABLE>>"])]

dot_node_k :: D.Dot_Options -> S.Node -> String
dot_node_k o =
    if D.use_tables o
    then dot_node_k_html o
    else dot_node_k_rec o

-- | Considering 'output_format' read either the environment variable
-- @DOTVIEWER@ or @SVGVIEWER@, the default values are 'dot_viewer' and
-- 'svg_viewer'.
get_viewer :: D.Dot_Options -> IO String
get_viewer o =
    if D.output_format o == D.DOT
    then S.get_env_default "DOTVIEWER" (D.dot_viewer o)
    else S.get_env_default "SVGVIEWER" (D.svg_viewer o)