HLint fixes, use correct timestamp

app/Main.hs

@@ -125,6 +125,14 @@ handleAppEvent app evt = traceShow app $
     UpdateText txt -> Model (app & textField1 .~ txt)
 
 buildUI app = trace "Created main UI" widgetTree where
+  widgetTree =
+    hstack [
+      textField textField1 `style` (bgColor lightGray <> textColor black),
+      textField textField2 `style` (bgColor darkGray <> textColor black),
+      textField textField3 `style` (bgColor lightGray <> textColor black)
+    ]
+
+buildUI2 app = trace "Created main UI" widgetTree where
   widgetTree =
     vstack [
       dropdown dropdown1 (fmap (\i -> "Value " <> showt i) [1..10::Int]) id,

app/Types.hs

@@ -11,11 +11,13 @@ data App = App {
   _clickCount :: !Int,
   _msgCount :: !Int,
   _textField1 :: Text,
+  _textField2 :: Text,
+  _textField3 :: Text,
   _dropdown1 :: Text
 } deriving (Show, Eq)
 
 instance Default App where
-  def = App 0 0 "" ""
+  def = App 0 0 "" "" "" ""
 
 makeLenses ''App
 

src/Monomer/Common/Style.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE TemplateHaskell #-}
-
 module Monomer.Common.Style where
 
 import Control.Applicative
@@ -209,16 +207,16 @@ borderRight width color = mempty {
 }
 
 swidth :: Double -> Style
-swidth width = mempty { _fixedWidth = (Just width) }
+swidth width = mempty { _fixedWidth = Just width }
 
 sheight :: Double -> Style
-sheight height = mempty { _fixedHeight = (Just height) }
+sheight height = mempty { _fixedHeight = Just height }
 
 bgColor :: Color -> Style
-bgColor color = mempty { _bgColor = (Just color) }
+bgColor color = mempty { _bgColor = Just color }
 
 bgRadius :: Double -> Style
-bgRadius rad = mempty { _bgRadius = (Just (Radius jrad jrad jrad jrad)) } where
+bgRadius rad = mempty { _bgRadius = Just (Radius jrad jrad jrad jrad) } where
   jrad = Just rad
 
 textColor :: Color -> Style

src/Monomer/Graphics/Drawing.hs

@@ -4,7 +4,7 @@ module Monomer.Graphics.Drawing where
 
 import qualified Data.Text as T
 
-import Control.Monad (when, void)
+import Control.Monad (when, void, forM_)
 import Data.Default
 import Data.Maybe
 
@@ -21,8 +21,7 @@ justDef (Just val) = val
 drawBgRect :: (Monad m) => Renderer m -> Rect -> Style -> m ()
 drawBgRect renderer rect Style{..} = do
   drawRect renderer rect _bgColor _bgRadius
-  when (isJust _border) $ do
-    drawRoundedBorder renderer rect (fromJust _border)
+  forM_ _border (drawRoundedBorder renderer rect)
 
 drawRect :: (Monad m) => Renderer m -> Rect -> Maybe Color -> Maybe Radius -> m ()
 drawRect _ _ Nothing _ = pure ()
@@ -44,14 +43,14 @@ drawRoundedRect renderer (Rect x y w h) Radius{..} =
     xr = x + w
     yt = y
     yb = y + h
-    x1 = x + (justDef _rTopLeft)
-    x2 = x + w - (justDef _rTopRight)
-    x3 = x + (justDef _rBottomLeft)
-    x4 = x + w - (justDef _rBottomRight)
-    y1 = y + (justDef _rTopLeft)
-    y2 = y + h - (justDef _rBottomLeft)
-    y3 = y + (justDef _rTopRight)
-    y4 = y + h - (justDef _rBottomRight)
+    x1 = x + justDef _rTopLeft
+    x2 = x + w - justDef _rTopRight
+    x3 = x + justDef _rBottomLeft
+    x4 = x + w - justDef _rBottomRight
+    y1 = y + justDef _rTopLeft
+    y2 = y + h - justDef _rBottomLeft
+    y3 = y + justDef _rTopRight
+    y4 = y + h - justDef _rBottomRight
   in do
     arc renderer (Point x1 y1) (justDef _rTopLeft) 180 270
     lineTo renderer (Point x2 yt) --
@@ -126,7 +125,7 @@ drawRoundedBorder renderer (Rect x y w h) Border{..} =
 
       if isJust s1 && isJust s2 && fromJust s1 /= fromJust s2 then
         fillLinearGradient renderer (midPoint p1 p4) (midPoint p2 p3) (_bsColor (fromJust s1)) (_bsColor (fromJust s2))
-      else if (isJust s1) then
+      else if isJust s1 then
         fillColor renderer (_bsColor (fromJust s1))
       else 
         fillColor renderer (_bsColor (fromJust s2))
@@ -165,7 +164,7 @@ drawText renderer viewport (Just TextStyle{..}) txt = do
   text renderer viewport defaultFont tsFontSize tsAlign txt
 
 drawText_ :: (Monad m) => Renderer m -> Rect -> Maybe TextStyle -> T.Text -> m ()
-drawText_ renderer viewport style txt = do
+drawText_ renderer viewport style txt =
   void $ drawText renderer viewport style txt
 
 calcTextBounds :: (Monad m) => Renderer m -> Maybe TextStyle -> T.Text -> Size
@@ -178,14 +177,14 @@ calcTextBounds renderer (Just TextStyle{..}) txt =
 
 subtractBorder :: Rect -> Border -> Rect
 subtractBorder (Rect x y w h) (Border l r t b _) = Rect nx ny nw nh where
-  nx = x + (_bsWidth (justDef l))
-  ny = y + (_bsWidth (justDef t))
-  nw = w - (_bsWidth (justDef l)) - (_bsWidth (justDef r))
-  nh = h - (_bsWidth (justDef t)) - (_bsWidth (justDef b))
+  nx = x + _bsWidth (justDef l)
+  ny = y + _bsWidth (justDef t)
+  nw = w - _bsWidth (justDef l) - _bsWidth (justDef r)
+  nh = h - _bsWidth (justDef t) - _bsWidth (justDef b)
 
 subtractPadding :: Rect -> Padding -> Rect
 subtractPadding (Rect x y w h) (Padding l r t b) = Rect nx ny nw nh where
-  nx = x + (justDef l)
-  ny = y + (justDef t)
-  nw = w - (justDef l) - (justDef r)
-  nh = h - (justDef t) - (justDef b)
+  nx = x + justDef l
+  ny = y + justDef t
+  nw = w - justDef l - justDef r
+  nh = h - justDef t - justDef b

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -38,7 +38,7 @@ newRenderer c dpr overlaysRef = Renderer {..} where
     liftIO $ VG.restore c
 
   -- Overlays
-  createOverlay overlay = do
+  createOverlay overlay =
     liftIO $ modifyIORef overlaysRef (|> overlay)
 
   runOverlays = do
@@ -57,17 +57,17 @@ newRenderer c dpr overlaysRef = Renderer {..} where
   stroke =
     liftIO $ VG.stroke c
 
-  strokeColor color = do
+  strokeColor color =
     liftIO $ VG.strokeColor c (colorToPaint color)
 
-  strokeWidth width = do
+  strokeWidth width =
     liftIO $ VG.strokeWidth c (realToFrac $ width * dpr)
 
   -- Fill
   fill =
     liftIO $ VG.fill c
 
-  fillColor color = do
+  fillColor color =
     liftIO $ VG.fillColor c (colorToPaint color)
 
   fillLinearGradient (Point x1 y1) (Point x2 y2) color1 color2 =
@@ -79,26 +79,26 @@ newRenderer c dpr overlaysRef = Renderer {..} where
       liftIO $ VG.fillPaint c gradient
 
   -- Drawing
-  moveTo (Point x y) = do
+  moveTo (Point x y) =
     liftIO $ nvMoveTo c (x * dpr) (y * dpr)
 
   line (Point x1 y1) (Point x2 y2) = do
     liftIO $ nvMoveTo c (x1 * dpr) (y1 * dpr)
     liftIO $ nvLineTo c (x2 * dpr) (y2 * dpr)
 
-  lineTo (Point x y) = do
+  lineTo (Point x y) =
     liftIO $ nvLineTo c (x * dpr) (y * dpr)
 
-  rect (Rect x y w h) = do
+  rect (Rect x y w h) =
     liftIO $ VG.rect c (realToFrac $ x * dpr) (realToFrac $ y * dpr) (realToFrac $ w * dpr) (realToFrac $ h * dpr)
 
-  arc (Point x1 y1) rad angleStart angleEnd = do
+  arc (Point x1 y1) rad angleStart angleEnd =
     liftIO $ nvArc c (x1 * dpr) (y1 * dpr) (rad * dpr) angleStart angleEnd VG.CW
 
-  quadTo (Point x1 y1) (Point x2 y2) = do
+  quadTo (Point x1 y1) (Point x2 y2) =
     liftIO $ VG.quadTo c (realToFrac $ x1 * dpr) (realToFrac $ y1 * dpr) (realToFrac $ x2 * dpr) (realToFrac $ y2 * dpr)
 
-  ellipse (Rect x y w h) = do
+  ellipse (Rect x y w h) =
     liftIO $ VG.ellipse c (realToFrac $ cx * dpr) (realToFrac $ cy * dpr) (realToFrac $ rx * dpr) (realToFrac $ ry * dpr)
     where cx = x + rx
           cy = y + ry
@@ -125,7 +125,7 @@ newRenderer c dpr overlaysRef = Renderer {..} where
            | va == AMiddle = yr + (hr + realToFrac th) / 2
            | otherwise = yr + hr
 
-    when (message /= "") $ do
+    when (message /= "") $
       liftIO $ VG.text c (realToFrac tx) (realToFrac ty) message
 
     return $ Rect (tx / dpr) ((ty - realToFrac asc) / dpr) (realToFrac tw / dpr) (realToFrac th / dpr)
@@ -133,21 +133,21 @@ newRenderer c dpr overlaysRef = Renderer {..} where
   textBounds _ _ "" = def
   textBounds font fontSize message = unsafePerformIO $ do
     liftIO $ VG.fontFace c font
-    liftIO $ VG.fontSize c $ realToFrac $ fontSize
+    liftIO $ VG.fontSize c $ realToFrac fontSize
     VG.Bounds (VG.V4 x1 y1 x2 y2) <- liftIO $ VG.textBounds c 0 0 message
 
     return $ Size (realToFrac $ x2 - x1) (realToFrac $ y2 - y1)
 
 nvMoveTo :: VG.Context -> Double -> Double -> IO ()
-nvMoveTo c x y = do
+nvMoveTo c x y =
   VG.moveTo c (realToFrac x) (realToFrac y)
 
 nvLineTo :: VG.Context -> Double -> Double -> IO ()
-nvLineTo c x y = do
+nvLineTo c x y =
   VG.lineTo c (realToFrac x) (realToFrac y)
 
 nvArc :: VG.Context -> Double -> Double -> Double -> Double -> Double -> VG.Winding -> IO ()
-nvArc c cx cy radius angleStart angleEnd winding = do
+nvArc c cx cy radius angleStart angleEnd winding =
   VG.arc c (realToFrac cx) (realToFrac cy) (realToFrac radius) (VG.degToRad $ realToFrac angleStart) (VG.degToRad $ realToFrac angleEnd) winding
 
 colorToPaint :: Color -> VG.Color

src/Monomer/Main/Core.hs

@@ -107,7 +107,7 @@ mainLoop window c renderer !prevTicks !tsAccum !frames widgetRoot = do
     _wcGlobalKeys = M.empty,
     _wcApp = currentApp,
     _wcInputStatus = inputStatus,
-    _wcTimestamp = ts
+    _wcTimestamp = startTicks
   }
   (wtWctx, _, wtWidgetRoot) <- handleWidgetTasks renderer wctx widgetRoot
   (seWctx, _, seWidgetRoot) <- handleSystemEvents renderer wtWctx systemEvents wtWidgetRoot

