{-| Module : Main 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 'Todo' example. -} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Lens import Data.Default import Data.Maybe import Data.Text (Text) import TextShow import Monomer import TodoTypes import qualified Monomer.Lens as L import qualified Data.Text as T type TodoWenv = WidgetEnv TodoModel TodoEvt type TodoNode = WidgetNode TodoModel TodoEvt todoRowKey :: Todo -> Text todoRowKey todo = "todoRow" <> showt (todo ^. todoId) todoRow :: TodoWenv -> TodoModel -> Int -> Todo -> TodoNode todoRow wenv model idx t = animRow `nodeKey` todoKey where sectionBg = wenv ^. L.theme . L.sectionColor rowButtonColor = wenv ^. L.theme . L.userColorMap . at "rowButton" . non def rowSepColor = gray & L.a .~ 0.5 todoKey = todoRowKey t todoDone = t ^. status == Done isLast = idx == length (model ^. todos) - 1 (todoBg, todoFg) | todoDone = (doneBg, doneFg) | otherwise = (pendingBg, pendingFg) todoStatus = labelS (t ^. status) `styleBasic` [textFont "Medium", textSize 12, textAscender, textColor todoFg, padding 6, paddingH 8, radius 12, bgColor todoBg] rowButton caption action = button caption action `styleBasic` [textFont "Remix", textMiddle, textColor rowButtonColor, bgColor transparent, border 0 transparent] `styleHover` [bgColor sectionBg] `styleFocus` [bgColor (sectionBg & L.a .~ 0.5)] `styleFocusHover` [bgColor sectionBg] todoInfo = hstack [ vstack [ labelS (t ^. todoType) `styleBasic` [textSize 12, textColor darkGray], spacer_ [width 5], label (t ^. description) `styleBasic` [textThroughline_ todoDone] ], filler, box_ [alignRight] todoStatus `styleBasic` [width 80], spacer, rowButton remixEdit2Line (TodoEdit idx t), spacer, rowButton remixDeleteBinLine (TodoDeleteBegin idx t) ] `styleBasic` [ paddingV 15, styleIf (not isLast) $ borderB 1 rowSepColor ] animRow = animFadeOut_ [onFinished (TodoDelete idx t)] todoInfo todoEdit :: TodoWenv -> TodoModel -> TodoNode todoEdit wenv model = editNode where sectionBg = wenv ^. L.theme . L.sectionColor isValidInput = model ^. activeTodo . description /= "" (saveAction, saveLabel) = case model ^. action of TodoEditing idx -> (TodoSave idx, "Save") _ -> (TodoAdd, "Add") saveTodoBtn = mainButton saveLabel saveAction editFields = keystroke [("Enter", saveAction) | isValidInput] $ vstack [ hstack [ label "Task:", spacer, textField (activeTodo . description) `nodeKey` "todoDesc" ], spacer, hgrid [ hstack [ label "Type:", spacer, textDropdownS (activeTodo . todoType) todoTypes `nodeKey` "todoType", spacer -- Added here to avoid grid expanding it to 1/3 total width ], hstack [ label "Status:", spacer, textDropdownS (activeTodo . status) todoStatuses ] ] ] editNode = keystroke [("Esc", TodoCancel)] $ vstack [ editFields, spacer, hstack [ filler, saveTodoBtn `nodeEnabled` isValidInput, spacer, button "Cancel" TodoCancel ] ] `styleBasic` [bgColor sectionBg, padding 20] buildUI :: TodoWenv -> TodoModel -> TodoNode buildUI wenv model = widgetTree where sectionBg = wenv ^. L.theme . L.sectionColor isEditing | TodoEditing _ <- model ^. action = True | otherwise = False countLabel = label caption `styleBasic` styles where caption = "Tasks (" <> showt (length $ model ^. todos) <> ")" styles = [textFont "Regular", textSize 16, padding 20, bgColor sectionBg] todoList = vstack (zipWith (todoRow wenv model) [0..] (model ^. todos)) newButton = mainButton "New" TodoNew `nodeKey` "todoNew" `nodeVisible` not isEditing editLayer = content where dualSlide content = outer where inner = animSlideIn_ [slideTop, duration 200] content `nodeKey` "animEditIn" outer = animSlideOut_ [slideTop, duration 200, onFinished TodoHideEditDone] inner `nodeKey` "animEditOut" content = vstack [ dualSlide (todoEdit wenv model), filler ] `styleBasic` [bgColor (grayDark & L.a .~ 0.5)] confirmDeleteLayer = case model ^.action of TodoConfirmingDelete idx todo -> [popup] where popup = confirmMsg msg (TodoConfirmDelete idx todo) TodoCancelDelete msg = "Are you sure you want to delete '" <> (todo ^. description) <> "' ?" _ -> [] mainLayer = vstack [ countLabel, scroll_ [] (todoList `styleBasic` [padding 20, paddingT 5]), filler, box_ [alignRight] newButton `styleBasic` [bgColor sectionBg, padding 20] ] widgetTree = zstack ([ mainLayer, editLayer `nodeVisible` isEditing ] <> confirmDeleteLayer) handleEvent :: TodoWenv -> TodoNode -> TodoModel -> TodoEvt -> [EventResponse TodoModel TodoEvt TodoModel TodoEvt] handleEvent wenv node model evt = case evt of TodoInit -> [SetFocusOnKey "todoNew"] TodoNew -> [ Event TodoShowEdit, Model $ model & action .~ TodoAdding & activeTodo .~ def, SetFocusOnKey "todoDesc"] TodoEdit idx td -> [ Event TodoShowEdit, Model $ model & action .~ TodoEditing idx & activeTodo .~ td, SetFocusOnKey "todoDesc"] TodoAdd -> [ Event TodoHideEdit, Model $ addNewTodo wenv model, SetFocusOnKey "todoNew"] TodoSave idx -> [ Event TodoHideEdit, Model $ model & todos . ix idx .~ (model ^. activeTodo), SetFocusOnKey "todoNew"] TodoDeleteBegin idx todo -> [ Model (model & action .~ TodoConfirmingDelete idx todo)] TodoConfirmDelete idx todo -> [ Model (model & action .~ TodoNone), Message (WidgetKey (todoRowKey todo)) AnimationStart] TodoCancelDelete -> [ Model (model & action .~ TodoNone)] TodoDelete idx todo -> [ Model $ model & todos .~ remove idx (model ^. todos), SetFocusOnKey "todoNew"] TodoCancel -> [ Event TodoHideEdit, Model $ model & activeTodo .~ def, SetFocusOnKey "todoNew"] TodoShowEdit -> [ Message "animEditIn" AnimationStart, Message "animEditOut" AnimationStop ] TodoHideEdit -> [ Message "animEditIn" AnimationStop, Message "animEditOut" AnimationStart ] TodoHideEditDone -> [ Model $ model & action .~ TodoNone] addNewTodo :: WidgetEnv s e -> TodoModel -> TodoModel addNewTodo wenv model = newModel where newTodo = model ^. activeTodo & todoId .~ currentTimeMs wenv newModel = model & todos .~ (newTodo : model ^. todos) initialTodos :: [Todo] initialTodos = todos where items = mconcat $ replicate 1 [ Todo 0 Home Done "Tidy up the room", Todo 0 Home Pending "Buy groceries", Todo 0 Home Pending "Pay the bills", Todo 0 Home Pending "Repair kitchen sink", Todo 0 Work Done "Check the status of project A", Todo 0 Work Pending "Finish project B", Todo 0 Work Pending "Send email to clients", Todo 0 Work Pending "Contact cloud services provider" ] todos = zipWith (\t idx -> t & todoId .~ idx) items [0..] main :: IO () main = do startApp (TodoModel initialTodos def TodoNone) handleEvent buildUI config where config = [ appWindowTitle "Todo list", appWindowIcon "./assets/images/icon.png", appTheme customDarkTheme, appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf", appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf", appFontDef "Bold" "./assets/fonts/Roboto-Bold.ttf", appFontDef "Remix" "./assets/fonts/remixicon.ttf", appInitEvent TodoInit ] doneBg = rgbHex "#CFF6E2" doneFg = rgbHex "#459562" pendingBg = rgbHex "#F5F0CC" pendingFg = rgbHex "#827330" grayLight = rgbHex "#9E9E9E" grayDark = rgbHex "#393939" grayDarker = rgbHex "#2E2E2E" customLightTheme :: Theme customLightTheme = lightTheme -- & L.userColorMap . at "statusFont" ?~ grayDarker & L.userColorMap . at "rowButton" ?~ grayLight customDarkTheme :: Theme customDarkTheme = darkTheme -- & L.userColorMap . at "statusFont" ?~ grayDarker & L.userColorMap . at "rowButton" ?~ gray remove :: Int -> [a] -> [a] remove idx ls = take idx ls ++ drop (idx + 1) ls