{-# OPTIONS_HADDOCK hide #-} -- This source file is part of HGamer3D -- (A project to enable 3D game development in Haskell) -- For the latest info, see http://www.hgamer3d.org -- -- (c) 2011-2013 Peter Althainz -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. -- GUI/Internal/Form.hs -- |Form functionality of the GUI. Implementation module with internal data structures exposed. Public API in HGamer3D.GUI. module HGamer3D.GUI.Internal.Form where import HGamer3D.GUI.Internal.Base import HGamer3D.GUI.Internal.Widgets import HGamer3D.GUI.Internal.Properties import HGamer3D.GUI.Schema.Widget import HGamer3D.GUI.Schema.Layout import HGamer3D.GUI.Schema.Form import HGamer3D.GUI.Schema.GUIDim import Data.Maybe import Control.Monad {- ---------------------------------------------------------------- Functions for ECS API ---------------------------------------------------------------- -} data GUIEngineDataWidget = GEDButton GUIButton String | GEDRadioButton GUIRadioButton String | GEDCheckBox GUICheckBox String | GEDComboBox GUIComboBox String | GEDListBox GUIListBox String | GEDSpinner GUISpinner String | GEDSlider GUISlider String | GEDEditText GUIEditText String | GEDMultilineText GUIMultilineText String data GUIEngineDataLayout = GEDHLayout GUIHLayout | GEDVLayout GUIVLayout | GEDGridLayout GUIGridLayout | GEDWindow GUIWindow data GUIEngineData = GUIEngineData GUIEngineDataElement Form data GUIEngineDataElement = GEDSingleElement GUIEngineDataWidget | GEDCombinedElement GUIEngineDataLayout [GUIEngineDataElement] -- there is a big distinction in the typesystem between a type which is not known to the function but it is assumed it has a specific type on calling (typevariable a) and the return value of being any possible type which is requested by outer world type (typevariable b). So _undef is polymorphic in its out value, this only can be accomplished by undef! _toUndef :: GUIElement a -> GUIElement b _toUndef (GUIElement window _) = (GUIElement window undefined) _getWidget :: GUIEngineDataElement -> GUIElement a _getWidget (GEDSingleElement (GEDButton w _)) = _toUndef w _getWidget (GEDSingleElement (GEDRadioButton w _)) = _toUndef w _getWidget (GEDSingleElement (GEDCheckBox w _)) = _toUndef w _getWidget (GEDSingleElement (GEDComboBox w _)) = _toUndef w _getWidget (GEDSingleElement (GEDListBox w _)) = _toUndef w _getWidget (GEDSingleElement (GEDSpinner w _)) = _toUndef w _getWidget (GEDSingleElement (GEDSlider w _)) = _toUndef w _getWidget (GEDSingleElement (GEDEditText w _)) = _toUndef w _getWidget (GEDSingleElement (GEDMultilineText w _)) = _toUndef w _getWidget (GEDCombinedElement (GEDHLayout l) _) = _toUndef l _getWidget (GEDCombinedElement (GEDVLayout l) _) = _toUndef l _getWidget (GEDCombinedElement (GEDGridLayout l) _) = _toUndef l _getWidget (GEDCombinedElement (GEDWindow l) _) = _toUndef l _createLayout :: GUISystem -> Layout -> String -> IO GUIEngineDataLayout _createLayout guis layout typename = do case layout of VerticalLayout props -> vLayout guis (_createProps props) >>= return . GEDVLayout HorizontalLayout props -> hLayout guis (_createProps props) >>= return . GEDHLayout GridLayout x y props -> gridLayout guis (_createProps props) >>= return . GEDGridLayout Window name props -> window guis typename (_createProps props) >>= return . GEDWindow -- the following routine assume same typename for new layout, it only modify props _updateLayoutProps :: GUIEngineDataLayout -> Layout -> IO () _updateLayoutProps edata layout = do -- check assumptions case (edata, layout) of (GEDHLayout hLayout, HorizontalLayout props) -> setP hLayout (_createProps props) (GEDVLayout vLayout, VerticalLayout props) -> setP vLayout (_createProps props) (GEDGridLayout gLayout, GridLayout x y props) -> setP gLayout (_createProps props) (GEDWindow window, Window n props) -> setP window (_createProps props) _ -> error "HGamer3D.GUI.Internal.Form._updateLayoutProps: update parameters not matching!" return () _createProps' :: (WidgetProperty -> GUIElement a -> IO ()) -> [WidgetProperty] -> [GUIElement a -> IO ()] _createProps' addOn props = let oneProp prop = case prop of XPos gd -> pX =: gd YPos gd -> pY =: gd Width gd -> pWidth =: gd Height gd -> pHeight =: gd Visible v -> pVisible =: v Alpha f -> pAlpha =: f Text t -> pText =: t Margin m -> pMargin =: m Tooltip t -> pTooltip =: t _ -> addOn prop in map oneProp props _createProps = _createProps' (\w -> (const (return ()))) _createPropsCB :: [WidgetProperty] -> [GUIComboBox -> IO ()] _createPropsCB props = let addOn prop = case prop of TextChoice tc -> pTextChoice =: tc _ -> const (return ()) in _createProps' addOn props _createPropsLB :: [WidgetProperty] -> [GUIListBox -> IO ()] _createPropsLB props = let addOn prop = case prop of TextSelection ts -> pTextSelection =: ts _ -> const (return ()) in _createProps' addOn props _createPropsHV :: [WidgetProperty] -> [GUIHasValue a -> IO ()] _createPropsHV props = let addOn prop = case prop of Value v -> pValue =: v _ -> const (return ()) in _createProps' addOn props _createPropsHS :: [WidgetProperty] -> [GUIHasSelection a -> IO ()] _createPropsHS props = let addOn prop = case prop of Selected s -> pSelected =: s _ -> const (return ()) in _createProps' addOn props _createWidget :: GUISystem -> Widget -> String -> IO GUIEngineDataElement _createWidget guis widget typename = do case widget of Button name props -> do w <- button guis typename (_createProps props) registerGUIEvent guis w "Clicked" name return (GEDSingleElement (GEDButton w name)) RadioButton name props -> do w <- radioButton guis typename (_createPropsHS props) registerGUIEvent guis w "SelectStateChanged" name return (GEDSingleElement (GEDRadioButton w name)) CheckBox name props -> do w <- checkBox guis typename (_createPropsHS props) registerGUIEvent guis w "CheckStateChanged" name return (GEDSingleElement (GEDCheckBox w name)) ComboBox name props -> do w <- comboBox guis typename (_createPropsCB props) registerGUIEvent guis w "ListSelectionAccepted" name return (GEDSingleElement (GEDComboBox w name)) ListBox name props -> do w <- listBox guis typename (_createPropsLB props) registerGUIEvent guis w "ItemSelectionChanged" name return (GEDSingleElement (GEDListBox w name)) Spinner name props -> do w <- spinner guis typename (_createPropsHV props) registerGUIEvent guis w "ValueChanged" name return (GEDSingleElement (GEDSpinner w name)) Slider name props -> do w <- slider guis typename (_createPropsHV props) registerGUIEvent guis w "ValueChanged" name return (GEDSingleElement (GEDSlider w name)) EditText name props -> do w <- editText guis typename (_createProps props) registerGUIEvent guis w "TextAccepted" name registerGUIEvent guis w "TextChanged" name return (GEDSingleElement (GEDEditText w name)) MultilineText name props -> do w <- multilineText guis typename (_createProps props) registerGUIEvent guis w "TextAccepted" name registerGUIEvent guis w "TextChanged" name return (GEDSingleElement (GEDMultilineText w name)) _updateWidgetProps :: GUIEngineDataElement -> Widget -> IO () _updateWidgetProps edata widget = do case (edata, widget) of (GEDSingleElement (GEDButton w _), Button name props) -> setP w (_createProps props) (GEDSingleElement (GEDRadioButton w _), RadioButton name props) -> setP w (_createPropsHS props) (GEDSingleElement (GEDCheckBox w _), CheckBox name props) -> setP w (_createPropsHS props) (GEDSingleElement (GEDComboBox w _), ComboBox name props) -> setP w (_createPropsCB props) (GEDSingleElement (GEDListBox w _), ListBox name props) -> setP w (_createPropsLB props) (GEDSingleElement (GEDSpinner w _), Spinner name props) -> setP w (_createPropsHV props) (GEDSingleElement (GEDSlider w _), Slider name props) -> setP w (_createPropsHV props) (GEDSingleElement (GEDEditText w _), EditText name props) -> setP w (_createProps props) (GEDSingleElement (GEDMultilineText w _), MultilineText name props) -> setP w (_createProps props) _ -> error "HGamer3D.GUI.Internal.Form._updateWidgetProps: update parameters not matching!" return () createForm :: GUISystem -> Form -> IO GUIEngineData createForm guis form = do let (Form typename formcontent) = form let createFormContent formcontent = do case formcontent of WidgetFC widget -> _createWidget guis widget typename LayoutFC layout formList -> do layoutW <- _createLayout guis layout typename widgetsW <- mapM createFormContent formList let cl = GEDCombinedElement layoutW widgetsW mapM (\f -> addChildGuiEl (_getWidget cl) (_getWidget f)) widgetsW return $ cl formW <- createFormContent formcontent addGuiElToDisplay guis (_getWidget formW) return $ GUIEngineData formW form getFormValues :: GUIEngineData -> IO [(String, FormValue)] getFormValues (GUIEngineData elem form) = do let addTo oldList n con = return . (flip (:)) oldList . (,) n . con let getItem oldList eitem = case eitem of GEDSingleElement widget -> case widget of GEDButton w n -> return ( (n, FVE) : oldList) GEDRadioButton w n -> getP w pSelected >>= addTo oldList n FVB GEDCheckBox w n -> getP w pSelected >>= addTo oldList n FVB GEDComboBox w n -> getP w pText >>= addTo oldList n FVS GEDListBox w n -> getP w pTextSelection >>= addTo oldList n FVTS GEDSpinner w n -> getP w pValue >>= addTo oldList n FVF GEDSlider w n -> getP w pValue >>= addTo oldList n FVF GEDEditText w n -> getP w pText >>= addTo oldList n FVS GEDMultilineText w n -> getP w pText >>= addTo oldList n FVS let foldEitems oldList eitem = case eitem of GEDSingleElement widget -> getItem oldList eitem GEDCombinedElement _ widgetList -> foldM foldEitems oldList widgetList foldEitems [] elem _getFormStructure :: Form -> [String] _getFormStructure (Form typename content) = let getItem oldList eitem = case eitem of WidgetFC widget -> case widget of Button n _ -> ("Button/" ++ n) : oldList RadioButton n _ -> ("RadioButton/" ++ n) : oldList CheckBox n _ -> ("CheckBox/" ++ n) : oldList ComboBox n _ -> ("ComboBox/" ++ n) : oldList ListBox n _ -> ("ListBox/" ++ n) : oldList Spinner n _ -> ("Spinner/" ++ n) : oldList Slider n _ -> ("Slider/" ++ n) : oldList EditText n _ -> ("EditText/" ++ n) : oldList MultilineText n _ -> ("MultilineText/" ++ n) : oldList LayoutFC layout itemList -> let subList = foldl getItem [] itemList in case layout of VerticalLayout props -> ["VLStart"] ++ subList ++ ["VLEnd"] ++ oldList HorizontalLayout props -> ["HLStart"] ++ subList ++ ["HLEnd"] ++ oldList GridLayout _ _ props -> ["GridStart"] ++ subList ++ ["GridEnd"] ++ oldList Window n props -> ["WStart"] ++ subList ++ ["WEnd"] ++ oldList in getItem [typename] content setFormValues :: GUIEngineData -> [(String, FormValue)] -> IO () setFormValues (GUIEngineData elem form) valueList = do let filterItemSet w n prop valueList = do case filter (\(name, value) -> name == n) valueList of [] -> return () ((n', v') : _) -> do setP w [prop v'] return () let setItem valueList eitem = case eitem of GEDSingleElement widget -> case widget of GEDButton w n -> return () GEDRadioButton w n -> filterItemSet w n (\v -> let (FVB v') = v in pSelected =: v') valueList GEDCheckBox w n -> filterItemSet w n (\v -> let (FVB v') = v in pSelected =: v') valueList GEDComboBox w n -> filterItemSet w n (\v -> let (FVS v') = v in pText =: v') valueList GEDListBox w n -> filterItemSet w n (\v -> let (FVTS v') = v in pTextSelection =: v') valueList GEDSpinner w n -> filterItemSet w n (\v -> let (FVF v') = v in pValue =: v') valueList GEDSlider w n -> filterItemSet w n (\v -> let (FVF v') = v in pValue =: v') valueList GEDEditText w n -> filterItemSet w n (\v -> let (FVS v') = v in pText =: v') valueList GEDMultilineText w n -> filterItemSet w n (\v -> let (FVS v') = v in pText =: v') valueList GEDCombinedElement _ widgetList -> mapM (setItem valueList) widgetList >> return () setItem valueList elem return () removeForm :: GUISystem -> GUIEngineData -> IO () removeForm guis form = do let (GUIEngineData elem schema) = form -- first detach from screen removeGuiElFromDisplay guis (_getWidget elem) -- then delete the elements in order let deleteSingleItem elem = case elem of GEDSingleElement w -> deleteGuiEl guis (_getWidget elem) GEDCombinedElement layout widgetList -> do -- remove childs from parent, then delete mapM (\el -> removeChildGuiEl (_getWidget elem) (_getWidget el)) widgetList mapM deleteSingleItem widgetList deleteGuiEl guis (_getWidget elem) deleteSingleItem elem return () -- update form with same structure, apply properties again for all elements, which are different _updateFormElement :: GUISystem -> GUIEngineDataElement -> FormContent -> FormContent -> IO () _updateFormElement guis elem oldFC newFC = do case (elem, oldFC, newFC) of (GEDSingleElement w, WidgetFC (Button _ oldProps), WidgetFC wid@(Button _ newProps)) -> do if oldProps /= newProps then _updateWidgetProps elem wid else return () (GEDSingleElement w, WidgetFC (RadioButton _ oldProps), WidgetFC wid@(RadioButton _ newProps)) -> do if oldProps /= newProps then _updateWidgetProps elem wid else return () (GEDSingleElement w, WidgetFC (CheckBox _ oldProps), WidgetFC wid@(CheckBox _ newProps)) -> do if oldProps /= newProps then _updateWidgetProps elem wid else return () (GEDSingleElement w, WidgetFC (ComboBox _ oldProps), WidgetFC wid@(ComboBox _ newProps)) -> do if oldProps /= newProps then _updateWidgetProps elem wid else return () (GEDSingleElement w, WidgetFC (ListBox _ oldProps), WidgetFC wid@(ListBox _ newProps)) -> do if oldProps /= newProps then _updateWidgetProps elem wid else return () (GEDSingleElement w, WidgetFC (Spinner _ oldProps), WidgetFC wid@(Spinner _ newProps)) -> do if oldProps /= newProps then _updateWidgetProps elem wid else return () (GEDSingleElement w, WidgetFC (Slider _ oldProps), WidgetFC wid@(Slider _ newProps)) -> do if oldProps /= newProps then _updateWidgetProps elem wid else return () (GEDSingleElement w, WidgetFC (EditText _ oldProps), WidgetFC wid@(EditText _ newProps)) -> do if oldProps /= newProps then _updateWidgetProps elem wid else return () (GEDSingleElement w, WidgetFC (MultilineText _ oldProps), WidgetFC wid@(MultilineText _ newProps)) -> do if oldProps /= newProps then _updateWidgetProps elem wid else return () (GEDCombinedElement layout elems, LayoutFC oldLayout oldContentList, LayoutFC newLayout newContentList) -> do if oldLayout /= newLayout then _updateLayoutProps layout newLayout else return () mapM (\(elem, oldContent, newContent) -> _updateFormElement guis elem oldContent newContent) (zip3 elems oldContentList newContentList) return () updateForm :: GUISystem -> GUIEngineData -> Form -> IO GUIEngineData updateForm guis edata form = do -- check if different structure, then redo let ed@(GUIEngineData elem oldForm) = edata if (_getFormStructure oldForm) /= (_getFormStructure form) then do removeForm guis ed createForm guis form -- if structure is the same, only update properties else do let (Form typename content) = form let (Form typename oldContent) = oldForm _updateFormElement guis elem oldContent content return edata