never executed always true always false
    1 {-|
    2 Module: Flaw.UI.Layout
    3 Description: Helper functions for placing UI elements in free containers.
    4 License: MIT
    5 -}
    6 
    7 module Flaw.UI.Layout
    8   ( FlowLayoutState(..)
    9   , FlowLayoutM
   10   , panelFlowLayout
   11   , frameFlowLayout
   12   , titleInFlowLayout
   13   , labeledFlowLayout
   14   , checkBoxedFlowLayout
   15   , elementInFlowLayout
   16   , elementWithSizeInFlowLayout
   17   , okCancelButtonsInFlowLayout
   18   ) where
   19 
   20 import Control.Concurrent.STM
   21 import Control.Monad.State.Strict
   22 import qualified Data.Text as T
   23 
   24 import Flaw.Math
   25 import Flaw.UI
   26 import Flaw.UI.Button
   27 import Flaw.UI.CheckBox
   28 import Flaw.UI.Frame
   29 import Flaw.UI.Label
   30 import Flaw.UI.Metrics
   31 import Flaw.UI.Panel
   32 import Flaw.UI.VisualElement
   33 
   34 data FlowLayoutState = FlowLayoutState
   35   { flsMetrics :: !Metrics
   36   , flsParentElement :: !Panel
   37   , flsLayoutHandler :: !(Rect -> STM Rect)
   38   , flsPreSize :: !Size
   39   }
   40 
   41 type FlowLayoutM = StateT FlowLayoutState STM
   42 
   43 {-# INLINEABLE panelFlowLayout #-}
   44 panelFlowLayout :: Metrics -> FlowLayoutM () -> STM Panel
   45 panelFlowLayout metrics flowLayout = do
   46   panel <- newPanel False
   47   FlowLayoutState
   48     { flsLayoutHandler = layoutHandler
   49     } <- execStateT flowLayout FlowLayoutState
   50     { flsMetrics = metrics
   51     , flsParentElement = panel
   52     , flsLayoutHandler = return
   53     , flsPreSize = Vec2 0 0
   54     }
   55   setLayoutHandler panel $ \(Vec2 sx sy) -> void $ layoutHandler $ Vec4 0 0 sx sy
   56   return panel
   57 
   58 {-# INLINEABLE frameFlowLayout #-}
   59 frameFlowLayout :: Metrics -> FlowLayoutM () -> STM Frame
   60 frameFlowLayout metrics@Metrics
   61   { metricsGap = gap
   62   , metricsBigGap = bigGap
   63   , metricsFrameClient = frameClient
   64   } flowLayout = do
   65   panel <- newPanel True
   66   FlowLayoutState
   67     { flsLayoutHandler = layoutHandler
   68     , flsPreSize = preSize
   69     } <- execStateT flowLayout FlowLayoutState
   70     { flsMetrics = metrics
   71     , flsParentElement = panel
   72     , flsLayoutHandler = return
   73     , flsPreSize = Vec2 0 0
   74     }
   75   setLayoutHandler panel $ \(Vec2 sx sy) ->
   76     void $ layoutHandler (Vec4 bigGap bigGap (sx - bigGap) (sy - bigGap))
   77   frame <- newFrame panel metrics
   78   layoutElement frame $ xy__ frameClient + zw__ frameClient + preSize + Vec2 (bigGap * 2) (bigGap * 2 - gap)
   79   return frame
   80 
   81 -- | Title in a layout.
   82 titleInFlowLayout :: T.Text -> FlowLayoutM ()
   83 titleInFlowLayout text = do
   84   labelVE <- lift $ do
   85     label <- newTitleLabel
   86     setText label text
   87     newVisualElement label
   88   FlowLayoutState
   89     { flsMetrics = Metrics
   90       { metricsLabelSize = labelSize
   91       , metricsTitleHeight = titleHeight
   92       }
   93     } <- get
   94   let Vec2 labelWidth _labelHeight = labelSize
   95   elementWithSizeInFlowLayout labelVE $ Vec2 labelWidth titleHeight
   96 
   97 -- | Label a sublayout.
   98 -- Sublayout will be placed to the right of the label.
   99 {-# INLINEABLE labeledFlowLayout #-}
  100 labeledFlowLayout :: T.Text -> FlowLayoutM a -> FlowLayoutM a
  101 labeledFlowLayout text subLayout = do
  102   -- get state
  103   s@FlowLayoutState
  104     { flsMetrics = Metrics
  105       { metricsGap = gap
  106       , metricsLabelSize = labelSize
  107       }
  108     , flsParentElement = parentElement
  109     , flsLayoutHandler = lh
  110     , flsPreSize = ps
  111     } <- get
  112   let
  113     Vec2 labelWidth labelHeight = labelSize
  114     Vec2 psx psy = ps
  115   -- create label
  116   label <- lift newTextLabel
  117   lift $ setText label text
  118   labelVE <- lift $ newVisualElement label
  119   labelVEChild <- lift $ addFreeChild parentElement labelVE
  120   -- run sub layout
  121   (r, FlowLayoutState
  122     { flsLayoutHandler = subLayoutHandler
  123     , flsPreSize = sps
  124     }) <- lift $ runStateT subLayout s
  125     { flsLayoutHandler = return
  126     , flsPreSize = Vec2 0 0
  127     }
  128   let Vec2 spsx spsy = sps
  129   put s
  130     { flsLayoutHandler = lh >=> \(Vec4 px py qx qy) -> do
  131       placeFreeChild parentElement labelVEChild (Vec2 px py)
  132       layoutElement labelVE labelSize
  133       sub <- subLayoutHandler $ Vec4 (px + labelWidth + gap) py qx qy
  134       let Vec4 _subpx subpy _subqx subqy = sub
  135       return $ Vec4 px (max (py + labelHeight + gap) subpy) qx (min qy subqy)
  136     , flsPreSize = Vec2 (max psx (labelWidth + gap + spsx)) (psy + max (labelHeight + gap) spsy)
  137     }
  138   return r
  139 
  140 -- | Label a sublayout with checkbox.
  141 -- Sublayout will be placed to the right of the checkbox.
  142 {-# INLINEABLE checkBoxedFlowLayout #-}
  143 checkBoxedFlowLayout :: T.Text -> (CheckBox -> FlowLayoutM a) -> FlowLayoutM a
  144 checkBoxedFlowLayout text subLayout = do
  145   -- get state
  146   s@FlowLayoutState
  147     { flsMetrics = Metrics
  148       { metricsGap = gap
  149       , metricsLabelSize = labelSize
  150       }
  151     , flsParentElement = parentElement
  152     , flsLayoutHandler = lh
  153     , flsPreSize = ps
  154     } <- get
  155   let
  156     Vec2 labelWidth labelHeight = labelSize
  157     Vec2 psx psy = ps
  158   -- create label
  159   checkBox <- lift $ newLabeledCheckBox text
  160   checkBoxChild <- lift $ addFreeChild parentElement checkBox
  161   -- run sub layout
  162   (r, FlowLayoutState
  163     { flsLayoutHandler = subLayoutHandler
  164     , flsPreSize = sps
  165     }) <- lift $ runStateT (subLayout checkBox) s
  166     { flsLayoutHandler = return
  167     , flsPreSize = Vec2 0 0
  168     }
  169   let Vec2 spsx spsy = sps
  170   put s
  171     { flsLayoutHandler = lh >=> \(Vec4 px py qx qy) -> do
  172       placeFreeChild parentElement checkBoxChild (Vec2 px py)
  173       layoutElement checkBox labelSize
  174       sub <- subLayoutHandler $ Vec4 (px + labelWidth + gap) py qx qy
  175       let Vec4 _subpx subpy _subqx subqy = sub
  176       return $ Vec4 px (max (py + labelHeight + gap) subpy) qx (min qy subqy)
  177     , flsPreSize = Vec2 (max psx (labelWidth + gap + spsx)) (psy + max (labelHeight + gap) spsy)
  178     }
  179   return r
  180 
  181 -- | Place element in layout.
  182 -- Adds gap after element.
  183 {-# INLINEABLE elementInFlowLayout #-}
  184 elementInFlowLayout :: (Element e, HasPreferredSize e) => e -> FlowLayoutM ()
  185 elementInFlowLayout element = do
  186   FlowLayoutState
  187     { flsMetrics = metrics
  188     } <- get
  189   elementWithSizeInFlowLayout element (preferredSize metrics element)
  190 
  191 -- | Place explicitly sized element in layout.
  192 -- Adds gap after element.
  193 {-# INLINEABLE elementWithSizeInFlowLayout #-}
  194 elementWithSizeInFlowLayout :: Element e => e -> Size -> FlowLayoutM ()
  195 elementWithSizeInFlowLayout element (Vec2 epsx epsy) = do
  196   -- get state
  197   s@FlowLayoutState
  198     { flsMetrics = Metrics
  199       { metricsGap = gap
  200       }
  201     , flsParentElement = parentElement
  202     , flsLayoutHandler = lh
  203     , flsPreSize = ps
  204     } <- get
  205   let Vec2 psx psy = ps
  206   -- add to container
  207   elementChild <- lift $ addFreeChild parentElement element
  208   put s
  209     { flsLayoutHandler = lh >=> \(Vec4 px py qx qy) -> do
  210       placeFreeChild parentElement elementChild (Vec2 px py)
  211       layoutElement element $ Vec2 (qx - px) epsy
  212       return $ Vec4 px (py + epsy + gap) qx qy
  213     , flsPreSize = Vec2 (max psx epsx) (psy + epsy + gap)
  214     }
  215 
  216 -- | Right-aligned pair of buttons.
  217 okCancelButtonsInFlowLayout :: Button -> Button -> FlowLayoutM ()
  218 okCancelButtonsInFlowLayout okButton cancelButton = do
  219   s@FlowLayoutState
  220     { flsMetrics = Metrics
  221       { metricsGap = gap
  222       , metricsBigGap = bigGap
  223       , metricsButtonSize = buttonSize
  224       }
  225     , flsParentElement = parentElement
  226     , flsLayoutHandler = layoutHandler
  227     , flsPreSize = preSize
  228     } <- get
  229   let
  230     Vec2 buttonWidth buttonHeight = buttonSize
  231     Vec2 psx psy = preSize
  232   okButtonChild <- lift $ addFreeChild parentElement okButton
  233   cancelButtonChild <- lift $ addFreeChild parentElement cancelButton
  234   lift $ do
  235     layoutElement okButton buttonSize
  236     layoutElement cancelButton buttonSize
  237     setDefaultElement parentElement okButton
  238     setCancelElement parentElement cancelButton
  239     setButtonDefault okButton
  240     setButtonCancel cancelButton
  241   put s
  242     { flsLayoutHandler = layoutHandler >=> \(Vec4 px py qx qy) -> do
  243       placeFreeChild parentElement okButtonChild $ Vec2 (qx - buttonWidth * 2 - gap) (py + bigGap - gap)
  244       placeFreeChild parentElement cancelButtonChild $ Vec2 (qx - buttonWidth) (py + bigGap - gap)
  245       return $ Vec4 px (py + buttonHeight + gap) qx qy
  246     , flsPreSize = Vec2 (max psx $ buttonWidth * 2 + gap) (psy + buttonHeight + bigGap)
  247     }