{-| Module : Tutorial06_Composite Copyright : (c) 2018 Francisco Vallarino License : BSD-3-Clause (see the LICENSE file) Maintainer : fjvallarino@gmail.com Stability : experimental Portability : non-portable Main module for the '06 - Composite' tutorial. -} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Tutorial06_Composite where import Control.Concurrent (threadDelay) import Control.Lens import Data.List import Data.Text (Text) import Monomer import TextShow import qualified Data.Text as T import qualified Monomer.Lens as L data CompModel = CompModel { _listA :: [Int], _listB :: [Int] } deriving (Eq, Show) data CompEvent = DropToA Int | DropToB Int deriving (Eq, Show) data AppModel = AppModel { _showDialog :: Bool, _parentModel :: CompModel, _dialogModel :: CompModel } deriving (Eq, Show) data AppEvent = AppInit | ShowDialog | CloseDialog deriving (Eq, Show) makeLenses 'CompModel makeLenses 'AppModel buildUIComp :: WidgetEnv CompModel CompEvent -> CompModel -> WidgetNode CompModel CompEvent buildUIComp wenv model = widgetTree where sectionBg = rgbHex "#80B6FD" sectionHover = rgbHex "#A0D8FD" textDrag = rgbHex "#E0FFFF" itemA val = label ("Item: " <> showt val) `styleBasic` [textColor black, padding 5] dragItem val = draggable_ val [draggableStyle [bgColor textDrag, radius 5]] (itemA val) `styleBasic` [cursorHand] dragList items = vstack (dragItem <$> items) dropContainer target list = dropTarget_ target [dropTargetStyle [radius 10, bgColor sectionHover]] (dragList (model ^. list)) `styleBasic` [minWidth 100, flexHeight 100, padding 5, radius 10, bgColor sectionBg] dropTargetA = dropContainer DropToA listA dropTargetB = dropContainer DropToB listB widgetTree = hstack [ box dropTargetA `styleBasic` [paddingR 5], box dropTargetB `styleBasic` [paddingL 5] ] handleEventComp :: WidgetEnv CompModel CompEvent -> WidgetNode CompModel CompEvent -> CompModel -> CompEvent -> [EventResponse CompModel CompEvent sp ep] handleEventComp wenv node model evt = case evt of DropToA val -> [Model $ model & listA .~ sort (val : model ^. listA) & listB .~ delete val (model ^. listB)] DropToB val -> [Model $ model & listA .~ delete val (model ^. listA) & listB .~ sort (val : model ^. listB)] compWidget :: (WidgetModel sp, WidgetEvent ep) => ALens' sp CompModel -> WidgetNode sp ep compWidget field = composite "compWidget" field buildUIComp handleEventComp buildUI :: WidgetEnv AppModel AppEvent -> AppModel -> WidgetNode AppModel AppEvent buildUI wenv model = widgetTree where baseLayer = vstack [ compWidget parentModel, spacer, hstack [ button "Show Dialog" ShowDialog ] ] `styleBasic` [padding 10] closeIcon = icon IconClose `styleBasic` [width 16, height 16, fgColor black, cursorHand] dialogLayer = vstack [ hstack [ filler, box_ [alignTop, onClick CloseDialog] closeIcon ], spacer, compWidget dialogModel ] `styleBasic` [width 500, height 400, padding 10, radius 10, bgColor darkGray] widgetTree = zstack [ baseLayer, box_ [alignCenter, alignMiddle] dialogLayer `nodeVisible` model ^. showDialog `styleBasic` [bgColor (gray & L.a .~ 0.8)] ] handleEvent :: WidgetEnv AppModel AppEvent -> WidgetNode AppModel AppEvent -> AppModel -> AppEvent -> [AppEventResponse AppModel AppEvent] handleEvent wenv node model evt = case evt of AppInit -> [] ShowDialog -> [Model $ model & showDialog .~ True] CloseDialog -> [Model $ model & showDialog .~ False] main06 :: IO () main06 = do startApp model handleEvent buildUI config where config = [ appWindowTitle "Tutorial 06 - Composite", appWindowIcon "./assets/images/icon.bmp", appTheme darkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appInitEvent AppInit ] compModel = CompModel { _listA = [1..10], _listB = [] } model = AppModel { _showDialog = False, _parentModel = compModel, _dialogModel = compModel }