src/Monomer/Widget/BaseContainer.hs

@@ -91,6 +91,7 @@ containerMergeTrees mergeWidgetState wctx ctx newInstance oldInstance = result w
   newPairs = Seq.zipWith (\idx child -> (addToCurrent ctx idx, child)) indexes newChildren
   mergedResults = mergeChildren wctx newPairs oldChildren
   mergedChildren = fmap _resultWidget mergedResults
+  concatSeq seqs = foldl' (><) Seq.empty seqs
   mergedReqs = concatSeq $ fmap _resultRequests mergedResults
   mergedEvents = concatSeq $ fmap _resultEvents mergedResults
   mergedInstance = (mergeWidgetState wctx oldState newInstance) {
@@ -104,7 +105,7 @@ mergeChildren wctx ((ctx, newChild) :<| newChildren) Empty = child <| mergeChild
   child = _widgetInit (_instanceWidget newChild) wctx ctx newChild
 mergeChildren wctx ((ctx, newChild) :<| newChildren) oldFull@(oldChild :<| oldChildren) = result where
   newWidget = _instanceWidget newChild
-  oldKeyed = maybe Nothing (\key -> M.lookup key (_wcGlobalKeys wctx)) (_instanceKey newChild)
+  oldKeyed = _instanceKey newChild >>= (\key -> M.lookup key (_wcGlobalKeys wctx))
   mergedOld = _widgetMerge newWidget wctx ctx newChild oldChild
   mergedKey = _widgetMerge newWidget wctx ctx newChild (snd $ fromJust oldKeyed)
   initNew = _widgetInit newWidget wctx ctx newChild
@@ -113,9 +114,6 @@ mergeChildren wctx ((ctx, newChild) :<| newChildren) oldFull@(oldChild :<| oldCh
                         | otherwise -> (initNew, oldFull)
   result = child <| mergeChildren wctx newChildren oldRest
 
-concatSeq :: Seq (Seq a) -> Seq a
-concatSeq seqs = foldl' (><) Seq.empty seqs
-
 -- | Find next focusable item
 containerNextFocusable :: PathContext -> WidgetInstance s e -> Maybe Path
 containerNextFocusable ctx widgetInstance = nextFocus where

src/Monomer/Widget/Widgets/Stack.hs

@@ -54,7 +54,7 @@ makeStack isHorizontal = createContainer {
       sSize = sizeSelector $ calcPreferredSize sChildren
       fSize = sizeSelector $ calcPreferredSize fChildren
       fRatio = if | mSize - sSize > fSize &&     remainderExist -> 1
-                  | mSize - sSize > fSize && not remainderExist -> (mSize - sSize) / fSize
+               -- | mSize - sSize > fSize && not remainderExist -> (mSize - sSize) / fSize
                   | mSize - sSize > 0                           -> (mSize - sSize) / fSize
                   | otherwise                                   -> 0
       remainderTotal = mSize - (sSize + fSize * fRatio)

src/Monomer/Widget/Widgets/TextField.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -76,14 +75,14 @@ makeTextField userField tfs@(TextFieldState currText currPos) = createWidget {
     handleEvent wctx ctx evt widgetInstance = case evt of
       Click (Point x y) _ status -> Just $ resultReqs reqs widgetInstance where
         isPressed = status == PressedBtn
-        reqs = if isPressed then [SetFocus $ currentPath ctx] else []
+        reqs = [SetFocus $ currentPath ctx | isPressed]
 
       KeyAction mod code KeyPressed -> Just $ resultReqs reqs newInstance where
         (newText, newPos) = handleKeyPress currText currPos code
         reqs = reqGetClipboard ++ reqSetClipboard ++ reqUpdateUserState
-        reqGetClipboard = if isClipboardPaste evt then [GetClipboard (currentPath ctx)] else []
-        reqSetClipboard = if isClipboardCopy evt then [SetClipboard (ClipboardText currText)] else []
-        reqUpdateUserState = if currText /= newText then [UpdateUserState $ \app -> app & userField .~ newText] else []
+        reqGetClipboard = [GetClipboard (currentPath ctx) | isClipboardPaste evt]
+        reqSetClipboard = [SetClipboard (ClipboardText currText) | isClipboardCopy evt]
+        reqUpdateUserState = [UpdateUserState $ \app -> app & userField .~ newText | currText /= newText]
         newState = TextFieldState newText newPos
         newInstance = widgetInstance { _instanceWidget = makeTextField userField newState }
 
@@ -107,14 +106,14 @@ makeTextField userField tfs@(TextFieldState currText currPos) = createWidget {
     render renderer wctx ctx WidgetInstance{..} =
       let ts = _wcTimestamp wctx
           textStyle = _textStyle _instanceStyle
-          cursorAlpha = if isFocused ctx then (fromIntegral $ ts `mod` 1000) / 1000.0 else 0
+          cursorAlpha = if isFocused ctx then fromIntegral (ts `mod` 1000) / 1000.0 else 0
           textColor = (tsTextColor textStyle) { _alpha = cursorAlpha }
           renderArea@(Rect rl rt rw rh) = _instanceRenderArea
       in do
         drawBgRect renderer renderArea _instanceStyle
         Rect tl tt _ _ <- drawText renderer renderArea textStyle currText
 
-        when True $ do
+        when (isFocused ctx) $ do
           let Size sw sh = calcTextBounds renderer textStyle (if part1 == "" then " " else part1)
           drawRect renderer (Rect (tl + sw) tt caretWidth sh) (Just textColor) Nothing
           return ()

tasks.md

@@ -62,14 +62,14 @@
   - Add a way to get path of widget given an id, and provide a method to send a message/event (most likely, a new Request kind)
   - Rename EventResult to something more accurate
     - Replace resultWidget and friends with non-Maybe versions (update widgets)
-
-- Pending
   - Add _renderLast_ function to Renderer, which delays rendering until the first pass is done
     - Futher calls to _renderLast_ should not be ignored (tooltip on dropdown menu?)
     - A _handleDelayedRendering_ also needs to be added
     - We also need a way of receiving events on _upper_ layers
     - All this is needed for dropdowns, but it's also useful for tooltips
   - Create Dropdown
+
+- Pending
   - Improve hstack/vstack
     - If available space is greater than requested, do not apply resizing logic
   - Does a styling engine make sense or doing something similar to Flutter is simpler?
@@ -95,9 +95,13 @@
     - Create self rendered version
     - Expose customizable interface
     - Request scroll when needed
+    - Validate Maybe values are supported
+    - Create nullable version which takes care of fmapping traversable with Just
   - Should Resize be restored?
   - Create layer widget to handle overlays/dialog boxes/tooltips (takes care of overlays)
-  - Add text selection/editing to textField
+  - Improve textField
+    - Add text selection/editing to textField
+    - Find non visible character that returns correct height if input is empty
   - Request text input when text field gets focus (required for mobile)
   - Add testing
     - Delayed until this point to try to settle down interfaces