aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2022-07-06 17:34:38 +0200
committerstuebinm2022-07-06 17:34:38 +0200
commit95156397e2fd4bb01723c28792242b9f844ac752 (patch)
tree51b6a05f1c0e3b22f850c5cb3badc009e718fa6e
parent198290cf11d859aa7f10e9377db8b65646340bca (diff)
wrote some generic html form code
this automatically derives lucid html versions of ADTs which are hopefully compatible with the FormUrlEncoded type class
Diffstat (limited to '')
-rw-r--r--lib/Server/ControlRoom.hs109
1 files 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