summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--forum/author.ur14
-rw-r--r--forum/author.urs8
-rw-r--r--forum/forum.css5
-rw-r--r--forum/forum.ur48
-rw-r--r--forum/lib.urp1
-rw-r--r--forum/myOption.ur4
-rw-r--r--forum/myOption.urs1
-rw-r--r--forum/score.ur5
-rw-r--r--forum/score.urs5
9 files changed, 81 insertions, 10 deletions
diff --git a/forum/author.ur b/forum/author.ur
index f58d4cf..5cbc136 100644
--- a/forum/author.ur
+++ b/forum/author.ur
@@ -57,8 +57,22 @@ val sql_username = sql_prim
fun name uOrA = uOrA
+val nameError = MyOption.getError
+
val orAnonymous = Some
+(* I can't express this in terms of whenIdentified'--I get a "substitution in
+constructor is blocked by a too-deep unification variable." *)
+fun whenIdentified [ctx] [use] uOrA text =
+ case uOrA of
+ None => <xml/>
+ | Some u => text
+
+fun whenIdentified' [ctx] [use] uOrA generator =
+ case uOrA of
+ None => <xml/>
+ | Some u => generator u
+
fun toOptionTag [_use] uOrA =
case uOrA of
None => <xml/>
diff --git a/forum/author.urs b/forum/author.urs
index 1f394f0..db6e7a8 100644
--- a/forum/author.urs
+++ b/forum/author.urs
@@ -43,9 +43,17 @@ val sql_username : sql_injectable username
(******************************** Converting *********************************)
val name : usernameOrAnonymous -> option username
+val nameError : usernameOrAnonymous -> username
val orAnonymous : username -> usernameOrAnonymous
+val whenIdentified : ctx ::: {Unit} -> use ::: {Type} ->
+ usernameOrAnonymous -> xml ctx use [] -> xml ctx use []
+
+val whenIdentified' : ctx ::: {Unit} -> use ::: {Type} ->
+ usernameOrAnonymous -> (username -> xml ctx use [])
+ -> xml ctx use []
+
(* Converts a 'usernameOrAnonymous' to an 'option' tag. If anonymous, produces
empty XML. *)
val toOptionTag : use ::: {Type} -> usernameOrAnonymous -> xml select use []
diff --git a/forum/forum.css b/forum/forum.css
index 4f7b7f2..9193de0 100644
--- a/forum/forum.css
+++ b/forum/forum.css
@@ -27,6 +27,7 @@
}
.Forum_entryMetadata {
+ display: inline;
font-style: italic;
color: hsl(0, 0%, 65%);
}
@@ -44,3 +45,7 @@ li .Forum_entryMetadata {
.Forum_entryBody {
height: 15em;
}
+
+.Forum_voting, .Forum_voting * {
+ display: inline;
+}
diff --git a/forum/forum.ur b/forum/forum.ur
index c43befe..85f3e19 100644
--- a/forum/forum.ur
+++ b/forum/forum.ur
@@ -26,6 +26,7 @@ style entryList
style entryMetadata
style entryTitle
style entryBody
+style voting
table entry : { Id : int,
References : option int,
@@ -40,6 +41,8 @@ table vote : { QuestionId : int,
Author : Author.username,
Value : Score.score
}
+ CONSTRAINT OneVotePerEntry UNIQUE (QuestionId, Author),
+ CONSTRAINT RefersToEntry FOREIGN KEY QuestionId REFERENCES entry(Id)
(* Like query1', but automatically dereferences the field *)
fun queryColumn [tab ::: Name] [field ::: Name] [state ::: Type]
@@ -56,27 +59,51 @@ fun getScore (questionId : int) : transaction Score.score =
Score.update
Score.undecided
+fun recordVote (value : Score.score) (entryId : int) _formData : transaction page =
+ authorOpt <- Author.current;
+ (* If the user didn't exist, the user should not have been allowed to vote
+ in the first place. *)
+ let val author = Author.nameError authorOpt
+ in
+ dml (INSERT INTO vote (QuestionId, Author, Value)
+ VALUES ({[entryId]}, {[author]}, {[value]}));
+ detail entryId
+ end
+
+and upvote entryId _formData = recordVote Score.insightful entryId _formData
+
+
+
(***************************** Single questions ******************************)
-fun detail (id : int) : transaction page =
+and detail (id : int) : transaction page =
authorOpt <- Author.current;
question <- oneRow1 (SELECT * FROM entry
WHERE Entry.Class = {[EntryClass.question]}
AND Entry.Id = {[id]});
- answerBlock <- queryX1 (SELECT * FROM entry
+ score <- getScore id;
+ answerBlock <- queryX1' (SELECT * FROM entry
WHERE Entry.Class = {[EntryClass.answer]}
AND Entry.References = {[Some id]})
(fn answer =>
- <xml><p>
- {[answer.Body]}
- <span class={entryMetadata}>&mdash;{[answer.Author]}</span>
- </p></xml>);
+ score <- getScore answer.Id;
+ return (
+ <xml><p>
+ {[answer.Body]}
+ <span class={entryMetadata}>&mdash;{[answer.Author]} ({[Score.withUnits score "point"]})</span>
+ </p></xml>));
return (
Template.generic (Some "Forum") <xml>
<div class={content}>
<h2>{[question.Title]}</h2>
<p>{[question.Body]}</p>
- <p class={entryMetadata}>Asked by {[question.Author]}</p>
+ <p class={entryMetadata}>
+ Asked by {[question.Author]} ({[Score.withUnits score "point"]})
+ </p>
+ {Author.whenIdentified authorOpt
+ <xml>
+ <form class={voting}><submit action={upvote id} value="⬆" /></form>
+ </xml>}
<div>{answerBlock}</div>
@@ -85,7 +112,7 @@ fun detail (id : int) : transaction page =
<textarea {#Body} class={entryBody} /><br />
Answering as:
<select {#Author}>
- {Author.toOptionTag authorOpt}
+ {Author.whenIdentified' authorOpt (fn u => <xml><option>{[u]}</option></xml>)}
<option>Anonymous</option>
</select>
<submit action={reply id} value="Answer" />
@@ -113,7 +140,7 @@ fun prettyPrintQuestion entry : transaction xbody =
<xml><li>
<h3><a link={detail entry.Id}>{[entry.Title]}</a></h3>
{[entry.Body]}
- <span class={entryMetadata}>Asked by {[entry.Author]}; score {[score]}</span>
+ <span class={entryMetadata}>Asked by {[entry.Author]} ({[Score.withUnits score "point"]})</span>
</li></xml>)
val allQuestions : transaction page =
@@ -153,7 +180,8 @@ fun main () : transaction page =
<textarea {#Body} class={entryBody} /><br />
Asking as:
<select {#Author}>
- {Author.toOptionTag askerOpt}
+ {Author.whenIdentified' askerOpt (fn u =>
+ <xml><option>{[u]}</option></xml>)}
<option>Anonymous</option>
</select>
<submit action={ask} value="Ask" />
diff --git a/forum/lib.urp b/forum/lib.urp
index 77d7073..d313fcd 100644
--- a/forum/lib.urp
+++ b/forum/lib.urp
@@ -6,6 +6,7 @@ rewrite style Main/Forum/* Forum/
rewrite style Main/Forum/ Forum/
$/option
+myOption
$/string
../styles
author
diff --git a/forum/myOption.ur b/forum/myOption.ur
new file mode 100644
index 0000000..e859454
--- /dev/null
+++ b/forum/myOption.ur
@@ -0,0 +1,4 @@
+fun getError [t] maybe =
+ case maybe of
+ None => error <xml>Attempted to extract a value out of a None</xml>
+ | Some v => v
diff --git a/forum/myOption.urs b/forum/myOption.urs
new file mode 100644
index 0000000..890c31b
--- /dev/null
+++ b/forum/myOption.urs
@@ -0,0 +1 @@
+val getError : t ::: Type -> option t -> t
diff --git a/forum/score.ur b/forum/score.ur
index 48bbc01..a966a4d 100644
--- a/forum/score.ur
+++ b/forum/score.ur
@@ -15,3 +15,8 @@ val undecided = 0
val inane = -1
fun toInt s = s
+
+fun withUnits s base =
+ show s ^ " " ^ (case s of
+ 1 => base
+ | _ => base ^ "s")
diff --git a/forum/score.urs b/forum/score.urs
index d3e3e18..616d1b6 100644
--- a/forum/score.urs
+++ b/forum/score.urs
@@ -24,3 +24,8 @@ val update : score -> score -> score
(******************************** Conversion *********************************)
val toInt : score -> int
+
+
+(****************************** Pretty-printing ******************************)
+
+val withUnits : score -> string -> string
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-03 17:27:43 +0000