rm scfg wip
This commit is contained in:
parent
8c2c90b3c2
commit
872cf1b72f
13 changed files with 156 additions and 343 deletions
|
|
@ -1,4 +1,4 @@
|
|||
version=0.27.0
|
||||
version=0.28.1
|
||||
assignment-operator=end-line
|
||||
break-cases=fit
|
||||
break-fun-decl=wrap
|
||||
|
|
|
|||
52
geochan.opam
52
geochan.opam
|
|
@ -1,53 +1,44 @@
|
|||
# This file is generated by dune, edit dune-project instead
|
||||
opam-version: "2.0"
|
||||
synopsis: "A geo-imageboard written in OCaml"
|
||||
description:
|
||||
"Geochan is an open source imageboard with threads pinned to a geolocation."
|
||||
maintainer: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
|
||||
authors: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
|
||||
synopsis: "OCaml library/executable to TODO"
|
||||
description: "geochan is an OCaml library/executable to TODO."
|
||||
authors: ["swrup <swrup@protonmail.com>"]
|
||||
license: "AGPL-3.0-or-later"
|
||||
tags: [
|
||||
"imageboard"
|
||||
"forum"
|
||||
"map"
|
||||
"leaflet"
|
||||
"single-page-application"
|
||||
"functional-reactive-programming"
|
||||
"permap" "forum" "map" "local-knownledge" "ecology" "permaculture" "plant"
|
||||
]
|
||||
homepage: "https://git.zapashcanon.fr/zapashcanon/geochan"
|
||||
doc: "https://doc.zapashcanon.fr/geochan"
|
||||
bug-reports: "https://git.zapashcanon.fr/zapashcanon/geochan/issues"
|
||||
depends: [
|
||||
"dune" {>= "3.0"}
|
||||
"bos"
|
||||
"dune" {>= "2.8"}
|
||||
"dream"
|
||||
"lwt"
|
||||
"yojson"
|
||||
"brr"
|
||||
"leaflet"
|
||||
"js_of_ocaml"
|
||||
"uuidm"
|
||||
"scfg"
|
||||
"crunch"
|
||||
"safepass"
|
||||
"omd"
|
||||
"lambdasoup"
|
||||
"bos"
|
||||
"caqti"
|
||||
"caqti-driver-sqlite3"
|
||||
"conan"
|
||||
"conan-database"
|
||||
"crunch"
|
||||
"data-encoding"
|
||||
"digestif"
|
||||
"directories"
|
||||
"dream"
|
||||
"dream-pure"
|
||||
"emile"
|
||||
"fmt"
|
||||
"fpath"
|
||||
"htmlit"
|
||||
"js_of_ocaml"
|
||||
"leaflet"
|
||||
"lwt"
|
||||
"note"
|
||||
"lambdasoup"
|
||||
"omd"
|
||||
"safepass"
|
||||
"scfg"
|
||||
"uri"
|
||||
"uuidm"
|
||||
"alcotest" {with-test}
|
||||
"re" {with-test}
|
||||
"ocamlformat" {with-dev-setup}
|
||||
"prelude"
|
||||
"ocaml" {>= "5.1"}
|
||||
"yojson"
|
||||
"ocaml" {>= "4.08"}
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
|
|
@ -64,4 +55,3 @@ build: [
|
|||
"@doc" {with-doc}
|
||||
]
|
||||
]
|
||||
dev-repo: "git+https://git.zapashcanon.fr/zapashcanon/geochan.git"
|
||||
|
|
|
|||
|
|
@ -123,7 +123,6 @@ let add_user_404 id =
|
|||
| _ -> session
|
||||
in
|
||||
update_session session;
|
||||
begin
|
||||
match find_user id with Some _ -> update_user None | None -> ()
|
||||
begin match find_user id with Some _ -> update_user None | None -> ()
|
||||
end;
|
||||
()
|
||||
|
|
|
|||
|
|
@ -148,9 +148,7 @@ let mk_comment_div t_s =
|
|||
t_s
|
||||
|> S.changes
|
||||
|> E.filter_map (fun rf ->
|
||||
match rf.Post_form_data.is_open with
|
||||
| false -> None
|
||||
| true -> Some true )
|
||||
match rf.Post_form_data.is_open with false -> None | true -> Some true )
|
||||
in
|
||||
Elr.set_has_focus ~on:focus_e textarea;
|
||||
El.div ~at:[ class' "comment-input-div" ] [ label; textarea ]
|
||||
|
|
@ -258,9 +256,7 @@ let profile user =
|
|||
user.avatar_info
|
||||
|> Option.map (fun _ ->
|
||||
let input_el =
|
||||
El.input
|
||||
~at:[ type' "hidden"; name "delete-avatar"; value "" ]
|
||||
()
|
||||
El.input ~at:[ type' "hidden"; name "delete-avatar"; value "" ] ()
|
||||
in
|
||||
let btn = mk_btn "delete current avatar" in
|
||||
mk ~btn [ input_el ] )
|
||||
|
|
|
|||
|
|
@ -258,8 +258,7 @@ let do_action : Client_types.action -> t -> t =
|
|||
let quickview =
|
||||
opt |> Option.map (fun (rect, v) -> (rect, Loading v)) |> load_quickview
|
||||
in
|
||||
begin
|
||||
match quickview with
|
||||
begin match quickview with
|
||||
| Some (_, Loading post_id) -> Network.GET.post post_id
|
||||
| _ -> ()
|
||||
end;
|
||||
|
|
@ -270,8 +269,7 @@ let do_action : Client_types.action -> t -> t =
|
|||
let do_data_update : Client_types.data_update -> t -> t =
|
||||
fun action t ->
|
||||
Fmt.pr {|do data update: "%a"@.|} pp_data_update action;
|
||||
begin
|
||||
match action with
|
||||
begin match action with
|
||||
| Post_update v -> Db.add_post v
|
||||
| Thread_update thread_w_reply ->
|
||||
Db.update_thread_w_reply (Some thread_w_reply)
|
||||
|
|
|
|||
|
|
@ -72,8 +72,7 @@ let on_link_click () =
|
|||
let navigation_handler ev =
|
||||
(* TODO rm magick if possible *)
|
||||
let el : El.t = Obj.magic (Ev.target ev) in
|
||||
begin
|
||||
if Jstr.equal (El.tag_name el) (Jstr.v "a") then
|
||||
begin if Jstr.equal (El.tag_name el) (Jstr.v "a") then
|
||||
match El.at (Jstr.v "href") el with
|
||||
| None -> Fmt.failwith "<a> element with no href"
|
||||
| Some href -> begin
|
||||
|
|
|
|||
|
|
@ -81,8 +81,7 @@ module GET = struct
|
|||
fun req v ->
|
||||
let open Client_types in
|
||||
let open Events in
|
||||
begin
|
||||
match req with
|
||||
begin match req with
|
||||
| Catalog -> send_data_update (Catalog_update v)
|
||||
| Thread _id -> send_data_update (Thread_update v)
|
||||
| Post _id -> send_data_update (Post_update v)
|
||||
|
|
@ -155,8 +154,7 @@ module POST = struct
|
|||
fun o v ->
|
||||
let open Client_types in
|
||||
let open Events in
|
||||
begin
|
||||
match o with
|
||||
begin match o with
|
||||
| Home ->
|
||||
send_data_update (Thread_update v);
|
||||
send_action (Post_form_change Form_reset);
|
||||
|
|
|
|||
|
|
@ -1,170 +1,3 @@
|
|||
(* TODO
|
||||
custom parameter type
|
||||
print a scfg
|
||||
handle failures *)
|
||||
module M = struct
|
||||
open Scfg
|
||||
|
||||
type nil = NIL
|
||||
|
||||
type dir
|
||||
|
||||
type param
|
||||
|
||||
type ('a, 'b) directive =
|
||||
{ name : string
|
||||
; params : 'a
|
||||
; children : 'b
|
||||
}
|
||||
|
||||
type ('r, _) t =
|
||||
| Bool : (param, bool) t
|
||||
| Int : (param, int) t
|
||||
| Float : (param, float) t
|
||||
| String : (param, string) t
|
||||
| Directive :
|
||||
(string * (param, 'a) t_list * (dir, 'b) t_list)
|
||||
-> (dir, ('a, 'b) directive) t
|
||||
| Leaf : (string * (param, 'a) t_list) -> (dir, ('a, nil) directive) t
|
||||
|
||||
and ('r, _) t_list =
|
||||
| Nil : ('r, nil) t_list
|
||||
| One : ('r, 'a) t -> ('r, 'a) t_list
|
||||
| Cons : (('r, 'a) t * ('r, 'b) t_list) -> ('r, 'a * 'b) t_list
|
||||
|
||||
let error () = Fmt.failwith "invalid schema"
|
||||
|
||||
let conv_param : type a. (param, a) t -> string -> a =
|
||||
fun param_t v ->
|
||||
try
|
||||
match param_t with
|
||||
| Bool -> bool_of_string v
|
||||
| Int -> int_of_string v
|
||||
| Float -> float_of_string v
|
||||
| String -> v
|
||||
with Invalid_argument _ -> error ()
|
||||
|
||||
let rec conv_param_list : type a. (param, a) t_list -> string list -> a =
|
||||
fun param_l_t l ->
|
||||
match param_l_t with
|
||||
| Nil -> ( match l with [] -> NIL | _ -> error () )
|
||||
| One k -> ( match l with [ hd ] -> conv_param k hd | _ -> error () )
|
||||
| Cons (k, k_l) -> (
|
||||
match l with
|
||||
| [] -> error ()
|
||||
| hd :: tl -> (conv_param k hd, conv_param_list k_l tl) )
|
||||
|
||||
let rec conv_dir : type a. (dir, a) t -> Types.directive -> a =
|
||||
fun dir_t dir ->
|
||||
match dir_t with
|
||||
| Directive (name, params, children) -> (
|
||||
match String.equal name dir.name with
|
||||
| false -> error ()
|
||||
| true ->
|
||||
{ name
|
||||
; params = conv_param_list params dir.params
|
||||
; children = conv children dir.children
|
||||
} )
|
||||
| Leaf (name, params) -> (
|
||||
match String.equal name dir.name with
|
||||
| false -> error ()
|
||||
| true ->
|
||||
{ name; params = conv_param_list params dir.params; children = NIL } )
|
||||
|
||||
and conv : type a. (dir, a) t_list -> Types.config -> a =
|
||||
fun dir_l_t l ->
|
||||
match dir_l_t with
|
||||
| Nil -> ( match l with [] -> NIL | _ -> error () )
|
||||
| One k -> ( match l with [ hd ] -> conv_dir k hd | _ -> error () )
|
||||
| Cons (k, k_l) -> (
|
||||
match l with [] -> error () | hd :: tl -> (conv_dir k hd, conv k_l tl) )
|
||||
|
||||
let ( @^ ) = fun a b -> Cons (a, b)
|
||||
|
||||
let ( @+ ) = fun a b -> Cons (a, One b)
|
||||
|
||||
let ( !@ ) = fun a -> One a
|
||||
|
||||
let directive : type a b.
|
||||
string
|
||||
-> (param, a) t_list
|
||||
-> (dir, b) t_list
|
||||
-> (dir, (a, b) directive) t =
|
||||
fun name params children -> Directive (name, params, children)
|
||||
|
||||
let leaf : type a. string -> (param, a) t_list -> (dir, (a, nil) directive) t
|
||||
=
|
||||
fun name params -> Leaf (name, params)
|
||||
end
|
||||
|
||||
module M_test = struct
|
||||
open M
|
||||
|
||||
module Uuu = struct
|
||||
module Pp = struct
|
||||
let hide_data : (param, 'a) t * ('a ) -> (param, 'a) t =
|
||||
fun (t, _v) ->
|
||||
|
||||
let ( @^ ) = fun a b -> Cons (hide_data a, b)
|
||||
|
||||
let ( @+ ) = fun a b -> Cons (hide_data a, One (hide_data b))
|
||||
|
||||
let ( !@ ) = fun a -> One (hide_data a)
|
||||
end
|
||||
|
||||
open Pp
|
||||
|
||||
let sch = !@(leaf "cc" (!@ (String, "uu" ) ) )
|
||||
end
|
||||
|
||||
let schema_1 = !@(leaf "cc" !@String)
|
||||
|
||||
let schema_2 =
|
||||
!@(directive "salut" (String @^ Bool @+ Float) !@(leaf "euj" !@Int))
|
||||
|
||||
let schema_3 = leaf "cc" !@String @^ leaf "cc" !@String @+ leaf "cc" !@String
|
||||
|
||||
let txt_1 = Scfg.Parse.from_string {|cc param_1
|
||||
|} |> Result.get_ok
|
||||
|
||||
let txt_2 =
|
||||
Scfg.Parse.from_string
|
||||
{|salut param_str true 0.46 {
|
||||
euj 3456
|
||||
}
|
||||
|}
|
||||
|> Result.get_ok
|
||||
|
||||
let txt_3 =
|
||||
Scfg.Parse.from_string {|cc sava
|
||||
cc sava
|
||||
cc sava
|
||||
|}
|
||||
|> Result.get_ok
|
||||
|
||||
let () =
|
||||
let v_1 = conv schema_1 txt_1 in
|
||||
let { name; params; children } = v_1 in
|
||||
assert (name = "cc");
|
||||
assert (params = "param_1");
|
||||
assert (children = NIL);
|
||||
|
||||
let v_2 = conv schema_2 txt_2 in
|
||||
let { name; params; children } = v_2 in
|
||||
assert (name = "salut");
|
||||
assert (params = ("param_str", (true, 0.46)));
|
||||
assert (children.name = "euj");
|
||||
assert (children.params = 3456);
|
||||
|
||||
let v_3 = conv schema_3 txt_3 in
|
||||
let dir1, (dir2, dir3) = v_3 in
|
||||
assert (dir1 = dir2);
|
||||
assert (dir2 = dir3);
|
||||
()
|
||||
end
|
||||
|
||||
(* ------ *)
|
||||
|
||||
type _ tag =
|
||||
| String : string tag
|
||||
| Bool : bool tag
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue