Merge branch 'release/v1.10'

4 files changed, 236 insertions, 90 deletions

diff --git a/src/pronouns/config.clj b/src/pronouns/config.clj
new file mode 100644
index 0000000..b0c83d5
--- /dev/null
+++ b/src/pronouns/config.clj
@@ -0,0 +1,21 @@
+;; pronoun.is - a website for pronoun usage examples
+;; Copyright (C) 2014 - 2016 Morgan Astra
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>
+
+(ns pronouns.config
+  (:require [pronouns.util :as u]))
+
+(def ^:dynamic *pronouns-table*
+  (u/slurp-tabfile "resources/pronouns.tab"))
diff --git a/src/pronouns/pages.clj b/src/pronouns/pages.clj
index 3e63437..60175c9 100644
--- a/src/pronouns/pages.clj
+++ b/src/pronouns/pages.clj
@@ -1,9 +1,30 @@
+;; pronoun.is - a website for pronoun usage examples
+;; Copyright (C) 2014 - 2016 Morgan Astra
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>
+
 (ns pronouns.pages
   (:require [clojure.string :as s]
+            [pronouns.config :refer [*pronouns-table*]]
             [pronouns.util :as u]
             [hiccup.core :refer :all]
             [hiccup.util :refer [escape-html]]))
 
+(defn href
+  [url text]
+  [:a {:href url} text])
+
 (defn wrap-pronoun
   [pronoun]
   [:b pronoun])
@@ -38,68 +59,75 @@
                    "."))
 
 (defn title-block [title]
-  [:div {:class "title"}
+  [:div {:class "section title"}
    [:h1 title]])
 
 (defn examples-block
   [subject object possessive-determiner possessive-pronoun reflexive]
-  [:div {:class "examples"}
-   [:p [:h2 "Here are some usage examples for my pronouns:"]]
-   (subject-example subject)
-   (object-example object)
-   (posessive-determiner-example subject possessive-determiner)
-   (possessive-pronoun-example possessive-pronoun)
-   (reflexive-example subject reflexive)])
+  (let [sub-obj (str subject "/" object)
+        header-str (str "Here are some usage examples for my "
+                        sub-obj
+                        " pronouns")]
+    [:div {:class "section examples"}
+     [:h2 header-str]
+     [:p (subject-example subject)
+         (object-example object)
+         (posessive-determiner-example subject possessive-determiner)
+         (possessive-pronoun-example possessive-pronoun)
+         (reflexive-example subject reflexive)]]))
 
 (defn about-block []
-  [:div {:class "about"}
+  [:div {:class "section about"}
    [:p "Full usage: "
-    [:tt "http://pronoun.is/subject-pronoun/object-pronoun/possessive-determiner/possessive-pronoun/reflexive"]
-    " displays examples of your pronouns."]
+       [:tt "http://pronoun.is/subject-pronoun/object-pronoun/possessive-determiner/possessive-pronoun/reflexive"]
+       " displays examples of your pronouns."]
    [:p "This is a bit unwieldy. If we have a good guess we'll let you use just the first one or two."]])
 
 (defn contact-block []
-  (let [twitter-name (fn [handle] [:a {:href (str "https://www.twitter.com/" handle)} (str "@" handle)])]
-  [:div {:class "contact"}
-   [:p
-    "Written by "
-    (twitter-name "morganastra")
-    ", whose "
-    [:a {:href "http://pronoun.is/ze/zir"} "pronoun.is/ze/zir"]
-    ". "
-   "Visit the project on " [:a {:href "https://github.com/witch-house/pronoun.is"} "github!"]]]))
-
+  (let [twitter-name (fn [handle] (href (str "https://www.twitter.com/" handle)
+                                       (str "@" handle)))]
+    [:div {:class "section contact"}
+     [:p "Written by "
+         (twitter-name "morganastra")
+         ", whose "
+         (href "http://pronoun.is/ze/zir?or=she" "pronoun.is/ze/zir?or=she")]
+     [:p "pronoun.is is free software under the "
+         (href "https://www.gnu.org/licenses/agpl.html" "AGPLv3")
+         "! visit the project on "
+         (href "https://github.com/witch-house/pronoun.is" "github")]
+     [:p "<3"]]))
+
+(defn footer-block []
+  [:footer (about-block) (contact-block)])
 
 (defn format-pronoun-examples
-  [subject object possessive-determiner possessive-pronoun reflexive]
+  [pronoun-declensions]
   (let [title "Pronoun Island: English Language Examples"]
-  (html
-   [:html
-    [:head
-     [:title title]
-     [:meta {:name "viewport" :content "width=device-width"}]
-     [:link {:rel "stylesheet" :href "/pronouns.css"}]]
-    [:body
-     (title-block title)
-     (examples-block subject object possessive-determiner possessive-pronoun reflexive)
-     (about-block)
-     (contact-block)]])))
-
-
-(defn parse-pronouns-with-lookup [pronouns-string pronouns-table]
+    (html
+     [:html
+      [:head
+       [:title title]
+       [:meta {:name "viewport" :content "width=device-width"}]
+       [:link {:rel "stylesheet" :href "/pronouns.css"}]]
+      [:body
+       (title-block title)
+       (map #(apply examples-block %) pronoun-declensions)
+       (footer-block)]])))
+
+(defn lookup-pronouns [pronouns-string]
   (let [inputs (s/split pronouns-string #"/")
         n (count inputs)]
     (if (>= n 5)
       (take 5 inputs)
-      (u/table-lookup inputs pronouns-table))))
+      (u/table-lookup inputs *pronouns-table*))))
 
 (defn make-link [path]
   (let [link (str "/" path)
         label path]
-    [:li [:a {:href link} label]]))
+    [:li (href link label)]))
 
