Formless + Halogen Store part 3

Main.purs

-- | This example shows using Halogen Store with Formless, but the form is the only
-- | component that interacts with the global state, not the parent.
module Main where

import Prelude

import Data.Newtype (class Newtype, unwrap)
import Data.Either (Either(..))
import Data.Int as Int
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Aff.Class (class MonadAff)
import Effect.Class (liftEffect)
import Effect.Class.Console (logShow)
import Formless as F
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Store.Connect (connect, Connected)
import Halogen.Store.Select (Selector, selectEq)
import Halogen.Store.Monad (class MonadStore, runStoreT, updateStore)
import Halogen.VDom.Driver (runUI)
import TryPureScript as TryPureScript
import Type.Proxy (Proxy(..))
import Web.Event.Event (Event, preventDefault)
import Web.UIEvent.MouseEvent as ME

-----
-- HALOGEN APP
-----

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  app <- runStoreT initialStore reduce page
  runUI app unit body

-----
-- MAIN COMPONENT
-----

data Action = HandleDogForm Dog

page 
  :: forall query input output m
   . MonadAff m 
  => MonadStore StoreAction Store m 
  => H.Component query input output m
page = H.mkComponent
  { initialState: \_ -> { isFoo: true }
  , render
  , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
  }
  where
  handleAction = case _ of
    HandleDogForm dog ->
      liftEffect $ TryPureScript.render =<< TryPureScript.withConsole do
        logShow (dog :: Dog)
    
  render { isFoo } = 
    HH.div_
      [ HH.slot F._formless unit formComponent { isFoo } HandleDogForm ]
  
-----
-- GLOBAL STATE
-----

data Connection = Offline | Online

derive instance Eq Connection

instance Show Connection where
  show = case _ of
    Offline -> "offline"
    Online -> "online"

type Store = { connection :: Connection, unused :: Unit }

initialStore :: Store
initialStore = { connection: Online, unused: unit }

type StoreAction = Store -> Store

reduce :: Store -> StoreAction -> Store
reduce store k = k store

-----
-- FORMLESS FORM TYPES
-----

type Dog = { name :: String, age :: Age }

newtype Age = Age Int

derive instance newtypeAge :: Newtype Age _

instance showAge :: Show Age where
  show = show <<< unwrap

data AgeError = TooLow | TooHigh | InvalidInt

newtype DogForm (r :: Row Type -> Type) f = DogForm (r
  ( name :: f Void     String String
  , age  :: f AgeError String Age
  ))

derive instance newtypeDogForm :: Newtype (DogForm r f) _

-----
-- FORMLESS FORM COMPONENT
-----

type FormInput = (isFoo :: Boolean)

type FormState = SharedContext FormInput

data FormAction 
  = FormSubmit Event 
  | FormReceive (Connected Context { isFoo :: Boolean })
  | FormToggleConnection Event
  
type SharedContext (r :: Row Type) = (connection :: Connection | r)
  
type Context = { | SharedContext () }

selector :: Selector Store Context
selector = selectEq \store -> { connection: store.connection }

deriveState 
  :: forall m
   . Monad m 
  => Connected Context { isFoo :: Boolean }
  -> (F.State DogForm FormState m -> F.State DogForm FormState m)
deriveState { context, input } = _
  { connection = context.connection
  , isFoo = input.isFoo
  }

formComponent 
  :: forall query m
   . MonadAff m 
  => MonadStore StoreAction Store m 
  => F.Component DogForm query () { isFoo :: Boolean } Dog m
formComponent = connect selector $ F.component mkInput spec

mkInput :: forall m. Monad m => Connected Context { isFoo :: Boolean } -> F.Input DogForm FormState m
mkInput { context, input } =
  { connection: context.connection
  , isFoo: input.isFoo
  , initialInputs: Nothing
  , validators: DogForm
      { name: F.noValidation
      , age: F.hoistFnE_ \str -> case Int.fromString str of
          Nothing -> Left InvalidInt
          Just n
            | n < 0 -> Left TooLow
            | n > 30 -> Left TooHigh
            | otherwise -> Right (Age n)
      }
  }

spec 
  :: forall query m
   . MonadStore StoreAction Store m
  => MonadAff m
  => F.Spec DogForm FormState query FormAction () (Connected Context { isFoo :: Boolean }) Dog m
spec = F.defaultSpec 
  { render = render
  , handleAction = handleAction
  , handleEvent = handleEvent 
  , receive = Just <<< FormReceive
  }
  where
  handleAction = case _ of
    FormSubmit event -> do
      H.liftEffect $ preventDefault event
      F.handleAction handleAction handleEvent F.submit
  
    FormReceive i ->
      H.modify_ $ deriveState i
    
    FormToggleConnection event -> do
      H.liftEffect $ preventDefault event
      updateStore \store -> store 
        { connection = if store.connection == Offline then Online else Offline }

  handleEvent = F.raiseResult
    
  render { form, connection, isFoo } =
    HH.form
      [ HE.onSubmit $ F.injAction <<< FormSubmit ]
      [ HH.div_
          [ HH.span_ [ HH.text $ "You are " <> show connection <> "!" ]
          , HH.button
              [ HE.onClick $ F.injAction <<< FormToggleConnection <<< ME.toEvent ]
              [ HH.text "Toggle Connection" ]
          ]
      , HH.p_
         [ HH.text $ "Is foo? " <> show isFoo ]
      , HH.label
          [ HP.style "display: flex; align-items:center;" ]
          [ HH.span
              [ HP.style "margin-right: 5px;" ]
              [ HH.text "Name" ]
          , HH.input
              [ HP.value $ F.getInput _name form
              , HP.placeholder "Toby"
              , HE.onValueInput $ F.set _name
              ]
          ]
      , HH.label
          [ HP.style "display: flex; align-items:center;" ]
          [ HH.span
              [ HP.style "margin-right: 5px;" ]
              [ HH.text "Age" ]
          , HH.input
              [ HP.value $ F.getInput _age form
              , HP.placeholder "10"
              , HE.onValueInput $ F.setValidate _age
              ]
          ]
      , HH.text case F.getError _age form of
          Nothing -> ""
          Just InvalidInt -> "Age must be an integer"
          Just TooLow -> "Age cannot be negative"
          Just TooHigh -> "No dog has lived past 30 before"
      , HH.input
          [ HP.value "Submit"
          , HP.type_ HP.InputSubmit
          ]
      ]

_name = Proxy :: Proxy "name"
_age = Proxy :: Proxy "age"