aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Lucid/Forms.hs105
-rw-r--r--lib/Server/ControlRoom.hs105
-rw-r--r--tracktrain.cabal1
3 files changed, 123 insertions, 88 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 10:05:32 +0000