-
Notifications
You must be signed in to change notification settings - Fork 1
/
slides.ml
92 lines (78 loc) · 1.91 KB
/
slides.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
open Cow
open Printf
(** Layout modes for the rendering of the slides *)
type layout =
|Regular
|Faux_widescreen
|Widescreen
(* Styles of each slide *)
type style =
|Title
|Smaller
|No_background
|Fill
(* A single slide *)
type article = {
styles: style list;
content: Xml.t;
}
type presentation = {
topic: string;
layout: layout;
articles: article list;
}
let layout_to_string = function
|Regular -> "layout-regular"
|Faux_widescreen -> "layout-faux-widescreen"
|Widescreen -> "layout-widescreen"
let style_to_string = function
|Title -> "biglogo"
|Smaller -> "smaller"
|No_background -> "nobackground"
|Fill -> "fill"
(** Render one slide
* @param styles How to render the slide (title, normal, or smaller font)
* @param title Main title string of slide
* @param subtitle Optional subtitle for slide
* @param content XHTML body of the slide
**)
let article_to_xhtml article =
let attrs = match article.styles with
|[] -> []
|xs -> ["class", (String.concat " " (List.map style_to_string xs))]
in
<:html<
<article $alist:attrs$>
$article.content$
</article>
>>
(** Generate slides XHTML, given an input presentation *)
let slides p =
let template = "template-default" in
let classes = sprintf "slides %s %s" (layout_to_string p.layout) template in
<:html<
<html>
<head>
<title>$str:p.topic$</title>
<script type="text/javascript" src="slides.js"> </script>
</head>
<style>
</style>
<body>
<section class="$str:classes$">
$list:List.map article_to_xhtml p.articles$
</section>
</body>
</html>
>>
(* Helper function to generate SVG tag *)
let svg fname =
<:html<
<object class="centered" data=$str:fname$ type="image/svg+xml"> </object>
>>
(* Helper function to href to github *)
let github ml f =
let url = sprintf "http://github.com/avsm/mirage/tree/master/%s" ml in
<:html<
<a href=$str:url$><tt>$str:f$</tt></a>
>>