Formless + Halogen Store

Main.purs

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 (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)

-----
-- 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 | Receive (Connected Store Unit)

page :: forall q o m. MonadAff m => MonadStore StoreAction Store m => H.Component q Unit o m
page = connect (selectEq identity) $ H.mkComponent
  { initialState: \{ context } -> context
  , render
  , eval: H.mkEval $ H.defaultEval { handleAction = handleAction, receive = Just <<< Receive }
  }
  where
  handleAction = case _ of
    HandleDogForm dog ->
      liftEffect $ TryPureScript.render =<< TryPureScript.withConsole do
        logShow (dog :: Dog)
    
    Receive store ->
      H.put store.context

  render { name } = 
    HH.div_
      [ HH.p_ [ HH.text $ "Global name: " <> name ]
      , HH.slot F._formless unit (F.component mkInput spec) { name } HandleDogForm
      ]
  
-----
-- GLOBAL STATE
-----

type Store = { name :: String }

initialStore :: Store
initialStore = { name: "Toby" }

type StoreAction = Store -> Store

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

-----
-- FORMLESS FORM
-----

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) _

mkInput :: forall m. Monad m => { name :: String } -> F.Input' DogForm m
mkInput { name } =
  { initialInputs: Just $ F.wrapInputFields
      { name
      , age: ""
      }
  , 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)
      }
  }

data FormAction = FormSubmit Event

spec 
  :: forall query m
   . MonadStore StoreAction Store m
  => MonadAff m
  => F.Spec DogForm () query FormAction () { name :: String } Dog m
spec = F.defaultSpec { render = render, handleAction = handleAction, handleEvent = handleEvent }
  where
  handleAction (FormSubmit event) = do
    H.liftEffect $ preventDefault event
    { form } <- H.get
    let submittedName = F.getInput _name form
    updateStore \store -> store { name = submittedName }
    F.handleAction handleAction handleEvent F.submit
    
  handleEvent = F.raiseResult
    
  render { form } =
    HH.form
      [ HE.onSubmit $ F.injAction <<< FormSubmit ]
      [ 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"