-(defn front [pronouns-table]
-  (let [abbreviations (u/abbreviate pronouns-table)
+(defn front []
+  (let [abbreviations (u/abbreviate *pronouns-table*)
         links (map make-link abbreviations)
         title "Pronoun Island"]
     (html
@@ -110,19 +138,34 @@
        [:link {:rel "stylesheet" :href "/pronouns.css"}]]
       [:body
        (title-block title)
-       [:div {:class "table"}
-       [:p "pronoun.is is a www site for showing people how to use pronouns in English."]
+       [:div {:class "section table"}
+       [:p "pronoun.is is a website for personal pronoun usage examples"]
        [:p "here are some pronouns the site knows about:"]
        [:ul links]]]
-      (contact-block)])))
+      (footer-block)])))
 
 (defn not-found []
-  (str "We couldn't find those pronouns in our database, please ask us to "
-       "add them, or issue a pull request at "
-       "https://github.com/witch-house/pronoun.is/blob/master/resources/pronouns.tab"))
-
-(defn pronouns [path pronouns-table]
-  (let [pronouns (parse-pronouns-with-lookup (escape-html path) pronouns-table)]
-    (if pronouns
-      (apply format-pronoun-examples pronouns)
+  (let [title "Pronoun Island: English Language Examples"]
+    (html
+     [:html
+      [:head
+       [:title title]
+       [:meta {:name "viewport" :content "width=device-width"}]
+       [:link {:rel "stylesheet" :href "/pronouns.css"}]]
+      [:body
+       (title-block title)
+      [:div {:class "section examples"}
+       [:p [:h2 (str "We couldn't find those pronouns in our database."
+                     "If you think we should have them, please reach out!")]]]
+       (footer-block)]])))
+
+(defn pronouns [params]
+  (let [path (params :*)
+        alts (or (params "or") [])
+        pronouns (concat [path] (u/vec-coerce alts))
+        pronoun-declensions (filter some? (map #(lookup-pronouns
+                                                 (escape-html %))
+                                               pronouns))]
+    (if (seq pronoun-declensions)
+      (format-pronoun-examples pronoun-declensions)
       (not-found))))
diff --git a/src/pronouns/util.clj b/src/pronouns/util.clj
index 4d4f928..6d8d37e 100644
--- a/src/pronouns/util.clj
+++ b/src/pronouns/util.clj
@@ -1,31 +1,105 @@
+;; pronoun.is - a website for pronoun usage examples
+;; Copyright (C) 2014 - 2016 Morgan Astra
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>
+
 (ns pronouns.util
   (:require [clojure.string :as s]))
 
+(defn print-and-return "for debugging" [x] (println x) x)
+
 (defn slurp-tabfile [path]
+  "read a tabfile from a filesystem <path> as a table"
   (let [lines (s/split (slurp path) #"\n")]
     (map #(s/split % #"\t") lines)))
 
+(defn table-front-filter
+  "filter a <table> to the rows which begin with <query-key>"
+  [query-key table]
+  (let [arity (count query-key)]
+    (filter #(= query-key (take arity %)) table)))
+
+(defn table-end-filter
+  "filter a <table> to the rows which end with <query-key>"
+  [query-key table]
+  (let [table-arity (count (first table))
+        query-arity (count query-key)]
+    (filter #(= query-key (drop (- table-arity query-arity) %)) table)))
+
 (defn table-lookup
+  "find the row corresponding to <query-key> in <table>"
   [query-key table]
-  (let [arity (count query-key)
-        filtered-table (filter #(= query-key (take arity %)) table)]
-    (first filtered-table)))
-
-(defn tabfile-lookup
-  [query-key tabfile]
-  (table-lookup query-key (slurp-tabfile tabfile)))
-
-(defn minimum-unambiguous-path
-  ([pronouns-table sections] (minimum-unambiguous-path pronouns-table sections 1))
-  ([pronouns-table sections number-of-sections]
-    (let [sections-subset (take number-of-sections sections)
-          results (filter #(= (take number-of-sections %) sections-subset) pronouns-table)]
-      (case (count results)
-        0 nil
-        1 (clojure.string/join "/" sections-subset)
-        (recur pronouns-table sections (+ number-of-sections 1))))))
+  (if (some #(= "..." %) query-key)
+    (let [[query-front query-end-] (split-with #(not= "..." %) query-key)
+          query-end (drop 1 query-end-)
+          front-matches (table-front-filter query-front table)]
+      (first (table-end-filter query-end front-matches)))
+    (first (table-front-filter query-key table))))
+
+(defn shortest-unambiguous-forward-path
+  "Compute the shortest (in number of path elements) forward path which
+  unambiguously refers to a specific <row> in a <table>. The behavior of
+  this function is undefined if given a <row> that is not in the <table>.
+
+  See also: shortest-unambiguous-path"
+  [table row]
+  (loop [n 1]
+    (let [row-front (take n row)]
+      (if (>= 1 (count (table-front-filter row-front table)))
+        row-front
+        (recur (inc n))))))
+
+(defn shortest-unambiguous-ellipses-path
+  "Compute the shortest (in number of path elements) ellipses path which
+  unambiguously refers to a specific <row> in a <table>. The behavior of
+  this function is undefined if given a <row> that is not in the <table>.
+
+  See also: shortest-unambiguous-path"
+  [table row]
+  (let [row-end (last row)
+        filtered-table (table-end-filter [row-end] table)]
+    (loop [n 1]
+      (let [row-front (take n row)]
+        (if (>= 1 (count (table-front-filter row-front filtered-table)))
+          (concat row-front ["..." row-end])
+          (recur (inc n)))))))
+
+(defn shortest-unambiguous-path
+  "Compute the shortest (in number of path elements) path which unambiguously
+  refers to a specific <row> in a <table>. The behavior of this function is
+  undefined if given a <row> that is not in the <table>.
+
+  A path can either be a 'forward path', in which it specifies the row with
+  elements from the front (e.g. ze/zir), or an 'ellipses path', which elides
+  unnecessary elements from the middle (e.g. they/.../themselves). If the
+  shortest forward and ellipses paths are the same length, prefer the forward
+  path"
+  [table row]
+  (let [forward-path (shortest-unambiguous-forward-path table row)
+        ellipses-path (shortest-unambiguous-ellipses-path table row)]
+    (s/join "/"
+            (if (> (count forward-path) (count ellipses-path))
+              ellipses-path
+              forward-path))))
 
 (defn abbreviate
-  "given a list of pronoun rows, return a list of minimum unabiguous paths"
-  [pronouns-table]
-  (map (partial minimum-unambiguous-path pronouns-table) pronouns-table))
+  "return the list of minimum unabiguous paths from a <table>"
+  [table]
+  (map (partial shortest-unambiguous-path table) table))
+
+(defn vec-coerce [x]
+  "wrap a value <x> in a vector if it is not already in one. note that if
+  <x> is already in a sequence for which vector? is false, this will add
+  another layer of nesting."
+  (if (vector? x) x [x]))
diff --git a/src/pronouns/web.clj b/src/pronouns/web.clj
index 23ac603..eda8376 100644
--- a/src/pronouns/web.clj
+++ b/src/pronouns/web.clj
@@ -1,3 +1,19 @@
+;; pronoun.is - a website for pronoun usage examples
+;; Copyright (C) 2014 - 2016 Morgan Astra
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>
+
 (ns pronouns.web
   (:require [compojure.core :refer [defroutes GET PUT POST DELETE ANY]]
             [compojure.handler :refer [site]]
@@ -6,24 +22,19 @@
             [clojure.string :as s]
             [ring.middleware.logger :as logger]
             [ring.middleware.stacktrace :as trace]
-            [ring.middleware.session :as session]
-            [ring.middleware.session.cookie :as cookie]
+            [ring.middleware.params :as params]
             [ring.adapter.jetty :as jetty]
             [environ.core :refer [env]]
             [pronouns.util :as u]
             [pronouns.pages :as pages]))
 
-(def config {:default-server-port 5000
-             :pronoun-table-path "resources/pronouns.tab"})
-(def pronouns-table (u/slurp-tabfile (:pronoun-table-path config)))
-
 (defroutes app-routes
   (GET "/" []
        {:status 200
         :headers {"Content-Type" "text/html"}
-        :body (pages/front pronouns-table)})
+        :body (pages/front)})
 
-  (GET "/pronouns.css" {params :params}
+  (GET "/pronouns.css" []
      {:status 200
      :headers {"Content-Type" "text/css"}
      :body (slurp (io/resource "pronouns.css"))})
@@ -31,7 +42,7 @@
   (GET "/*" {params :params}
        {:status 200
         :headers {"Content-Type" "text/html"}
-        :body (pages/pronouns (:* params) pronouns-table)})
+        :body (pages/pronouns params)})
 
   (ANY "*" []
        (route/not-found (slurp (io/resource "404.html")))))
@@ -40,21 +51,18 @@
   (fn [req]
     (try (handler req)
          (catch Exception e
-           {:status 500
-            :headers {"Content-Type" "text/html"}
-            :body (slurp (io/resource "500.html"))}))))
+           (binding [*out* *err*]
+             {:status 500
+              :headers {"Content-Type" "text/html"}
+              :body (slurp (io/resource "500.html"))})))))
 
 (def app
   (-> app-routes
       logger/wrap-with-logger
       wrap-error-page
-      trace/wrap-stacktrace))
+      trace/wrap-stacktrace
+      params/wrap-params))
 
 (defn -main []
-  (let [port (Integer. (:port env
-                              (:default-server-port config)))]
+  (let [port (Integer. (:port env))]
     (jetty/run-jetty app {:port port})))
-
-;; For interactive development:
-;; (.stop server)
-;; (def server (-main))