{-# Language GADTs #-}
-- | C code generator
module Sound.DF.Uniform.LL.CGen where

import Data.Char {- base -}
import Data.Int {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import Data.Typeable {- base -}
import System.Process {- process -}
import System.FilePath {- filepath -}

import Sound.DF.Uniform.LL.K
import Sound.DF.Uniform.LL.UId

-- * C init / call

-- | C comment.
type C_Comment = String

-- | Add comment markers.
--
-- > c_comment "c" == "/* c */"
c_comment :: String -> C_Comment
c_comment c = concat ["/* ",c," */"]

-- | C type.
type C_Type = String

-- | Translate 'TypeRep' to 'C_Type'.
--
-- > c_typerep_ctype bool_t == "bool"
-- > c_typerep_ctype (typeOf (0.0::Float)) == "float"
c_typerep_ctype :: TypeRep -> C_Type
c_typerep_ctype t =
    let tbl = [(bool_t,"bool")
              ,(int32_t,"int32_t")
              ,(float_t,"float")]
    in fromMaybe (error (show ("c_typerep_ctype",t))) (lookup t tbl)

-- | Qualified name, (structure,access,member).
type C_QName = (String,String,String)

var_fld_initialiser :: Var_Fld -> String
var_fld_initialiser v =
    case v of
      Var_B b -> map toLower (show b)
      Var_I i -> show i
      Var_F f -> show f
      Var_V _ -> error "var_fld_initialiser: vector"

-- | Initialise 'C_QName' to value.
--
-- > c_init_atom ("s",".","r") 5 == "s.m = 5;"
c_init_atom :: C_QName -> Var_Fld -> String
c_init_atom (s,a,p) q = concat [s,a,p," = ",var_fld_initialiser q,";"]

-- | Initialise 'C_QName' to array.  Generates loop code for sequences
-- of equal initial values.
--
-- > c_init_vec ("s",".","r") [0,1] == ["s.r[0] = 0;"
-- >                                   ,"s.r[1] = 1;"]
--
-- > let r = ["for(int i=0;i < 2;i++) {s.r[i] = 0;}"]
-- > in c_init_vec ("s",".","r") [0,0] == r
c_init_vec :: (Eq a,Show a) => C_QName -> [a] -> [String]
c_init_vec (s,a,n) l =
    let init_arr_1 p q r = concat [s,a,p,"[",q,"] = ",show r,";"]
        init_arr p q r = ["for(int i=",show q
                         ,";i < ",show (q + length r)
                         ,";i++) {"
                         ,init_arr_1 p "i" (head r)
                         ,"}"]
        f (k,i) = case i of
                    [i'] -> init_arr_1 n (show k) i'
                    _ -> concat (init_arr n k i)
        l' = group l
    in map f (zip (dx_d (map length l')) l')

-- | Initialise 'C_QName' to value or array.
--
-- > let {qn = ("s","->","r")
-- >     ;r = ["for(int i=0;i < 2;i++) {s->r[i] = 0;}","s->r[2] = 1;"]}
-- > in c_init_var qn (Right [0,0,1]) == r
c_init_var :: C_QName -> Var_Fld -> [String]
c_init_var qn e =
    case e of
      Var_B _ -> [c_init_atom qn e]
      Var_I _ -> [c_init_atom qn e]
      Var_F _ -> [c_init_atom qn e]
      Var_V [] -> error "c_init_var: Right []"
      Var_V l -> c_init_vec qn l

-- | Qualify name if required.  The /rf/ flag indicates if array is a
-- reference or an allocation.
--
-- > c_array_qual (Vec_Port float_t 3) "a" True == "*a"
-- > c_array_qual (Vec_Port float_t 3) "a" False == "a[3]"
c_array_qual :: Maybe Int -> String -> Bool -> String
c_array_qual vc nm rf =
    case vc of
      Nothing -> nm
      Just n -> if rf
                then '*' : nm
                else nm ++ bracket ('[',']') (show n)

-- | C function call.  (comment?,function,arguments)
type C_Call = (Maybe String,String,[(Var_Ty,Id)])

-- | Construct a function/macro call.
--
-- > c_call (Nothing,"f",["0","1"]) == "f(0,1);"
-- > c_call ("c","f",["0","1"]) == "f(0,1); /* c */"
c_call :: C_Call -> String
c_call (tr,s,as) =
    let as' = map m_clabel as
        c = concat ([s,"("] ++ intersperse "," as' ++ [");"])
    in concat [c," ",maybe "" c_comment tr]

-- * Variables

-- | Enumeration of variable types.
data Var_Ty = Rec_Var | Std_Var | Buf_Var Int
              deriving (Eq,Show)

-- | The character prefix for a 'Var' name is given by the 'Var_Ty'.
var_ty_char :: Var_Ty -> Char
var_ty_char ty =
    case ty of
      Rec_Var -> 'r'
      Std_Var -> 'n'
      Buf_Var _ -> 'n'

data Var_Fld = Var_F Float | Var_V [Float] | Var_B Bool | Var_I Int32

-- | (Type,Array,Label,Initialised)
type Var = (Var_Ty,TypeRep,Id,Maybe Var_Fld)

-- | 'Var' name.
var_nm :: Var -> String
var_nm (vc,_,k,_) = clabel (vc,k)

-- | Non-'Std_Var' are stateful, ie. 'Rec_Var' and 'Buf_Var'.
is_stateful :: Var -> Bool
is_stateful (vt,_,_,_) = vt /= Std_Var

-- | 'Rec_Var' are stateful and /atom/s.
is_stateful_atom :: Var -> Bool
is_stateful_atom (vt,_,_,_) = vt == Rec_Var

-- | Generate 'Var' from 'K'.
k_var :: Id -> Var_Ty -> K -> Var
k_var k vt n =
    case n of
      N _ -> error "k_var: ()"
      B b -> (vt,bool_t,k,Just (Var_B b)) -- error ("k_var: bool: " ++ show b)
      I i -> (vt,int32_t,k,Just (Var_F (fromIntegral i)))
      F f -> (vt,float_t,k,Just (Var_F f))
      V _ -> error "k_var: vec"

-- | Generate 'Buf_Var' from 'Vec'.
buffer_var :: Id -> Vec Float -> Var
buffer_var k (Vec _ n l) = (Buf_Var n,float_t,k,Just (Var_V l))

-- | 'c_init_var' of 'Var'.
var_init :: String -> String -> Var -> [String]
var_init s a (vt,_,k,i) =
    case i of
      Nothing -> error (show ("var_init",s,a,vt,k))
      Just i' -> c_init_var (s,a,clabel (vt,k)) i'

-- | 'Var' C declaration, /rf/ determines 'c_array_qual' form.
var_decl :: Bool -> Var -> String
var_decl rf (vt,ty,k,_) =
    let vc = case vt of
               Buf_Var n -> Just n
               _ -> Nothing
        nm = clabel (vt,k)
    in c_typerep_ctype ty ++ " " ++ c_array_qual vc nm rf ++ ";"

-- | Generate a C @struct@ for 'Var', predicate determines if array
-- variables are refernces or allocations.
gen_var_struct :: String -> (Var -> Bool) -> [Var] -> [String]
gen_var_struct nm f vs =
    let dc = zipWith var_decl (map f vs) vs
    in c_comment nm :
       bracket ("struct " ++ nm ++ " {","};") dc

-- | Construct an identifier.
--
-- > clabel (Std_Var,0) == "n_0"
clabel :: (Var_Ty,Id) -> String
clabel (ty,k) = var_ty_char ty : '_' : show k

-- | 'clabel' of 'Std_Var'.
--
-- > std_clabel 0 == "n_0"
std_clabel :: Id -> String
std_clabel k = clabel (Std_Var,k)

-- | Variant with @m.@ prefix.
m_clabel :: (Var_Ty,Id) -> String
m_clabel = ("m." ++) . clabel

-- | 'c_init_var' for constant.
--
-- > c_const (0,I 1) == ["m.n_0 = 1;"]
c_const :: (Id,K) -> [String]
c_const (k,v) =
    case v of
      B x -> c_init_var ("m",".",std_clabel k) (Var_B x)
      F x -> c_init_var ("m",".",std_clabel k) (Var_F x)
      I x -> c_init_var ("m",".",std_clabel k) (Var_I x)
      _ -> error "c_const: k"

-- * Code generators

-- | C declarations for DSP functions (memreq,init and step).
dsp_fun_decl :: [String]
dsp_fun_decl =
    ["size_t dsp_memreq();"
    ,"void dsp_init(void *p);"
    ,"void dsp_step(df_world *w,int w_nf);"]

-- | The structure for all memory stores.  In the uniform model this
-- is a notational convenience only.  In a partioned model it is
-- functional.
cmem :: [Var] -> [String]
cmem = gen_var_struct "df_mem" is_stateful

-- | The structure for stateful 'Var'.
cstate :: [Var] -> [String]
cstate = gen_var_struct "df_state" (const False) . filter is_stateful

-- | Generate dsp_memreq function.
dsp_memreq :: [String]
dsp_memreq =
    ["size_t dsp_memreq()"
    ,"{"
    ,"return (sizeof(struct df_state));"
    ,"}"]

-- | Generate dsp_init function.
dsp_init :: [Var] -> [String]
dsp_init vs =
    let a = ["void dsp_init(void *p)"
            ,"{"]
        b = ["return;"
            ,"}"]
        c = case filter is_stateful vs of
              [] -> []
              vs' -> "struct df_state *s = (struct df_state *)p;" :
                     concatMap (var_init "s" "->") vs'
    in a ++ c ++ b

-- | List of constants, list of variables, list of c-calls.
type Instructions = ([(Id,K)],[Var],[C_Call])

-- | Generate @dsp_step@ function.
dsp_step :: Instructions -> [String]
dsp_step (ks,vs,cc) =
    let f v = let nm = var_nm v in "m." ++ nm ++ " = s->" ++ nm ++ ";"
        g v = let nm = var_nm v in "s->" ++ nm ++ " = m." ++ nm ++ ";"
    in concat [["void dsp_step(df_world *w,int w_nf)"
               ,"{"
               ,"struct df_mem m;"]
              ,let v = filter is_stateful vs
               in if null v
                  then []
                  else ["struct df_state *s = (struct df_state*)w_state(w);"
                       ,"/* load state */"] ++
                        map f v
              ,["/* constants */"]
              ,concatMap c_const ks
              ,["/* algorithm */"
               ,"/* k-rate (fc == 0) */"
               ,"/* a-rate (fc == 1..) */"
               ,"for(int fc = 0; fc < w_nf; fc++) {"]
              ,map c_call cc
              ,["}"
               ,"/* store state */"]
              ,map g (filter is_stateful_atom vs)
              ,["}"]]

-- | Generate C code for graph.
code_gen :: Host -> Instructions -> String
code_gen h (ks,vs,cc) =
    let hd = ["#include <stdio.h>"
             ,"#include <stdint.h>"
             ,"#include <stdlib.h>"
             ,"#include <stdbool.h>"
             ,"#include <math.h>"
             ,host_include h
             ,"#include \"/home/rohan/sw/hdf/c/hdf.h\""]
        c = [hd
            ,host_dsp_fun_decl h
            ,cstate vs
            ,cmem vs
            ,dsp_memreq
            ,dsp_init vs
            ,dsp_step (ks,vs,cc)]
    in (unlines . concat) c

-- * Host

-- | Enumeration of code hosts.
data Host = JACK | SC3 | Text

-- | Host specific @#include@ file.
host_include :: Host -> String
host_include h =
    case h of
      JACK -> "#include \"/home/rohan/sw/rju/jack-dl.h\""
      SC3 -> "#include \"/home/rohan/sw/sc3-rdu/cpp/RDL.h\""
      Text -> "#include \"/home/rohan/sw/hdf/c/text-dl.h\""

-- | Host specific form of 'dsp_fun_decl' (@extern C@ where required).
host_dsp_fun_decl :: Host -> [String]
host_dsp_fun_decl h =
    case h of
      SC3 -> bracket ("extern \"C\" {","}") dsp_fun_decl
      _ -> dsp_fun_decl

-- | Generate compiler command for 'Host' given @include@ directory
-- prefix.
host_compiler_cmd :: (Host,FilePath) -> (String,[String])
host_compiler_cmd (h,d) =
    case h of
      SC3 ->
           ("g++"
           ,["-Wall","-g","-O2","-shared","-fPIC"
            ,"-I",d </> "include/SuperCollider/plugin_interface"
            ,"-I",d </> "include/SuperCollider/common"])
      _ ->
          ("gcc"
          ,["-Wall","-g","--std=c99","-O2","-shared","-fPIC"
           ,"-I",d </> "include"])

-- | Format 'host_compiler_cmd' as 'String'.
--
-- > host_compiler_cmd_str (JACK,"/home/rohan/opt")
-- > host_compiler_cmd_str (SC3,"/home/rohan/opt")
-- > host_compiler_cmd_str (Text,"/home/rohan/opt")
host_compiler_cmd_str :: (Host, FilePath) -> String
host_compiler_cmd_str = let f (cmd,arg) = unwords (cmd : arg) in f . host_compiler_cmd

-- * IO

-- | Generate C code, write file to disk and call the GNU C compiler
--   to build shared library.
dl_gen :: FilePath -> (Host,FilePath) -> Instructions -> IO ()
dl_gen fn (h,d) i = do
  let c = fn <.> "c"
      so = fn <.> "so"
      (cmd,opt) = host_compiler_cmd (h,d)
      opt' = opt ++ [c,"-o",so]
  writeFile c (code_gen h i)
  _ <- rawSystem cmd opt'
  return ()

-- * List

-- | Bracket list with elements.
--
-- > bracket ('<','>') "float" == "<float>"
bracket :: (a,a) -> [a] -> [a]
bracket (i,j) k = i : k ++ [j]

-- | Integrate, with implicit @0@.
--
-- > dx_d [5,6] == [0,5,11]
dx_d :: Num n => [n] -> [n]
dx_d = (0 :) . scanl1 (+)