  Ohm is © 2013  

exception ParseError of Lexing.position

type 'a t = {
  revpath : string list ; 
  source  : string ; 
  inner   : 'a 
}

let source_of_revpath revpath = 
  match List.rev revpath with 
  | folder :: file :: _ -> "_" ^ folder ^ "_" ^ file 
  | _ -> assert false (* All assets should respect folder/file.htm convention *)

let parse revpath lexbuf =
  let reader = TokenAsset.read () in
  try let stream = ParseAsset.file reader lexbuf in
      { revpath ; source = source_of_revpath revpath ; inner = stream }
  with exn -> raise (ParseError lexbuf.Lexing.lex_curr_p)
  
let extract_strings streams = 
  List.fold_right 
    (fun asset (current,out) -> 
      let stream = asset.inner in 
      let current, stream = SyntaxAsset.extract_strings current stream in 
      let current = SyntaxAsset.({ current with 
	htmls = (asset.source, current.html) :: current.htmls ; 
	html = "" }) 
      in
      let asset = {
	revpath = asset.revpath ;
	source  = asset.source ;
	inner   = stream
      } in
      (current,asset :: out))
    streams (SyntaxAsset.({
      html   = "" ;
      htmls  = [] ; 
      coffee = Buffer.create 16 ; 
      id     = 1 ;
      css    = Buffer.create 16
    }),[])
  
let extract_assets assets = 
  List.fold_left
    (fun out asset -> 
      let add revpath inner = { revpath ; source = asset.source ; inner } in 
      let out, inner = 
	SyntaxAsset.extract_assets add asset.revpath out asset.inner in
      { revpath = asset.revpath ;
	source  = asset.source ;
	inner } :: out)
    [] assets

let chain_of_revpath revpath = 
  String.concat "_" 
    (List.rev_map String.capitalize revpath)

let  ml_of_revpath revpath = "asset_" ^ chain_of_revpath revpath ^ ".ml"
let mli_of_revpath revpath = ml_of_revpath revpath ^ "i"

let module_of_revpath revpath = "Asset_" ^ chain_of_revpath revpath 

type generation = 
  [ `Stmt of string
  | `Indent of generation list ] 
    
let print_generated l = 
  let b = Buffer.create 16 in
  let rec gen indent = function
    | `Stmt   s -> Buffer.add_string b indent ; Buffer.add_string b s ; Buffer.add_char b '\n'
    | `Indent l -> List.iter (gen (indent ^ "  ")) l 
  in
  List.iter (gen "") l ;
  Buffer.contents b 

let header = "(* This asset file was generated by ohm-tool *)"
let (!!) fmt = Printf.sprintf fmt 

let generate_source htmls = 
  
  let the_struct = 
    print_generated (
      `Stmt header 
      :: List.map (fun (source, html) -> 
	`Stmt (!! "let %s = %S" source html)) htmls 
    )

  and the_sig = 
    print_generated (
      `Stmt header 
      :: List.map (fun (source,_) -> 
	`Stmt (!! "val %s : string" source)) htmls
    )
  in

  [ "assetData.ml", the_struct ; "assetData.mli", the_sig ] 

