Something went wrong. Try again.
static-site-generator blogging hypertext ocaml
Something went wrong. Try again.
8.3 kB · 280 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281(* * SPDX-FileCopyrightText: 2024 The Forester Project Contributors * SPDX-FileCopyrightText: 2026 The Forester Project Contributors * * SPDX-License-Identifier: GPL-3.0-or-later *)
open Forester_prelude
open struct module T = Types module R = Resolver include Baseend
type exports = (R.P.data, Grace.Range.t option) Trie.t
type loaded = unittype document = Lsp.Text_document.ttype parsed = Code.ttype expanded = {nodes: Syn.t; code: Code.t; units: exports}type evaluated = { resource: T.content T.resource; route_locally: bool; include_in_manifest: bool; expanded: expanded option;}
type 'a tag = | Loaded : loaded tag | Parsed : parsed tag | Expanded : expanded tag | Evaluated : evaluated tag
type 'a tree = {phase: 'a tag; tree: 'a; document: document option}
type t = Tree : 'a tree -> t
type source = [`String of Grace.Source.string_source]
let document_to_source document = let path = Lsp.Uri.to_path @@ Lsp.Text_document.documentUri document in let content = Lsp.Text_document.text document in `String ({name = Some path; content} : Grace.Source.string_source)
let make_document ~uri content = Lsp.Text_document.make ~position_encoding:`UTF16 {textDocument = {languageId = "forester"; text = content; uri; version = 1}}
let show_source : source -> string = function | `String {name; _} -> Option.fold name ~some:(fun s -> "String " ^ s) ~none:"<anonymous tree (shouldn't happen)>"
let source (Tree {document; _}) = match document with | Some doc -> document_to_source doc | None -> `String {name = None; content = ""}
module Loaded = struct type t = loaded tree let create : document -> t = fun doc -> {tree = (); phase = Loaded; document = Some doc}end
module Parsed = struct type t = parsed tree let create : document:document -> parsed -> t = fun ~document tree -> {tree; phase = Parsed; document = Some document} let nodes ({tree; _} : t) = tree let source : t -> source = function t -> source (Tree t)end
module Expanded = struct type t = expanded tree let create : document:document option -> expanded -> t = fun ~document tree -> {tree; phase = Expanded; document} let nodes {tree = {nodes; _}; _} = nodes let source : t -> source = function t -> source (Tree t)end
module Evaluated = struct type t = evaluated tree let create ?(route_locally = true) ?(include_in_manifest = true) ?expanded ?document (resource : _ T.resource) = let tree = let expanded = Option.map (fun e -> e.tree) expanded in {resource; route_locally; include_in_manifest; expanded} in let document = match document with | Some _ -> document | None -> Option.bind expanded (fun e -> e.document) in {tree; phase = Evaluated; document}
let document {document; _} = documentend
type phase = Phase : 'a tag -> phase
let lsp_uri : t -> Lsp.Uri.t option = function | Tree {document; _} -> Option.map Lsp.Text_document.documentUri document
let path = function | Tree {document; phase; tree} -> begin match phase with | Loaded | Parsed | Expanded -> Lsp.(Uri.to_path @@ Text_document.documentUri @@ Option.get document) | Evaluated -> begin match tree with | {resource; expanded; _} -> begin match expanded with | Some _ -> Lsp.(Uri.to_path @@ Text_document.documentUri @@ Option.get document) | None -> begin match resource with | T.Asset {source; _} -> source | T.Article {frontmatter = {source_path; uri; _}; _} -> begin match source_path with | Some source_path -> source_path | None -> Option.fold uri ~none:"<anonymous>" ~some:URI.to_string end | T.Syndication (Json_blob {blob_uri; _}) -> URI.to_string blob_uri | T.Syndication (Atom_feed {feed_uri; _}) -> URI.to_string feed_uri end end end end
let phase : type a. a tree -> phase = function | {phase; _} -> begin match phase with | Loaded -> Phase Loaded | Parsed -> Phase Parsed | Expanded -> Phase Expanded | Evaluated -> Phase Evaluated end
let document : t -> document option = function Tree {document; _} -> document
let of_doc : Lsp.Text_document.t -> t = fun document -> (* let uri = Lsp.Text_document.documentUri document in *) Tree {phase = Loaded; tree = (); document = Some document}
let get_syn = function | Tree {phase = Expanded; tree; _} -> Some (tree.nodes : Syn.t) | Tree {phase = Evaluated; tree; _} -> Option.map (fun e -> e.nodes) tree.expanded | _ -> None
let resource : t -> T.content T.resource option = function | Tree {phase; tree; _} -> begin match phase with | Loaded -> None | Parsed -> None | Expanded -> None | Evaluated -> Some tree.resource end
let to_expanded : t -> expanded option = function | Tree {phase; tree; _} -> begin match phase with | Expanded -> Some (tree : expanded) | Evaluated -> tree.expanded | _ -> None end
let evaluated : t -> evaluated option = function | Tree {phase; tree; _} -> begin match phase with | Loaded | Parsed | Expanded -> None | Evaluated -> Some tree end
let article : t -> T.content T.article option = function | Tree {phase; tree; _} -> begin match phase with | Loaded | Parsed | Expanded -> None | Evaluated -> begin match tree.resource with T.Article a -> Some a | _ -> None end end
let get_frontmatter : t -> T.content T.frontmatter option = function | Tree {phase; tree; _} -> begin match phase with | Evaluated -> begin match tree with | {resource = Types.Article {frontmatter; _}; _} -> Some frontmatter | _ -> None end | _ -> None end
let code : t -> Code.t tree option = function | Tree ({phase; tree; document} as t) -> begin match phase with | Loaded -> None | Parsed -> Some t | Evaluated -> let@ tree = Option.map @~ tree.expanded in {phase = Parsed; tree = tree.code; document} | Expanded -> Some {phase = Parsed; tree = tree.code; document} end
let nodes : Code.t tree -> Code.t = function {tree; _} -> tree
let syn : t -> expanded tree option = function | Tree {phase; tree; document} -> begin match phase with | Loaded -> None | Parsed -> None | Expanded -> Some {phase = Expanded; tree; document} | Evaluated -> let@ expanded = Option.map @~ tree.expanded in {tree = expanded; phase = Expanded; document} end
let units : t -> exports option = function | Tree {phase; tree; _} -> begin match phase with | Loaded | Parsed -> None | Expanded -> Some tree.units | Evaluated -> Option.map (fun {units; _} -> units) tree.expanded end
let is_parsed = function | Tree {phase; _} -> begin match phase with Loaded -> false | _ -> true end
let is_unparsed = is_parsed >>> not
let is_expanded = function | Tree {phase; _} -> begin match phase with | Loaded | Parsed -> false | Expanded | Evaluated -> true end
let is_unexpanded = is_expanded >>> not
let is_evaluated = function | Tree {phase; _} -> begin match phase with | Loaded | Parsed | Expanded -> false | Evaluated -> true end
let is_unevaluated = is_evaluated >>> not
let is_asset : t -> bool = function | Tree {phase; tree; _} -> begin match phase with | Loaded | Parsed | Expanded -> false | Evaluated -> begin match tree.resource with T.Asset _ -> true | _ -> false end end
let update_units : type a. a tree -> exports -> (a tree, [`Internal_error] Grace.Diagnostic.t) result = fun ({phase; tree; _} as t) units -> match phase with | Loaded | Parsed -> error @@ Grace.Diagnostic.createf Error ~code:`Internal_error "can't update units for this item. It has not been expanded yet" | Expanded -> ok @@ {t with tree = {tree with units}} | Evaluated -> ( match tree.expanded with | None -> error @@ Grace.Diagnostic.createf Error ~code:`Internal_error "can't update units for this item. It is not a tree." | Some expanded -> ok @@ {t with tree = {tree with expanded = Some {expanded with units}}})