unrof.cd

   1 (* Extraction from ROF XML *)
   2
   3 include "xhtml.cd"
   4
   5
   6
   7
   8 namespace ns2 = "http://cdm-fr.fr/2012/CDM-frSchema"
   9 namespace ns3 = "http://cdm-fr.fr/2012/CDM"
  10
  11
  12 type ws = ' ' | '\n' | '\t'
  13 type content = <entry id=String ref=String title=String >[ output? ]
  14 type output = <document class=String>[ ws* <title>String ws* (content | ws)* ]
  15
  16
  17 (* quicksort *)
  18
  19
  20 let quicksort
  21     (cmp : 'a -> 'a -> Int)
  22     (elems : ['a*]) : ['a*] =
  23
  24   let fun split
  25     (pivot: 'a)
  26     (elems : ['a*])
  27     (acc1 : ['a*]) (acc2 : ['a*]) : (['a*], ['a*]) =
  28   match elems with
  29     [] -> (acc1, acc2)
  30   | [ e; ll ] ->
  31       if cmp e pivot <= 0 then split pivot ll (e,acc1) acc2
  32       else split pivot ll acc1 (e,acc2)
  33   in
  34   match elems with
  35     [] -> []
  36   | [e; ll ] -> let (l1, l2) = split e ll [] [] in (quicksort cmp l1) @ (e,(quicksort cmp l2))
  37 ;;
  38
  39
  40 let cmp_entry (e1 : content) (e2 : content) : Int =
  41   match (e1, e2) with
  42     (<_ title=t1 ..>_, <_ title=t2 ..>_) -> if t1 << t2 then -1 else if t1 >> t2 then 1 else 0
  43 ;;
  44
  45 let level_of_int ( Int -> `h1 | `h2 | `h3 | `h4 | `h5 | `h6 )
  46   |  1 -> `h1
  47   | 2 -> `h2
  48   | 3 -> `h3
  49   | 4 -> `h4
  50   | 5 -> `h5
  51   | _ -> `h6
  52 ;;
  53
  54 let output_to_html (o : output) (dec : String) (level : Int) : xhtml:div =
  55
  56   match o with
  57     <document class="course">[ ws* <title>t _ * ] ->
  58       <div class="course">[ <span>t <br>[] '\n']
  59
  60   | <document class=c >[ ws* <title>t (cl :: content |_)* ] ->
  61       <div class=c> [ '\n' !dec ' ' <(level_of_int level)>t  '\n' ;
  62               (transform cl with
  63                 e -> entry_to_html e (' ', dec)  (level + 1)) @ [
  64                 !dec]
  65             ]
  66 (*  | String & u -> print_utf8 (u @ "\n"); raise "Impossible" *)
  67
  68
  69 let entry_to_html (e : content) (dec : String) (level : Int) :
  70     [ (Char | xhtml:div | xhtml:br | xhtml:a )* ] =
  71   print_utf8 "Inside entry\n";
  72   match e with
  73     <entry ref=base_ref  title=t ..>[] -> [ !dec <a href=(base_ref @ ".xhtml")>t <br>[] '\n' ]
  74
  75   | <entry (_)>[ out ]  ->   print_utf8 "After matching in entry\n";
  76
  77     let [] =
  78     match (out :? Any) with
  79 (*      [Any*] -> print_utf8 ("!!!1 " @ (string_of out)) *)
  80     | output -> print_utf8 ("!!!2 " @ (string_of out))
  81     | _ -> []
  82     in
  83    (*let _ = u in*) (* check this bug in CDuce ! *)
  84                             [ '\n'<div >[ '\n' !dec (output_to_html out dec (level)) '\n'  ] '\n' ]
  85
  86
  87 ;;
  88
  89
  90
  91 let mk_page ((o & <document ..>[ws* <title>t _*]) : output)  (style : String) : xhtml:html =
  92   xhtml:create <head>[<title>t
  93                       <link href="style_common.css" type="text/css" rel="stylesheet">[]
  94                       <link href=style type="text/css" rel="stylesheet">[]
  95                       ]
  96                <body>[ (output_to_html o "" 1) ]
  97 ;;
  98
  99
 100 let first_program_id (doc : AnyXml) : String =
 101   match [doc] // <ns2:relatedPrograms ..>_ with
 102     [ <_ ..>[ _* <ns2:relationInfo userDefined=(String&id) ..>_ _* ] _*] -> id
 103     | _ -> raise "Invalid ROF document"
 104 ;;
 105
 106 let todo_ids = ref ([(Latin1, output)*]) []
 107
 108 let push (x : (Latin1,output)) : [] =
 109   todo_ids := (x, !todo_ids)
 110 ;;
 111
 112
 113 let name_from_descr (l : String) (suff : String): Latin1 =
 114   let l =
 115     match l with
 116       [ ws* (x::Char)*? ws* ] -> x
 117   in
 118   let l =
 119   transform l @ "_" @ suff with
 120     ' '     -> [ '_' ]
 121   |  x & ('A'--'Z' | 'a'--'z' | '0'--'9') -> [x]
 122   in
 123   l
 124 ;;
 125
 126 let find_by_id (l : [ ('a & <_ id=String ..>_)* ]) (id : String) : ('a & <_ id=String ..>_) =
 127   match l with
 128     [] -> raise "Not found"
 129   | ((<_ id=x ..>_ & y), rest) -> if x = id then y else find_by_id rest id
 130
 131 ;;
 132
 133 let getContentById (doc : AnyXml) (id : String) : (Latin1,output) =
 134   let program =
 135     match doc with
 136       <ns3:CDM ..>[ (l::<(`ns3:program|`ns3:course) id=String ..>_ | _)* ] -> find_by_id l id
 137     | _ -> raise "Invalid ROF document"
 138   in
 139   match program with
 140     (<ns3:program ..>[ _* <ns2:programName ..>[ _* <ns2:text ..>(String&t) _*]
 141                       _* (<ns3:programStructure userDefined="ObjetsFils" ..>l | (l:=[]))
 142                       _* ] & (course:=`false))
 143   | (<ns3:course ..>[ _* <ns3:courseName ..>(String&t) _* ] & (l:= []) & (course:=`true))
 144  ->
 145     (name_from_descr t id, <document class=(if course then "course" else "box")>[ '\n'
 146                   <title>t '\n'
 147                     !(transform l with
 148                        <(`ns3:refCourse
 149                         |`ns3:refProgram) ref=(String&r) >_ ->
 150                          print_utf8 ("Looking for id: " @ r @"\n");
 151                          let (sonref,son) = getContentById doc r in
 152                          let descr = match son with <document ..>[ _* <title>tt _*] -> tt in
 153                          push (sonref,son);
 154                          [<entry id=r ref=sonref title=descr >[ son ] '\n'])
 155                 ])
 156
 157   | _ -> raise ("Invalid ROF document (id: " @ id @ ")")
 158 ;;
 159
 160
 161
 162
 163 let main (_ :[]) : [] =
 164   match argv [] with
 165     [ (file & Latin1) ((outdir & Latin1) ) _* ] ->
 166       (let doc = load_xml file in
 167       let id = first_program_id doc in
 168       let (file,out) = getContentById doc id in
 169       let out = match out with
 170           <document ..>[ (x::ws)* <title>t ; l ] ->
 171             <document class="box">[ !x <title>t !(quicksort cmp_entry (transform l with <entry (y)>_ -> [<entry (y)>[]])) ]
 172       in
 173
 174       let [] =
 175         let h = mk_page out "style_parcours_main.css" in
 176         xhtml:serialize h `xhtml (outdir @ "/" @ file @".xhtml")
 177       in
 178       transform !todo_ids with
 179         (file,out) ->
 180           let h = mk_page out "style_parcours.css" in
 181           xhtml:serialize h `xhtml (outdir @ "/" @ file @".xhtml")
 182       )
 183      | _ -> raise "Invalid command line arguments"
 184
 185 ;;
 186
 187
 188
 189
 190 let [] = main []