Add youido support for sum types (issue #92)

youido/examples/Example.hs

@@ -1,23 +1,24 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings, ExistentialQuantification, ScopedTypeVariables,
    ExtendedDefaultRules, FlexibleContexts, TemplateHaskell, MultiParamTypeClasses,
-   OverloadedLabels, TypeOperators, DataKinds, DeriveGeneric, FlexibleInstances #-}
+   OverloadedLabels, TypeOperators, DataKinds, DeriveGeneric,
+   FlexibleInstances, TypeApplications, GeneralizedNewtypeDeriving #-}
+
+module Main where
 
 import Youido.Serve
 import Youido.Types
 import Youido.Dashdo
+import SumTypeExample
 import Lucid
 import Lucid.Bootstrap
 import Lucid.Rdash
 import Numeric.Datasets.Gapminder
 import Numeric.Datasets
 import Control.Monad.Reader
-import Control.Monad.State.Strict
 import Control.Concurrent.STM.TVar
 import Control.Concurrent.STM
 import Data.List (nub)
-import Network.Wai
-import Data.Text (Text, pack, unpack)
+import Data.Text (Text, unpack)
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import Data.Monoid
@@ -27,9 +28,8 @@ import Lens.Micro.Platform
 import Dashdo.Elements
 import Dashdo.FlexibleInput
 import Dashdo.Types hiding (FormField)
-import Data.Proxy
 import GHC.Generics
-import Text.Digestive.View (View)
+import Text.Digestive.View
 import qualified Data.Text.IO as TIO
 
 import qualified Text.Digestive as D
@@ -58,20 +58,25 @@ instance  Monad m => FromForm m TodoTag
 newtype Assignee = Assignee Int deriving (Generic, Show, Eq, Num)
 
 instance MonadIO m => FormField m Assignee where
-  fromFormField def = D.monadic $ liftIO $ do
+  fromFormField chs def = D.monadic $ liftIO $ do
     employees <- getEmployees
-    return $ D.choice employees def
+    return . D.choice employees $ def
 
-  renderField _ fieldName label view = div_ [class_ "form-group"] $ do
+  renderField _ _ fieldName label view = div_ [class_ "form-group"] $ do
     DL.label fieldName view (toHtml label)
     with (DL.inputSelect fieldName (toHtml <$> view)) -- DL.inputWithType typ_ attrs fieldName view)
       [class_ "form-control", autofocus_]
     DL.errorList fieldName (toHtml <$> view)
 
+data Priority = None | Low | High | Custom { note :: Text, priorityNumber :: Int }
+  deriving (Show, Generic)
+instance (Monad m) => FormField m Priority
+
 data Todo = TodoItem {
  todoID :: Int,
  todo :: Text,
  assignee :: Assignee,
+ priority :: Priority,
  done :: Bool,
  tags :: [TodoTag]
  } deriving (Show, Generic)
@@ -92,7 +97,7 @@ instance MonadIO m => FromRequest m Countries
 instance ToURL Countries
 --------------------------------------------------
 type ExampleM = ReaderT (TVar ExampleState) IO
-data ExampleState = ExampleState { todoState :: TodoList }
+data ExampleState = ExampleState { todoState :: TodoList, quiz :: Quiz }
 
 -- readTodoState :: ExampleM TodoList
 readTodoState = ask >>= fmap todoState . liftIO . readTVarIO
@@ -125,10 +130,10 @@ bubblesDD gapM = do
 
 --------------------------------------------------
 
-todoListEditForm :: MonadIO m => View Text -> HtmlT m ()
-todoListEditForm view = container_ $ do
+todoListEditForm :: MonadIO m => Maybe TodoList -> View Text -> HtmlT m ()
+todoListEditForm mdef view = container_ $ do
   form_ [method_ "post", action_ (toURL $ UpdateTodoList FormLink)] $ do
-    renderForm (Proxy :: Proxy TodoList) view
+    renderSumForm Nothing mdef view
     button_ [type_ "submit"] "Save"
 
 todoH :: TodoR -> HtmlT ExampleM ()
@@ -140,21 +145,22 @@ todoH ListTodos = container_ $ do
   h4_ (toHtml titleT)
   a_ [type_ "button", class_ "btn btn-primary", href_ . toURL $ EditTodoList]
     "Edit List"
-  widget_ . widgetBody_ $ forM_ todosT $ \(TodoItem idT nameT assignT doneT tags) -> do
+  widget_ . widgetBody_ $ forM_ todosT $ \(TodoItem idT nameT assignT priorityT doneT tags) -> do
     let employee = fromMaybe "unknown" $ lookup assignT employees
     container_ $ do
       div_ $ do
         toHtml $
           show idT <> ". "
           <> (if doneT then "DONE: " else "TODO: ")
           <> unpack nameT
-          <> " (" <> unpack employee <> ") " 
+          <> " (" <> unpack employee <> ") "
+          <> " [Priority: " <> show priorityT <> "]"
           <> unpack (if length tags == 0 then ""
                      else " (" <> T.intercalate ", " (map tag tags) <> ")")
 
 todoH EditTodoList = do
   tdos <- readTodoState
-  todoListEditForm =<< (getView (Just tdos))
+  todoListEditForm (Just tdos) =<< (getView (Just tdos))
 
 todoH (UpdateTodoList (Form tdos)) = do
   atom <- ask
