From 93aa9f5995053166d51989a820f9b44d977423b9 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Thu, 26 Oct 2023 15:22:52 +1300
Subject: [PATCH] Reorganize keyboard templates.

---
 src/Text/HTML/Form/WebApp.hs                  | 25 +++++++++++++++----
 src/Text/HTML/Form/WebApp/Ginger.hs           |  7 +++---
 tpl/{ => keyboards}/latin1.html               |  2 +-
 .../latin1}/latin1-accent-lower.html          |  2 +-
 tpl/{ => keyboards/latin1}/latin1-accent.html |  2 +-
 tpl/{ => keyboards/latin1}/latin1-symbol.html |  2 +-
 tpl/{ => keyboards/latin1}/latin1-upper.html  |  2 +-
 7 files changed, 29 insertions(+), 13 deletions(-)
 rename tpl/{ => keyboards}/latin1.html (98%)
 rename tpl/{ => keyboards/latin1}/latin1-accent-lower.html (98%)
 rename tpl/{ => keyboards/latin1}/latin1-accent.html (98%)
 rename tpl/{ => keyboards/latin1}/latin1-symbol.html (99%)
 rename tpl/{ => keyboards/latin1}/latin1-upper.html (98%)

diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs
index e5d28ed..c1cb419 100644
--- a/src/Text/HTML/Form/WebApp.hs
+++ b/src/Text/HTML/Form/WebApp.hs
@@ -65,17 +65,32 @@ renderInput form ix input@Input {inputType="radio", inputName=k', value=v'} [] q
 renderInput form ix input@Input { inputType="<select>" } [] qs =
     template "select.html" form ix input qs
 renderInput form ix input [keyboard] qs =
-    template (Txt.unpack keyboard ++ ".html") form ix input qs
-renderInput form ix input [keyboard, ""] qs =
-    template (Txt.unpack keyboard ++ ".html") form ix input qs
+    renderInput form ix input [keyboard, ""] qs
+renderInput form ix input [keyboard, ""] qs | Just (Just _) <- resolveSource path =
+    template path form ix input qs
+  where path = "keyboards/" ++ Txt.unpack keyboard ++ ".html"
+renderInput form ix input [keyboard, ""] qs = do
+    configpath <- getXdgDirectory XdgConfig "bureaucromancy"
+    exists <- doesFileExist $ configpath </> "keyboard"
+    namespace <- if exists then readFile' $ configpath </> "keyboard"
+        else return "latin1"
+    let path = "keyboards/" ++ namespace ++ "/" ++ Txt.unpack keyboard ++ ".html"
+    let path2 = "keyboards/" ++ namespace ++ ".html"
+    let keyboard'
+            | Just (Just _) <- resolveSource path = path
+            | Just (Just _) <- resolveSource path2 = path2
+            | otherwise = "keyboards/latin1.html"
+    template keyboard' form ix input qs
 renderInput form ix input [] qs = do
     path <- getXdgDirectory XdgConfig "bureaucromancy"
     exists <- doesFileExist $ path </> "keyboard"
     keyboard <- if exists then readFile' $ path </> "keyboard"
         else return "latin1"
-    let keyboard' | Just (Just _) <- resolveSource (keyboard ++ ".html") = keyboard
+    let keyboard'
+            | Just (Just _) <- resolveSource ("keyboards/" ++ keyboard ++ ".html")
+                = keyboard
             | otherwise = "latin1"
-    template (keyboard' ++ ".html") form ix input qs
+    template ("keyboards/" ++ keyboard' ++ ".html") form ix input qs
 renderInput _ _ input _ _ =
     return $ Just $ Txt.concat ["Unknown input type: ", inputType input]
 
diff --git a/src/Text/HTML/Form/WebApp/Ginger.hs b/src/Text/HTML/Form/WebApp/Ginger.hs
index f2ed50f..5621d22 100644
--- a/src/Text/HTML/Form/WebApp/Ginger.hs
+++ b/src/Text/HTML/Form/WebApp/Ginger.hs
@@ -48,9 +48,10 @@ template name form ix input query
     xURI _ = return $ toGVal ()
 
 resolveSource :: FilePath -> Maybe (Maybe [Char])
-resolveSource = Just . fmap utf8 .
-    flip lookup $(makeRelativeToProject "tpl" >>= embedRecursiveDir) .
-    ('/':) . normalise
+resolveSource ('/':path) = resolveSource path
+resolveSource path = Just $ fmap utf8 $
+    flip lookup $(makeRelativeToProject "tpl" >>= embedRecursiveDir) $
+    normalise $ '/':path
 
 query2gval :: Monad m => Query -> GVal m
 query2gval qs =
diff --git a/tpl/latin1.html b/tpl/keyboards/latin1.html
similarity index 98%
rename from tpl/latin1.html
rename to tpl/keyboards/latin1.html
index a68afed..d1b6b45 100644
--- a/tpl/latin1.html
+++ b/tpl/keyboards/latin1.html
@@ -1,4 +1,4 @@
-{% extends "base.html" %}
+{% extends "/base.html" %}
 
 {%- block control -%}<section>
   <p><span style="white-space: pre">{{ input.value }}</span>
diff --git a/tpl/latin1-accent-lower.html b/tpl/keyboards/latin1/latin1-accent-lower.html
similarity index 98%
rename from tpl/latin1-accent-lower.html
rename to tpl/keyboards/latin1/latin1-accent-lower.html
index 6587c05..aa4c81f 100644
--- a/tpl/latin1-accent-lower.html
+++ b/tpl/keyboards/latin1/latin1-accent-lower.html
@@ -1,4 +1,4 @@
-{% extends "base.html" %}
+{% extends "/base.html" %}
 
 {%- block control -%}<section>
   <p><span style="white-space: pre">{{ input.value }}</span>
diff --git a/tpl/latin1-accent.html b/tpl/keyboards/latin1/latin1-accent.html
similarity index 98%
rename from tpl/latin1-accent.html
rename to tpl/keyboards/latin1/latin1-accent.html
index 40a52c5..b306a4c 100644
--- a/tpl/latin1-accent.html
+++ b/tpl/keyboards/latin1/latin1-accent.html
@@ -1,4 +1,4 @@
-{% extends "base.html" %}
+{% extends "/base.html" %}
 
 {%- block control -%}<section>
   <p><span style="white-space: pre">{{ input.value }}</span>
diff --git a/tpl/latin1-symbol.html b/tpl/keyboards/latin1/latin1-symbol.html
similarity index 99%
rename from tpl/latin1-symbol.html
rename to tpl/keyboards/latin1/latin1-symbol.html
index 73e59a7..635a737 100644
--- a/tpl/latin1-symbol.html
+++ b/tpl/keyboards/latin1/latin1-symbol.html
@@ -1,4 +1,4 @@
-{% extends "base.html" %}
+{% extends "/base.html" %}
 
 {%- block control -%}<section>
   <p><span style="white-space: pre">{{ input.value }}</span>
diff --git a/tpl/latin1-upper.html b/tpl/keyboards/latin1/latin1-upper.html
similarity index 98%
rename from tpl/latin1-upper.html
rename to tpl/keyboards/latin1/latin1-upper.html
index e59df3f..66d4f24 100644
--- a/tpl/latin1-upper.html
+++ b/tpl/keyboards/latin1/latin1-upper.html
@@ -1,4 +1,4 @@
-{% extends "base.html" %}
+{% extends "/base.html" %}
 
 {%- block control -%}<section>
   <p><span style="white-space: pre">{{ input.value }}</span>
-- 
2.30.2