threepenny-editors-0.5.5: examples/Person.hs

{-# LANGUAGE ApplicativeDo              #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE RecursiveDo                #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS_GHC -Wno-name-shadowing     #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
module Person (main) where
import           Control.Monad
import           Data.Maybe
import qualified Generics.SOP                              as SOP
import           Generics.SOP.TH
import           GHC.Generics                              (Generic)
import           Graphics.UI.Threepenny.Core
import           Graphics.UI.Threepenny.Editors
import           Graphics.UI.Threepenny.Editors.Layout     (above, beside)
import           Graphics.UI.Threepenny.Editors.Validation
import           Graphics.UI.Threepenny.Elements
import           Prelude                                   hiding (span)

main :: IO ()
main = startGUI defaultConfig setup

-- | A dual purpose data type that doubles as a value and as a widget depending on the type argument.
data PersonF (purpose :: Purpose) = Person
  { education           :: Field purpose Education
  , firstName, lastName :: Field purpose String
  , age                 :: Field purpose (Maybe Int)
  , brexiteer           :: Field purpose Brexiteer
  , status              :: Field purpose LegalStatus
  }
  deriving (Generic)

type Person = PersonF Data
type PersonEditor = PersonF Edit

defPerson :: Person
defPerson = Person Basic "First" "Last" Nothing (Brexiteer False) Single

instance Validable Person where
  validate Person{..} = fromWarnings $
    [ "First name cannot be null" | null firstName ] ++
    [ "Last name cannot be null"  | null lastName ] ++
    [ "Age must be a natural number" | Just x <- [age], x <= 0]

data LegalStatus
  = Single
  | Married
  | Divorced
  | Widowed
  deriving (Bounded, Enum, Eq, Ord, Show, Generic)

instance Editable LegalStatus
instance SOP.HasDatatypeInfo LegalStatus
instance SOP.Generic LegalStatus

data Education
  = Basic
  | Intermediate
  | Other String
  deriving (Eq, Ord, Read, Show, Generic)

getOther :: Education -> Maybe String
getOther (Other s) = Just s
getOther _         = Nothing

-- | A manually defined editor for 'Education'.
--   It is also possible to derive this 'Editor' via Generics.SOP, as done below.
editorEducation :: Editor Education Layout Education
editorEducation = do
    let selector x = case x of
            Other _ -> "Other"
            _       -> show x
    editorSum beside
      [ ("Basic", const Basic <$> withSomeWidget editorUnit)
      , ("Intermediate", const Intermediate <$> withSomeWidget editorUnit)
      , ("Other", dimapE (fromMaybe "" . getOther) Other someEditor)
      ]
      selector

instance Editable Education
instance SOP.HasDatatypeInfo Education
instance SOP.Generic Education

newtype Brexiteer = Brexiteer Bool deriving (Eq, Show, Ord, Generic)

instance Editable Brexiteer where editor = editorGeneric
instance SOP.HasDatatypeInfo Brexiteer
instance SOP.Generic Brexiteer

deriving instance Show Person

instance Editable Person

-- | An editor for 'Person' values that uses the 'Columns' layout builder
editorPersonColumns :: Editor Person Columns Person
editorPersonColumns = do
      firstName <- fieldLayout Next "First:"     firstName editor
      lastName  <- fieldLayout Next "Last:"      lastName editor
      age       <- fieldLayout Next "Age:"       age editor
      education <- fieldLayout Break "Education:" education editorEducation
      status    <- fieldLayout Next "Status"     status (editorJust $ editorSelection (pure [minBound..]) (pure (string.show)))
      brexiteer <- fieldLayout Next "Brexiter"   brexiteer editor
      return Person{..}


-- | A editor for 'Person' values with a fully fledged Widget type.
--   The UI and layout are defined in the 'Renderable' instance for the widget.
personEditor :: Editor Person PersonEditor Person
personEditor = editorGenericBi

instance Renderable PersonEditor where
  getLayout Person{..} =
    ( ("First: "  ||| firstName) ===
      ("Last: "   ||| lastName)  ===
      ("Status: " ||| status)
    ) |||
    (("Age:" ||| age) ===
     ("Brexiteer: " ||| brexiteer) ===
     ("Education: " ||| education))
   where
    a ||| b = getLayout a `beside` getLayout b
    a === b = getLayout a `above`  getLayout b

-- Driver
setup :: Window -> UI ()
setup w = void $ mdo
  _ <- return w # set title "Threepenny editors example"
  person1C <- create editorPersonColumns person1B
  person2  <- create editorGeneric person1B
  person3e <- create personEditor person1B
  -- When using a biapplicative editor, we can set the attributes of the field editors after creation.
  _ <- element (firstName (widgetControl person3e)) # set style [("background-color", "Blue")]
  person1B <- accumB defPerson (updateIfValid . head <$> unions
                            [ edited person1C
                            , edited person2
                            , edited person3e
                            ])

  -- We can attach validation to any editor
  validation <-
      stepper ok (validate . head <$>
                  unions [ edited person1C
                         , edited person2
                         , edited person3e])

  getBody w #+ [grid
    [ [span # sink text (show <$> validation) # set style [("color", "red")]]
    , [render person1C]
    , [hr]
    , [render person2]
    , [hr]
    , [render person3e]
    , [hr]
    ]]

deriveGeneric ''PersonF