let generate_asset asset = 

  let ids : SyntaxAsset.id_cell list = SyntaxAsset.extract_ids asset.inner in
  let root : SyntaxAsset.cell_root = SyntaxAsset.extract_roots ids in 

  let formats = SyntaxAsset.formats root in 

  let the_struct = 
    
    let print_cell = function 
      | `Print uid    -> Some (`Stmt (!! "_%d _html ;" uid))
      | `String (_,0) -> None
      | `String (start,length) -> Some (
	`Stmt (!! "Buffer.add_substring _html.Ohm.Html.html _source %d %d ;"
		  start length))
      | `Id i -> Some (
	`Stmt (!! "Ohm.Html.Convenience.id _%d _html ;" i) 
      )
      | `Script (s,k,t) -> Some (

	let args = 
	  String.concat ";" begin List.map (fun (_,name,_,(_,serialize)) ->
	    let what = if name = "this" then "_data" else !! "(_data # %s)" name in
	    serialize what
	  ) t end 
	in

	let here = 
	  String.concat ";" begin List.map (fun (i,n) -> 
	  !! "%S,Ohm.Id.to_json _%d" ("$" ^ SyntaxAsset.contents n) i
	  ) k end 
	in 
	
	`Stmt (!! "Ohm.Html.run (Ohm.JsCode.make ~name:%S ~args:[Ohm.Json.Object [%s];%s]) _html ;" 
		  s here args)
      )
    in

    let rec print_root = function 
      | `Render [] -> [ `Stmt "Ohm.Run.return ignore" ] 
      | `Render cells -> 
	[ `Stmt "Ohm.Run.return (fun _html ->" 
	; `Indent ((BatList.filter_map print_cell cells))
	; `Stmt ")" ]
      | `Extract (uid,name,tail) -> begin
	match name with 
	  | Some name -> 
	    let contents = SyntaxAsset.contents name in
	    if contents = "this" then
	      ( `Stmt (!! "let  _%d = _data in" uid ) )
	      :: print_root tail
	    else
	      ( `Stmt (!! "let  _%d = _data # %s in" uid contents ) )
	      :: print_root tail
	  | None -> 
	    ( `Stmt (!! "let  _%d = () in" uid))
	    :: print_root tail
      end
      | `DefId ([],tail) -> print_root tail 
      | `DefId (h::t,tail) -> 
	( `Stmt (!! "let  _%d = Ohm.Id.gen () in" h))
	:: print_root (`DefId (t,tail))
      | `Seq (a,b) -> 
	(`Stmt "let! () = Ohm.Universal.ohm begin ")
	:: (`Indent (print_root a)) 
	:: (`Stmt "in")
	:: print_root b
      | `Apply (uid,uid',what,tail) -> 
	( `Stmt (!! "let  _%d = _%d |> %s in" uid uid' 
		    (String.concat "." (List.map SyntaxAsset.contents what))))
	:: print_root tail
      | `Ohm (uid,uid',tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm _%d in" uid uid'))
	:: print_root tail
      | `AdLib (uid,variant,uid',tail) ->
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm (Ohm.AdLib.write %s) in" uid
		   (match uid' with 
		     | None -> SyntaxAsset.contents variant
		     | Some uid' -> !! "(%s _%d)" (SyntaxAsset.contents variant) uid')))
	:: print_root tail
      | `Put (uid,uid',`Raw,tail) -> 
	(`Stmt (!! "let  _%d _html = Buffer.add_string _html.Ohm.Html.html _%d in" 
		   uid uid'))
	:: print_root tail
      | `Put (uid,uid',`Esc,tail) -> 
	(`Stmt (!! "let  _%d = Ohm.Html.esc _%d in" uid uid'))
	:: print_root tail
      | `If (uid,uid',if_true,if_false,tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm begin" uid))
	:: (`Indent [ `Stmt (!! "if _%d then" uid') 
		    ; `Indent (print_root if_true) 
		    ; `Stmt "else" 
		    ; `Indent (print_root if_false) 
		    ])
	:: (`Stmt "end in") 
	:: print_root tail 
      | `Sub (uid,uid',what,tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm begin" uid))
	:: (`Indent ( `Stmt (!! "let _data = _%d in" uid') 
		      :: print_root what ))
	:: (`Stmt "end in") 
	:: print_root tail 
      | `Call (uid,revpath,tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm (%s.render _data) in"
		   uid (module_of_revpath revpath)))
	:: print_root tail 
      | `Option (uid,_,uid',if_some,if_none,tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm begin" uid))
	:: (`Indent [ `Stmt (!! "match _%d with" uid') 
		    ; `Stmt "| None ->" 
		    ; `Indent (print_root if_none) 
		    ; `Stmt "| Some _data ->" 
		    ; `Indent (print_root if_some) ])
	:: (`Stmt "end in") 
	:: print_root tail 
      | `List (uid,_,uid',if_list,if_none,tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm begin" uid))
	:: (`Indent [ `Stmt (!! "match _%d with" uid') 
		    ; `Stmt "| [] ->" 
		    ; `Indent (print_root if_none) 
		    ; `Stmt "| _list -> " 
		    ; `Indent [ `Stmt "let! _render = Ohm.Universal.ohm (Ohm.Run.list_map (fun _data ->" 
			      ; `Indent (print_root if_list) 
			      ; `Stmt ") _list) in" 
			      ; `Stmt "Ohm.Run.return (Ohm.Html.concat _render)" ]])
	:: (`Stmt "end in") 
	:: print_root tail 
    in

    let contents =
      ( `Stmt header ) 
      :: ( `Stmt "open BatPervasives" ) 
      :: ( `Stmt ("let _source = AssetData." ^ asset.source ))
      :: ( `Stmt "let bind = Ohm.Universal.bind" )
      :: ( `Stmt (String.concat "\n" formats)) 
      :: ( `Stmt "let render _data =" )
      :: [ `Indent (print_root root) ]
    in

    print_generated contents

  in

  [ ml_of_revpath asset.revpath, the_struct ] 

let distribute_adlib (defs,languages) (path,contents) = 
  let file = Filename.basename path in 
  if file = "def.adlib.ml" then ((path,contents) :: defs, languages) else
    let prefix  = String.sub file 0 (String.length file - String.length ".adlib.ml") in
    let current = try BatMap.find prefix languages with Not_found -> [] in
    (defs, BatMap.add prefix ((path,contents) :: current) languages) 

let generate_adlib_block prefix suffix contents = 
  prefix 
  ^ String.concat "" (List.map begin fun (path,contents) ->
    (!! "\n# 0 %S\n" path) ^ contents   
  end contents) 
  ^ suffix

let generate_adlib assets = 

  let (defs,languages) = List.fold_left distribute_adlib ([],BatMap.empty) assets in

  let key = generate_adlib_block "type key = \n[ `EMPTY" "\n]\n\n" defs in    
  let langnames = BatMap.foldi (fun k _ l -> k :: l) languages [] in 

  let mli = header ^ "\n" ^ key ^ 
    (String.concat "" (List.map (fun l -> "val "^l^" : key Ohm.AdLib.source\n") langnames))
  in

  let languages = BatMap.foldi begin fun k v l ->
    (generate_adlib_block
      ("let "^k^" : key -> string = function\n| `EMPTY -> \"\"")
      ";;" v) :: l 
  end languages [] in

  let ml = header ^ "\nopen Ohm.AdLib\n\n" ^ key ^
    (String.concat "\n\n" languages) 
  in
  
  [ "asset_AdLib.ml", ml ; "asset_AdLib.mli" , mli ]

 All assets should respect folder/file.htm convention 
  Ohm is © 2013  

exception ParseError of Lexing.position

type 'a t = {
  revpath : string list ; 
  source  : string ; 
  inner   : 'a 
}

let source_of_revpath revpath = 
  match List.rev revpath with 
  | folder :: file :: _ -> "_" ^ folder ^ "_" ^ file 

let parse revpath lexbuf =
  let reader = TokenAsset.read () in
  try let stream = ParseAsset.file reader lexbuf in
      { revpath ; source = source_of_revpath revpath ; inner = stream }
  with exn -> raise (ParseError lexbuf.Lexing.lex_curr_p)
  
let extract_strings streams = 
  List.fold_right 
    (fun asset (current,out) -> 
      let stream = asset.inner in 
      let current, stream = SyntaxAsset.extract_strings current stream in 
      let current = SyntaxAsset.({ current with 
	htmls = (asset.source, current.html) :: current.htmls ; 
	html = "" }) 
      in
      let asset = {
	revpath = asset.revpath ;
	source  = asset.source ;
	inner   = stream
      } in
      (current,asset :: out))
    streams (SyntaxAsset.({
      html   = "" ;
      htmls  = [] ; 
      coffee = Buffer.create 16 ; 
      id     = 1 ;
      css    = Buffer.create 16
    }),[])
  
let extract_assets assets = 
  List.fold_left
    (fun out asset -> 
      let add revpath inner = { revpath ; source = asset.source ; inner } in 
      let out, inner = 
	SyntaxAsset.extract_assets add asset.revpath out asset.inner in
      { revpath = asset.revpath ;
	source  = asset.source ;
	inner } :: out)
    [] assets

let chain_of_revpath revpath = 
  String.concat "_" 
    (List.rev_map String.capitalize revpath)

let  ml_of_revpath revpath = "asset_" ^ chain_of_revpath revpath ^ ".ml"
let mli_of_revpath revpath = ml_of_revpath revpath ^ "i"

let module_of_revpath revpath = "Asset_" ^ chain_of_revpath revpath 

type generation = 
  [ `Stmt of string
  | `Indent of generation list ] 
    
let print_generated l = 
  let b = Buffer.create 16 in
  let rec gen indent = function
    | `Stmt   s -> Buffer.add_string b indent ; Buffer.add_string b s ; Buffer.add_char b '\n'
    | `Indent l -> List.iter (gen (indent ^ "  ")) l 
  in
  List.iter (gen "") l ;
  Buffer.contents b 

let header = "(* This asset file was generated by ohm-tool *)"
let (!!) fmt = Printf.sprintf fmt 

let generate_source htmls = 
  
  let the_struct = 
    print_generated (
      `Stmt header 
      :: List.map (fun (source, html) -> 
	`Stmt (!! "let %s = %S" source html)) htmls 
    )

  and the_sig = 
    print_generated (
      `Stmt header 
      :: List.map (fun (source,_) -> 
	`Stmt (!! "val %s : string" source)) htmls
    )
  in

  [ "assetData.ml", the_struct ; "assetData.mli", the_sig ] 

let generate_asset asset = 

  let ids : SyntaxAsset.id_cell list = SyntaxAsset.extract_ids asset.inner in
  let root : SyntaxAsset.cell_root = SyntaxAsset.extract_roots ids in 

  let formats = SyntaxAsset.formats root in 

  let the_struct = 
    
    let print_cell = function 
      | `Print uid    -> Some (`Stmt (!! "_%d _html ;" uid))
      | `String (_,0) -> None
      | `String (start,length) -> Some (
	`Stmt (!! "Buffer.add_substring _html.Ohm.Html.html _source %d %d ;"
		  start length))
      | `Id i -> Some (
	`Stmt (!! "Ohm.Html.Convenience.id _%d _html ;" i) 
      )
      | `Script (s,k,t) -> Some (

	let args = 
	  String.concat ";" begin List.map (fun (_,name,_,(_,serialize)) ->
	    let what = if name = "this" then "_data" else !! "(_data # %s)" name in
	    serialize what
	  ) t end 
	in

	let here = 
	  String.concat ";" begin List.map (fun (i,n) -> 
	  !! "%S,Ohm.Id.to_json _%d" ("$" ^ SyntaxAsset.contents n) i
	  ) k end 
	in 
	
	`Stmt (!! "Ohm.Html.run (Ohm.JsCode.make ~name:%S ~args:[Ohm.Json.Object [%s];%s]) _html ;" 
		  s here args)
      )
    in

    let rec print_root = function 
      | `Render [] -> [ `Stmt "Ohm.Run.return ignore" ] 
      | `Render cells -> 
	[ `Stmt "Ohm.Run.return (fun _html ->" 
	; `Indent ((BatList.filter_map print_cell cells))
	; `Stmt ")" ]
      | `Extract (uid,name,tail) -> begin
	match name with 
	  | Some name -> 
	    let contents = SyntaxAsset.contents name in
	    if contents = "this" then
	      ( `Stmt (!! "let  _%d = _data in" uid ) )
	      :: print_root tail
	    else
	      ( `Stmt (!! "let  _%d = _data # %s in" uid contents ) )
	      :: print_root tail
	  | None -> 
	    ( `Stmt (!! "let  _%d = () in" uid))
	    :: print_root tail
      end
      | `DefId ([],tail) -> print_root tail 
      | `DefId (h::t,tail) -> 
	( `Stmt (!! "let  _%d = Ohm.Id.gen () in" h))
	:: print_root (`DefId (t,tail))
      | `Seq (a,b) -> 
	(`Stmt "let! () = Ohm.Universal.ohm begin ")
	:: (`Indent (print_root a)) 
	:: (`Stmt "in")
	:: print_root b
      | `Apply (uid,uid',what,tail) -> 
	( `Stmt (!! "let  _%d = _%d |> %s in" uid uid' 
		    (String.concat "." (List.map SyntaxAsset.contents what))))
	:: print_root tail
      | `Ohm (uid,uid',tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm _%d in" uid uid'))
	:: print_root tail
      | `AdLib (uid,variant,uid',tail) ->
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm (Ohm.AdLib.write %s) in" uid
		   (match uid' with 
		     | None -> SyntaxAsset.contents variant
		     | Some uid' -> !! "(%s _%d)" (SyntaxAsset.contents variant) uid')))
	:: print_root tail
      | `Put (uid,uid',`Raw,tail) -> 
	(`Stmt (!! "let  _%d _html = Buffer.add_string _html.Ohm.Html.html _%d in" 
		   uid uid'))
	:: print_root tail
      | `Put (uid,uid',`Esc,tail) -> 
	(`Stmt (!! "let  _%d = Ohm.Html.esc _%d in" uid uid'))
	:: print_root tail
      | `If (uid,uid',if_true,if_false,tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm begin" uid))
	:: (`Indent [ `Stmt (!! "if _%d then" uid') 
		    ; `Indent (print_root if_true) 
		    ; `Stmt "else" 
		    ; `Indent (print_root if_false) 
		    ])
	:: (`Stmt "end in") 
	:: print_root tail 
      | `Sub (uid,uid',what,tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm begin" uid))
	:: (`Indent ( `Stmt (!! "let _data = _%d in" uid') 
		      :: print_root what ))
	:: (`Stmt "end in") 
	:: print_root tail 
      | `Call (uid,revpath,tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm (%s.render _data) in"
		   uid (module_of_revpath revpath)))
	:: print_root tail 
      | `Option (uid,_,uid',if_some,if_none,tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm begin" uid))
	:: (`Indent [ `Stmt (!! "match _%d with" uid') 
		    ; `Stmt "| None ->" 
		    ; `Indent (print_root if_none) 
		    ; `Stmt "| Some _data ->" 
		    ; `Indent (print_root if_some) ])
	:: (`Stmt "end in") 
	:: print_root tail 
      | `List (uid,_,uid',if_list,if_none,tail) -> 
	(`Stmt (!! "let! _%d = Ohm.Universal.ohm begin" uid))
	:: (`Indent [ `Stmt (!! "match _%d with" uid') 
		    ; `Stmt "| [] ->" 
		    ; `Indent (print_root if_none) 
		    ; `Stmt "| _list -> " 
		    ; `Indent [ `Stmt "let! _render = Ohm.Universal.ohm (Ohm.Run.list_map (fun _data ->" 
			      ; `Indent (print_root if_list) 
			      ; `Stmt ") _list) in" 
			      ; `Stmt "Ohm.Run.return (Ohm.Html.concat _render)" ]])
	:: (`Stmt "end in") 
	:: print_root tail 
    in

    let contents =
      ( `Stmt header ) 
      :: ( `Stmt "open BatPervasives" ) 
      :: ( `Stmt ("let _source = AssetData." ^ asset.source ))
      :: ( `Stmt "let bind = Ohm.Universal.bind" )
      :: ( `Stmt (String.concat "\n" formats)) 
      :: ( `Stmt "let render _data =" )
      :: [ `Indent (print_root root) ]
    in

    print_generated contents

  in

  [ ml_of_revpath asset.revpath, the_struct ] 

let distribute_adlib (defs,languages) (path,contents) = 
  let file = Filename.basename path in 
  if file = "def.adlib.ml" then ((path,contents) :: defs, languages) else
    let prefix  = String.sub file 0 (String.length file - String.length ".adlib.ml") in
    let current = try BatMap.find prefix languages with Not_found -> [] in
    (defs, BatMap.add prefix ((path,contents) :: current) languages) 

let generate_adlib_block prefix suffix contents = 
  prefix 
  ^ String.concat "" (List.map begin fun (path,contents) ->
    (!! "\n# 0 %S\n" path) ^ contents   
  end contents) 
  ^ suffix

let generate_adlib assets = 

  let (defs,languages) = List.fold_left distribute_adlib ([],BatMap.empty) assets in

  let key = generate_adlib_block "type key = \n[ `EMPTY" "\n]\n\n" defs in    
  let langnames = BatMap.foldi (fun k _ l -> k :: l) languages [] in 

  let mli = header ^ "\n" ^ key ^ 
    (String.concat "" (List.map (fun l -> "val "^l^" : key Ohm.AdLib.source\n") langnames))
  in

  let languages = BatMap.foldi begin fun k v l ->
    (generate_adlib_block
      ("let "^k^" : key -> string = function\n| `EMPTY -> \"\"")
      ";;" v) :: l 
  end languages [] in

  let ml = header ^ "\nopen Ohm.AdLib\n\n" ^ key ^
    (String.concat "\n\n" languages) 
  in
  
  [ "asset_AdLib.ml", ml ; "asset_AdLib.mli" , mli ]
