[OCaml] Mobile-friendly clone of cgit.
refactor make pages declarative over a generic Ui module
Page modules assembled markup by hand, so the same list, badge, and disclosure shapes were rebuilt in each of them and CSS contracts could drift between pages. Introduce lib/views/ui.ml as the only module that names HTML elements. It is deliberately app-agnostic — no Git, repository, or route knowledge, every function taking plain strings — so it reads as a general library of site building blocks: links, lists, badges, disclosures, trees, breadcrumbs, navigation, toolbars, pagination, line-numbered code listings, a diff viewer, and document scaffolding. The class names it emits are documented as its contract with styles.css. Components becomes ogit's vocabulary over Ui and owns every URL, so pages never write one by hand. Layout, Root, Repo and Error are now descriptions: they name the parts a page is made of and hand them to Layout. None of the four contains an HTML reference. Logic that was interleaved with markup moves out: language detection to Syntax, Git date formatting to Time_fmt. Routes.link_to is removed, so Routes no longer depends on dream-html. The line-numbered listing was implemented three times (blob, summary README, files README) and is now one Ui.code_listing. Rendered output is unchanged: all 17 captured page types — root, project dirs, summary, commits with each filter and pagination state, files, tree, blob, commit detail, branches, tags, README, 400 and 404 — are byte-identical to the pre-refactor baseline. dune build, fmt and the 62 tests pass.
Changed files
README.org
@@ -29,12 +29,7 @@
29
29
default-branch policy so operations in one request reuse the same
30
30
store.
31
31
4. =Views= renders data supplied by handlers. Views do not access the
32
Removed:
filesystem or load configuration. =Views.Components= holds the
33
Removed:
markup fragments shared between pages — the navigation bars, the
34
Removed:
disclosure chevron, and the collapsible directory row used by both
35
Removed:
the repository file tree and the project directory listing — so that
36
Removed:
a single definition backs each CSS contract. =Views.Layout= composes
37
Removed:
those fragments into the page shell.
32
Added:
filesystem or load configuration.
38
33
5. =Static_handler= serves assets embedded at build time by
39
34
=ocaml-crunch=.
40
35
@@ -42,6 +37,27 @@
42
37
malformed input becomes =400 Bad Request=, missing repositories or Git
43
38
objects become =404 Not Found=, and storage or filesystem failures
44
39
become =500 Internal Server Error=.
40
Added:
41
Added:
** View layer
42
Added:
43
Added:
The view layer is split into three levels so that page code stays
44
Added:
declarative:
45
Added:
46
Added:
1. =Ui= is the only module that names HTML elements. It is generic: it
47
Added:
knows nothing about Git or ogit's routes, and every function takes
48
Added:
plain strings and already-built nodes. It supplies links, lists,
49
Added:
disclosures, breadcrumbs, toolbars, pagination, line-numbered code
50
Added:
listings, a diff viewer, and document scaffolding. The class names it
51
Added:
emits are its contract with =styles.css=.
52
Added:
2. =Components= names ogit's page parts — navigation bars, repository
53
Added:
rows, tree rows, commit-type badges — and wires them to =Routes=, so
54
Added:
URLs are never written by hand. =Layout= composes the page shell.
55
Added:
3. =Root= and =Repo= describe pages: they say which parts a page is made
56
Added:
of and hand them to =Layout=. Neither contains markup.
57
Added:
58
Added:
Supporting logic lives beside them rather than inside the page
59
Added:
descriptions: =Syntax= guesses a blob's language for highlighting, and
60
Added:
=Time_fmt= formats Git dates. =Charts= generates standalone SVG.
45
61
46
62
47
63
* Configuration
lib/routes.ml
@@ -32,11 +32,6 @@
32
32
| Readme repo -> "/" ^ repo ^ "/README"
33
33
| Raw_file (repo, hash) -> "/" ^ repo ^ "/raw/" ^ hash
34
34
35
Removed:
let link_to route ?(other_attrs = []) contents =
36
Removed:
let open Dream_html in
37
Removed:
let open HTML in
38
Removed:
a (href "%s" (path_of route) :: other_attrs) [ contents ]
39
Removed:
40
35
(** Dispatch a request path (without leading slash) into a route. Returns
41
36
[(repo_name, action, param)] where action identifies what to do. *)
42
37
type action =
lib/views/components.ml
@@ -1,88 +1,83 @@
1
1
(* -*- mode: tuareg; -*- *)
2
2
3
Removed:
(** Reusable HTML building blocks shared across views.
3
Added:
(** Ogit's vocabulary of page parts.
4
4
5
Removed:
This module holds presentation fragments that appear on more than one page
6
Removed:
so their markup — and therefore their CSS contract — stays identical
7
Removed:
everywhere. Nothing here performs I/O or touches repository state. *)
5
Added:
Where {!Ui} supplies generic building blocks, this module names the parts
6
Added:
specific to a Git browser and wires them to {!Routes}, so page modules can
7
Added:
describe a page without mentioning HTML or URL strings.
8
8
9
Removed:
open Dream_html
9
Added:
Every function returns a {!Ui.node}. Nothing here performs I/O. *)
10
10
11
11
(** {1 Page identity} *)
12
12
13
Removed:
type page = Summary | Commits | Files | Branches | Tags | Readme
13
Added:
type page =
14
Added:
| Summary
15
Added:
| Commits
16
Added:
| Files
17
Added:
| Branches
18
Added:
| Tags
19
Added:
| Readme
20
Added:
(** Which repository page is being shown. Drives the [aria-current] marker
21
Added:
in the navigation. *)
22
Added:
14
23
type site = { user_name : string; root_title : string; nav_logo : string }
24
Added:
(** Site-wide presentation settings, resolved once from configuration. *)
15
25
16
26
let site ~user_name ~root_title ~nav_logo = { user_name; root_title; nav_logo }
17
27
18
Removed:
let page_to_nav_item repo = function
19
Removed:
| Summary -> (Routes.Repo repo, "Summary", Summary)
20
Removed:
| Commits -> (Routes.Commits repo, "Commits", Commits)
21
Removed:
| Files -> (Routes.Files repo, "Files", Files)
22
Removed:
| Branches -> (Routes.Branches repo, "Branches", Branches)
23
Removed:
| Tags -> (Routes.Tags repo, "Tags", Tags)
24
Removed:
| Readme -> (Routes.Readme repo, "README", Readme)
28
Added:
(** {1 Routes as links} *)
25
29
26
Removed:
(** {1 Disclosure widgets} *)
30
Added:
let url route = Routes.path_of route
27
31
28
Removed:
(** Decorative disclosure indicator. Rotated by CSS when the enclosing [details]
29
Removed:
is open, so it carries no textual meaning and is hidden from assistive
30
Removed:
technology. *)
31
Removed:
let chevron () =
32
Removed:
HTML.(span [ class_ "tree-chevron"; Aria.hidden true ] [ txt "\xe2\x80\xba" ])
32
Added:
(** A link to a route, with the route standing in for a hand-written URL. *)
33
Added:
let route_link ?class_ ?label route text =
34
Added:
Ui.text_link ?class_ ?label ~href:(url route) text
33
35
34
Removed:
(** A collapsible directory row.
36
Added:
(** The commit list is narrowed through query parameters, which {!Routes} does
37
Added:
not model because it covers path-shaped routes only. Passing the filters
38
Added:
already in effect keeps them applied as the reader pages or switches
39
Added:
filters. *)
40
Added:
let commits_url ?filter_type ?author ?committer ?(page = 1) repo =
41
Added:
let params =
42
Added:
(if page > 1 then [ ("page", string_of_int page) ] else [])
43
Added:
@ (match filter_type with Some value -> [ ("type", value) ] | None -> [])
44
Added:
@ (match author with Some value -> [ ("author", value) ] | None -> [])
45
Added:
@ match committer with Some value -> [ ("committer", value) ] | None -> []
46
Added:
in
47
Added:
let base = Printf.sprintf "/%s/commits/" repo in
48
Added:
match params with
49
Added:
| [] -> base
50
Added:
| _ -> base ^ "?" ^ Dream.to_form_urlencoded params
35
51
36
Removed:
Renders [li.tree-dir > details > summary.tree-toggle] where the summary
37
Removed:
holds the chevron plus an anchor to [route]. Clicking the summary padding or
38
Removed:
chevron toggles the nested list; clicking the anchor navigates. Both the
39
Removed:
repository file tree and the project directory listing use this so their
40
Removed:
interaction model is identical.
52
Added:
(** Where a repository's clone URL lives. *)
53
Added:
let clone_url repo = Printf.sprintf "/%s" repo
41
54
42
Removed:
@param extra_class appended to the [li] class list (e.g. [" tree-hidden"]).
43
Removed:
@param expanded renders the [details] initially open.
44
Removed:
@param label
45
Removed:
anchor text, conventionally the directory name with a trailing slash.
46
Removed:
@param children [li] nodes for the nested list. *)
47
Removed:
let tree_dir ?(extra_class = "") ?(expanded = false) ~route ~label children =
48
Removed:
let details_attrs = if expanded then HTML.[ open_ ] else [] in
49
Removed:
(* Bound outside the [HTML] scope below, where [label] would otherwise
50
Removed:
resolve to [HTML.label]. *)
51
Removed:
let label_text = label in
52
Removed:
HTML.(
53
Removed:
li
54
Removed:
[ class_ "tree-dir%s" extra_class ]
55
Removed:
[
56
Removed:
details details_attrs
57
Removed:
[
58
Removed:
summary
59
Removed:
[ class_ "tree-toggle" ]
60
Removed:
[
61
Removed:
chevron ();
62
Removed:
Routes.link_to route
63
Removed:
~other_attrs:[ class_ "tree-link" ]
64
Removed:
(txt "%s" label_text);
65
Removed:
];
66
Removed:
ul [ class_ "tree-nested" ] children;
67
Removed:
];
68
Removed:
])
55
Added:
(** {1 Navigation} *)
69
56
70
Removed:
(** A collapsible page section headed by [h1], used for the repository-list
71
Removed:
groupings on the root page. *)
72
Removed:
let section_disclosure ?(expanded = false) ~title:section_title children =
73
Removed:
let details_attrs = if expanded then HTML.[ open_ ] else [] in
74
Removed:
HTML.(
75
Removed:
details details_attrs
76
Removed:
(summary
77
Removed:
[ class_ "section-toggle" ]
78
Removed:
[ chevron (); h1 [] [ txt "%s" section_title ] ]
79
Removed:
:: children))
57
Added:
let page_route repo = function
58
Added:
| Summary -> Routes.Repo repo
59
Added:
| Commits -> Routes.Commits repo
60
Added:
| Files -> Routes.Files repo
61
Added:
| Branches -> Routes.Branches repo
62
Added:
| Tags -> Routes.Tags repo
63
Added:
| Readme -> Routes.Readme repo
80
64
81
Removed:
(** {1 Navigation} *)
65
Added:
let page_name = function
66
Added:
| Summary -> "Summary"
67
Added:
| Commits -> "Commits"
68
Added:
| Files -> "Files"
69
Added:
| Branches -> "Branches"
70
Added:
| Tags -> "Tags"
71
Added:
| Readme -> "README"
82
72
83
Removed:
(** Static assets may be configured as bare paths; make them root-relative
84
Removed:
unless they are already absolute or a data URI. *)
85
Removed:
let normalize_asset_url source =
73
Added:
let page_link repo ~active page =
74
Added:
Ui.nav_link ~current:(page = active)
75
Added:
~href:(url (page_route repo page))
76
Added:
(page_name page)
77
Added:
78
Added:
(** Configured logos may be given as bare paths; make those root-relative while
79
Added:
leaving absolute and data URLs alone. *)
80
Added:
let asset_url source =
86
81
if
87
82
String.starts_with ~prefix:"/" source
88
83
|| String.starts_with ~prefix:"http://" source
@@ -91,109 +86,108 @@
91
86
then source
92
87
else "/" ^ source
93
88
94
Removed:
let nav_logo ~href:logo_href ~alt:alt_text logo =
95
Removed:
HTML.(
96
Removed:
a
97
Removed:
[ id "nav-logo"; href "%s" logo_href ]
98
Removed:
[
99
Removed:
img
100
Removed:
[
101
Removed:
src "%s" (normalize_asset_url logo);
102
Removed:
alt "%s" alt_text;
103
Removed:
class_ "site-logo";
104
Removed:
];
105
Removed:
])
89
Added:
let logo ~href ~alt source =
90
Added:
Ui.link ~id:"nav-logo" ~href
91
Added:
[ Ui.image ~class_:"site-logo" ~alt ~src:(asset_url source) () ]
106
92
107
Removed:
(** Breadcrumb trail for a nested repository path. Every segment but the last
108
Removed:
links to its project directory; the last links to the repository summary. *)
109
Removed:
let repo_breadcrumb repo =
93
Added:
(** The trail of a nested repository path. Intermediate segments link to their
94
Added:
project directory; the final segment links to the repository itself. *)
95
Added:
let repo_trail repo =
110
96
let segments =
111
97
String.split_on_char '/' repo |> List.filter (fun segment -> segment <> "")
112
98
in
113
Removed:
let last_index = List.length segments - 1 in
114
Removed:
let nodes =
115
Removed:
List.mapi
116
Removed:
(fun index segment ->
117
Removed:
let path = String.concat "/" (List_ext.take (index + 1) segments) in
118
Removed:
let repo_link =
119
Removed:
if index = last_index then
120
Removed:
Routes.link_to (Repo repo) (txt "%s" segment)
121
Removed:
else Routes.link_to (Project_dir path) (txt "%s" segment)
122
Removed:
in
123
Removed:
if index = 0 then repo_link
124
Removed:
else
125
Removed:
HTML.(
126
Removed:
null
127
Removed:
[
128
Removed:
span [ class_ "nav-home-sep"; Aria.hidden true ] [ txt "/" ];
129
Removed:
repo_link;
130
Removed:
]))
131
Removed:
segments
99
Added:
let last = List.length segments - 1 in
100
Added:
let crumb_of index segment =
101
Added:
let route =
102
Added:
if index = last then Routes.Repo repo
103
Added:
else
104
Added:
Routes.Project_dir
105
Added:
(String.concat "/" (List_ext.take (index + 1) segments))
106
Added:
in
107
Added:
Ui.crumb ~href:(url route) segment
132
108
in
133
Removed:
HTML.(span [ id "nav-home"; class_ "repo-hierarchy" ] nodes)
109
Added:
Ui.breadcrumb ~id:"nav-home" ~class_:"repo-hierarchy"
110
Added:
~separator_class:"nav-home-sep" ~separator_decorative:true ~separator:"/"
111
Added:
(List.mapi crumb_of segments)
134
112
135
Removed:
(** Top navigation for pages that are not scoped to a repository. *)
136
Removed:
let rootnav ~title:nav_title ~nav_logo:logo ?home_href () =
113
Added:
(** Top navigation away from any repository: the repository list and project
114
Added:
directory pages. When [home_href] is absent the page {i is} the list, so the
115
Added:
logo points outward instead of back to itself. *)
116
Added:
let site_nav ~title ~logo:source ?home_href () =
137
117
let logo_href, logo_alt =
138
118
match home_href with
139
119
| None -> ("https://git-scm.com", "Git website")
140
120
| Some _ -> ("/", "Repository list")
141
121
in
142
Removed:
let home_href = Option.value home_href ~default:"/" in
143
Removed:
HTML.(
144
Removed:
nav
145
Removed:
[ id "top"; Aria.label "Site navigation" ]
146
Removed:
[
147
Removed:
nav_logo ~href:logo_href ~alt:logo_alt logo;
148
Removed:
a [ id "nav-home"; href "%s" home_href ] [ txt "%s" nav_title ];
149
Removed:
])
122
Added:
Ui.navigation ~id:"top" ~label:"Site navigation"
123
Added:
[
124
Added:
logo ~href:logo_href ~alt:logo_alt source;
125
Added:
Ui.text_link ~id:"nav-home"
126
Added:
~href:(Option.value home_href ~default:"/")
127
Added:
title;
128
Added:
]
150
129
151
Removed:
(** Top navigation for repository-scoped pages. *)
152
Removed:
let topnav ?(active = Summary) ~nav_logo:logo repo =
153
Removed:
let nav_items =
154
Removed:
List.map (page_to_nav_item repo)
155
Removed:
[ Summary; Commits; Files; Branches; Tags; Readme ]
156
Removed:
in
157
Removed:
let li_of_item (route, text, page) =
158
Removed:
let attrs = if page = active then [ Aria.current `page ] else [] in
159
Removed:
HTML.li attrs [ Routes.link_to route (txt "%s" text) ]
160
Removed:
in
161
Removed:
HTML.(
162
Removed:
nav
163
Removed:
[ id "top"; Aria.label "Repository navigation" ]
164
Removed:
[
165
Removed:
nav_logo ~href:"/" ~alt:"Repository list" logo;
166
Removed:
repo_breadcrumb repo;
167
Removed:
input [ type_ "checkbox"; id "nav-toggle"; class_ "nav-toggle" ];
168
Removed:
label
169
Removed:
[ for_ "nav-toggle"; class_ "nav-hamburger"; Aria.label "Menu" ]
170
Removed:
[ txt "\xe2\x8b\xae" ];
171
Removed:
ul [ id "nav-links" ] (List.map li_of_item nav_items);
172
Removed:
])
130
Added:
(** Top navigation within a repository. The link list collapses behind a
131
Added:
CSS-only control on narrow viewports. *)
132
Added:
let repo_nav ~active ~logo:source repo =
133
Added:
Ui.navigation ~id:"top" ~label:"Repository navigation"
134
Added:
[
135
Added:
logo ~href:"/" ~alt:"Repository list" source;
136
Added:
repo_trail repo;
137
Added:
Ui.css_toggle ~id:"nav-toggle" ~toggle_class:"nav-toggle"
138
Added:
~control_class:"nav-hamburger" ~label:"Menu" ~glyph:"\xe2\x8b\xae" ();
139
Added:
Ui.nav_links ~id:"nav-links"
140
Added:
(List.map (page_link repo ~active)
141
Added:
[ Summary; Commits; Files; Branches; Tags; Readme ]);
142
Added:
]
173
143
174
Removed:
(** Fixed bottom navigation, revealed by CSS on narrow viewports only. *)
175
Removed:
let bottomnav ?(active = Summary) repo =
176
Removed:
let items = [ Summary; Commits; Files; Readme ] in
177
Removed:
let li_of_item page =
178
Removed:
let route, nav_label, _ = page_to_nav_item repo page in
179
Removed:
let attrs =
180
Removed:
[ HTML.class_ "bottom-nav-item" ]
181
Removed:
@ if page = active then [ Aria.current `page ] else []
182
Removed:
in
183
Removed:
HTML.(li attrs [ Routes.link_to route (txt "%s" nav_label) ])
184
Removed:
in
185
Removed:
HTML.(
186
Removed:
nav
187
Removed:
[ id "bottom-nav"; Aria.label "Mobile navigation" ]
188
Removed:
[ ul [ id "bottom-nav-links" ] (List.map li_of_item items) ])
144
Added:
(** Condensed navigation pinned to the bottom of the viewport, revealed by CSS
145
Added:
on narrow screens where the top link list is hidden. *)
146
Added:
let mobile_nav ~active repo =
147
Added:
Ui.navigation ~id:"bottom-nav" ~label:"Mobile navigation"
148
Added:
[
149
Added:
Ui.nav_links ~id:"bottom-nav-links" ~item_class:"bottom-nav-item"
150
Added:
(List.map (page_link repo ~active) [ Summary; Commits; Files; Readme ]);
151
Added:
]
189
152
190
Removed:
(** Sticky secondary bar below the top nav. Collapses to nothing when empty so
191
Removed:
the [body.has-toolbar] sticky offsets stay consistent. *)
192
Removed:
let repo_toolbar children =
193
Removed:
match children with
194
Removed:
| [] -> HTML.null []
195
Removed:
| _ ->
196
Removed:
HTML.(
197
Removed:
div
198
Removed:
[ id "toolbar"; role `toolbar; Aria.label "Repository toolbar" ]
199
Removed:
children)
153
Added:
(** {1 Toolbar} *)
154
Added:
155
Added:
let toolbar children =
156
Added:
Ui.toolbar ~id:"toolbar" ~label:"Repository toolbar" children
157
Added:
158
Added:
(** {1 Trees} *)
159
Added:
160
Added:
(** A directory row that both expands in place and links to its own page. *)
161
Added:
let directory ?modifier ~route ~name children =
162
Added:
Ui.tree_branch ?modifier ~href:(url route) (name ^ "/") children
163
Added:
164
Added:
let file_entry ?modifier ~route name =
165
Added:
Ui.tree_leaf ?modifier ~href:(url route) name
166
Added:
167
Added:
let truncated ~route count =
168
Added:
Ui.tree_more ~href:(url route)
169
Added:
(Printf.sprintf "%d more items\xe2\x80\xa6" count)
170
Added:
171
Added:
(** {1 Sections} *)
172
Added:
173
Added:
(** A collapsible group of repositories on the root page. *)
174
Added:
let group ?expanded ~title children =
175
Added:
Ui.disclosure ?expanded ~summary_class:"section-toggle"
176
Added:
~summary:[ Ui.chevron (); Ui.heading [ Ui.text title ] ]
177
Added:
children
178
Added:
179
Added:
(** {1 Inline pieces} *)
180
Added:
181
Added:
(** A conventional-commit type, coloured per type and linking to the filtered
182
Added:
commit list. *)
183
Added:
let commit_type_badge ?href commit_type =
184
Added:
Ui.badge ~base_class:"commit-pill" ~variant:commit_type ?href commit_type
185
Added:
186
Added:
(** A README rendered below a listing. Level 3 because it sits under the page
187
Added:
heading and the listing it accompanies. *)
188
Added:
let inline_readme content =
189
Added:
Ui.region ~class_:"readme-inline"
190
Added:
[
191
Added:
Ui.heading ~level:3 [ Ui.text "README" ];
192
Added:
Ui.code_listing ~class_:"blob" ~anchor_prefix:"readme-" content;
193
Added:
]
lib/views/error.ml
@@ -1,7 +1,11 @@
1
1
(* -*- mode: tuareg; -*- *)
2
2
3
Removed:
open Dream_html
3
Added:
(** Error pages.
4
4
5
Added:
These are deliberately self-contained rather than going through {!Layout}:
6
Added:
an error may be raised before a repository context exists, so the page can
7
Added:
depend on nothing but the status and message. *)
8
Added:
5
9
let hint_of_status status =
6
10
match Dream.status_to_int status with
7
11
| 400 ->
@@ -21,39 +25,26 @@
21
25
22
26
let render ?(title = "Request failed") ?(status = `Internal_Server_Error)
23
27
message =
24
Removed:
let page_title = title in
25
28
let status_code = Dream.status_to_int status |> string_of_int in
26
Removed:
let hint = hint_of_status status in
27
Removed:
let open HTML in
28
Removed:
respond ~status
29
Removed:
@@ html
30
Removed:
[ lang "en" ]
31
Removed:
[
32
Removed:
head []
33
Removed:
[
34
Removed:
HTML.title [] "%s" page_title;
35
Removed:
meta
36
Removed:
[
37
Removed:
name "viewport"; content "width=device-width, initial-scale=1";
38
Removed:
];
39
Removed:
link [ rel "stylesheet"; href "/static/styles.css" ];
40
Removed:
];
41
Removed:
body []
42
Removed:
[
43
Removed:
header
44
Removed:
[ id "error-header" ]
45
Removed:
[
46
Removed:
span [ class_ "error-code" ] [ txt "%s" status_code ];
47
Removed:
h1 [] [ txt "%s" page_title ];
48
Removed:
];
49
Removed:
HTML.main
50
Removed:
[ id "main" ]
51
Removed:
[
52
Removed:
p [ class_ "error-hint" ] [ txt "%s" hint ];
53
Removed:
p [ class_ "error-detail" ] [ txt "%s" message ];
54
Removed:
p
55
Removed:
[ class_ "error-nav" ]
56
Removed:
[ a [ href "/" ] [ txt "Return to the repository list" ] ];
57
Removed:
];
58
Removed:
];
59
Removed:
]
29
Added:
Ui.respond ~status
30
Added:
@@ Ui.document
31
Added:
~head:
32
Added:
(Ui.document_head ~title
33
Added:
[ Ui.meta_viewport; Ui.stylesheet "/static/styles.css" ])
34
Added:
~body:
35
Added:
(Ui.document_body
36
Added:
[
37
Added:
Ui.page_header ~id:"error-header"
38
Added:
[
39
Added:
Ui.inline_text ~class_:"error-code" status_code;
40
Added:
Ui.heading [ Ui.text title ];
41
Added:
];
42
Added:
Ui.page_main ~id:"main"
43
Added:
[
44
Added:
Ui.paragraph_text ~class_:"error-hint" (hint_of_status status);
45
Added:
Ui.paragraph_text ~class_:"error-detail" message;
46
Added:
Ui.paragraph ~class_:"error-nav"
47
Added:
[ Ui.text_link ~href:"/" "Return to the repository list" ];
48
Added:
];
49
Added:
])
50
Added:
()
lib/views/layout.ml
@@ -1,11 +1,16 @@
1
1
(* -*- mode: tuareg; -*- *)
2
2
3
Removed:
open Dream_html
3
Added:
(** The page shell: everything that surrounds a page's own content.
4
4
5
Removed:
(* Page identity and site configuration live in [Components] so the navigation
6
Removed:
fragments can be built without depending on this module. They are re-exported
7
Removed:
here because callers address them as [Layout.Summary], [Layout.site], etc. *)
5
Added:
Pages hand this module a {!body_data} description and receive a complete
6
Added:
document. The shell decides which navigation applies, whether a toolbar is
7
Added:
present, and what goes in the head — pages never assemble those themselves.
8
Added:
*)
8
9
10
Added:
(* Page identity and site settings are defined in [Components] so navigation can
11
Added:
be built without depending on this module. They are re-exported here because
12
Added:
callers name them [Layout.Summary], [Layout.site], and so on. *)
13
Added:
9
14
type page = Components.page =
10
15
| Summary
11
16
| Commits
@@ -23,110 +28,101 @@
23
28
let site = Components.site
24
29
25
30
type body_data = {
26
Removed:
title : string;
27
Removed:
repo : string option;
31
Added:
title : string; (** heading for pages that show one *)
32
Added:
repo : string option; (** [None] on the repository list and project dirs *)
28
33
subtitle : string;
29
34
active : page;
30
Removed:
toolbar : node list;
31
Removed:
content : node list;
32
Removed:
home_href : string option;
35
Added:
toolbar : Ui.node list;
36
Added:
content : Ui.node list;
37
Added:
home_href : string option; (** where the site nav's home link points *)
33
38
}
34
39
35
Removed:
let page_header ~has_repo page_title subtitle =
36
Removed:
let subtitle =
37
Removed:
if String.starts_with ~prefix:"Unnamed repository" subtitle then ""
38
Removed:
else subtitle
39
Removed:
in
40
Removed:
if has_repo then
41
Removed:
if subtitle = "" then HTML.null []
42
Removed:
else HTML.(header [ id "page-header" ] [ p [] [ txt "%s" subtitle ] ])
43
Removed:
else
44
Removed:
HTML.(
45
Removed:
header
46
Removed:
[ id "page-header" ]
40
Added:
let stylesheets =
41
Added:
[
42
Added:
"/static/styles.css";
43
Added:
"https://cdnjs.cloudflare.com/ajax/libs/highlight.js/11.11.1/styles/github-dark.min.css";
44
Added:
]
45
Added:
46
Added:
let highlight_js =
47
Added:
"https://cdnjs.cloudflare.com/ajax/libs/highlight.js/11.11.1/highlight.min.js"
48
Added:
49
Added:
(* Colours the blob listing after load. The listing is complete and readable
50
Added:
without it. *)
51
Added:
let highlight_blob =
52
Added:
{|document.addEventListener("DOMContentLoaded",function(){var b=document.getElementById("blob");if(!b||typeof hljs==="undefined")return;var cls=b.className.match(/language-([\w-]+)/);if(!cls)return;var lang=cls[1];b.querySelectorAll("span.line").forEach(function(el){var r=hljs.highlight(el.textContent,{language:lang,ignoreIllegals:true});el.innerHTML=r.value})});|}
53
Added:
54
Added:
let head page_title =
55
Added:
Ui.document_head ~title:page_title
56
Added:
((Ui.meta_viewport :: List.map Ui.stylesheet stylesheets)
57
Added:
@ [ Ui.icon "/static/git_icon.svg"; Ui.deferred_script highlight_js ])
58
Added:
59
Added:
(* A freshly initialised repository carries git's placeholder description; treat
60
Added:
it as no description at all rather than showing boilerplate. *)
61
Added:
let meaningful_subtitle subtitle =
62
Added:
if String.starts_with ~prefix:"Unnamed repository" subtitle then ""
63
Added:
else subtitle
64
Added:
65
Added:
(** Inside a repository only the description is shown, since the navigation
66
Added:
already names the repository. Elsewhere the site identifies itself. *)
67
Added:
let header ~has_repo page_title subtitle =
68
Added:
match (has_repo, meaningful_subtitle subtitle) with
69
Added:
| true, "" -> Ui.nothing
70
Added:
| true, subtitle ->
71
Added:
Ui.page_header ~id:"page-header" [ Ui.paragraph_text subtitle ]
72
Added:
| false, subtitle ->
73
Added:
Ui.page_header ~id:"page-header"
47
74
([
48
Removed:
img
49
Removed:
[
50
Removed:
src "/static/git_icon.svg";
51
Removed:
alt "";
52
Removed:
role `presentation;
53
Removed:
class_ "site-logo";
54
Removed:
];
55
Removed:
h1 [] [ txt "%s" page_title ];
75
Added:
Ui.image ~class_:"site-logo" ~src:"/static/git_icon.svg" ();
76
Added:
Ui.heading [ Ui.text page_title ];
56
77
]
57
78
@
58
79
if subtitle = "" then []
59
Removed:
else [ p [ class_ "subtitle" ] [ txt "%s" subtitle ] ]))
80
Added:
else [ Ui.paragraph_text ~class_:"subtitle" subtitle ])
60
81
61
Removed:
let page_footer user_name =
82
Added:
let footer user_name =
62
83
let now = Unix.(time () |> localtime) in
63
84
let year = string_of_int (now.tm_year + 1900) in
64
Removed:
HTML.(
65
Removed:
footer []
66
Removed:
[
67
Removed:
(if user_name = "" then txt "Copyright %s" year
68
Removed:
else txt "Copyright %s %s" year user_name);
69
Removed:
txt " — ";
70
Removed:
a [ href "https://validator.w3.org/check/referer" ] [ txt "Validate" ];
71
Removed:
])
72
Removed:
73
Removed:
let head page_title =
74
Removed:
let open HTML in
75
Removed:
head []
85
Added:
Ui.page_footer
76
86
[
77
Removed:
title [] "%s" page_title;
78
Removed:
meta [ name "viewport"; content "width=device-width, initial-scale=1" ];
79
Removed:
link [ rel "stylesheet"; href "/static/styles.css" ];
80
Removed:
link
81
Removed:
[
82
Removed:
rel "stylesheet";
83
Removed:
href
84
Removed:
"https://cdnjs.cloudflare.com/ajax/libs/highlight.js/11.11.1/styles/github-dark.min.css";
85
Removed:
];
86
Removed:
link [ rel "icon"; type_ "image/x-icon"; href "/static/git_icon.svg" ];
87
Removed:
script
88
Removed:
[
89
Removed:
src
90
Removed:
"https://cdnjs.cloudflare.com/ajax/libs/highlight.js/11.11.1/highlight.min.js";
91
Removed:
defer;
92
Removed:
]
93
Removed:
"";
87
Added:
Ui.text
88
Added:
(if user_name = "" then Printf.sprintf "Copyright %s" year
89
Added:
else Printf.sprintf "Copyright %s %s" year user_name);
90
Added:
Ui.text " — ";
91
Added:
Ui.text_link ~href:"https://validator.w3.org/check/referer" "Validate";
94
92
]
95
93
96
94
let body site page_data =
97
Removed:
let open HTML in
98
Removed:
let body_attrs =
95
Added:
(* The sticky toolbar shifts everything below it; the class lets CSS offset
96
Added:
sticky descendants by the right amount. *)
97
Added:
let body_class =
99
98
match (page_data.repo, page_data.toolbar) with
100
Removed:
| Some _, _ :: _ -> [ class_ "has-toolbar" ]
101
Removed:
| _ -> []
99
Added:
| Some _, _ :: _ -> Some "has-toolbar"
100
Added:
| _ -> None
102
101
in
103
Removed:
body body_attrs
102
Added:
let navigation, toolbar, header_node, mobile =
103
Added:
match page_data.repo with
104
Added:
| None ->
105
Added:
( Components.site_nav ~title:site.root_title ~logo:site.nav_logo
106
Added:
?home_href:page_data.home_href (),
107
Added:
Ui.nothing,
108
Added:
Ui.nothing,
109
Added:
Ui.nothing )
110
Added:
| Some repo ->
111
Added:
( Components.repo_nav ~active:page_data.active ~logo:site.nav_logo repo,
112
Added:
Components.toolbar page_data.toolbar,
113
Added:
header ~has_repo:true page_data.title page_data.subtitle,
114
Added:
Components.mobile_nav ~active:page_data.active repo )
115
Added:
in
116
Added:
Ui.document_body ?class_:body_class
104
117
[
105
Removed:
a [ href "#main"; class_ "skip-link" ] [ txt "Skip to content" ];
106
Removed:
(match page_data.repo with
107
Removed:
| None ->
108
Removed:
Components.rootnav ~title:site.root_title ~nav_logo:site.nav_logo
109
Removed:
?home_href:page_data.home_href ()
110
Removed:
| Some repo ->
111
Removed:
Components.topnav ~active:page_data.active ~nav_logo:site.nav_logo
112
Removed:
repo);
113
Removed:
(match page_data.repo with
114
Removed:
| None -> HTML.null []
115
Removed:
| Some _ -> Components.repo_toolbar page_data.toolbar);
116
Removed:
HTML.main
117
Removed:
[ id "main" ]
118
Removed:
((match page_data.repo with
119
Removed:
| None -> HTML.null []
120
Removed:
| Some _ ->
121
Removed:
page_header ~has_repo:true page_data.title page_data.subtitle)
122
Removed:
:: page_data.content);
123
Removed:
(match page_data.repo with
124
Removed:
| None -> HTML.null []
125
Removed:
| Some repo -> Components.bottomnav ~active:page_data.active repo);
126
Removed:
page_footer site.user_name;
127
Removed:
script []
128
Removed:
{|document.addEventListener("DOMContentLoaded",function(){var b=document.getElementById("blob");if(!b||typeof hljs==="undefined")return;var cls=b.className.match(/language-([\w-]+)/);if(!cls)return;var lang=cls[1];b.querySelectorAll("span.line").forEach(function(el){var r=hljs.highlight(el.textContent,{language:lang,ignoreIllegals:true});el.innerHTML=r.value})});|};
118
Added:
Ui.skip_link ~href:"#main" "Skip to content";
119
Added:
navigation;
120
Added:
toolbar;
121
Added:
Ui.page_main ~id:"main" (header_node :: page_data.content);
122
Added:
mobile;
123
Added:
footer site.user_name;
124
Added:
Ui.inline_script highlight_blob;
129
125
]
130
126
131
127
let render ?(page_title = "Ogit") site body_data =
132
Removed:
HTML.html [ HTML.lang "en" ] [ head page_title; body site body_data ]
128
Added:
Ui.document ~head:(head page_title) ~body:(body site body_data) ()
lib/views/repo.ml
@@ -1,898 +1,441 @@
1
1
(* -*- mode: tuareg; -*- *)
2
2
3
Removed:
open Dream_html
4
Removed:
5
Removed:
type context = { repo : string; description : string; site : Layout.site }
6
Removed:
type commit_message = { summary : string; body : string }
7
Removed:
8
Removed:
let context ~site ~repo ~description = { repo; description; site }
9
Removed:
10
Removed:
let language_of_filename name =
11
Removed:
match Filename.extension name |> String.lowercase_ascii with
12
Removed:
| ".ml" | ".mli" -> Some "ocaml"
13
Removed:
| ".c" | ".h" -> Some "c"
14
Removed:
| ".cpp" | ".cc" | ".cxx" | ".hpp" -> Some "cpp"
15
Removed:
| ".cs" -> Some "csharp"
16
Removed:
| ".css" -> Some "css"
17
Removed:
| ".diff" | ".patch" -> Some "diff"
18
Removed:
| ".el" | ".lisp" | ".cl" -> Some "lisp"
19
Removed:
| ".erl" -> Some "erlang"
20
Removed:
| ".ex" | ".exs" -> Some "elixir"
21
Removed:
| ".go" -> Some "go"
22
Removed:
| ".hs" -> Some "haskell"
23
Removed:
| ".html" | ".htm" -> Some "xml"
24
Removed:
| ".java" -> Some "java"
25
Removed:
| ".js" | ".mjs" | ".cjs" -> Some "javascript"
26
Removed:
| ".json" -> Some "json"
27
Removed:
| ".kt" -> Some "kotlin"
28
Removed:
| ".lua" -> Some "lua"
29
Removed:
| ".md" -> Some "markdown"
30
Removed:
| ".nix" -> Some "nix"
31
Removed:
| ".php" -> Some "php"
32
Removed:
| ".pl" | ".pm" | ".t" -> Some "perl"
33
Removed:
| ".py" -> Some "python"
34
Removed:
| ".r" -> Some "r"
35
Removed:
| ".rb" -> Some "ruby"
36
Removed:
| ".rs" -> Some "rust"
37
Removed:
| ".scala" -> Some "scala"
38
Removed:
| ".sh" | ".bash" | ".zsh" -> Some "bash"
39
Removed:
| ".sql" -> Some "sql"
40
Removed:
| ".swift" -> Some "swift"
41
Removed:
| ".toml" -> Some "ini"
42
Removed:
| ".ts" | ".tsx" -> Some "typescript"
43
Removed:
| ".xml" | ".svg" | ".xsl" -> Some "xml"
44
Removed:
| ".yaml" | ".yml" -> Some "yaml"
45
Removed:
| ".zig" -> Some "zig"
46
Removed:
| _ -> None
47
Removed:
48
Removed:
let language_of_shebang line =
49
Removed:
if not (String.starts_with ~prefix:"#!" line) then None
50
Removed:
else
51
Removed:
(* Extract the last path component, ignoring env and arguments *)
52
Removed:
let rest = String.sub line 2 (String.length line - 2) in
53
Removed:
let parts = String.split_on_char ' ' (String.trim rest) in
54
Removed:
let interpreter =
55
Removed:
match parts with
56
Removed:
| [] -> ""
57
Removed:
| cmd :: args ->
58
Removed:
let base = Filename.basename cmd in
59
Removed:
if base = "env" then
60
Removed:
(* /usr/bin/env python3 — take next non-flag argument *)
61
Removed:
List.find_opt (fun s -> s <> "" && s.[0] <> '-') args
62
Removed:
|> Option.value ~default:"" |> Filename.basename
63
Removed:
else base
64
Removed:
in
65
Removed:
(* Strip version suffixes: python3.11 -> python, ruby3.2 -> ruby *)
66
Removed:
let strip_trailing_digits s =
67
Removed:
let len = String.length s in
68
Removed:
let rec find_end i =
69
Removed:
if i < 0 then s
70
Removed:
else if s.[i] >= '0' && s.[i] <= '9' then find_end (i - 1)
71
Removed:
else String.sub s 0 (i + 1)
72
Removed:
in
73
Removed:
find_end (len - 1)
74
Removed:
in
75
Removed:
let interpreter =
76
Removed:
match String.split_on_char '.' interpreter with
77
Removed:
| [] -> ""
78
Removed:
| base :: _ -> strip_trailing_digits base
79
Removed:
in
80
Removed:
match String.lowercase_ascii interpreter with
81
Removed:
| "sh" | "bash" | "dash" | "ash" | "zsh" -> Some "bash"
82
Removed:
| "python" -> Some "python"
83
Removed:
| "ruby" -> Some "ruby"
84
Removed:
| "perl" -> Some "perl"
85
Removed:
| "node" | "deno" | "bun" -> Some "javascript"
86
Removed:
| "lua" -> Some "lua"
87
Removed:
| "php" -> Some "php"
88
Removed:
| "elixir" -> Some "elixir"
89
Removed:
| "awk" | "gawk" | "mawk" -> Some "awk"
90
Removed:
| "ocaml" -> Some "ocaml"
91
Removed:
| _ -> None
92
Removed:
93
Removed:
let language_of_emacs_prop line =
94
Removed:
let find_between s prefix suffix =
95
Removed:
let plen = String.length prefix in
96
Removed:
let slen = String.length suffix in
97
Removed:
let total = String.length s in
98
Removed:
let rec find_start i =
99
Removed:
if i > total - plen then None
100
Removed:
else if String.sub s i plen = prefix then
101
Removed:
let after = i + plen in
102
Removed:
let rec find_end j =
103
Removed:
if j > total - slen then None
104
Removed:
else if String.sub s j slen = suffix then
105
Removed:
Some (String.sub s after (j - after) |> String.trim)
106
Removed:
else find_end (j + 1)
107
Removed:
in
108
Removed:
find_end after
109
Removed:
else find_start (i + 1)
110
Removed:
in
111
Removed:
find_start 0
112
Removed:
in
113
Removed:
let extract_mode between =
114
Removed:
let props = String.split_on_char ';' between in
115
Removed:
let mode_prop =
116
Removed:
List.find_map
117
Removed:
(fun prop ->
118
Removed:
match String.split_on_char ':' (String.trim prop) with
119
Removed:
| [ key; value ]
120
Removed:
when String.trim (String.lowercase_ascii key) = "mode" ->
121
Removed:
Some (String.trim value)
122
Removed:
| _ -> None)
123
Removed:
props
124
Removed:
in
125
Removed:
match mode_prop with
126
Removed:
| Some _ -> mode_prop
127
Removed:
| None ->
128
Removed:
if
129
Removed:
(not (String.contains between ':'))
130
Removed:
&& not (String.contains between ';')
131
Removed:
then Some (String.trim between)
132
Removed:
else None
133
Removed:
in
134
Removed:
let normalize_mode mode =
135
Removed:
match String.lowercase_ascii mode with
136
Removed:
| "tuareg" | "caml" | "ocaml" -> Some "ocaml"
137
Removed:
| "emacs-lisp" | "lisp" | "elisp" -> Some "lisp"
138
Removed:
| "shell-script" | "sh" | "bash" -> Some "bash"
139
Removed:
| "python" -> Some "python"
140
Removed:
| "ruby" -> Some "ruby"
141
Removed:
| "perl" | "cperl" -> Some "perl"
142
Removed:
| "c" -> Some "c"
143
Removed:
| "c++" -> Some "cpp"
144
Removed:
| "javascript" | "js" -> Some "javascript"
145
Removed:
| "typescript" -> Some "typescript"
146
Removed:
| "rust" -> Some "rust"
147
Removed:
| "go" -> Some "go"
148
Removed:
| "haskell" -> Some "haskell"
149
Removed:
| "lua" -> Some "lua"
150
Removed:
| "sql" -> Some "sql"
151
Removed:
| "yaml" -> Some "yaml"
152
Removed:
| "nix" -> Some "nix"
153
Removed:
| "makefile" -> Some "makefile"
154
Removed:
| m -> Some m
155
Removed:
in
156
Removed:
let ( >>= ) = Option.bind in
157
Removed:
find_between line "-*-" "-*-" >>= extract_mode >>= normalize_mode
158
Removed:
159
Removed:
let language_of_vim_modeline line =
160
Removed:
let contains_substring s sub =
161
Removed:
let slen = String.length s in
162
Removed:
let sublen = String.length sub in
163
Removed:
let rec check i =
164
Removed:
if i > slen - sublen then false
165
Removed:
else if String.sub s i sublen = sub then true
166
Removed:
else check (i + 1)
167
Removed:
in
168
Removed:
sublen <= slen && check 0
169
Removed:
in
170
Removed:
let l = String.lowercase_ascii line in
171
Removed:
let has_vim_prefix =
172
Removed:
contains_substring l "vim:"
173
Removed:
|| contains_substring l "vi:" || contains_substring l "ex:"
174
Removed:
in
175
Removed:
if not has_vim_prefix then None
176
Removed:
else
177
Removed:
let find_value prefix s =
178
Removed:
let plen = String.length prefix in
179
Removed:
let slen = String.length s in
180
Removed:
let rec find_at i =
181
Removed:
if i > slen - plen then None
182
Removed:
else if String.sub s i plen = prefix then
183
Removed:
let vstart = i + plen in
184
Removed:
let rec scan_end j =
185
Removed:
if j >= slen || s.[j] = ' ' || s.[j] = ':' || s.[j] = '\t' then j
186
Removed:
else scan_end (j + 1)
187
Removed:
in
188
Removed:
let vend = scan_end vstart in
189
Removed:
Some (String.sub s vstart (vend - vstart))
190
Removed:
else find_at (i + 1)
191
Removed:
in
192
Removed:
find_at 0
193
Removed:
in
194
Removed:
let ft =
195
Removed:
match find_value "ft=" l with
196
Removed:
| Some _ as r -> r
197
Removed:
| None -> find_value "filetype=" l
198
Removed:
in
199
Removed:
match ft with
200
Removed:
| None -> None
201
Removed:
| Some ft -> (
202
Removed:
match ft with
203
Removed:
| "sh" | "bash" | "zsh" -> Some "bash"
204
Removed:
| "python" -> Some "python"
205
Removed:
| "ruby" -> Some "ruby"
206
Removed:
| "perl" -> Some "perl"
207
Removed:
| "javascript" | "js" -> Some "javascript"
208
Removed:
| "typescript" -> Some "typescript"
209
Removed:
| "ocaml" -> Some "ocaml"
210
Removed:
| "c" -> Some "c"
211
Removed:
| "cpp" -> Some "cpp"
212
Removed:
| "rust" -> Some "rust"
213
Removed:
| "go" -> Some "go"
214
Removed:
| "haskell" -> Some "haskell"
215
Removed:
| "lua" -> Some "lua"
216
Removed:
| "make" | "makefile" -> Some "makefile"
217
Removed:
| "yaml" -> Some "yaml"
218
Removed:
| "sql" -> Some "sql"
219
Removed:
| "nix" -> Some "nix"
220
Removed:
| other -> Some other)
221
Removed:
222
Removed:
let language_of_content content =
223
Removed:
let lines = String.split_on_char '\n' content in
224
Removed:
let len = List.length lines in
225
Removed:
let first_lines =
226
Removed:
let n = min 5 len in
227
Removed:
List_ext.take n lines
228
Removed:
in
229
Removed:
let last_lines =
230
Removed:
let start = max 0 (len - 5) in
231
Removed:
List_ext.drop start lines
232
Removed:
in
233
Removed:
let try_lines detector lines = List.find_map detector lines in
234
Removed:
let ( <|> ) a b = match a with Some _ -> a | None -> b () in
235
Removed:
match first_lines with
236
Removed:
| [] -> None
237
Removed:
| first :: _ ->
238
Removed:
( ( language_of_shebang first <|> fun () ->
239
Removed:
try_lines language_of_emacs_prop first_lines )
240
Removed:
<|> fun () -> try_lines language_of_vim_modeline first_lines )
241
Removed:
<|> fun () -> try_lines language_of_vim_modeline last_lines
242
Removed:
243
Removed:
let page_title context = context.repo ^ " — " ^ context.description
244
Removed:
245
Removed:
let render_page ?heading ?toolbar context ~active content =
246
Removed:
respond
247
Removed:
@@ Layout.render context.site ~page_title:(page_title context)
248
Removed:
{
249
Removed:
repo = Some context.repo;
250
Removed:
title = Option.value heading ~default:context.repo;
251
Removed:
subtitle = context.description;
252
Removed:
active;
253
Removed:
toolbar = Option.value toolbar ~default:[];
254
Removed:
home_href = None;
255
Removed:
content;
256
Removed:
}
257
Removed:
258
Removed:
let li_of_branch repo (branch : Resolvers.Reference.t) =
259
Removed:
HTML.(
260
Removed:
li []
261
Removed:
[
262
Removed:
Routes.link_to
263
Removed:
(Commits_branch (repo, branch.name))
264
Removed:
(txt "%s" branch.name);
265
Removed:
])
266
Removed:
267
Removed:
let li_of_tag repo (tag : Resolvers.Reference.t) =
268
Removed:
HTML.(li [] [ Routes.link_to (Tags repo) (txt "%s" tag.name) ])
269
Removed:
270
Removed:
let parse_commit_message = function
271
Removed:
| None -> { summary = ""; body = "" }
272
Removed:
| Some message -> (
273
Removed:
match String.split_on_char '\n' message with
274
Removed:
| [] -> { summary = ""; body = "" }
275
Removed:
| summary :: rest ->
276
Removed:
{ summary; body = String.concat "\n" rest |> String.trim })
277
Removed:
278
Removed:
let conventional_commit_types =
279
Removed:
[
280
Removed:
"feat";
281
Removed:
"fix";
282
Removed:
"docs";
283
Removed:
"style";
284
Removed:
"refactor";
285
Removed:
"perf";
286
Removed:
"test";
287
Removed:
"build";
288
Removed:
"ci";
289
Removed:
"chore";
290
Removed:
"revert";
291
Removed:
]
292
Removed:
293
Removed:
let parse_conventional summary =
294
Removed:
match String.index_opt summary ':' with
295
Removed:
| None -> (None, summary)
296
Removed:
| Some colon_pos ->
297
Removed:
let prefix = String.sub summary 0 colon_pos in
298
Removed:
let type_name =
299
Removed:
match String.index_opt prefix '(' with
300
Removed:
| Some paren_pos -> String.sub prefix 0 paren_pos
301
Removed:
| None -> prefix
302
Removed:
in
303
Removed:
let type_lower = String.lowercase_ascii type_name in
304
Removed:
if List.mem type_lower conventional_commit_types then
305
Removed:
let rest =
306
Removed:
String.sub summary (colon_pos + 1)
307
Removed:
(String.length summary - colon_pos - 1)
308
Removed:
|> String.trim
309
Removed:
in
310
Removed:
(Some type_lower, rest)
311
Removed:
else (None, summary)
312
Removed:
313
Removed:
let timestamp (date, _) =
314
Removed:
let tm = date |> Int64.to_float |> Unix.localtime in
315
Removed:
Printf.sprintf "%04d-%02d-%02d %02d:%02d" (tm.tm_year + 1900) (tm.tm_mon + 1)
316
Removed:
tm.tm_mday tm.tm_hour tm.tm_min
317
Removed:
318
Removed:
let detailed_timestamp (date, timezone) =
319
Removed:
let offset_seconds, suffix =
320
Removed:
match timezone with
321
Removed:
| None -> (0, "Z")
322
Removed:
| Some (offset : Git.User.tz_offset) ->
323
Removed:
let direction = match offset.sign with `Plus -> 1 | `Minus -> -1 in
324
Removed:
let seconds = direction * ((offset.hours * 60) + offset.minutes) * 60 in
325
Removed:
let sign = match offset.sign with `Plus -> "+" | `Minus -> "-" in
326
Removed:
(seconds, Printf.sprintf "%s%02d:%02d" sign offset.hours offset.minutes)
327
Removed:
in
328
Removed:
let adjusted = Int64.add date (Int64.of_int offset_seconds) in
329
Removed:
let tm = adjusted |> Int64.to_float |> Unix.gmtime in
330
Removed:
let date =
331
Removed:
Printf.sprintf "%04d-%02d-%02d" (tm.tm_year + 1900) (tm.tm_mon + 1)
332
Removed:
tm.tm_mday
333
Removed:
in
334
Removed:
let clock = Printf.sprintf "%02d:%02d:%02d" tm.tm_hour tm.tm_min tm.tm_sec in
335
Removed:
( Printf.sprintf "%sT%s%s" date clock suffix,
336
Removed:
Printf.sprintf "%s %s %s" date clock suffix )
337
Removed:
338
Removed:
let time_node date =
339
Removed:
let machine_time, display_time = detailed_timestamp date in
340
Removed:
HTML.(time [ datetime "%s" machine_time ] [ txt "%s" display_time ])
341
Removed:
342
Removed:
let commits_url ?filter_type ?author ?committer ?(page = 1) repo =
343
Removed:
let params =
344
Removed:
(if page > 1 then [ ("page", string_of_int page) ] else [])
345
Removed:
@ (match filter_type with Some value -> [ ("type", value) ] | None -> [])
346
Removed:
@ (match author with Some value -> [ ("author", value) ] | None -> [])
347
Removed:
@ match committer with Some value -> [ ("committer", value) ] | None -> []
348
Removed:
in
349
Removed:
let base = Printf.sprintf "/%s/commits/" repo in
350
Removed:
match params with
351
Removed:
| [] -> base
352
Removed:
| _ -> base ^ "?" ^ Dream.to_form_urlencoded params
353
Removed:
354
Removed:
let identity_link ?filter_type ?author ?committer ?(show_email = false) ~role
355
Removed:
repo (user : Resolvers.Commit.user) =
356
Removed:
let url, role_label =
357
Removed:
match role with
358
Removed:
| `Author ->
359
Removed:
(commits_url ?filter_type ~author:user.email ?committer repo, "author")
360
Removed:
| `Committer ->
361
Removed:
( commits_url ?filter_type ?author ~committer:user.email repo,
362
Removed:
"committer" )
363
Removed:
in
364
Removed:
let link_text =
365
Removed:
if show_email then Printf.sprintf "%s <%s>" user.name user.email
366
Removed:
else user.name
367
Removed:
in
368
Removed:
HTML.(
369
Removed:
a
370
Removed:
[
371
Removed:
href "%s" url;
372
Removed:
class_ "commit-identity";
373
Removed:
Aria.label "Filter commits by %s %s" role_label user.name;
374
Removed:
]
375
Removed:
[ txt "%s" link_text ])
376
Removed:
377
Removed:
let li_of_commit ?filter_type ?author ?committer ?(hide_pill = false) repo
378
Removed:
(commit : Resolvers.Commit.t) =
379
Removed:
let message = parse_commit_message commit.message in
380
Removed:
let commit_type, commit_title = parse_conventional message.summary in
381
Removed:
let commit_route = Routes.Commit (repo, commit.hash) in
382
Removed:
let timestamp_span =
383
Removed:
HTML.(
384
Removed:
span [ class_ "timestamp" ] [ txt "%s" (timestamp commit.author.date) ])
385
Removed:
in
386
Removed:
let pill =
387
Removed:
match commit_type with
388
Removed:
| _ when hide_pill -> HTML.null []
389
Removed:
| None -> HTML.null []
390
Removed:
| Some ct ->
391
Removed:
HTML.(
392
Removed:
span
393
Removed:
[ class_ "commit-pill commit-pill-%s" ct ]
394
Removed:
[
395
Removed:
a
396
Removed:
[
397
Removed:
href "%s"
398
Removed:
(commits_url ~filter_type:ct ?author ?committer repo);
399
Removed:
]
400
Removed:
[ txt "%s" ct ];
401
Removed:
])
402
Removed:
in
403
Removed:
let title_span =
404
Removed:
HTML.(
405
Removed:
span
406
Removed:
[ class_ "commit-title" ]
407
Removed:
[ pill; Routes.link_to commit_route (txt "%s" commit_title) ])
408
Removed:
in
409
Removed:
let ago_span =
410
Removed:
HTML.(
411
Removed:
span
412
Removed:
[ class_ "commit-ago" ]
413
Removed:
[ txt "%s" (Time_fmt.relative_time commit.author.date) ])
414
Removed:
in
415
Removed:
let author_span =
416
Removed:
match author with
417
Removed:
| Some _ -> HTML.null []
418
Removed:
| None ->
419
Removed:
HTML.(
420
Removed:
span
421
Removed:
[ class_ "commit-author" ]
422
Removed:
[
423
Removed:
identity_link ?filter_type ?author ?committer ~role:`Author repo
424
Removed:
commit.author;
425
Removed:
])
426
Removed:
in
427
Removed:
HTML.(li [] [ timestamp_span; title_span; ago_span; author_span ])
428
Removed:
429
Removed:
let rec li_of_tree_node repo (pe : Resolvers.Tree.tree_node) =
430
Removed:
let entry = pe.entry in
431
Removed:
let route = Routes.File (repo, entry.hash) in
432
Removed:
let is_hidden = String.length entry.name > 0 && entry.name.[0] = '.' in
433
Removed:
let hidden_class = if is_hidden then " tree-hidden" else "" in
434
Removed:
match pe.children with
435
Removed:
| None ->
436
Removed:
(* Regular file *)
437
Removed:
HTML.(
438
Removed:
li
439
Removed:
[ class_ "tree-file%s" hidden_class ]
440
Removed:
[ Routes.link_to route (txt "%s" entry.name) ])
441
Removed:
| Some children ->
442
Removed:
let max_display = 16 in
443
Removed:
let total = List.length children in
444
Removed:
let displayed, overflow =
445
Removed:
if total <= max_display then (children, 0)
446
Removed:
else (List_ext.take max_display children, total - max_display)
447
Removed:
in
448
Removed:
let overflow_item =
449
Removed:
if overflow = 0 then []
450
Removed:
else
451
Removed:
HTML.
452
Removed:
[
453
Removed:
li
454
Removed:
[ class_ "tree-overflow" ]
455
Removed:
[
456
Removed:
Routes.link_to route
457
Removed:
(txt "%d more items\xe2\x80\xa6" overflow);
458
Removed:
];
459
Removed:
]
460
Removed:
in
461
Removed:
Components.tree_dir ~extra_class:hidden_class ~route
462
Removed:
~label:(entry.name ^ "/")
463
Removed:
(List.map (li_of_tree_node repo) displayed @ overflow_item)
464
Removed:
465
Removed:
let summary context ?readme frequency =
466
Removed:
let chart_section =
467
Removed:
HTML.
468
Removed:
[
469
Removed:
h3 [] [ txt "Commit activity (past 30 days)" ];
470
Removed:
div
471
Removed:
[ class_ "chart-container" ]
472
Removed:
[
473
Removed:
Charts.commit_frequency ~chart_width:600 ~chart_height:200 frequency;
474
Removed:
];
475
Removed:
p
476
Removed:
[ class_ "summary-more" ]
477
Removed:
[ Routes.link_to (Commits context.repo) (txt "View all commits") ];
478
Removed:
]
479
Removed:
in
480
Removed:
let readme_section =
481
Removed:
match readme with
482
Removed:
| None -> HTML.null []
483
Removed:
| Some (blob : Resolvers.Blob.t) ->
484
Removed:
let formatted =
485
Removed:
String.split_on_char '\n' blob.content
486
Removed:
|> List.mapi (fun number line ->
487
Removed:
let line_number = number + 1 in
488
Removed:
HTML.
489
Removed:
[
490
Removed:
a
491
Removed:
[
492
Removed:
id "readme-%d" line_number;
493
Removed:
class_ "line-anchor";
494
Removed:
href "#readme-%d" line_number;
495
Removed:
Aria.label "Line %d" line_number;
496
Removed:
]
497
Removed:
[ txt "%d" line_number ];
498
Removed:
span [ class_ "line" ] [ txt "\t%s\n" line ];
499
Removed:
])
500
Removed:
|> List.concat
501
Removed:
in
502
Removed:
HTML.(
503
Removed:
section
504
Removed:
[ class_ "readme-inline" ]
505
Removed:
[ h3 [] [ txt "README" ]; div [ class_ "blob" ] formatted ])
506
Removed:
in
507
Removed:
let clone_link =
508
Removed:
HTML.(
509
Removed:
a
510
Removed:
[
511
Removed:
href "/%s" context.repo;
512
Removed:
class_ "toolbar-button";
513
Removed:
Aria.label "Clone %s" context.repo;
514
Removed:
]
515
Removed:
[ txt "Clone repo" ])
516
Removed:
in
517
Removed:
render_page context ~active:Summary ~toolbar:[ clone_link ]
518
Removed:
HTML.
519
Removed:
[
520
Removed:
div
521
Removed:
[ class_ "summary-layout" ]
522
Removed:
[
523
Removed:
div [ class_ "summary-commits" ] chart_section;
524
Removed:
div [ class_ "summary-readme" ] [ readme_section ];
525
Removed:
];
526
Removed:
]
527
Removed:
528
Removed:
let commits ?filter_type ?author ?committer ~page ~has_prev ~has_next context
529
Removed:
commits =
530
Removed:
let hide_pill = Option.is_some filter_type in
531
Removed:
let filters =
532
Removed:
(match filter_type with
533
Removed:
| None -> []
534
Removed:
| Some commit_type ->
535
Removed:
[
536
Removed:
( "commit type",
537
Removed:
commit_type,
538
Removed:
commits_url ?author ?committer context.repo,
539
Removed:
"commit-pill commit-pill-" ^ commit_type );
540
Removed:
])
541
Removed:
@ (match author with
542
Removed:
| None -> []
543
Removed:
| Some email ->
544
Removed:
[
545
Removed:
( "author",
546
Removed:
"Author: " ^ email,
547
Removed:
commits_url ?filter_type ?committer context.repo,
548
Removed:
"toolbar-filter-value" );
549
Removed:
])
550
Removed:
@
551
Removed:
match committer with
552
Removed:
| None -> []
553
Removed:
| Some email ->
554
Removed:
[
555
Removed:
( "committer",
556
Removed:
"Committer: " ^ email,
557
Removed:
commits_url ?filter_type ?author context.repo,
558
Removed:
"toolbar-filter-value" );
559
Removed:
]
560
Removed:
in
561
Removed:
let page_url page =
562
Removed:
commits_url ?filter_type ?author ?committer ~page context.repo
563
Removed:
in
564
Removed:
let show_pagination = has_prev || has_next in
565
Removed:
let filters_toolbar =
566
Removed:
match filters with
567
Removed:
| [] -> None
568
Removed:
| _ ->
569
Removed:
let filter_el (filter_name, display, dismiss_href, value_class) =
570
Removed:
HTML.(
571
Removed:
span
572
Removed:
[ class_ "toolbar-filter" ]
573
Removed:
[
574
Removed:
span [ class_ "%s" value_class ] [ txt "%s" display ];
575
Removed:
a
576
Removed:
[
577
Removed:
href "%s" dismiss_href;
578
Removed:
class_ "toolbar-dismiss";
579
Removed:
Aria.label "Remove %s filter" filter_name;
580
Removed:
]
581
Removed:
[ txt "\xc3\x97" ];
582
Removed:
])
583
Removed:
in
584
Removed:
Some
585
Removed:
HTML.(div [ class_ "toolbar-filters" ] (List.map filter_el filters))
586
Removed:
in
587
Removed:
let pagination_toolbar =
588
Removed:
if not show_pagination then None
589
Removed:
else
590
Removed:
Some
591
Removed:
HTML.(
592
Removed:
nav
593
Removed:
[ class_ "toolbar-pagination"; Aria.label "Pagination" ]
594
Removed:
[
595
Removed:
(if has_prev then
596
Removed:
a
597
Removed:
[
598
Removed:
href "%s" (page_url (page - 1));
599
Removed:
class_ "pagination-btn";
600
Removed:
Aria.label "Previous page";
601
Removed:
]
602
Removed:
[ txt "<" ]
603
Removed:
else
604
Removed:
span
605
Removed:
[
606
Removed:
class_ "pagination-btn pagination-disabled";
607
Removed:
Aria.hidden true;
608
Removed:
]
609
Removed:
[ txt "<" ]);
610
Removed:
span
611
Removed:
[ class_ "pagination-page"; Aria.current `page ]
612
Removed:
[ txt "%d" page ];
613
Removed:
(if has_next then
614
Removed:
a
615
Removed:
[
616
Removed:
href "%s" (page_url (page + 1));
617
Removed:
class_ "pagination-btn";
618
Removed:
Aria.label "Next page";
619
Removed:
]
620
Removed:
[ txt ">" ]
621
Removed:
else
622
Removed:
span
623
Removed:
[
624
Removed:
class_ "pagination-btn pagination-disabled";
625
Removed:
Aria.hidden true;
626
Removed:
]
627
Removed:
[ txt ">" ]);
628
Removed:
])
629
Removed:
in
630
Removed:
let toolbar =
631
Removed:
List.filter_map Fun.id [ filters_toolbar; pagination_toolbar ]
632
Removed:
in
633
Removed:
render_page context ~active:Commits ~toolbar
634
Removed:
HTML.
635
Removed:
[
636
Removed:
ul
637
Removed:
[ id "commit-list" ]
638
Removed:
(List.map
639
Removed:
(li_of_commit ~hide_pill ?filter_type ?author ?committer
640
Removed:
context.repo)
641
Removed:
commits);
642
Removed:
]
643
Removed:
644
Removed:
let breadcrumb_pill repo (trail : (string * string) list) =
645
Removed:
let repo_name =
646
Removed:
match List.rev (String.split_on_char '/' repo) with
647
Removed:
| name :: _ -> name
648
Removed:
| [] -> repo
649
Removed:
in
650
Removed:
let repo_anchor =
651
Removed:
Routes.link_to (Files repo)
652
Removed:
~other_attrs:[ HTML.class_ "path-pill-link" ]
653
Removed:
(txt "%s" repo_name)
654
Removed:
in
655
Removed:
let file_segments =
656
Removed:
List.map
657
Removed:
(fun (entry_name, hash) ->
658
Removed:
HTML.(
659
Removed:
null
660
Removed:
[
661
Removed:
span [ class_ "path-pill-sep" ] [ txt "/" ];
662
Removed:
Routes.link_to
663
Removed:
(File (repo, hash))
664
Removed:
~other_attrs:[ class_ "path-pill-link" ]
665
Removed:
(txt "%s" entry_name);
666
Removed:
]))
667
Removed:
trail
668
Removed:
in
669
Removed:
HTML.(span [ class_ "path-pill" ] (repo_anchor :: file_segments))
670
Removed:
671
Removed:
let files context trail ?readme (entries : Resolvers.Tree.tree_node list) =
672
Removed:
let pill = breadcrumb_pill context.repo trail in
673
Removed:
let readme_section =
674
Removed:
match readme with
675
Removed:
| None -> HTML.null []
676
Removed:
| Some (blob : Resolvers.Blob.t) ->
677
Removed:
let formatted =
678
Removed:
String.split_on_char '\n' blob.content
679
Removed:
|> List.mapi (fun number line ->
680
Removed:
let line_number = number + 1 in
681
Removed:
HTML.
682
Removed:
[
683
Removed:
a
684
Removed:
[
685
Removed:
id "readme-%d" line_number;
686
Removed:
class_ "line-anchor";
687
Removed:
href "#readme-%d" line_number;
688
Removed:
Aria.label "Line %d" line_number;
689
Removed:
]
690
Removed:
[ txt "%d" line_number ];
691
Removed:
span [ class_ "line" ] [ txt "\t%s\n" line ];
692
Removed:
])
693
Removed:
|> List.concat
694
Removed:
in
695
Removed:
HTML.(
696
Removed:
section
697
Removed:
[ class_ "readme-inline" ]
698
Removed:
[ h3 [] [ txt "README" ]; div [ class_ "blob" ] formatted ])
699
Removed:
in
700
Removed:
render_page context ~active:Files ~toolbar:[ pill ]
701
Removed:
HTML.
702
Removed:
[
703
Removed:
ul [ id "file-tree" ] (List.map (li_of_tree_node context.repo) entries);
704
Removed:
readme_section;
705
Removed:
]
706
Removed:
707
Removed:
let file ?(active = Layout.Files) context trail (blob : Resolvers.Blob.t) =
708
Removed:
let language =
709
Removed:
let from_filename =
710
Removed:
match List.rev trail with
711
Removed:
| (name, _) :: _ -> language_of_filename name
712
Removed:
| [] -> None
713
Removed:
in
714
Removed:
match from_filename with
715
Removed:
| Some _ -> from_filename
716
Removed:
| None -> language_of_content blob.content
717
Removed:
in
718
Removed:
let blob_attrs =
719
Removed:
match language with
720
Removed:
| Some lang -> [ HTML.id "blob"; HTML.class_ "language-%s" lang ]
721
Removed:
| None -> [ HTML.id "blob" ]
722
Removed:
in
723
Removed:
let to_numbered_line number line =
724
Removed:
let line_number = number + 1 in
725
Removed:
HTML.
726
Removed:
[
727
Removed:
a
728
Removed:
[
729
Removed:
id "%d" line_number;
730
Removed:
class_ "line-anchor";
731
Removed:
href "#%d" line_number;
732
Removed:
Aria.label "Line %d" line_number;
733
Removed:
]
734
Removed:
[ txt "%d" line_number ];
735
Removed:
span [ class_ "line" ] [ txt "\t%s\n" line ];
736
Removed:
]
737
Removed:
in
738
Removed:
let formatted_blob =
739
Removed:
String.split_on_char '\n' blob.content
740
Removed:
|> List.mapi to_numbered_line |> List.concat
741
Removed:
in
742
Removed:
let raw_link =
743
Removed:
match List.rev trail with
744
Removed:
| (_, hash) :: _ ->
745
Removed:
HTML.(
746
Removed:
p []
747
Removed:
[ Routes.link_to (Raw_file (context.repo, hash)) (txt "View raw") ])
748
Removed:
| [] -> HTML.null []
749
Removed:
in
750
Removed:
let toolbar =
751
Removed:
match active with
752
Removed:
| Layout.Readme -> []
753
Removed:
| _ -> [ breadcrumb_pill context.repo trail ]
754
Removed:
in
755
Removed:
render_page context ~active ~toolbar
756
Removed:
HTML.[ raw_link; div blob_attrs formatted_blob ]
757
Removed:
758
Removed:
let commit context (commit : Resolvers.Commit.t) diff =
759
Removed:
let message = parse_commit_message commit.message in
760
Removed:
let number = function Some number -> string_of_int number | None -> "" in
761
Removed:
let line (line : Resolvers.Diff.line) =
762
Removed:
let class_name, marker, screen_reader_label =
763
Removed:
match line.kind with
764
Removed:
| Resolvers.Diff.Context -> ("context", " ", "")
765
Removed:
| Resolvers.Diff.Addition -> ("addition", "+", "Added: ")
766
Removed:
| Resolvers.Diff.Deletion -> ("deletion", "-", "Removed: ")
767
Removed:
in
768
Removed:
HTML.(
769
Removed:
div
770
Removed:
[ class_ "diff-line %s" class_name ]
771
Removed:
[
772
Removed:
span [ class_ "line-number" ] [ txt "%s" (number line.old_number) ];
773
Removed:
span [ class_ "line-number" ] [ txt "%s" (number line.new_number) ];
774
Removed:
span [ class_ "diff-marker"; Aria.hidden true ] [ txt "%s" marker ];
775
Removed:
span [ class_ "sr-only" ] [ txt "%s" screen_reader_label ];
776
Removed:
span [ class_ "diff-text" ] [ txt "%s" line.text ];
777
Removed:
])
778
Removed:
in
779
Removed:
let hunk (hunk : Resolvers.Diff.hunk) =
780
Removed:
HTML.
781
Removed:
[
782
Removed:
details
783
Removed:
[ class_ "diff-hunk"; open_ ]
784
Removed:
[
785
Removed:
summary
786
Removed:
[ class_ "hunk-header" ]
787
Removed:
[
788
Removed:
txt "@@ -%d,%d +%d,%d @@" hunk.old_start hunk.old_count
789
Removed:
hunk.new_start hunk.new_count;
790
Removed:
];
791
Removed:
div
792
Removed:
[ class_ "diff-lines-scroll" ]
793
Removed:
[ div [ class_ "diff-lines" ] (List.map line hunk.lines) ];
794
Removed:
];
795
Removed:
]
796
Removed:
in
797
Removed:
let mode = function
798
Removed:
| None -> "000000"
799
Removed:
| Some mode -> Printf.sprintf "%06o" mode
800
Removed:
in
801
Removed:
let hash = function
802
Removed:
| None -> "00000000"
803
Removed:
| Some hash -> Resolvers.short_hash hash
804
Removed:
in
805
Removed:
let file (file : Resolvers.Diff.file) =
806
Removed:
let file_body =
807
Removed:
if file.binary then
808
Removed:
HTML.[ p [ class_ "binary-diff" ] [ txt "Binary files differ" ] ]
809
Removed:
else List.concat_map hunk file.hunks
810
Removed:
in
811
Removed:
HTML.(
812
Removed:
details
813
Removed:
[ class_ "diff-file"; open_ ]
814
Removed:
(summary [ class_ "diff-file-header" ] [ txt "%s" file.path ]
815
Removed:
:: div
816
Removed:
[ class_ "diff-meta" ]
817
Removed:
[
818
Removed:
txt "index %s..%s %s..%s" (hash file.old_hash)
819
Removed:
(hash file.new_hash) (mode file.old_mode) (mode file.new_mode);
820
Removed:
]
821
Removed:
:: file_body))
822
Removed:
in
823
Removed:
let diff_content =
824
Removed:
match diff with
825
Removed:
| [] -> HTML.[ p [] [ txt "No file changes in this commit." ] ]
826
Removed:
| files -> List.map file files
827
Removed:
in
828
Removed:
let commit_type, commit_title = parse_conventional message.summary in
829
Removed:
let pill =
830
Removed:
match commit_type with
831
Removed:
| None -> HTML.null []
832
Removed:
| Some ct ->
833
Removed:
HTML.(
834
Removed:
span
835
Removed:
[ class_ "commit-pill commit-pill-%s" ct ]
836
Removed:
[
837
Removed:
a
838
Removed:
[ href "%s" (commits_url ~filter_type:ct context.repo) ]
839
Removed:
[ txt "%s" ct ];
840
Removed:
])
841
Removed:
in
842
Removed:
let content =
843
Removed:
HTML.(
844
Removed:
[ h3 [] [ pill; txt " %s" commit_title ] ]
845
Removed:
@ (if message.body = "" then []
846
Removed:
else [ p [ class_ "commit-body" ] [ txt "%s" message.body ] ])
847
Removed:
@ [
848
Removed:
dl
849
Removed:
[ class_ "commit-meta" ]
850
Removed:
[
851
Removed:
dt [] [ txt "Commit" ];
852
Removed:
dd [] [ txt "%s" commit.hash ];
853
Removed:
dt [] [ txt "Author" ];
854
Removed:
dd []
855
Removed:
[
856
Removed:
identity_link ~show_email:true ~role:`Author context.repo
857
Removed:
commit.author;
858
Removed:
];
859
Removed:
dt [] [ txt "Author date" ];
860
Removed:
dd [] [ time_node commit.author.date ];
861
Removed:
dt [] [ txt "Committer" ];
862
Removed:
dd []
863
Removed:
[
864
Removed:
identity_link ~show_email:true ~role:`Committer context.repo
865
Removed:
commit.committer;
866
Removed:
];
867
Removed:
dt [] [ txt "Committer date" ];
868
Removed:
dd [] [ time_node commit.committer.date ];
869
Removed:
];
870
Removed:
]
871
Removed:
@ diff_content)
872
Removed:
in
873
Removed:
render_page
874
Removed:
~heading:(context.repo ^ " : " ^ Resolvers.short_hash commit.hash)
875
Removed:
context ~active:Commits content
876
Removed:
877
Removed:
let branches context branches =
878
Removed:
let content =
879
Removed:
match branches with
880
Removed:
| [] -> HTML.[ p [] [ txt "No branches for repo %s" context.repo ] ]
881
Removed:
| branches ->
882
Removed:
HTML.
883
Removed:
[
884
Removed:
ul
885
Removed:
[ id "branch-list" ]
886
Removed:
(List.map (li_of_branch context.repo) branches);
887
Removed:
]
888
Removed:
in
889
Removed:
render_page context ~active:Branches content
890
Removed:
891
Removed:
let tags context tags =
892
Removed:
let content =
893
Removed:
match tags with
894
Removed:
| [] -> HTML.[ p [] [ txt "No tags for repo %s" context.repo ] ]
895
Removed:
| tags ->
896
Removed:
HTML.[ ul [ id "tag-list" ] (List.map (li_of_tag context.repo) tags) ]
897
Removed:
in
898
Removed:
render_page context ~active:Tags content
3
Added:
(** The repository pages: summary, commit list, file tree, blob, commit detail,
4
Added:
branches and tags.
5
Added:
6
Added:
Each page is a description: it names the parts it is made of and hands them
7
Added:
to {!Layout}. Markup lives in {!Ui}, ogit's page parts in {!Components},
8
Added:
language guessing in {!Syntax}, and date formatting in {!Time_fmt}. *)
9
Added:
10
Added:
type context = { repo : string; description : string; site : Layout.site }
11
Added:
(** What every repository page needs to know about its subject. *)
12
Added:
13
Added:
type commit_message = { summary : string; body : string }
14
Added:
15
Added:
let context ~site ~repo ~description = { repo; description; site }
16
Added:
17
Added:
(** {1 Commit messages} *)
18
Added:
19
Added:
let parse_commit_message = function
20
Added:
| None -> { summary = ""; body = "" }
21
Added:
| Some message -> (
22
Added:
match String.split_on_char '\n' message with
23
Added:
| [] -> { summary = ""; body = "" }
24
Added:
| summary :: rest ->
25
Added:
{ summary; body = String.concat "\n" rest |> String.trim })
26
Added:
27
Added:
let conventional_commit_types =
28
Added:
[
29
Added:
"feat";
30
Added:
"fix";
31
Added:
"docs";
32
Added:
"style";
33
Added:
"refactor";
34
Added:
"perf";
35
Added:
"test";
36
Added:
"build";
37
Added:
"ci";
38
Added:
"chore";
39
Added:
"revert";
40
Added:
]
41
Added:
42
Added:
(** Split a Conventional Commits subject into its type and the remaining title.
43
Added:
An unrecognised prefix is left in the title untouched, so non-conforming
44
Added:
histories still read correctly. *)
45
Added:
let parse_conventional summary =
46
Added:
match String.index_opt summary ':' with
47
Added:
| None -> (None, summary)
48
Added:
| Some colon_pos ->
49
Added:
let prefix = String.sub summary 0 colon_pos in
50
Added:
let type_name =
51
Added:
match String.index_opt prefix '(' with
52
Added:
| Some paren_pos -> String.sub prefix 0 paren_pos
53
Added:
| None -> prefix
54
Added:
in
55
Added:
let type_lower = String.lowercase_ascii type_name in
56
Added:
if List.mem type_lower conventional_commit_types then
57
Added:
let rest =
58
Added:
String.sub summary (colon_pos + 1)
59
Added:
(String.length summary - colon_pos - 1)
60
Added:
|> String.trim
61
Added:
in
62
Added:
(Some type_lower, rest)
63
Added:
else (None, summary)
64
Added:
65
Added:
(** {1 Links into the commit list} *)
66
Added:
67
Added:
let commits_url = Components.commits_url
68
Added:
69
Added:
(** A person's name, linking to the commits attributed to them. Keeps the other
70
Added:
active filters intact so identities compose with type filters. *)
71
Added:
let identity ?filter_type ?author ?committer ?(show_email = false) ~role repo
72
Added:
(user : Resolvers.Commit.user) =
73
Added:
let href, role_name =
74
Added:
match role with
75
Added:
| `Author ->
76
Added:
(commits_url ?filter_type ~author:user.email ?committer repo, "author")
77
Added:
| `Committer ->
78
Added:
( commits_url ?filter_type ?author ~committer:user.email repo,
79
Added:
"committer" )
80
Added:
in
81
Added:
Ui.text_link ~class_:"commit-identity"
82
Added:
~label:(Printf.sprintf "Filter commits by %s %s" role_name user.name)
83
Added:
~href
84
Added:
(if show_email then Printf.sprintf "%s <%s>" user.name user.email
85
Added:
else user.name)
86
Added:
87
Added:
(** {1 Page shell} *)
88
Added:
89
Added:
let page_title context = context.repo ^ " — " ^ context.description
90
Added:
91
Added:
let page ?heading ?(toolbar = []) context ~active content =
92
Added:
Ui.respond
93
Added:
@@ Layout.render context.site ~page_title:(page_title context)
94
Added:
{
95
Added:
repo = Some context.repo;
96
Added:
title = Option.value heading ~default:context.repo;
97
Added:
subtitle = context.description;
98
Added:
active;
99
Added:
toolbar;
100
Added:
home_href = None;
101
Added:
content;
102
Added:
}
103
Added:
104
Added:
(** {1 Rows} *)
105
Added:
106
Added:
let branch_row repo (branch : Resolvers.Reference.t) =
107
Added:
Ui.item
108
Added:
[ Components.route_link (Commits_branch (repo, branch.name)) branch.name ]
109
Added:
110
Added:
let tag_row repo (tag : Resolvers.Reference.t) =
111
Added:
Ui.item [ Components.route_link (Tags repo) tag.name ]
112
Added:
113
Added:
(** One line of the commit list: when it happened, what changed, and who did it.
114
Added:
115
Added:
@param hide_pill
116
Added:
suppresses the type badge when the list is already filtered to a single
117
Added:
type, where repeating it on every row adds nothing.
118
Added:
@param author
119
Added:
when filtering by author, the author column is dropped for the same
120
Added:
reason. *)
121
Added:
let commit_row ?filter_type ?author ?committer ?(hide_pill = false) repo
122
Added:
(commit : Resolvers.Commit.t) =
123
Added:
let message = parse_commit_message commit.message in
124
Added:
let commit_type, title = parse_conventional message.summary in
125
Added:
let badge =
126
Added:
match commit_type with
127
Added:
| Some commit_type when not hide_pill ->
128
Added:
Components.commit_type_badge
129
Added:
~href:(commits_url ~filter_type:commit_type ?author ?committer repo)
130
Added:
commit_type
131
Added:
| _ -> Ui.nothing
132
Added:
in
133
Added:
Ui.item
134
Added:
[
135
Added:
Ui.inline_text ~class_:"timestamp"
136
Added:
(Time_fmt.short_time commit.author.date);
137
Added:
Ui.inline ~class_:"commit-title"
138
Added:
[ badge; Components.route_link (Commit (repo, commit.hash)) title ];
139
Added:
Ui.inline_text ~class_:"commit-ago"
140
Added:
(Time_fmt.relative_time commit.author.date);
141
Added:
(match author with
142
Added:
| Some _ -> Ui.nothing
143
Added:
| None ->
144
Added:
Ui.inline ~class_:"commit-author"
145
Added:
[
146
Added:
identity ?filter_type ?author ?committer ~role:`Author repo
147
Added:
commit.author;
148
Added:
]);
149
Added:
]
150
Added:
151
Added:
(** Long directories are truncated with a link to the directory's own page,
152
Added:
keeping the tree scannable without hiding anything permanently. *)
153
Added:
let tree_display_limit = 16
154
Added:
155
Added:
let rec tree_row repo (node : Resolvers.Tree.tree_node) =
156
Added:
let entry = node.entry in
157
Added:
let route = Routes.File (repo, entry.hash) in
158
Added:
(* Dotfiles stay visible but are de-emphasised. *)
159
Added:
let modifier =
160
Added:
if String.length entry.name > 0 && entry.name.[0] = '.' then "tree-hidden"
161
Added:
else ""
162
Added:
in
163
Added:
match node.children with
164
Added:
| None -> Components.file_entry ~modifier ~route entry.name
165
Added:
| Some children ->
166
Added:
let total = List.length children in
167
Added:
let shown, omitted =
168
Added:
if total <= tree_display_limit then (children, 0)
169
Added:
else
170
Added:
(List_ext.take tree_display_limit children, total - tree_display_limit)
171
Added:
in
172
Added:
let overflow =
173
Added:
if omitted = 0 then [] else [ Components.truncated ~route omitted ]
174
Added:
in
175
Added:
Components.directory ~modifier ~route ~name:entry.name
176
Added:
(List.map (tree_row repo) shown @ overflow)
177
Added:
178
Added:
(** {1 Trails} *)
179
Added:
180
Added:
(** The path from the repository root to the entry being viewed. *)
181
Added:
let path_trail repo (trail : (string * string) list) =
182
Added:
let repo_name =
183
Added:
match List.rev (String.split_on_char '/' repo) with
184
Added:
| name :: _ -> name
185
Added:
| [] -> repo
186
Added:
in
187
Added:
let root = Ui.crumb ~href:(Components.url (Files repo)) repo_name in
188
Added:
let entries =
189
Added:
List.map
190
Added:
(fun (name, hash) ->
191
Added:
Ui.crumb ~href:(Components.url (File (repo, hash))) name)
192
Added:
trail
193
Added:
in
194
Added:
Ui.breadcrumb ~class_:"path-pill" ~link_class:"path-pill-link"
195
Added:
~separator_class:"path-pill-sep" ~separator:"/" (root :: entries)
196
Added:
197
Added:
(** {1 Pages} *)
198
Added:
199
Added:
let summary context ?readme frequency =
200
Added:
let activity =
201
Added:
[
202
Added:
Ui.heading ~level:3 [ Ui.text "Commit activity (past 30 days)" ];
203
Added:
Ui.block ~class_:"chart-container"
204
Added:
[ Charts.commit_frequency ~chart_width:600 ~chart_height:200 frequency ];
205
Added:
Ui.paragraph ~class_:"summary-more"
206
Added:
[ Components.route_link (Commits context.repo) "View all commits" ];
207
Added:
]
208
Added:
in
209
Added:
let readme_panel =
210
Added:
match readme with
211
Added:
| None -> Ui.nothing
212
Added:
| Some (blob : Resolvers.Blob.t) -> Components.inline_readme blob.content
213
Added:
in
214
Added:
page context ~active:Summary
215
Added:
~toolbar:
216
Added:
[
217
Added:
Ui.button_link
218
Added:
~label:(Printf.sprintf "Clone %s" context.repo)
219
Added:
~href:(Components.clone_url context.repo)
220
Added:
"Clone repo";
221
Added:
]
222
Added:
[
223
Added:
Ui.block ~class_:"summary-layout"
224
Added:
[
225
Added:
Ui.block ~class_:"summary-commits" activity;
226
Added:
Ui.block ~class_:"summary-readme" [ readme_panel ];
227
Added:
];
228
Added:
]
229
Added:
230
Added:
let commits ?filter_type ?author ?committer ~page:page_number ~has_prev
231
Added:
~has_next context commits =
232
Added:
(* Each active filter offers a control that clears just itself, leaving the
233
Added:
others applied. *)
234
Added:
let active_filters =
235
Added:
(match filter_type with
236
Added:
| None -> []
237
Added:
| Some commit_type ->
238
Added:
[
239
Added:
( "commit type",
240
Added:
commit_type,
241
Added:
commits_url ?author ?committer context.repo,
242
Added:
"commit-pill commit-pill-" ^ commit_type );
243
Added:
])
244
Added:
@ (match author with
245
Added:
| None -> []
246
Added:
| Some email ->
247
Added:
[
248
Added:
( "author",
249
Added:
"Author: " ^ email,
250
Added:
commits_url ?filter_type ?committer context.repo,
251
Added:
"toolbar-filter-value" );
252
Added:
])
253
Added:
@
254
Added:
match committer with
255
Added:
| None -> []
256
Added:
| Some email ->
257
Added:
[
258
Added:
( "committer",
259
Added:
"Committer: " ^ email,
260
Added:
commits_url ?filter_type ?author context.repo,
261
Added:
"toolbar-filter-value" );
262
Added:
]
263
Added:
in
264
Added:
let filters =
265
Added:
match active_filters with
266
Added:
| [] -> []
267
Added:
| filters ->
268
Added:
[
269
Added:
Ui.block ~class_:"toolbar-filters"
270
Added:
(List.map
271
Added:
(fun (name, value, dismiss_href, value_class) ->
272
Added:
Ui.dismissible ~value_class ~dismiss_href
273
Added:
~dismiss_label:(Printf.sprintf "Remove %s filter" name)
274
Added:
value)
275
Added:
filters);
276
Added:
]
277
Added:
in
278
Added:
let page_url n =
279
Added:
commits_url ?filter_type ?author ?committer ~page:n context.repo
280
Added:
in
281
Added:
let pagination =
282
Added:
if not (has_prev || has_next) then []
283
Added:
else
284
Added:
[
285
Added:
Ui.pagination
286
Added:
?previous_href:
287
Added:
(if has_prev then Some (page_url (page_number - 1)) else None)
288
Added:
?next_href:
289
Added:
(if has_next then Some (page_url (page_number + 1)) else None)
290
Added:
page_number;
291
Added:
]
292
Added:
in
293
Added:
page context ~active:Commits ~toolbar:(filters @ pagination)
294
Added:
[
295
Added:
Ui.items_of ~id:"commit-list"
296
Added:
(commit_row
297
Added:
~hide_pill:(Option.is_some filter_type)
298
Added:
?filter_type ?author ?committer context.repo)
299
Added:
commits;
300
Added:
]
301
Added:
302
Added:
let files context trail ?readme (entries : Resolvers.Tree.tree_node list) =
303
Added:
let readme_panel =
304
Added:
match readme with
305
Added:
| None -> Ui.nothing
306
Added:
| Some (blob : Resolvers.Blob.t) -> Components.inline_readme blob.content
307
Added:
in
308
Added:
page context ~active:Files
309
Added:
~toolbar:[ path_trail context.repo trail ]
310
Added:
[
311
Added:
Ui.items_of ~id:"file-tree" (tree_row context.repo) entries; readme_panel;
312
Added:
]
313
Added:
314
Added:
let file ?(active = Layout.Files) context trail (blob : Resolvers.Blob.t) =
315
Added:
let filename =
316
Added:
match List.rev trail with (name, _) :: _ -> Some name | [] -> None
317
Added:
in
318
Added:
let language = Syntax.detect ~filename blob.content in
319
Added:
let raw_link =
320
Added:
match List.rev trail with
321
Added:
| (_, hash) :: _ ->
322
Added:
Ui.paragraph
323
Added:
[ Components.route_link (Raw_file (context.repo, hash)) "View raw" ]
324
Added:
| [] -> Ui.nothing
325
Added:
in
326
Added:
(* The README page reuses this view but reaches it without a path, so it has no
327
Added:
trail to show. *)
328
Added:
let toolbar =
329
Added:
match active with
330
Added:
| Layout.Readme -> []
331
Added:
| _ -> [ path_trail context.repo trail ]
332
Added:
in
333
Added:
page context ~active ~toolbar
334
Added:
[
335
Added:
raw_link;
336
Added:
Ui.code_listing ~id:"blob"
337
Added:
?class_:(Option.map (Printf.sprintf "language-%s") language)
338
Added:
blob.content;
339
Added:
]
340
Added:
341
Added:
let commit context (commit : Resolvers.Commit.t) diff =
342
Added:
let message = parse_commit_message commit.message in
343
Added:
let commit_type, title = parse_conventional message.summary in
344
Added:
let number = function Some n -> string_of_int n | None -> "" in
345
Added:
let diff_line (line : Resolvers.Diff.line) : Ui.Diff.line =
346
Added:
{
347
Added:
before = number line.old_number;
348
Added:
after = number line.new_number;
349
Added:
change =
350
Added:
(match line.kind with
351
Added:
| Resolvers.Diff.Context -> Ui.Diff.Unchanged
352
Added:
| Resolvers.Diff.Addition -> Ui.Diff.Added
353
Added:
| Resolvers.Diff.Deletion -> Ui.Diff.Removed);
354
Added:
content = line.text;
355
Added:
}
356
Added:
in
357
Added:
let diff_section (hunk : Resolvers.Diff.hunk) : Ui.Diff.section =
358
Added:
{
359
Added:
section_heading =
360
Added:
Printf.sprintf "@@ -%d,%d +%d,%d @@" hunk.old_start hunk.old_count
361
Added:
hunk.new_start hunk.new_count;
362
Added:
lines = List.map diff_line hunk.lines;
363
Added:
}
364
Added:
in
365
Added:
let mode = function
366
Added:
| None -> "000000"
367
Added:
| Some mode -> Printf.sprintf "%06o" mode
368
Added:
in
369
Added:
let hash = function
370
Added:
| None -> "00000000"
371
Added:
| Some hash -> Resolvers.short_hash hash
372
Added:
in
373
Added:
let diff_file (file : Resolvers.Diff.file) : Ui.Diff.file =
374
Added:
{
375
Added:
path = file.path;
376
Added:
detail =
377
Added:
Printf.sprintf "index %s..%s %s..%s" (hash file.old_hash)
378
Added:
(hash file.new_hash) (mode file.old_mode) (mode file.new_mode);
379
Added:
sections = List.map diff_section file.hunks;
380
Added:
note = (if file.binary then Some "Binary files differ" else None);
381
Added:
}
382
Added:
in
383
Added:
let badge =
384
Added:
match commit_type with
385
Added:
| None -> Ui.nothing
386
Added:
| Some commit_type ->
387
Added:
Components.commit_type_badge
388
Added:
~href:(commits_url ~filter_type:commit_type context.repo)
389
Added:
commit_type
390
Added:
in
391
Added:
let body =
392
Added:
if message.body = "" then []
393
Added:
else [ Ui.paragraph_text ~class_:"commit-body" message.body ]
394
Added:
in
395
Added:
let timestamp date =
396
Added:
let machine, display = Time_fmt.exact_time date in
397
Added:
Ui.timestamp ~machine display
398
Added:
in
399
Added:
let metadata =
400
Added:
Ui.definitions ~class_:"commit-meta"
401
Added:
[
402
Added:
("Commit", [ Ui.text commit.hash ]);
403
Added:
( "Author",
404
Added:
[ identity ~show_email:true ~role:`Author context.repo commit.author ]
405
Added:
);
406
Added:
("Author date", [ timestamp commit.author.date ]);
407
Added:
( "Committer",
408
Added:
[
409
Added:
identity ~show_email:true ~role:`Committer context.repo
410
Added:
commit.committer;
411
Added:
] );
412
Added:
("Committer date", [ timestamp commit.committer.date ]);
413
Added:
]
414
Added:
in
415
Added:
page
416
Added:
~heading:(context.repo ^ " : " ^ Resolvers.short_hash commit.hash)
417
Added:
context ~active:Commits
418
Added:
((Ui.heading ~level:3 [ badge; Ui.text (" " ^ title) ] :: body)
419
Added:
@ [ metadata ]
420
Added:
@ Ui.Diff.view ~empty_message:"No file changes in this commit."
421
Added:
(List.map diff_file diff))
422
Added:
423
Added:
let branches context branches =
424
Added:
page context ~active:Branches
425
Added:
(match branches with
426
Added:
| [] ->
427
Added:
[
428
Added:
Ui.paragraph_text
429
Added:
(Printf.sprintf "No branches for repo %s" context.repo);
430
Added:
]
431
Added:
| branches ->
432
Added:
[ Ui.items_of ~id:"branch-list" (branch_row context.repo) branches ])
433
Added:
434
Added:
let tags context tags =
435
Added:
page context ~active:Tags
436
Added:
(match tags with
437
Added:
| [] ->
438
Added:
[
439
Added:
Ui.paragraph_text (Printf.sprintf "No tags for repo %s" context.repo);
440
Added:
]
441
Added:
| tags -> [ Ui.items_of ~id:"tag-list" (tag_row context.repo) tags ])
lib/views/root.ml
@@ -1,118 +1,76 @@
1
1
(* -*- mode: tuareg; -*- *)
2
2
3
Removed:
open Dream_html
3
Added:
(** The repository list, and the project directory pages that share its shape.
4
4
5
Removed:
let rec li_of_fs_node ~prefix ~dates node =
5
Added:
A project directory is the same page scoped to a subtree, so both are
6
Added:
described here. *)
7
Added:
8
Added:
(** One entry in the list: either a repository, or a directory that expands to
9
Added:
reveal the repositories beneath it. *)
10
Added:
let rec repo_row ~prefix ~dates node =
6
11
match node with
7
12
| Resolvers.Repo { repo_name; description } ->
8
Removed:
let full_path =
9
Removed:
if prefix = "" then repo_name else prefix ^ "/" ^ repo_name
13
Added:
let path = if prefix = "" then repo_name else prefix ^ "/" ^ repo_name in
14
Added:
let described =
15
Added:
if description = Resolvers.default_repo_description then []
16
Added:
else [ Ui.inline_text ~class_:"repo-description" description ]
10
17
in
11
Removed:
let desc_span =
12
Removed:
if description = Resolvers.default_repo_description then HTML.null []
13
Removed:
else HTML.(span [ class_ "repo-description" ] [ txt "%s" description ])
14
Removed:
in
15
Removed:
let ago_span =
16
Removed:
match List.assoc_opt full_path dates with
17
Removed:
| None | Some None -> HTML.null []
18
Added:
let updated =
19
Added:
match List.assoc_opt path dates with
20
Added:
| None | Some None -> Ui.nothing
18
21
| Some (Some date) ->
19
Removed:
HTML.(
20
Removed:
span
21
Removed:
[ class_ "commit-ago" ]
22
Removed:
[ txt "%s" (Time_fmt.relative_time date) ])
22
Added:
Ui.inline_text ~class_:"commit-ago" (Time_fmt.relative_time date)
23
23
in
24
Removed:
HTML.(
25
Removed:
li []
26
Removed:
[
27
Removed:
Routes.link_to (Routes.Repo full_path)
28
Removed:
(null
29
Removed:
[
30
Removed:
span [ class_ "repo-name" ] [ txt "%s" repo_name ]; desc_span;
31
Removed:
]);
32
Removed:
ago_span;
33
Removed:
])
34
Removed:
| Resolvers.Directory (dir_name, children) ->
35
Removed:
let child_prefix =
36
Removed:
if prefix = "" then dir_name else prefix ^ "/" ^ dir_name
37
Removed:
in
38
Removed:
Components.tree_dir ~route:(Routes.Project_dir child_prefix)
39
Removed:
~label:(dir_name ^ "/")
40
Removed:
(List.map (li_of_fs_node ~prefix:child_prefix ~dates) children)
24
Added:
Ui.item
25
Added:
[
26
Added:
Ui.link
27
Added:
~href:(Components.url (Routes.Repo path))
28
Added:
(Ui.inline_text ~class_:"repo-name" repo_name :: described);
29
Added:
updated;
30
Added:
]
31
Added:
| Resolvers.Directory (name, children) ->
32
Added:
let path = if prefix = "" then name else prefix ^ "/" ^ name in
33
Added:
Components.directory ~route:(Routes.Project_dir path) ~name
34
Added:
(List.map (repo_row ~prefix:path ~dates) children)
41
35
36
Added:
(** Repositories may be grouped into Favorites and Archived sections. With no
37
Added:
grouping configured the list renders flat and unheaded, which keeps the
38
Added:
common case free of pointless chrome. *)
42
39
let render (site : Layout.site) ~dates ?(prefix = "") ?(favorites = [])
43
40
?(archived = []) ?readme nodes =
44
Removed:
let repo_list list_id nodes =
45
Removed:
HTML.(
46
Removed:
ul [ id "%s" list_id ] (List.map (li_of_fs_node ~prefix ~dates) nodes))
41
Added:
let repo_list id nodes = Ui.items_of ~id (repo_row ~prefix ~dates) nodes in
42
Added:
let optional_group ~class_ ~title ~expanded ~id = function
43
Added:
| [] -> Ui.nothing
44
Added:
| repos ->
45
Added:
Ui.region ~class_
46
Added:
[ Components.group ~expanded ~title [ repo_list id repos ] ]
47
47
in
48
Removed:
let favorites_section =
49
Removed:
match favorites with
50
Removed:
| [] -> HTML.null []
51
Removed:
| _ ->
52
Removed:
HTML.(
53
Removed:
section
54
Removed:
[ class_ "repo-section repo-favorites" ]
55
Removed:
[
56
Removed:
Components.section_disclosure ~expanded:true ~title:"Favorites"
57
Removed:
[ repo_list "repo-list-favorites" favorites ];
58
Removed:
])
48
Added:
let favorites_group =
49
Added:
optional_group ~class_:"repo-section repo-favorites" ~title:"Favorites"
50
Added:
~expanded:true ~id:"repo-list-favorites" favorites
59
51
in
60
Removed:
let main_section =
61
Removed:
HTML.(
62
Removed:
div
63
Removed:
[ id "repositories" ]
64
Removed:
(match (favorites, archived) with
65
Removed:
| [], [] ->
66
Removed:
(* No partitioning — render flat without a heading *)
67
Removed:
[ repo_list "repo-list" nodes ]
68
Removed:
| _ ->
69
Removed:
if nodes = [] then []
70
Removed:
else
71
Removed:
[
72
Removed:
Components.section_disclosure ~expanded:true
73
Removed:
~title:"Repositories"
74
Removed:
[ repo_list "repo-list" nodes ];
75
Removed:
]))
52
Added:
let archived_group =
53
Added:
optional_group ~class_:"repo-section repo-archived" ~title:"Archived"
54
Added:
~expanded:false ~id:"repo-list-archived" archived
76
55
in
77
Removed:
let archived_section =
78
Removed:
match archived with
79
Removed:
| [] -> HTML.null []
80
Removed:
| _ ->
81
Removed:
HTML.(
82
Removed:
section
83
Removed:
[ class_ "repo-section repo-archived" ]
84
Removed:
[
85
Removed:
Components.section_disclosure ~title:"Archived"
86
Removed:
[ repo_list "repo-list-archived" archived ];
87
Removed:
])
56
Added:
let main_group =
57
Added:
Ui.block ~id:"repositories"
58
Added:
(match (favorites, archived) with
59
Added:
| [], [] -> [ repo_list "repo-list" nodes ]
60
Added:
| _ when nodes = [] -> []
61
Added:
| _ ->
62
Added:
[
63
Added:
Components.group ~expanded:true ~title:"Repositories"
64
Added:
[ repo_list "repo-list" nodes ];
65
Added:
])
88
66
in
89
Removed:
let readme_section =
67
Added:
let readme_panel =
90
68
match readme with
91
Removed:
| None -> HTML.null []
92
Removed:
| Some (blob : Resolvers.Blob.t) ->
93
Removed:
let formatted =
94
Removed:
String.split_on_char '\n' blob.content
95
Removed:
|> List.mapi (fun number line ->
96
Removed:
let line_number = number + 1 in
97
Removed:
HTML.
98
Removed:
[
99
Removed:
a
100
Removed:
[
101
Removed:
id "readme-%d" line_number;
102
Removed:
class_ "line-anchor";
103
Removed:
href "#readme-%d" line_number;
104
Removed:
Aria.label "Line %d" line_number;
105
Removed:
]
106
Removed:
[ txt "%d" line_number ];
107
Removed:
span [ class_ "line" ] [ txt "\t%s\n" line ];
108
Removed:
])
109
Removed:
|> List.concat
110
Removed:
in
111
Removed:
HTML.(
112
Removed:
section
113
Removed:
[ class_ "readme-inline" ]
114
Removed:
[ h3 [] [ txt "README" ]; div [ class_ "blob" ] formatted ])
69
Added:
| None -> Ui.nothing
70
Added:
| Some (blob : Resolvers.Blob.t) -> Components.inline_readme blob.content
115
71
in
72
Added:
(* A project directory page is titled by its own segment; the root page by the
73
Added:
configured site title. *)
116
74
let nav_title =
117
75
if prefix = "" then site.root_title
118
76
else
@@ -120,7 +78,7 @@
120
78
| name :: _ -> name
121
79
| [] -> prefix
122
80
in
123
Removed:
respond
81
Added:
Ui.respond
124
82
@@ Layout.render site
125
83
{
126
84
title = nav_title;
@@ -130,17 +88,14 @@
130
88
toolbar = [];
131
89
home_href =
132
90
(if prefix = "" then None
133
Removed:
else Some (Routes.path_of (Project_dir prefix)));
91
Added:
else Some (Components.url (Project_dir prefix)));
134
92
content =
135
93
[
136
Removed:
HTML.(
137
Removed:
div
138
Removed:
[ class_ "root-layout" ]
139
Removed:
[
140
Removed:
div
141
Removed:
[ class_ "root-repos" ]
142
Removed:
[ favorites_section; main_section; archived_section ];
143
Removed:
div [ class_ "root-readme" ] [ readme_section ];
144
Removed:
]);
94
Added:
Ui.block ~class_:"root-layout"
95
Added:
[
96
Added:
Ui.block ~class_:"root-repos"
97
Added:
[ favorites_group; main_group; archived_group ];
98
Added:
Ui.block ~class_:"root-readme" [ readme_panel ];
99
Added:
];
145
100
];
146
101
}
lib/views/syntax.ml
@@ -0,0 +1,245 @@
1
Added:
(* -*- mode: tuareg; -*- *)
2
Added:
3
Added:
(** Guessing a file's language for syntax highlighting.
4
Added:
5
Added:
Detection is best-effort and purely advisory: the blob renders identically
6
Added:
whether or not a language is found, so a wrong guess degrades to plain text
7
Added:
rather than breaking the page.
8
Added:
9
Added:
Sources are tried in descending order of reliability: the filename
10
Added:
extension, then a shebang, then an Emacs file variable, then a Vim modeline.
11
Added:
*)
12
Added:
13
Added:
let of_filename name =
14
Added:
match Filename.extension name |> String.lowercase_ascii with
15
Added:
| ".ml" | ".mli" -> Some "ocaml"
16
Added:
| ".c" | ".h" -> Some "c"
17
Added:
| ".cpp" | ".cc" | ".cxx" | ".hpp" -> Some "cpp"
18
Added:
| ".cs" -> Some "csharp"
19
Added:
| ".css" -> Some "css"
20
Added:
| ".diff" | ".patch" -> Some "diff"
21
Added:
| ".el" | ".lisp" | ".cl" -> Some "lisp"
22
Added:
| ".erl" -> Some "erlang"
23
Added:
| ".ex" | ".exs" -> Some "elixir"
24
Added:
| ".go" -> Some "go"
25
Added:
| ".hs" -> Some "haskell"
26
Added:
| ".html" | ".htm" -> Some "xml"
27
Added:
| ".java" -> Some "java"
28
Added:
| ".js" | ".mjs" | ".cjs" -> Some "javascript"
29
Added:
| ".json" -> Some "json"
30
Added:
| ".kt" -> Some "kotlin"
31
Added:
| ".lua" -> Some "lua"
32
Added:
| ".md" -> Some "markdown"
33
Added:
| ".nix" -> Some "nix"
34
Added:
| ".php" -> Some "php"
35
Added:
| ".pl" | ".pm" | ".t" -> Some "perl"
36
Added:
| ".py" -> Some "python"
37
Added:
| ".r" -> Some "r"
38
Added:
| ".rb" -> Some "ruby"
39
Added:
| ".rs" -> Some "rust"
40
Added:
| ".scala" -> Some "scala"
41
Added:
| ".sh" | ".bash" | ".zsh" -> Some "bash"
42
Added:
| ".sql" -> Some "sql"
43
Added:
| ".swift" -> Some "swift"
44
Added:
| ".toml" -> Some "ini"
45
Added:
| ".ts" | ".tsx" -> Some "typescript"
46
Added:
| ".xml" | ".svg" | ".xsl" -> Some "xml"
47
Added:
| ".yaml" | ".yml" -> Some "yaml"
48
Added:
| ".zig" -> Some "zig"
49
Added:
| _ -> None
50
Added:
51
Added:
let of_shebang line =
52
Added:
if not (String.starts_with ~prefix:"#!" line) then None
53
Added:
else
54
Added:
(* Extract the last path component, ignoring env and arguments *)
55
Added:
let rest = String.sub line 2 (String.length line - 2) in
56
Added:
let parts = String.split_on_char ' ' (String.trim rest) in
57
Added:
let interpreter =
58
Added:
match parts with
59
Added:
| [] -> ""
60
Added:
| cmd :: args ->
61
Added:
let base = Filename.basename cmd in
62
Added:
if base = "env" then
63
Added:
(* /usr/bin/env python3 — take next non-flag argument *)
64
Added:
List.find_opt (fun s -> s <> "" && s.[0] <> '-') args
65
Added:
|> Option.value ~default:"" |> Filename.basename
66
Added:
else base
67
Added:
in
68
Added:
(* Strip version suffixes: python3.11 -> python, ruby3.2 -> ruby *)
69
Added:
let strip_trailing_digits s =
70
Added:
let len = String.length s in
71
Added:
let rec find_end i =
72
Added:
if i < 0 then s
73
Added:
else if s.[i] >= '0' && s.[i] <= '9' then find_end (i - 1)
74
Added:
else String.sub s 0 (i + 1)
75
Added:
in
76
Added:
find_end (len - 1)
77
Added:
in
78
Added:
let interpreter =
79
Added:
match String.split_on_char '.' interpreter with
80
Added:
| [] -> ""
81
Added:
| base :: _ -> strip_trailing_digits base
82
Added:
in
83
Added:
match String.lowercase_ascii interpreter with
84
Added:
| "sh" | "bash" | "dash" | "ash" | "zsh" -> Some "bash"
85
Added:
| "python" -> Some "python"
86
Added:
| "ruby" -> Some "ruby"
87
Added:
| "perl" -> Some "perl"
88
Added:
| "node" | "deno" | "bun" -> Some "javascript"
89
Added:
| "lua" -> Some "lua"
90
Added:
| "php" -> Some "php"
91
Added:
| "elixir" -> Some "elixir"
92
Added:
| "awk" | "gawk" | "mawk" -> Some "awk"
93
Added:
| "ocaml" -> Some "ocaml"
94
Added:
| _ -> None
95
Added:
96
Added:
let of_emacs_variables line =
97
Added:
let find_between s prefix suffix =
98
Added:
let plen = String.length prefix in
99
Added:
let slen = String.length suffix in
100
Added:
let total = String.length s in
101
Added:
let rec find_start i =
102
Added:
if i > total - plen then None
103
Added:
else if String.sub s i plen = prefix then
104
Added:
let after = i + plen in
105
Added:
let rec find_end j =
106
Added:
if j > total - slen then None
107
Added:
else if String.sub s j slen = suffix then
108
Added:
Some (String.sub s after (j - after) |> String.trim)
109
Added:
else find_end (j + 1)
110
Added:
in
111
Added:
find_end after
112
Added:
else find_start (i + 1)
113
Added:
in
114
Added:
find_start 0
115
Added:
in
116
Added:
let extract_mode between =
117
Added:
let props = String.split_on_char ';' between in
118
Added:
let mode_prop =
119
Added:
List.find_map
120
Added:
(fun prop ->
121
Added:
match String.split_on_char ':' (String.trim prop) with
122
Added:
| [ key; value ]
123
Added:
when String.trim (String.lowercase_ascii key) = "mode" ->
124
Added:
Some (String.trim value)
125
Added:
| _ -> None)
126
Added:
props
127
Added:
in
128
Added:
match mode_prop with
129
Added:
| Some _ -> mode_prop
130
Added:
| None ->
131
Added:
if
132
Added:
(not (String.contains between ':'))
133
Added:
&& not (String.contains between ';')
134
Added:
then Some (String.trim between)
135
Added:
else None
136
Added:
in
137
Added:
let normalize_mode mode =
138
Added:
match String.lowercase_ascii mode with
139
Added:
| "tuareg" | "caml" | "ocaml" -> Some "ocaml"
140
Added:
| "emacs-lisp" | "lisp" | "elisp" -> Some "lisp"
141
Added:
| "shell-script" | "sh" | "bash" -> Some "bash"
142
Added:
| "python" -> Some "python"
143
Added:
| "ruby" -> Some "ruby"
144
Added:
| "perl" | "cperl" -> Some "perl"
145
Added:
| "c" -> Some "c"
146
Added:
| "c++" -> Some "cpp"
147
Added:
| "javascript" | "js" -> Some "javascript"
148
Added:
| "typescript" -> Some "typescript"
149
Added:
| "rust" -> Some "rust"
150
Added:
| "go" -> Some "go"
151
Added:
| "haskell" -> Some "haskell"
152
Added:
| "lua" -> Some "lua"
153
Added:
| "sql" -> Some "sql"
154
Added:
| "yaml" -> Some "yaml"
155
Added:
| "nix" -> Some "nix"
156
Added:
| "makefile" -> Some "makefile"
157
Added:
| m -> Some m
158
Added:
in
159
Added:
let ( >>= ) = Option.bind in
160
Added:
find_between line "-*-" "-*-" >>= extract_mode >>= normalize_mode
161
Added:
162
Added:
let of_vim_modeline line =
163
Added:
let contains_substring s sub =
164
Added:
let slen = String.length s in
165
Added:
let sublen = String.length sub in
166
Added:
let rec check i =
167
Added:
if i > slen - sublen then false
168
Added:
else if String.sub s i sublen = sub then true
169
Added:
else check (i + 1)
170
Added:
in
171
Added:
sublen <= slen && check 0
172
Added:
in
173
Added:
let l = String.lowercase_ascii line in
174
Added:
let has_vim_prefix =
175
Added:
contains_substring l "vim:"
176
Added:
|| contains_substring l "vi:" || contains_substring l "ex:"
177
Added:
in
178
Added:
if not has_vim_prefix then None
179
Added:
else
180
Added:
let find_value prefix s =
181
Added:
let plen = String.length prefix in
182
Added:
let slen = String.length s in
183
Added:
let rec find_at i =
184
Added:
if i > slen - plen then None
185
Added:
else if String.sub s i plen = prefix then
186
Added:
let vstart = i + plen in
187
Added:
let rec scan_end j =
188
Added:
if j >= slen || s.[j] = ' ' || s.[j] = ':' || s.[j] = '\t' then j
189
Added:
else scan_end (j + 1)
190
Added:
in
191
Added:
let vend = scan_end vstart in
192
Added:
Some (String.sub s vstart (vend - vstart))
193
Added:
else find_at (i + 1)
194
Added:
in
195
Added:
find_at 0
196
Added:
in
197
Added:
let ft =
198
Added:
match find_value "ft=" l with
199
Added:
| Some _ as r -> r
200
Added:
| None -> find_value "filetype=" l
201
Added:
in
202
Added:
match ft with
203
Added:
| None -> None
204
Added:
| Some ft -> (
205
Added:
match ft with
206
Added:
| "sh" | "bash" | "zsh" -> Some "bash"
207
Added:
| "python" -> Some "python"
208
Added:
| "ruby" -> Some "ruby"
209
Added:
| "perl" -> Some "perl"
210
Added:
| "javascript" | "js" -> Some "javascript"
211
Added:
| "typescript" -> Some "typescript"
212
Added:
| "ocaml" -> Some "ocaml"
213
Added:
| "c" -> Some "c"
214
Added:
| "cpp" -> Some "cpp"
215
Added:
| "rust" -> Some "rust"
216
Added:
| "go" -> Some "go"
217
Added:
| "haskell" -> Some "haskell"
218
Added:
| "lua" -> Some "lua"
219
Added:
| "make" | "makefile" -> Some "makefile"
220
Added:
| "yaml" -> Some "yaml"
221
Added:
| "sql" -> Some "sql"
222
Added:
| "nix" -> Some "nix"
223
Added:
| other -> Some other)
224
Added:
225
Added:
(** Inspect the first and last five lines, where editors conventionally place
226
Added:
mode declarations. *)
227
Added:
let of_content content =
228
Added:
let lines = String.split_on_char '\n' content in
229
Added:
let len = List.length lines in
230
Added:
let first_lines = List_ext.take (min 5 len) lines in
231
Added:
let last_lines = List_ext.drop (max 0 (len - 5)) lines in
232
Added:
let try_lines detector lines = List.find_map detector lines in
233
Added:
let ( <|> ) a b = match a with Some _ -> a | None -> b () in
234
Added:
match first_lines with
235
Added:
| [] -> None
236
Added:
| first :: _ ->
237
Added:
( (of_shebang first <|> fun () -> try_lines of_emacs_variables first_lines)
238
Added:
<|> fun () -> try_lines of_vim_modeline first_lines )
239
Added:
<|> fun () -> try_lines of_vim_modeline last_lines
240
Added:
241
Added:
(** Prefer the filename, falling back to markers inside the content. *)
242
Added:
let detect ~filename content =
243
Added:
match Option.bind filename of_filename with
244
Added:
| Some _ as found -> found
245
Added:
| None -> of_content content
lib/views/time_fmt.ml
@@ -1,7 +1,13 @@
1
1
(* -*- mode: tuareg; -*- *)
2
2
3
Removed:
(** Human-readable relative timestamps. *)
3
Added:
(** Formatting Git dates for display.
4
4
5
Added:
Git records a commit date as a Unix timestamp plus the offset of the zone
6
Added:
the author was in. Relative and short forms drop that offset and use the
7
Added:
server's local zone, which is what a reader scanning a list wants; the
8
Added:
detailed form preserves it, because on a single commit the author's own
9
Added:
wall-clock time is the meaningful one. *)
10
Added:
5
11
let relative_time (date, _) =
6
12
let seconds = Unix.time () -. Int64.to_float date |> int_of_float in
7
13
let minutes = seconds / 60 in
@@ -19,3 +25,31 @@
19
25
| _ when days < 30 -> quantity days "day"
20
26
| _ when months < 12 -> quantity months "month"
21
27
| _ -> quantity years "year"
28
Added:
29
Added:
(** Minute precision, server-local, for dense listings. *)
30
Added:
let short_time (date, _) =
31
Added:
let tm = date |> Int64.to_float |> Unix.localtime in
32
Added:
Printf.sprintf "%04d-%02d-%02d %02d:%02d" (tm.tm_year + 1900) (tm.tm_mon + 1)
33
Added:
tm.tm_mday tm.tm_hour tm.tm_min
34
Added:
35
Added:
(** Second precision in the recorded zone. Returns the machine-readable form for
36
Added:
a [datetime] attribute alongside the human-readable form. *)
37
Added:
let exact_time (date, timezone) =
38
Added:
let offset_seconds, suffix =
39
Added:
match timezone with
40
Added:
| None -> (0, "Z")
41
Added:
| Some (offset : Git.User.tz_offset) ->
42
Added:
let direction = match offset.sign with `Plus -> 1 | `Minus -> -1 in
43
Added:
let seconds = direction * ((offset.hours * 60) + offset.minutes) * 60 in
44
Added:
let sign = match offset.sign with `Plus -> "+" | `Minus -> "-" in
45
Added:
(seconds, Printf.sprintf "%s%02d:%02d" sign offset.hours offset.minutes)
46
Added:
in
47
Added:
let adjusted = Int64.add date (Int64.of_int offset_seconds) in
48
Added:
let tm = adjusted |> Int64.to_float |> Unix.gmtime in
49
Added:
let day =
50
Added:
Printf.sprintf "%04d-%02d-%02d" (tm.tm_year + 1900) (tm.tm_mon + 1)
51
Added:
tm.tm_mday
52
Added:
in
53
Added:
let clock = Printf.sprintf "%02d:%02d:%02d" tm.tm_hour tm.tm_min tm.tm_sec in
54
Added:
( Printf.sprintf "%sT%s%s" day clock suffix,
55
Added:
Printf.sprintf "%s %s %s" day clock suffix )
lib/views/ui.ml
@@ -0,0 +1,496 @@
1
Added:
(* -*- mode: tuareg; -*- *)
2
Added:
3
Added:
(** Generic site building blocks.
4
Added:
5
Added:
This module is the only place in the view layer that names HTML elements. It
6
Added:
knows nothing about the application domain — no Git, repositories, or ogit
7
Added:
routes — so the same vocabulary would serve any static-first web
8
Added:
application: every function takes plain strings and already-built nodes.
9
Added:
10
Added:
{2 Conventions}
11
Added:
12
Added:
- {b Semantic first.} Each block picks the most meaningful element available
13
Added:
([nav], [header], [time], [dl], [details]) rather than a [div] with a
14
Added:
class. Callers choose blocks by meaning, not by appearance.
15
Added:
- {b Classes are a contract.} Blocks emit a fixed vocabulary of class names
16
Added:
— [tree-dir], [tree-toggle], [line-anchor], [pagination-btn] and so on —
17
Added:
which a stylesheet is expected to implement. Those names are structural,
18
Added:
never domain-specific: a "tree" here is any hierarchical list, not a file
19
Added:
tree in particular. Optional [?class_] arguments add a modifier
20
Added:
{i alongside} the base class rather than replacing it.
21
Added:
- {b No scripting.} Interactive blocks ({!disclosure}, {!css_toggle}) rely
22
Added:
on native HTML and CSS, so pages stay usable with JavaScript disabled.
23
Added:
24
Added:
Nothing here performs I/O. *)
25
Added:
26
Added:
open Dream_html
27
Added:
28
Added:
type node = Dream_html.node
29
Added:
(** A rendered fragment. Exposed so callers can annotate lists of children
30
Added:
without opening [Dream_html] themselves. *)
31
Added:
32
Added:
(** Join class names, dropping empty ones. Lets callers pass a modifier without
33
Added:
having to manage separators or risk a stray leading space. *)
34
Added:
let classes parts =
35
Added:
parts |> List.filter (fun part -> part <> "") |> String.concat " "
36
Added:
37
Added:
(** {1 Attribute plumbing} *)
38
Added:
39
Added:
let opt_id = function None -> [] | Some value -> [ HTML.id "%s" value ]
40
Added:
let opt_class = function None -> [] | Some value -> [ HTML.class_ "%s" value ]
41
Added:
let opt_aria_label = function None -> [] | Some v -> [ Aria.label "%s" v ]
42
Added:
let flag_current = function false -> [] | true -> [ Aria.current `page ]
43
Added:
let flag_open = function false -> [] | true -> HTML.[ open_ ]
44
Added:
45
Added:
(** {1 Text and grouping} *)
46
Added:
47
Added:
(** Renders no markup. Use for absent optional content. *)
48
Added:
let nothing = HTML.null []
49
Added:
50
Added:
(** Escaped text. *)
51
Added:
let text value = txt "%s" value
52
Added:
53
Added:
(** Several nodes where one is expected, without introducing a wrapper element.
54
Added:
*)
55
Added:
let group nodes = HTML.null nodes
56
Added:
57
Added:
(** {1 Inline} *)
58
Added:
59
Added:
(** An inline run of text or nodes.
60
Added:
61
Added:
@param decorative
62
Added:
hides the span from assistive technology, for glyphs that repeat
63
Added:
information already available as text. *)
64
Added:
let inline ?class_ ?(decorative = false) children =
65
Added:
let hidden = if decorative then [ Aria.hidden true ] else [] in
66
Added:
HTML.span (opt_class class_ @ hidden) children
67
Added:
68
Added:
let inline_text ?class_ ?decorative value =
69
Added:
inline ?class_ ?decorative [ text value ]
70
Added:
71
Added:
(** {1 Links} *)
72
Added:
73
Added:
(** A hyperlink.
74
Added:
75
Added:
@param label
76
Added:
an accessible name, for links whose visible text is not descriptive on its
77
Added:
own. *)
78
Added:
let link ?id ?class_ ?label ~href children =
79
Added:
HTML.a
80
Added:
(opt_id id
81
Added:
@ [ HTML.href "%s" href ]
82
Added:
@ opt_class class_ @ opt_aria_label label)
83
Added:
children
84
Added:
85
Added:
let text_link ?id ?class_ ?label ~href value =
86
Added:
link ?id ?class_ ?label ~href [ text value ]
87
Added:
88
Added:
(** {1 Images} *)
89
Added:
90
Added:
(** @param alt
91
Added:
omit for decorative images; the block then marks itself presentational so
92
Added:
screen readers skip it. *)
93
Added:
let image ?class_ ?alt ~src () =
94
Added:
let describe =
95
Added:
match alt with
96
Added:
| Some value -> [ HTML.alt "%s" value ]
97
Added:
| None -> [ HTML.alt ""; HTML.role `presentation ]
98
Added:
in
99
Added:
HTML.img ((HTML.src "%s" src :: describe) @ opt_class class_)
100
Added:
101
Added:
(** {1 Blocks} *)
102
Added:
103
Added:
let block ?id ?class_ children =
104
Added:
HTML.div (opt_id id @ opt_class class_) children
105
Added:
106
Added:
let region ?id ?class_ children =
107
Added:
HTML.section (opt_id id @ opt_class class_) children
108
Added:
109
Added:
let paragraph ?class_ children = HTML.p (opt_class class_) children
110
Added:
let paragraph_text ?class_ value = paragraph ?class_ [ text value ]
111
Added:
112
Added:
(** A heading. [level] follows the document outline: 1 for the page's subject, 2
113
Added:
and 3 for nested sections. Skipping levels breaks screen-reader navigation,
114
Added:
so pass the level that matches the structure rather than the one that looks
115
Added:
right. *)
116
Added:
let heading ?(level = 1) ?class_ children =
117
Added:
let element =
118
Added:
match level with
119
Added:
| 1 -> HTML.h1
120
Added:
| 2 -> HTML.h2
121
Added:
| 3 -> HTML.h3
122
Added:
| 4 -> HTML.h4
123
Added:
| 5 -> HTML.h5
124
Added:
| _ -> HTML.h6
125
Added:
in
126
Added:
element (opt_class class_) children
127
Added:
128
Added:
(** {1 Lists} *)
129
Added:
130
Added:
let items ?id ?class_ children = HTML.ul (opt_id id @ opt_class class_) children
131
Added:
132
Added:
let item ?class_ ?(current = false) children =
133
Added:
HTML.li (opt_class class_ @ flag_current current) children
134
Added:
135
Added:
(** A list built from values, saving callers a [List.map]. *)
136
Added:
let items_of ?id ?class_ render values =
137
Added:
items ?id ?class_ (List.map render values)
138
Added:
139
Added:
(** {1 Badges} *)
140
Added:
141
Added:
(** A small rounded label. [variant] is appended to the base class as
142
Added:
[<base> <base>-<variant>] so a stylesheet can colour each kind. [href] turns
143
Added:
the label's text into a link while leaving the badge itself inert. *)
144
Added:
let badge ?(base_class = "badge") ?variant ?href value =
145
Added:
let classes =
146
Added:
match variant with
147
Added:
| None -> base_class
148
Added:
| Some variant -> Printf.sprintf "%s %s-%s" base_class base_class variant
149
Added:
in
150
Added:
let body =
151
Added:
match href with
152
Added:
| None -> [ text value ]
153
Added:
| Some href -> [ link ~href [ text value ] ]
154
Added:
in
155
Added:
inline ~class_:classes body
156
Added:
157
Added:
(** {1 Time} *)
158
Added:
159
Added:
(** A machine-readable timestamp: [machine] fills the [datetime] attribute,
160
Added:
[display] is the visible text. *)
161
Added:
let timestamp ~machine display =
162
Added:
HTML.time [ HTML.datetime "%s" machine ] [ text display ]
163
Added:
164
Added:
(** {1 Definition lists} *)
165
Added:
166
Added:
(** Term/description pairs, for metadata panels. *)
167
Added:
let definitions ?class_ pairs =
168
Added:
let entry (term, description) =
169
Added:
group [ HTML.dt [] [ text term ]; HTML.dd [] description ]
170
Added:
in
171
Added:
HTML.dl (opt_class class_) (List.map entry pairs)
172
Added:
173
Added:
(** {1 Disclosure} *)
174
Added:
175
Added:
(** Decorative open/close indicator, rotated by CSS from the enclosing
176
Added:
[details]. It carries no textual meaning, so it is hidden from assistive
177
Added:
technology. *)
178
Added:
let chevron ?(class_ = "tree-chevron") () =
179
Added:
inline ~class_ ~decorative:true [ text "\xe2\x80\xba" ]
180
Added:
181
Added:
(** A native disclosure widget: [details] wrapping a clickable [summary] and its
182
Added:
panel. No JavaScript involved.
183
Added:
184
Added:
@param expanded renders the panel open on load.
185
Added:
@param summary the always-visible header contents.
186
Added:
@param children the panel contents, revealed when open. *)
187
Added:
let disclosure ?class_ ?(expanded = false) ?summary_class ~summary children =
188
Added:
HTML.details
189
Added:
(opt_class class_ @ flag_open expanded)
190
Added:
(HTML.summary (opt_class summary_class) summary :: children)
191
Added:
192
Added:
(** A CSS-only toggle: a visually hidden checkbox paired with a [label] acting
193
Added:
as its control. Lets stylesheets reveal and collapse content without
194
Added:
scripting. *)
195
Added:
let css_toggle ~id:toggle_id ~toggle_class ~control_class ~label:control_label
196
Added:
~glyph () =
197
Added:
group
198
Added:
[
199
Added:
HTML.input
200
Added:
[
201
Added:
HTML.type_ "checkbox";
202
Added:
HTML.id "%s" toggle_id;
203
Added:
HTML.class_ "%s" toggle_class;
204
Added:
];
205
Added:
HTML.label
206
Added:
[
207
Added:
HTML.for_ "%s" toggle_id;
208
Added:
HTML.class_ "%s" control_class;
209
Added:
Aria.label "%s" control_label;
210
Added:
]
211
Added:
[ text glyph ];
212
Added:
]
213
Added:
214
Added:
(** {1 Trees} *)
215
Added:
216
Added:
(** A leaf row in a hierarchical list.
217
Added:
218
Added:
@param modifier a class added alongside the base [tree-file] class. *)
219
Added:
let tree_leaf ?(modifier = "") ~href label =
220
Added:
item ~class_:(classes [ "tree-file"; modifier ]) [ text_link ~href label ]
221
Added:
222
Added:
(** A branch row in a hierarchical list.
223
Added:
224
Added:
Renders a disclosure inside the list item: the summary holds a chevron and a
225
Added:
link, the panel holds the nested list. Clicking the summary padding or the
226
Added:
chevron toggles; clicking the link navigates. Every nested collection on a
227
Added:
site therefore gets the same keyboard and pointer behaviour.
228
Added:
229
Added:
@param modifier a class added alongside the base [tree-dir] class.
230
Added:
@param expanded renders the nested list open on load. *)
231
Added:
let tree_branch ?(modifier = "") ?(expanded = false) ~href label children =
232
Added:
item
233
Added:
~class_:(classes [ "tree-dir"; modifier ])
234
Added:
[
235
Added:
disclosure ~expanded ~summary_class:"tree-toggle"
236
Added:
~summary:[ chevron (); text_link ~class_:"tree-link" ~href label ]
237
Added:
[ items ~class_:"tree-nested" children ];
238
Added:
]
239
Added:
240
Added:
(** A row standing in for entries omitted from a truncated list. *)
241
Added:
let tree_more ?(class_ = "tree-overflow") ~href label =
242
Added:
item ~class_ [ text_link ~href label ]
243
Added:
244
Added:
(** {1 Breadcrumbs} *)
245
Added:
246
Added:
type crumb = { crumb_text : string; crumb_href : string option }
247
Added:
(** One step in a trail. A crumb without an href renders as plain text. *)
248
Added:
249
Added:
let crumb ?href text = { crumb_text = text; crumb_href = href }
250
Added:
251
Added:
(** A trail of links joined by a separator.
252
Added:
253
Added:
@param separator_decorative
254
Added:
hides the separators from assistive technology. Appropriate when the trail
255
Added:
already reads as a list of links; leave it off when the separator carries
256
Added:
meaning, such as a path delimiter worth reading aloud. *)
257
Added:
let breadcrumb ?id ?class_ ?link_class ?separator_class
258
Added:
?(separator_decorative = false) ~separator crumbs =
259
Added:
let render index { crumb_text; crumb_href } =
260
Added:
let body =
261
Added:
match crumb_href with
262
Added:
| Some href -> text_link ?class_:link_class ~href crumb_text
263
Added:
| None -> inline_text ?class_:link_class crumb_text
264
Added:
in
265
Added:
if index = 0 then body
266
Added:
else
267
Added:
group
268
Added:
[
269
Added:
inline_text ?class_:separator_class ~decorative:separator_decorative
270
Added:
separator;
271
Added:
body;
272
Added:
]
273
Added:
in
274
Added:
HTML.span (opt_id id @ opt_class class_) (List.mapi render crumbs)
275
Added:
276
Added:
(** {1 Navigation} *)
277
Added:
278
Added:
type nav_link = { nav_href : string; nav_text : string; nav_current : bool }
279
Added:
280
Added:
let nav_link ?(current = false) ~href text =
281
Added:
{ nav_href = href; nav_text = text; nav_current = current }
282
Added:
283
Added:
(** A navigation landmark. [label] names it for assistive technology, which
284
Added:
matters as soon as a page has more than one. *)
285
Added:
let navigation ?id ?class_ ~label children =
286
Added:
HTML.nav (opt_id id @ opt_class class_ @ [ Aria.label "%s" label ]) children
287
Added:
288
Added:
(** A list of navigation links; the current page's item carries
289
Added:
[aria-current="page"]. *)
290
Added:
let nav_links ?id ?class_ ?item_class links =
291
Added:
let render { nav_href; nav_text; nav_current } =
292
Added:
item ?class_:item_class ~current:nav_current
293
Added:
[ text_link ~href:nav_href nav_text ]
294
Added:
in
295
Added:
items ?id ?class_ (List.map render links)
296
Added:
297
Added:
(** {1 Toolbars} *)
298
Added:
299
Added:
(** A bar of controls acting on the current page. An empty toolbar renders
300
Added:
nothing, so layout offsets that depend on its presence stay consistent. *)
301
Added:
let toolbar ?id ?class_ ?label children =
302
Added:
match children with
303
Added:
| [] -> nothing
304
Added:
| _ ->
305
Added:
HTML.div
306
Added:
(opt_id id @ opt_class class_
307
Added:
@ [ HTML.role `toolbar ]
308
Added:
@ opt_aria_label label)
309
Added:
children
310
Added:
311
Added:
(** A link styled as a toolbar button. Still a link, not a [button], because it
312
Added:
navigates rather than acting on the current page — which keeps middle-click
313
Added:
and "open in new tab" working. *)
314
Added:
let button_link ?(class_ = "toolbar-button") ?label ~href text =
315
Added:
text_link ~class_ ?label ~href text
316
Added:
317
Added:
(** An active filter together with a control that removes it.
318
Added:
319
Added:
@param value_class styles the displayed value.
320
Added:
@param dismiss_label accessible name of the remove control. *)
321
Added:
let dismissible ?(class_ = "toolbar-filter")
322
Added:
?(dismiss_class = "toolbar-dismiss") ~value_class ~dismiss_href
323
Added:
~dismiss_label value =
324
Added:
inline ~class_
325
Added:
[
326
Added:
inline_text ~class_:value_class value;
327
Added:
text_link ~class_:dismiss_class ~label:dismiss_label ~href:dismiss_href
328
Added:
"\xc3\x97";
329
Added:
]
330
Added:
331
Added:
(** {1 Pagination} *)
332
Added:
333
Added:
(** Previous/next controls around a page number.
334
Added:
335
Added:
A missing neighbour renders as an inert, aria-hidden placeholder rather than
336
Added:
disappearing, so the controls keep their position between pages.
337
Added:
338
Added:
The glyphs are decorative; [previous_label] and [next_label] carry the
339
Added:
accessible names. *)
340
Added:
let pagination ?(label = "Pagination") ?(previous_text = "<") ?(next_text = ">")
341
Added:
?(previous_label = "Previous page") ?(next_label = "Next page")
342
Added:
?previous_href ?next_href page =
343
Added:
let control href_opt glyph control_label =
344
Added:
match href_opt with
345
Added:
| Some href ->
346
Added:
text_link ~class_:"pagination-btn" ~label:control_label ~href glyph
347
Added:
| None ->
348
Added:
inline_text ~class_:"pagination-btn pagination-disabled"
349
Added:
~decorative:true glyph
350
Added:
in
351
Added:
navigation ~class_:"toolbar-pagination" ~label
352
Added:
[
353
Added:
control previous_href previous_text previous_label;
354
Added:
HTML.span
355
Added:
[ HTML.class_ "pagination-page"; Aria.current `page ]
356
Added:
[ text (string_of_int page) ];
357
Added:
control next_href next_text next_label;
358
Added:
]
359
Added:
360
Added:
(** {1 Code} *)
361
Added:
362
Added:
(** A line-numbered listing of source text.
363
Added:
364
Added:
Every line gets a stable anchor so single lines can be linked and
365
Added:
highlighted. [anchor_prefix] namespaces those anchors, which is required
366
Added:
when one page shows more than one listing.
367
Added:
368
Added:
Content is emitted verbatim as text; syntax colouring, if any, is a
369
Added:
progressive enhancement layered on top. *)
370
Added:
let code_listing ?id ?class_ ?(anchor_prefix = "") content =
371
Added:
let numbered_line index line =
372
Added:
let number = index + 1 in
373
Added:
let name = Printf.sprintf "%s%d" anchor_prefix number in
374
Added:
[
375
Added:
HTML.a
376
Added:
[
377
Added:
HTML.id "%s" name;
378
Added:
HTML.class_ "line-anchor";
379
Added:
HTML.href "#%s" name;
380
Added:
Aria.label "Line %d" number;
381
Added:
]
382
Added:
[ text (string_of_int number) ];
383
Added:
HTML.span [ HTML.class_ "line" ] [ txt "\t%s\n" line ];
384
Added:
]
385
Added:
in
386
Added:
block ?id ?class_
387
Added:
(String.split_on_char '\n' content |> List.mapi numbered_line |> List.concat)
388
Added:
389
Added:
(** {1 Diffs} *)
390
Added:
391
Added:
(** A viewer for line-oriented change sets. The data types are deliberately
392
Added:
plain so any producer of diffs can feed them. *)
393
Added:
module Diff = struct
394
Added:
type change = Unchanged | Added | Removed
395
Added:
396
Added:
type line = {
397
Added:
before : string; (** line number in the old revision, or [""] *)
398
Added:
after : string; (** line number in the new revision, or [""] *)
399
Added:
change : change;
400
Added:
content : string;
401
Added:
}
402
Added:
403
Added:
type section = { section_heading : string; lines : line list }
404
Added:
405
Added:
type file = {
406
Added:
path : string;
407
Added:
detail : string; (** provenance line, e.g. revision identifiers *)
408
Added:
sections : section list;
409
Added:
note : string option; (** shown instead of sections, e.g. binary files *)
410
Added:
}
411
Added:
412
Added:
let line_node { before; after; change; content } =
413
Added:
let variant, marker, announcement =
414
Added:
match change with
415
Added:
| Unchanged -> ("context", " ", "")
416
Added:
| Added -> ("addition", "+", "Added: ")
417
Added:
| Removed -> ("deletion", "-", "Removed: ")
418
Added:
in
419
Added:
block ~class_:("diff-line " ^ variant)
420
Added:
[
421
Added:
inline_text ~class_:"line-number" before;
422
Added:
inline_text ~class_:"line-number" after;
423
Added:
inline_text ~class_:"diff-marker" ~decorative:true marker;
424
Added:
(* Restores, for screen readers, the meaning the marker conveys
425
Added:
visually. *)
426
Added:
inline_text ~class_:"sr-only" announcement;
427
Added:
inline_text ~class_:"diff-text" content;
428
Added:
]
429
Added:
430
Added:
let section_node { section_heading; lines } =
431
Added:
disclosure ~class_:"diff-hunk" ~expanded:true ~summary_class:"hunk-header"
432
Added:
~summary:[ text section_heading ]
433
Added:
[
434
Added:
block ~class_:"diff-lines-scroll"
435
Added:
[ block ~class_:"diff-lines" (List.map line_node lines) ];
436
Added:
]
437
Added:
438
Added:
let file_node { path; detail; sections; note } =
439
Added:
let body =
440
Added:
match note with
441
Added:
| Some note -> [ paragraph_text ~class_:"binary-diff" note ]
442
Added:
| None -> List.map section_node sections
443
Added:
in
444
Added:
disclosure ~class_:"diff-file" ~expanded:true
445
Added:
~summary_class:"diff-file-header"
446
Added:
~summary:[ text path ]
447
Added:
(block ~class_:"diff-meta" [ text detail ] :: body)
448
Added:
449
Added:
(** Render a change set, or [empty_message] when there is nothing to show. *)
450
Added:
let view ~empty_message = function
451
Added:
| [] -> [ paragraph_text empty_message ]
452
Added:
| files -> List.map file_node files
453
Added:
end
454
Added:
455
Added:
(** {1 Document scaffolding} *)
456
Added:
457
Added:
let meta_viewport =
458
Added:
HTML.meta
459
Added:
[ HTML.name "viewport"; HTML.content "width=device-width, initial-scale=1" ]
460
Added:
461
Added:
let stylesheet href = HTML.link [ HTML.rel "stylesheet"; HTML.href "%s" href ]
462
Added:
463
Added:
let icon ?(media_type = "image/x-icon") href =
464
Added:
HTML.link [ HTML.rel "icon"; HTML.type_ "%s" media_type; HTML.href "%s" href ]
465
Added:
466
Added:
let deferred_script src = HTML.script [ HTML.src "%s" src; HTML.defer ] ""
467
Added:
468
Added:
(** Inline behaviour. Reserved for progressive enhancement: pages must stay
469
Added:
usable when it does not run. *)
470
Added:
let inline_script source = HTML.script [] "%s" source
471
Added:
472
Added:
let document_head ~title:document_title extra =
473
Added:
HTML.head [] (HTML.title [] "%s" document_title :: extra)
474
Added:
475
Added:
(** A link that jumps past repeated navigation, revealed on focus. Expected on
476
Added:
every page for keyboard users. *)
477
Added:
let skip_link ~href label = text_link ~class_:"skip-link" ~href label
478
Added:
479
Added:
let page_header ?id ?class_ children =
480
Added:
HTML.header (opt_id id @ opt_class class_) children
481
Added:
482
Added:
let page_main ?id ?class_ children =
483
Added:
HTML.main (opt_id id @ opt_class class_) children
484
Added:
485
Added:
let page_footer ?class_ children = HTML.footer (opt_class class_) children
486
Added:
let document_body ?class_ children = HTML.body (opt_class class_) children
487
Added:
488
Added:
let document ?(lang = "en") ~head ~body () =
489
Added:
HTML.html [ HTML.lang "%s" lang ] [ head; body ]
490
Added:
491
Added:
(** {1 Responses} *)
492
Added:
493
Added:
let respond ?status page =
494
Added:
match status with
495
Added:
| None -> Dream_html.respond page
496
Added:
| Some status -> Dream_html.respond ~status page