From 25a672a436eec65f2de097a1187ba8a3b8b6165a Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 7 Jul 2022 00:10:13 +0200 Subject: generic html forms for ADTs this does some GHC generics witchery, now in its own module! --- lib/Lucid/Forms.hs | 105 ++++++++++++++++++++++++++++++++++++++++++++++ lib/Server/ControlRoom.hs | 105 ++++++++-------------------------------------- tracktrain.cabal | 1 + 3 files changed, 123 insertions(+), 88 deletions(-) create mode 100644 lib/Lucid/Forms.hs diff --git a/lib/Lucid/Forms.hs b/lib/Lucid/Forms.hs new file mode 100644 index 0000000..26be845 --- /dev/null +++ b/lib/Lucid/Forms.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + + +module Lucid.Forms (GToHtmlForm(..), GToHtmlFormInput(..), ToHtmlForm(..), ToHtmlFormInput(..)) where + +import Data.Maybe (maybeToList) +import Data.Proxy (Proxy (..)) +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 Lucid (Html, ToHtml (toHtml), action_, div_, + for_, form_, id_, input_, label_, + method_, name_, placeholder_, type_, + value_) +import Text.ProtocolBuffers (Default (defaultValue)) + +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 for things which can be (single) options (i.e. a single input-tag or +-- | a group of radio buttons) in an html form +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] + + +-- | 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 for things which can be entered via html forms +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" + +instance Default HtmlFormOptions where + defaultValue = defaultOptions + +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] diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index c63b74b..edfdeb3 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -13,26 +13,27 @@ 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 -import Servant.API (Capture, Get, JSON, NoContent, - PlainText, Post, QueryParam, - ReqBody, type (:<|>) ((:<|>))) +import Lucid (Html, ToHtml (toHtml), action_, + div_, for_, form_, id_, input_, + label_, method_, name_, + placeholder_, type_, value_) +import Servant (Capture, FormUrlEncoded, Get, + JSON, NoContent, PlainText, Post, + QueryParam, ReqBody, + type (:<|>) (..), type (:>)) import Servant.HTML.Lucid (HTML) -import Server.Util import Web.FormUrlEncoded (ToForm) import Web.Internal.FormUrlEncoded (Form) +import GTFS (CalendarDate, + CalendarExceptionType, TripID) +import Lucid.Forms (ToHtmlForm (..), + ToHtmlFormInput (..)) +import Server.Util (Service) + data TripList = TripList { tripListHeader :: Text , tripListType :: Text @@ -52,81 +53,9 @@ controlRoomServer = ) - - -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 ToHtml TripList where + toHtml _ = div_ "todo" + diff --git a/tracktrain.cabal b/tracktrain.cabal index 7f89cb9..91b8adf 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -99,6 +99,7 @@ library , Server , Server.GTFS_RT , Server.ControlRoom + , Lucid.Forms , PersistOrphans , Persist , API -- cgit v1.2.3