From 95156397e2fd4bb01723c28792242b9f844ac752 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 6 Jul 2022 17:34:38 +0200
Subject: wrote some generic html form code

this automatically derives lucid html versions of ADTs which are
hopefully compatible with the FormUrlEncoded type class
---
 lib/Server/ControlRoom.hs | 109 +++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 97 insertions(+), 12 deletions(-)

diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 6f5999f..68d1437 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -1,15 +1,27 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DefaultSignatures   #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module Server.ControlRoom where
 
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
+import           Data.Maybe                  (maybeToList)
 import           Data.Swagger                (ToSchema (..))
 import           Data.Text                   (Text)
+import qualified Data.Text                   as T
+import           Data.Time                   (Day)
+import           GHC.Generics                (C1, D1, Generic (Rep), K1,
+                                              Meta (..), Rec0, S1, U1,
+                                              type (:*:), type (:+:))
+import           GHC.TypeLits                (KnownSymbol, symbolVal)
 import           GTFS
 import           Lucid
 import           Servant
@@ -18,6 +30,7 @@ import           Servant.API                 (Capture, Get, JSON, NoContent,
                                               ReqBody, type (:<|>) ((:<|>)))
 import           Servant.HTML.Lucid          (HTML)
 import           Server.Util
+import           Web.FormUrlEncoded          (ToForm)
 import           Web.Internal.FormUrlEncoded (Form)
 
 data TripList = TripList
@@ -38,12 +51,84 @@ controlRoomServer =
            pure "hello"
        )
 
-instance ToHtml TripList where
-  toHtml TripList{..} = form_ [action_ "./irgendwo", method_ "post"] $ do
-    input_ [type_ "text", name_ "caldateServiceId"]
-    input_ [type_ "text", name_ "caldateDate"]
-    input_ [type_ "text", name_ "caldateExceptionType"]
-    input_ [type_ "submit", value_ "hallo!"]
+
+
+
+class GToHtmlFormInput a where
+  gtoHtmlFormInput :: Text -> Proxy (a p) -> Html ()
+
+instance (KnownSymbol name)
+  => GToHtmlFormInput (C1 (MetaCons name f s) U1) where
+  gtoHtmlFormInput group _ = do
+    input_ [type_ "radio", id_ name, value_ name, name_ group] -- need a shared name for all options here
+    label_ [for_ name] (toHtml name)
+    where name = T.pack (symbolVal (Proxy @name))
+
+instance (GToHtmlFormInput l, GToHtmlFormInput r) => GToHtmlFormInput (l :+: r) where
+  gtoHtmlFormInput group _ = do
+    gtoHtmlFormInput group (Proxy @(l _))
+    gtoHtmlFormInput group (Proxy @(r _))
+
+-- | ignore constructor & type metainfo
+instance GToHtmlFormInput a => GToHtmlFormInput (D1 r a) where
+  gtoHtmlFormInput group _ = gtoHtmlFormInput group (Proxy @(a _))
+
+
+class ToHtmlFormInput a where
+  toFormInput :: Text -> Proxy a -> Html ()
+  default toFormInput :: (GToHtmlFormInput (Rep a)) => Text -> Proxy a -> Html ()
+  toFormInput group p = gtoHtmlFormInput group (Proxy @(Rep a _))
+
+instance ToHtmlFormInput Text where
+  toFormInput name _ = input_ [type_ "text", name_ name, placeholder_ name]
+instance ToHtmlFormInput Day where
+  toFormInput name _ = input_ [type_ "text", name_ name]
+instance ToHtmlFormInput CalendarExceptionType
+
+
+-- | generic conversion of record data types to input forms
+class GToHtmlForm a where
+  gtoHtmlForm :: Proxy (a p) -> Html ()
+
+-- | each record field is a form input
+instance (KnownSymbol name, ToHtmlFormInput a)
+  => GToHtmlForm (S1 (MetaSel (Just name) su ss ds) (Rec0 a)) where
+  gtoHtmlForm _ = toFormInput (T.pack (symbolVal (Proxy @name))) (Proxy @a)
+
+-- | just chain all fields
+instance (GToHtmlForm l, GToHtmlForm r) => GToHtmlForm (l :*: r) where
+  gtoHtmlForm _ = do
+    gtoHtmlForm (Proxy @(l _))
+    gtoHtmlForm (Proxy @(r _))
+
+-- | ignore constructor & type metainfo
+instance GToHtmlForm a => GToHtmlForm (D1 r a) where
+  gtoHtmlForm _ = gtoHtmlForm (Proxy @(a _))
+instance GToHtmlForm a => GToHtmlForm (C1 r a) where
+  gtoHtmlForm _ = gtoHtmlForm (Proxy @(a _))
+
+
+class ToHtmlForm a where
+  toHtmlForm :: Proxy a -> Html ()
+  default toHtmlForm :: (GToHtmlForm (Rep a)) => Proxy a -> Html ()
+  toHtmlForm = genericToHtmlForm defaultOptions
+
+data HtmlFormOptions = HtmlFormOptions
+  { htmlFormAction           :: Maybe Text
+  , htmlFormMethod           :: Text
+  , htmlFormSubmitButtonText :: Text
+  }
+
+defaultOptions ::HtmlFormOptions
+defaultOptions = HtmlFormOptions Nothing "post" "Ok"
+
+genericToHtmlForm :: (GToHtmlForm (Rep a2)) => HtmlFormOptions -> Proxy a2 -> Html ()
+genericToHtmlForm HtmlFormOptions{..} (Proxy :: Proxy a) =
+  form_ ((method_ htmlFormMethod) : maybeToList (fmap action_ htmlFormAction)) $ do
+    gtoHtmlForm (Proxy @(Rep a _))
+    input_ [type_ "submit", value_ htmlFormSubmitButtonText]
+
+instance ToHtmlForm CalendarDate
 
 instance ToSchema Form where
   declareNamedSchema _ = undefined
-- 
cgit v1.2.3