generic html forms for ADTs

this does some GHC generics witchery, now in its own module!

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