1 (** Ogit's vocabulary of page parts. 2 3 Where {!Ui} supplies generic building blocks, this module names the parts 4 specific to a Git browser and wires them to {!Routes}, so page modules can 5 describe a page without mentioning HTML or URL strings. 6 7 Every function returns a {!Ui.node}. Nothing here performs I/O. *) 8 9 (** {1 Page identity} *) 10 11 type page = 12 | Summary 13 | Commits 14 | Files 15 (** Which repository page is being shown. Drives the [aria-current] marker 16 in the navigation. *) 17 18 type site = { user_name : string; root_title : string; nav_logo : string } 19 (** Site-wide presentation settings, resolved once from configuration. *) 20 21 let site ~user_name ~root_title ~nav_logo = { user_name; root_title; nav_logo } 22 23 (** {1 Routes as links} *) 24 25 let url route = Routes.path_of route 26 27 (** A link to a route, with the route standing in for a hand-written URL. *) 28 let route_link ?class_ ?label route text = 29 Ui.text_link ?class_ ?label ~href:(url route) text 30 31 (** The commit list is narrowed through query parameters, which {!Routes} does 32 not model because it covers path-shaped routes only. Passing the filters 33 already in effect keeps them applied as the reader pages or switches 34 filters. *) 35 let commits_url ?filter_type ?author ?committer ?(page_number = 1) repo = 36 let params = 37 (if page_number > 1 then [ ("page", string_of_int page_number) ] else []) 38 @ (match filter_type with Some value -> [ ("type", value) ] | None -> []) 39 @ (match author with Some value -> [ ("author", value) ] | None -> []) 40 @ match committer with Some value -> [ ("committer", value) ] | None -> [] 41 in 42 let base = Printf.sprintf "/%s/commits/" repo in 43 match params with 44 | [] -> base 45 | _ -> base ^ "?" ^ Dream.to_form_urlencoded params 46 47 (** Where a repository's clone URL lives. *) 48 let clone_url repo = Printf.sprintf "/%s" repo 49 50 (** {1 Navigation} *) 51 52 let page_route repo = function 53 | Summary -> Routes.Repo repo 54 | Commits -> Routes.Commits repo 55 | Files -> Routes.Files repo 56 57 let page_name = function 58 | Summary -> "Summary" 59 | Commits -> "Commits" 60 | Files -> "Files" 61 62 let page_link repo ~active page = 63 Ui.nav_link ~current:(page = active) 64 ~href:(url (page_route repo page)) 65 (page_name page) 66 67 (** Configured logos may be given as bare paths; make those root-relative while 68 leaving absolute and data URLs alone. *) 69 let asset_url source = 70 if 71 String.starts_with ~prefix:"/" source 72 || String.starts_with ~prefix:"http://" source 73 || String.starts_with ~prefix:"https://" source 74 || String.starts_with ~prefix:"data:" source 75 then source 76 else "/" ^ source 77 78 let logo ~href ~alt source = 79 Ui.link ~id:"nav-logo" ~href 80 [ Ui.image ~class_:"site-logo" ~alt ~src:(asset_url source) () ] 81 82 (** Top navigation away from any repository: the repository list and project 83 directory pages. When [home_href] is absent the page {i is} the list, so the 84 logo points outward instead of back to itself. *) 85 let site_nav ~title ~logo:source ?home_href () = 86 let logo_href, logo_alt = 87 match home_href with 88 | None -> ("https://git-scm.com", "Git website") 89 | Some _ -> ("/", "Repository list") 90 in 91 Ui.navigation ~id:"top" ~label:"Site navigation" 92 [ 93 logo ~href:logo_href ~alt:logo_alt source; 94 Ui.text_link ~id:"nav-home" 95 ~href:(Option.value home_href ~default:"/") 96 title; 97 ] 98 99 (** Top navigation within a repository. The link list collapses behind a 100 CSS-only control on narrow viewports. *) 101 let repo_nav ~active ~logo:source repo = 102 let project_name = 103 match String.split_on_char '/' repo |> List.rev with 104 | last :: _ -> last 105 | [] -> repo 106 in 107 Ui.navigation ~id:"top" ~label:"Repository navigation" 108 [ 109 logo ~href:"/" ~alt:"Repository list" source; 110 Ui.text_link ~id:"nav-home" ~href:(url (Routes.Repo repo)) project_name; 111 Ui.css_toggle ~id:"nav-toggle" ~toggle_class:"nav-toggle" 112 ~control_class:"nav-hamburger" ~label:"Menu" ~glyph:"\xe2\x8b\xae" (); 113 Ui.nav_links ~id:"nav-links" 114 (List.map (page_link repo ~active) [ Summary; Commits; Files ]); 115 ] 116 117 (** The same repository destinations as {!repo_nav}, condensed and pinned to the 118 bottom of the viewport. CSS reveals it on narrow viewports, where the top 119 link list is hidden. 120 121 Named for its form rather than for a device: the viewport width decides when 122 it appears, and this module has no notion of what hardware is in use. *) 123 let compact_repo_nav ~active repo = 124 Ui.navigation ~id:"bottom-nav" ~label:"Compact navigation" 125 [ 126 Ui.nav_links ~id:"bottom-nav-links" ~item_class:"bottom-nav-item" 127 (List.map (page_link repo ~active) [ Summary; Commits; Files ]); 128 ] 129 130 (** {1 Toolbar} *) 131 132 let toolbar children = 133 Ui.toolbar ~id:"toolbar" ~label:"Repository toolbar" children 134 135 (** {1 Trees} *) 136 137 (** A directory row that both expands in place and links to its own page. *) 138 let directory ?modifier ~route ~name children = 139 Ui.tree_branch ?modifier ~href:(url route) (name ^ "/") children 140 141 let file_entry ?modifier ~route name = 142 Ui.tree_leaf ?modifier ~href:(url route) name 143 144 (** The row closing a truncated listing, linking to the full contents. *) 145 let overflow_row ~route count = 146 Ui.tree_overflow ~href:(url route) (Printf.sprintf "%d more items..." count) 147 148 (** {1 Sections} *) 149 150 (** A collapsible group of repositories on the root page. *) 151 let group ?expanded ~title children = 152 Ui.disclosure ?expanded ~summary_class:"section-toggle" 153 ~summary:[ Ui.chevron (); Ui.heading [ Ui.text title ] ] 154 children 155 156 (** {1 Inline pieces} *) 157 158 (** A conventional-commit type, coloured per type and linking to the filtered 159 commit list. *) 160 let commit_type_badge ?href commit_type = 161 Ui.badge ~base_class:"commit-pill" ~variant:commit_type ?href commit_type 162 163 (** A README displayed as semantic documentation. 164 165 Markdown and Org mode receive dedicated rendering; other README filenames 166 use the Markdown-compatible fallback until additional formats are added. *) 167 let inline_readme ?(filename = "README.md") content = 168 Prose.Render.render ~filename content 169