CombineForm.hs

{-# LANGUAGE FlexibleInstances 
           , FlexibleContexts
           , MultiParamTypeClasses
           , TypeSynonymInstances
           , FunctionalDependencies
           , UndecidableInstances
           #-}
module CombineForm where

import Yesod
import Yesod.Form.Core

import Data.HList hiding (tuple)
import Data.HList.Tuple
import Data.HList.Utils

-- Part 1: combine 2 forms

formFailure :: FormResult a -> [String]
formFailure (FormFailure fs) = fs
formFailure _ = []

combine2FormResults :: FormResult a -> FormResult b -> FormResult (a,b)
combine2FormResults (FormSuccess a) (FormSuccess b) = FormSuccess (a,b)
combine2FormResults FormMissing FormMissing = FormMissing
combine2FormResults a b = FormFailure $ formFailure a ++ formFailure b 

combine2Forms :: Form s y f1 -> Form s y f2 -> Form s y (f1,f2)
combine2Forms = combine2FormsWith sequence_

combine2FormsWith :: ([GWidget s y ()] -> GWidget s y ()) -> Form s y f1 -> Form s y f2 -> Form s y (f1,f2)
combine2FormsWith combine (GForm f1) (GForm f2) = GForm $ do 
  (r1,w1,enc) <- f1
  (r2,w2,_) <- f2
  return (combine2FormResults r1 r2, combine [w1, w2],enc)

-- Part 2: combine n forms

data First = First
data Second = Second

instance Apply First (a, b, c) a where
  apply _ (a,_,_) = a
instance Apply Second (a, b, c) b where
  apply _ (_,b,_) = b

data Deform = Deform

instance Apply Deform (GForm s m xml a) (FormInner s m (FormResult a, xml, Enctype)) where
  apply _ (GForm f) = f

data CombineFormResults = CombineFormResults

instance Apply CombineFormResults (FormResult e, FormResult l) (FormResult (HCons e l)) where
  apply _ (FormSuccess e, FormSuccess l) = FormSuccess $ HCons e l
  apply _ (FormMissing, FormMissing) = FormMissing
  apply _ (f1,f2) = FormFailure $ formFailure f1 ++ formFailure f2

tupleFormResult :: Tuple l t => FormResult l -> FormResult t
tupleFormResult (FormSuccess l) = FormSuccess $ tuple l
tupleFormResult (FormFailure fs) = FormFailure fs
tupleFormResult FormMissing = FormMissing

class CombineForms s y t rt | t -> rt where
  combineFormsWith :: ([GWidget s y ()] -> GWidget s y ()) -> t -> Form s y rt

  combineForms :: t -> Form s y rt
  combineForms = combineFormsWith sequence_

instance (Untuple t l
          -- get form monadic actions
         ,HMap Deform l as

          -- sequence form actions
         ,HSequence as (FormInner s y vs)

          -- extract hlist of FormResults from the form action values
         ,HMap First vs rs

          -- combine hlist of FormResults into FormResult hlist
         ,HFoldr CombineFormResults (FormResult HNil) rs (FormResult rl)
          -- tuple FormResult hlist into FormResult tuple
         ,Tuple rl rt

          -- combine widgets
         ,HMapOut Second vs (GWidget s y ())

          -- get enctype. NOTE: assumes (without checking) Enctype will be the same for all combined forms
         ,HHead vs (unused1,unused2,Enctype)
         ) => CombineForms s y t rt where
  combineFormsWith combineWidgets t = GForm $ do
    let l = untuple t
        as = hMap Deform l
    vs <- hSequence as
    let rs = hMap First vs
        rl = hFoldr CombineFormResults (FormSuccess HNil) rs
        rt = tupleFormResult rl
        ws = hMapOut Second vs
        (_,_,e) = hHead vs
    return $ (rt,combineWidgets ws,e)

test.hs

{-# LANGUAGE QuasiQuotes
           , OverloadedStrings 
           , TypeFamilies
           , MultiParamTypeClasses
           , TypeSynonymInstances
           #-}

import Control.Applicative
import Control.Monad

import Yesod
import Yesod.Handler
import Yesod.Dispatch
import CombineForm

data Test = Test

data Form1 = Form1 {
    field1 :: String
  }
  deriving Show

data Form2 = Form2 {
    field2 :: String
  }
  deriving Show

data Form3 = Form3 {
    field3 :: String
  }
  deriving Show

formlet1 f1 = fieldsToTable $ Form1 
  <$> stringField "Field 1" (field1 <$> f1)

formlet2 f2 = fieldsToTable $ Form2 
  <$> stringField "Field 2" (field2 <$> f2)

formlet3 f3 = fieldsToTable $ Form3 
  <$> stringField "Field 3" (field3 <$> f3)

getRootR = do
  (res,w,enc) <- runFormGet $ combineForms 
    (formlet1 Nothing
    ,formlet2 Nothing
    ,formlet3 Nothing)
  let forms = case res of
                FormSuccess (f1,f2,f3) -> [show f1, show f2, show f3]
                _ -> []

  defaultLayout $ do
    forM_ forms $ \form -> 
      addHamlet [$hamlet|
        $form$
        %br
      |]
    [$hamlet|
%form!enctype=$enc$
  %table
    ^w^
    %tr
      %td!colspan=2
        %input!type=submit
|]


mkYesod "Test" [$parseRoutes|
/ RootR GET
|]

instance Yesod Test where 
  approot _ = ""

main = basicHandler 3000 Test