diff options
author | stuebinm | 2022-07-06 17:34:38 +0200 |
---|---|---|
committer | stuebinm | 2022-07-06 17:34:38 +0200 |
commit | 95156397e2fd4bb01723c28792242b9f844ac752 (patch) | |
tree | 51b6a05f1c0e3b22f850c5cb3badc009e718fa6e /lib | |
parent | 198290cf11d859aa7f10e9377db8b65646340bca (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 'lib')
-rw-r--r-- | lib/Server/ControlRoom.hs | 109 |
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 |