ReflexForms.hs

{-# LANGUAGE DeriveFunctor #-}

module Form where

import Control.Lens
import Data.Default
import Data.Functor.Compose
import Data.Monoid
import Reflex

data FormInput t a = FormInput
    { _formInput_initialValue :: Maybe a
    , _formInput_setValue     :: Event t (Maybe a)
    }

instance Reflex t => Functor (FormInput t) where
    fmap f (FormInput iv sv) = FormInput (f <$> iv) (fmap f <$> sv)

data FormOutput t a = FormOutput
    { _formOutput_value  :: Dynamic t (Maybe a)
    , _formOutput_change :: Event t (Maybe a)
    }

instance Reflex t => Default (FormOutput t a) where
    def = FormOutput (constDyn Nothing) never

instance Reflex t => Functor (FormOutput t) where
    fmap f (FormOutput v c) = FormOutput (fmap f <$> v) (fmap f <$> c)

instance Reflex t => Applicative (FormOutput t) where
    pure a = FormOutput (constDyn $ Just a) never
    (FormOutput vf cf) <*> (FormOutput va ca) = FormOutput v
        (tagPromptlyDyn v $ leftmost [() <$ cf, () <$ ca])
      where
        v = getCompose $ Compose vf <*> Compose va

newtype FormT i o t m a = FormT { runFormT :: FormInput t i -> m (FormOutput t o, a) }

zoomForm :: Reflex t => (b -> v) -> FormT v o t m a -> FormT b o t m a
zoomForm l f = FormT $ \fi -> runFormT f (l <$> fi)