never executed always true always false
    1 {-|
    2 Module: Flaw.UI.Label
    3 Description: One-line centered text label.
    4 License: MIT
    5 -}
    6 
    7 module Flaw.UI.Label
    8   ( Label(..)
    9   , LabelStyle(..)
   10   , newLabel
   11   , newTextLabel
   12   , newTitleLabel
   13   , renderLabel
   14   ) where
   15 
   16 import Control.Concurrent.STM
   17 import qualified Data.Text as T
   18 
   19 import Flaw.Graphics
   20 import Flaw.Graphics.Font
   21 import Flaw.Graphics.Font.Render
   22 import Flaw.Math
   23 import Flaw.UI
   24 import Flaw.UI.Drawer
   25 
   26 data Label = Label
   27   { labelTextVar :: !(TVar T.Text)
   28   , labelTextScriptVar :: !(TVar FontScript)
   29   , labelStyle :: !LabelStyle
   30   }
   31 
   32 data LabelStyle
   33   = LabelStyleText
   34   | LabelStyleButton
   35   | LabelStyleTitle
   36 
   37 newLabel :: LabelStyle -> STM Label
   38 newLabel style = do
   39   textVar <- newTVar T.empty
   40   textScriptVar <- newTVar fontScriptUnknown
   41   return Label
   42     { labelTextVar = textVar
   43     , labelTextScriptVar = textScriptVar
   44     , labelStyle = style
   45     }
   46 
   47 newTextLabel :: STM Label
   48 newTextLabel = newLabel LabelStyleText
   49 
   50 newTitleLabel :: STM Label
   51 newTitleLabel = newLabel LabelStyleTitle
   52 
   53 instance Visual Label where
   54   renderVisual Label
   55     { labelTextVar = textVar
   56     , labelTextScriptVar = textScriptVar
   57     , labelStyle = lstyle
   58     } drawer position size style = do
   59     text <- readTVar textVar
   60     textScript <- readTVar textScriptVar
   61     return $ renderLabel text textScript lstyle drawer position size style
   62 
   63 instance HasText Label where
   64   setText Label
   65     { labelTextVar = textVar
   66     } = writeTVar textVar
   67   setTextScript Label
   68     { labelTextScriptVar = textScriptVar
   69     } = writeTVar textScriptVar
   70   getText Label
   71     { labelTextVar = textVar
   72     } = readTVar textVar
   73 
   74 {-# INLINABLE renderLabel #-}
   75 renderLabel :: Context c d => T.Text -> FontScript -> LabelStyle -> Drawer d -> Position -> Size -> Style -> Render c ()
   76 renderLabel text textScript style Drawer
   77   { drawerGlyphRenderer = glyphRenderer
   78   , drawerStyles = styles
   79   } (Vec2 px py) (Vec2 sx sy) Style
   80   { styleTextColor = color
   81   } = do
   82   (DrawerFont
   83     { drawerFontRenderableFontCache = renderableFontCache
   84     , drawerFontShaper = SomeFontShaper fontShaper
   85     }, alignmentX, alignmentY) <- return $ case style of
   86     LabelStyleText -> (drawerLabelFont styles, AlignLeft, AlignMiddle)
   87     LabelStyleButton -> (drawerLabelFont styles, AlignCenter, AlignMiddle)
   88     LabelStyleTitle -> (drawerTitleFont styles, AlignLeft, AlignMiddle)
   89   let
   90     (x, cursorX) = case alignmentX of
   91       AlignLeft -> (fromIntegral px, RenderTextCursorLeft)
   92       AlignCenter -> (fromIntegral px + fromIntegral sx * 0.5, RenderTextCursorCenter)
   93       AlignRight -> (fromIntegral px + fromIntegral sx, RenderTextCursorRight)
   94     (y, cursorY) = case alignmentY of
   95       AlignTop -> (fromIntegral py, RenderTextCursorTop)
   96       AlignMiddle -> (fromIntegral py + fromIntegral sy * 0.5, RenderTextCursorMiddle)
   97       AlignBottom -> (fromIntegral py + fromIntegral sy, RenderTextCursorBottom)
   98   renderGlyphs glyphRenderer renderableFontCache $
   99     renderTexts fontShaper [(text, color)] textScript (Vec2 x y) cursorX cursorY