@@ -164,18 +170,63 @@ todoH (UpdateTodoList (Form tdos)) = do
 
 todoH (UpdateTodoList (FormError v)) = do
   liftIO . putStrLn $ "UpdateTodoList error: " <> show (FormError v)
-  todoListEditForm v
+  todoListEditForm Nothing v
+
+--------------------------------------------------
+
+readQuiz = fmap quiz . liftIO . readTVarIO =<< ask
+
+quizH ShowQuiz = do
+  Quiz nm favCol r <- readQuiz
+  br_ []
+  h4_ (toHtml nm)
+  a_ [type_ "button", class_ "btn btn-primary", href_ $ toURL EditQuiz] "Edit"
+  br_ []
+  a_ [type_ "button", class_ "btn btn-default", href_ $ toURL NewQuiz] "New"
+  container_ $ do
+    toHtml $ "Favourite colour: " <> show favCol <> ", " <> show r
+
+quizH NewQuiz = do
+  liftIO . putStrLn $ "* New quiz *"
+  quizEditForm Nothing =<< getView (Nothing :: Maybe Quiz)
+
+quizH EditQuiz = do
+  q <- readQuiz
+  liftIO . putStrLn $ "\n ****** Getting view for quiz\n"
+  quizEditForm (Just q) =<< getView (Just q)
+
+quizH (UpdateQuiz (Form q)) = do
+  liftIO . putStrLn $ "UpdateQuiz:" <> show q
+  state <- ask
+  liftIO . atomically $
+    modifyTVar state $ \st -> st { quiz = q }
+  quizH ShowQuiz
+
+quizH (UpdateQuiz (FormError v)) = do
+  liftIO . putStrLn $ "UpdateQuiz error: " <> show (FormError v)
+  quizEditForm Nothing v
+
+quizEditForm :: Monad m => Maybe Quiz -> View Text -> HtmlT m ()
+quizEditForm mdef view = container_ $ do
+  form_ [method_ "post", action_ (toURL $ UpdateQuiz FormLink)] $ do
+    renderSumForm Nothing mdef view
+    button_ [type_ "submit"] "Save"
+
+--------------------------------------------------
 
 initialTodos = TodoList "My todos"
-  [ TodoItem 1 "Make todo app" 1 False [TodoTag "dev", TodoTag "work"]
-  , TodoItem 2 "Have lunch" 2 False [TodoTag "personal"]
-  , TodoItem 3 "Buy bread" 3 True []]
+  [ TodoItem 1 "Make todo app" 1 High False [TodoTag "dev", TodoTag "work"]
+  , TodoItem 2 "Have lunch" 2 None False [TodoTag "personal"]
+  , TodoItem 3 "Buy bread" 3 (Custom "eventually" 1) True []]
   "A field after a subform"
 
+initialQuiz = Quiz "A quiz" (Blue "navy" "extra thoughts") PreferNotToSay
+
 sidebar = rdashSidebar "Youido Example" (return ())
     [ ("Bubbles", "fas")  *~ #bubbles :/ Initial
     , ("Counties", "fas") *~ Countries
-    , ("Todos", "fas") *~ ListTodos ]
+    , ("Todos", "fas") *~ ListTodos
+    , ("Sum Types", "fas") *~ ShowQuiz ]
 
 inHeader :: Text -> Html ()
 inHeader js = do
@@ -184,8 +235,8 @@ inHeader js = do
 main :: IO ()
 main = do
   gapM <- getDataset gapminder
-  js <- TIO.readFile "form-repeat.js"
-  atom <- newTVarIO $ ExampleState initialTodos
+  js <- TIO.readFile "youido.js"
+  atom <- newTVarIO $ ExampleState initialTodos initialQuiz
   let runIt :: Bool -> ExampleM a -> IO a
       runIt _ todoM = runReaderT todoM atom
 
@@ -197,3 +248,4 @@ main = do
     wrapper .= \_ -> rdashWrapper "Youido Example" (inHeader js) sidebar
     hHtmlT $ countryH gapM
     hHtmlT todoH
+    hHtmlT quizH

youido/examples/SumTypeExample.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE DeriveGeneric, MultiParamTypeClasses, FlexibleInstances #-}
+
+module SumTypeExample where
+
+import Data.Text (Text)
+-- import qualified Data.Text as T
+import GHC.Generics
+import Youido.Types
+import Youido.Utils
+
+data Colour = Red
+            | Green { dark :: Bool }
+            | Blue { shade :: Text, extra :: Text }
+  deriving (Show, Generic)
+
+instance (Monad m) => FormField m Colour
+
+data Reason = PreferNotToSay | Explanation { explanation :: Text }
+  deriving (Show, Generic)
+instance (Monad m) => FormField m Reason
+
+data Quiz = Quiz
+  { name :: Text
+  , favouriteColour :: Colour
+  , reason :: Reason
+  } deriving (Show, Generic)
+
+instance (Monad m) => FromForm m Quiz
+
+data QuizR = ShowQuiz
+           | NewQuiz
+           | EditQuiz
+           | UpdateQuiz (Form Quiz)
+  deriving (Show, Generic)
+
+instance (Monad m) => FromRequest m QuizR
+instance ToURL QuizR