(* Extraction from ROF XML *)
include "xhtml.cd"
namespace ns2 = "http://cdm-fr.fr/2012/CDM-frSchema"
namespace ns3 = "http://cdm-fr.fr/2012/CDM"
type ws = ' ' | '\n' | '\t'
type content = [ output? ]
type output = [ ws* String ws* (content | ws)* ]
(* quicksort *)
let quicksort
(cmp : 'a -> 'a -> Int)
(elems : ['a*]) : ['a*] =
let fun split
(pivot: 'a)
(elems : ['a*])
(acc1 : ['a*]) (acc2 : ['a*]) : (['a*], ['a*]) =
match elems with
[] -> (acc1, acc2)
| [ e; ll ] ->
if cmp e pivot <= 0 then split pivot ll (e,acc1) acc2
else split pivot ll acc1 (e,acc2)
in
match elems with
[] -> []
| [e; ll ] -> let (l1, l2) = split e ll [] [] in (quicksort cmp l1) @ (e,(quicksort cmp l2))
;;
let cmp_entry (e1 : content) (e2 : content) : Int =
match (e1, e2) with
(<_ title=t1 ..>_, <_ title=t2 ..>_) -> if t1 << t2 then -1 else if t1 >> t2 then 1 else 0
;;
let level_of_int ( Int -> `h1 | `h2 | `h3 | `h4 | `h5 | `h6 )
| 1 -> `h1
| 2 -> `h2
| 3 -> `h3
| 4 -> `h4
| 5 -> `h5
| _ -> `h6
;;
let output_to_html (o : output) (dec : String) (level : Int) : xhtml:div =
match o with
<document class="course">[ ws* <title>t _ * ] ->
<div class="course">[ <span>t <br>[] '\n']
| <document class=c >[ ws* <title>t (cl :: content |_)* ] ->
<div class=c> [ '\n' !dec ' ' <(level_of_int level)>t '\n' ;
(transform cl with
e -> entry_to_html e (' ', dec) (level + 1)) @ [
!dec]
]
(* | String & u -> print_utf8 (u @ "\n"); raise "Impossible" *)
let entry_to_html (e : content) (dec : String) (level : Int) :
[ (Char | xhtml:div | xhtml:br | xhtml:a )* ] =
print_utf8 "Inside entry\n";
match e with
<entry ref=base_ref title=t ..>[] -> [ !dec <a href=(base_ref @ ".xhtml")>t <br>[] '\n' ]
| <entry (_)>[ out ] -> print_utf8 "After matching in entry\n";
let [] =
match (out :? Any) with
(* [Any*] -> print_utf8 ("!!!1 " @ (string_of out)) *)
| output -> print_utf8 ("!!!2 " @ (string_of out))
| _ -> []
in
(*let _ = u in*) (* check this bug in CDuce ! *)
[ '\n'<div >[ '\n' !dec (output_to_html out dec (level)) '\n' ] '\n' ]
;;
let mk_page ((o & <document ..>[ws* <title>t _*]) : output) (style : String) : xhtml:html =
xhtml:create <head>[<title>t
<link href="style_common.css" type="text/css" rel="stylesheet">[]
<link href=style type="text/css" rel="stylesheet">[]
]
<body>[ (output_to_html o "" 1) ]
;;
let first_program_id (doc : AnyXml) : String =
match [doc] // <ns2:relatedPrograms ..>_ with
[ <_ ..>[ _* <ns2:relationInfo userDefined=(String&id) ..>_ _* ] _*] -> id
| _ -> raise "Invalid ROF document"
;;
let todo_ids = ref ([(Latin1, output)*]) []
let push (x : (Latin1,output)) : [] =
todo_ids := (x, !todo_ids)
;;
let name_from_descr (l : String) (suff : String): Latin1 =
let l =
match l with
[ ws* (x::Char)*? ws* ] -> x
in
let l =
transform l @ "_" @ suff with
' ' -> [ '_' ]
| x & ('A'--'Z' | 'a'--'z' | '0'--'9') -> [x]
in
l
;;
let find_by_id (l : [ ('a & <_ id=String ..>_)* ]) (id : String) : ('a & <_ id=String ..>_) =
match l with
[] -> raise "Not found"
| ((<_ id=x ..>_ & y), rest) -> if x = id then y else find_by_id rest id
;;
let getContentById (doc : AnyXml) (id : String) : (Latin1,output) =
let program =
match doc with
<ns3:CDM ..>[ (l::<(`ns3:program|`ns3:course) id=String ..>_ | _)* ] -> find_by_id l id
| _ -> raise "Invalid ROF document"
in
match program with
(<ns3:program ..>[ _* <ns2:programName ..>[ _* <ns2:text ..>(String&t) _*]
_* (<ns3:programStructure userDefined="ObjetsFils" ..>l | (l:=[]))
_* ] & (course:=`false))
| (<ns3:course ..>[ _* <ns3:courseName ..>(String&t) _* ] & (l:= []) & (course:=`true))
->
(name_from_descr t id, <document class=(if course then "course" else "box")>[ '\n'
<title>t '\n'
!(transform l with
<(`ns3:refCourse
|`ns3:refProgram) ref=(String&r) >_ ->
print_utf8 ("Looking for id: " @ r @"\n");
let (sonref,son) = getContentById doc r in
let descr = match son with <document ..>[ _* <title>tt _*] -> tt in
push (sonref,son);
[<entry id=r ref=sonref title=descr >[ son ] '\n'])
])
| _ -> raise ("Invalid ROF document (id: " @ id @ ")")
;;
let main (_ :[]) : [] =
match argv [] with
[ (file & Latin1) ((outdir & Latin1) ) _* ] ->
(let doc = load_xml file in
let id = first_program_id doc in
let (file,out) = getContentById doc id in
let out = match out with
<document ..>[ (x::ws)* <title>t ; l ] ->
<document class="box">[ !x <title>t !(quicksort cmp_entry (transform l with <entry (y)>_ -> [<entry (y)>[]])) ]
in
let [] =
let h = mk_page out "style_parcours_main.css" in
xhtml:serialize h `xhtml (outdir @ "/" @ file @".xhtml")
in
transform !todo_ids with
(file,out) ->
let h = mk_page out "style_parcours.css" in
xhtml:serialize h `xhtml (outdir @ "/" @ file @".xhtml")
)
| _ -> raise "Invalid command line arguments"
;;
let [] = main []