{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
import Control.Monad
import Data.Biapplicative
import Data.Default
import Data.Maybe
import qualified Generics.SOP as SOP
import GHC.Generics (Generic)
import Graphics.UI.Threepenny.Core
import Graphics.UI.Threepenny.Editors
import Graphics.UI.Threepenny.Editors.Types
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 (usage :: Usage) = Person
{ education :: Field usage Education
, firstName, lastName :: Field usage String
, age :: Field usage (Maybe Int)
, brexiteer :: Field usage Brexiteer
, status :: Field usage LegalStatus
}
deriving (Generic)
type Person = PersonF Value
type PersonEditor = PersonF Edit
instance Validable Person where
validate Person{..}
| null firstName = Invalid "First name cannot be null"
| null lastName = Invalid "Last name cannot be null"
| Just x <- age, x <= 0 = Invalid "Age must be a natural number"
| otherwise = Ok
data LegalStatus
= Single
| Married
| Divorced
| Widowed
deriving (Bounded, Enum, Eq, Ord, Show, Generic)
instance Editable LegalStatus
instance SOP.HasDatatypeInfo LegalStatus
instance SOP.Generic LegalStatus
instance Default LegalStatus where def = Single
data Education
= Basic
| Intermediate
| Other String
deriving (Eq, Ord, Read, Show, Generic)
instance Default Education where def = Basic
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 Default Brexiteer where def = Brexiteer False
instance Editable Brexiteer where editor = editorGenericSimple
instance SOP.HasDatatypeInfo Brexiteer
instance SOP.Generic Brexiteer
deriving instance Show Person
instance Editable Person
instance SOP.HasDatatypeInfo Person
instance SOP.Generic Person
instance Default Person where def = Person Basic "First" "Last" (Just 18) def def
-- | An editor for 'Person' values that combines the 'Horizontal' and 'Vertical' layout builders
editorPersonHV :: Editor Person Vertical Person
editorPersonHV = do
(firstName, lastName) <- withLayout Vertical $ construct $ do
firstName <- fieldLayout Horizontal "First:" firstName editor
lastName <- fieldLayout Horizontal "Last:" lastName editor
return (firstName, lastName)
(age, education) <- withLayout Vertical $ construct $ do
age <- fieldLayout Horizontal "Age:" age editor
education <- fieldLayout Horizontal "Education:" education editorEducation
return (age, education)
(status, brexiteer) <- withLayout Vertical $ construct $ do
status <- fieldLayout Horizontal "Status" status (withSomeWidget $ editorJust $ editorSelection (pure [minBound..]) (pure (string.show)))
brexiteer <- fieldLayout Horizontal "Brexiter" brexiteer editor
return (status, brexiteer)
return 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 (withSomeWidget $ 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 =
bipure Person Person
<<*>> edit education editor
<<*>> edit firstName editor
<<*>> edit lastName editor
<<*>> edit age editor
<<*>> edit brexiteer editor
<<*>> edit status editor
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"
person1HV <- create editorPersonHV person1B
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 def (updateIfValid . head <$> unions
[ edited person1HV
, edited person1C
, edited person2
, edited person3e
])
-- We can attach validation to any editor
validation <-
stepper Ok (validate . head <$>
unions [ edited person1HV
, edited person1C
, edited person2
, edited person3e])
getBody w #+ [grid
[ [span # sink text (show <$> validation) # set style [("color", "red")]]
, [render person1HV]
, [hr]
, [render person1C]
, [hr]
, [render person2]
, [hr]
, [render person3e]
, [hr]
]]