mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-10-05 15:57:17 +03:00
Initial commit
This commit is contained in:
Francisco Vallarino
commit
910a51dbc5
7
.gitignore
vendored
Normal file
7
.gitignore
vendored
Normal file
@ -0,0 +1,7 @@
|
||||
.stack-work/
|
||||
.vscode/
|
||||
app copy/
|
||||
src copy/
|
||||
hs-GUI.cabal
|
||||
*~
|
||||
*.prof
|
||||
3
ChangeLog.md
Normal file
3
ChangeLog.md
Normal file
@ -0,0 +1,3 @@
|
||||
# Changelog for hs-music
|
||||
|
||||
## Unreleased changes
|
||||
30
LICENSE
Normal file
30
LICENSE
Normal file
@ -0,0 +1,30 @@
|
||||
Copyright (c) 2018 Francisco Vallarino
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Author name here nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
230
app/Main.hs
Normal file
230
app/Main.hs
Normal file
@ -0,0 +1,230 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.State
|
||||
import Data.Default
|
||||
import Foreign.C.Types
|
||||
import Lens.Micro.TH (makeLenses)
|
||||
import Lens.Micro.Mtl
|
||||
import NanoVG
|
||||
import SDL (($=))
|
||||
import Unsafe.Coerce
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
import System.Remote.Monitoring
|
||||
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Sequence as SQ
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector.Generic as V
|
||||
import qualified Foreign.C.String as STR
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import qualified SDL
|
||||
import qualified SDL.Vect
|
||||
import qualified SDL.Input.Mouse as Mouse
|
||||
import qualified SDL.Raw.Error as SRE
|
||||
|
||||
import Types
|
||||
import GUI.Core
|
||||
import qualified GUI.Data.Tree as TR
|
||||
import qualified GUI.NanoVGRenderer as NV
|
||||
import qualified GUI.Widget.Core as W
|
||||
import qualified GUI.Widget.Style as S
|
||||
import qualified GUI.Widget.Widgets as WS
|
||||
|
||||
foreign import ccall unsafe "initGlew" glewInit :: IO CInt
|
||||
|
||||
data AppEvent = Action1 Int | Action2 deriving (Show, Eq)
|
||||
|
||||
type WidgetM = StateT App IO
|
||||
type LocalWidget = W.Widget AppEvent WidgetM
|
||||
type WidgetTree = TR.Tree (W.WidgetNode AppEvent WidgetM)
|
||||
|
||||
(screenWidth, screenHeight) = (640, 480)
|
||||
windowSize = (Rect 0 0 (fromIntegral screenWidth) (fromIntegral screenHeight))
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
-- forkServer "localhost" 8000
|
||||
|
||||
SDL.initialize [SDL.InitVideo]
|
||||
SDL.HintRenderScaleQuality $= SDL.ScaleLinear
|
||||
do renderQuality <- SDL.get SDL.HintRenderScaleQuality
|
||||
when (renderQuality /= SDL.ScaleLinear) $
|
||||
putStrLn "Warning: Linear texture filtering not enabled!"
|
||||
|
||||
let customOpenGL = SDL.OpenGLConfig {
|
||||
SDL.glColorPrecision = SDL.V4 8 8 8 0,
|
||||
SDL.glDepthPrecision = 24,
|
||||
SDL.glStencilPrecision = 8,
|
||||
SDL.glProfile = SDL.Core SDL.Debug 3 2,
|
||||
SDL.glMultisampleSamples = 1
|
||||
}
|
||||
|
||||
window <-
|
||||
SDL.createWindow
|
||||
"SDL / OpenGL Example"
|
||||
SDL.defaultWindow {SDL.windowInitialSize = SDL.V2 screenWidth screenHeight,
|
||||
SDL.windowOpenGL = Just customOpenGL }
|
||||
|
||||
err <- SRE.getError
|
||||
err <- STR.peekCString err
|
||||
putStrLn err
|
||||
|
||||
_ <- SDL.glCreateContext window
|
||||
|
||||
_ <- glewInit
|
||||
|
||||
c@(Context c') <- createGL3 (S.fromList [Antialias, StencilStrokes, Debug])
|
||||
|
||||
fontRes <- createFont c "sans" (FileName "./assets/fonts/Roboto-Regular.ttf")
|
||||
|
||||
runStateT (runWidgets window c) def
|
||||
|
||||
putStrLn "About to destroyWindow"
|
||||
SDL.destroyWindow window
|
||||
SDL.quit
|
||||
|
||||
handleAppEvent :: AppEvent -> WidgetM ()
|
||||
handleAppEvent evt = do
|
||||
case evt of
|
||||
Action1 v -> do
|
||||
when (v == 0) $ clickCount += 1
|
||||
count <- use clickCount
|
||||
liftIO . putStrLn $ "Clicked button: " ++ (show v) ++ " - Count is: " ++ (show count)
|
||||
Action2 -> liftIO . putStrLn $ "I don't know what's this"
|
||||
|
||||
buildUI :: App -> WidgetTree
|
||||
buildUI model = styledTree where
|
||||
border1 = S.border 5 (RGB 0 255 0) 20
|
||||
border2 = S.borderLeft 20 (RGB 200 200 0) <> S.borderRight 20 (RGB 200 0 200)
|
||||
style1 = S.bgColor (RGB 0 0 255) <> S.textSize 64 <> border1 <> border2 <> S.bgRadius 20
|
||||
--extraWidgets = if _clickCount model < 3 then [] else [WS.button (Action1 0)] -- map (\i -> WS.button (Action1 0)) [0..(_clickCount model)]
|
||||
extraWidgets = map (\i -> WS.button (Action1 i)) [1..(_clickCount model)]
|
||||
widgetTree = WS.vgrid_ ([
|
||||
WS.button (Action1 0) `W.style` style1
|
||||
] ++ extraWidgets)
|
||||
-- widgetTree = WS.container_ [
|
||||
-- WS.button (Action1 1) `W.style` style1,
|
||||
-- WS.button (Action1 2),
|
||||
-- WS.button (Action1 3),
|
||||
-- WS.container `W.style` S.bgColor (RGB 0 0 255) `W.children` [
|
||||
-- WS.button (Action1 4),
|
||||
-- WS.button (Action1 5) `W.style` (S.bgColor (RGB 255 0 255) <> S.bgRadius 10),
|
||||
-- WS.button (Action1 6) `W.style` border1,
|
||||
-- WS.button (Action1 7)
|
||||
-- ]
|
||||
-- ]
|
||||
styledTree = W.cascadeStyle mempty widgetTree
|
||||
|
||||
runWidgets :: SDL.Window -> Context -> WidgetM ()
|
||||
runWidgets window c = do
|
||||
let renderer = NV.makeRenderer c
|
||||
|
||||
ticks <- SDL.ticks
|
||||
app <- get
|
||||
resizedUI <- W.resizeUI renderer windowSize (buildUI app)
|
||||
|
||||
mainLoop window c renderer (fromIntegral ticks) resizedUI
|
||||
|
||||
mainLoop :: SDL.Window -> Context -> Renderer WidgetM -> Int -> WidgetTree -> WidgetM ()
|
||||
mainLoop window c renderer prevTicks widgets = do
|
||||
ticks <- fmap fromIntegral SDL.ticks
|
||||
events <- SDL.pollEvents
|
||||
|
||||
let frameLength = 1000 `div` 30
|
||||
let nextFrame = \t -> if t >= frameLength then 0 else frameLength - t
|
||||
let !ts = (ticks - prevTicks)
|
||||
let eventsPayload = fmap SDL.eventPayload events
|
||||
let quit = elem SDL.QuitEvent eventsPayload
|
||||
|
||||
newWidgets <- handleSystemEvents renderer (convertEvents eventsPayload) widgets
|
||||
renderWidgets window c renderer newWidgets ticks
|
||||
liftIO $ threadDelay $ (nextFrame ts) * 1000
|
||||
unless quit (mainLoop window c renderer ticks newWidgets)
|
||||
|
||||
handleSystemEvents :: Renderer WidgetM -> [W.SystemEvent] -> WidgetTree -> WidgetM WidgetTree
|
||||
handleSystemEvents renderer systemEvents widgets = updatedWidgets where
|
||||
(eventsWidgets, appEvents) = W.handleEvents widgets systemEvents
|
||||
updatedWidgets = if | length appEvents == 0 -> return widgets
|
||||
| otherwise -> handleAppEvents renderer appEvents eventsWidgets
|
||||
|
||||
handleAppEvents :: Renderer WidgetM -> SQ.Seq AppEvent -> WidgetTree -> WidgetM WidgetTree
|
||||
handleAppEvents renderer appEvents oldWidgets = do
|
||||
app <- get
|
||||
forM_ appEvents handleAppEvent
|
||||
newApp <- get
|
||||
|
||||
let newWidgets = W.mergeTrees (buildUI newApp) oldWidgets
|
||||
let mergedWidgets = if | app /= newApp -> W.resizeUI renderer windowSize newWidgets
|
||||
| otherwise -> return oldWidgets
|
||||
|
||||
when (app /= newApp) $ liftIO $ putStrLn "App changed!"
|
||||
|
||||
mergedWidgets
|
||||
|
||||
renderWidgets :: SDL.Window -> Context -> Renderer WidgetM -> WidgetTree -> Int -> WidgetM ()
|
||||
renderWidgets !window !c !renderer widgets ticks = do
|
||||
SDL.V2 fbWidth fbHeight <- SDL.glGetDrawableSize window
|
||||
let !pxRatio = fromIntegral fbWidth / fromIntegral fbHeight
|
||||
let !w = fromIntegral screenWidth
|
||||
let !h = fromIntegral screenHeight
|
||||
|
||||
liftIO $ GL.clear [GL.ColorBuffer]
|
||||
liftIO $ beginFrame c screenWidth screenHeight pxRatio
|
||||
|
||||
mapM_ (\widgetNode -> W.handleRender renderer ticks widgetNode) widgets
|
||||
|
||||
liftIO $ endFrame c
|
||||
SDL.glSwapWindow window
|
||||
|
||||
convertEvents :: [SDL.EventPayload] -> [W.SystemEvent]
|
||||
convertEvents events = newEvents
|
||||
where
|
||||
newEvents = mouseEvents ++ keyboardEvents
|
||||
mouseEvents = mouseClick events
|
||||
keyboardEvents = keyboardEvent events
|
||||
--SDL.P (SDL.V2 mouseX mouseY) <- Mouse.getAbsoluteMouseLocation
|
||||
|
||||
mouseClick :: [SDL.EventPayload] -> [W.SystemEvent]
|
||||
mouseClick events =
|
||||
case clickEvent of
|
||||
Just (SDL.MouseButtonEvent SDL.MouseButtonEventData
|
||||
{ SDL.mouseButtonEventMotion = motion,
|
||||
SDL.mouseButtonEventButton = button,
|
||||
SDL.mouseButtonEventPos = SDL.P (SDL.V2 x y) }) -> leftClicked ++ leftReleased ++ rightClicked ++ rightReleased
|
||||
where isLeft = button == SDL.ButtonLeft
|
||||
isRight = button == SDL.ButtonRight
|
||||
isClicked = motion == SDL.Pressed
|
||||
isReleased = motion == SDL.Released
|
||||
mousePos = Point (fromIntegral x) (fromIntegral y)
|
||||
leftClicked = if isLeft && isClicked then [W.Click mousePos W.LeftBtn W.PressedBtn] else []
|
||||
leftReleased = if isLeft && isReleased then [W.Click mousePos W.LeftBtn W.ReleasedBtn] else []
|
||||
rightClicked = if isRight && isClicked then [W.Click mousePos W.RightBtn W.PressedBtn] else []
|
||||
rightReleased = if isRight && isReleased then [W.Click mousePos W.RightBtn W.ReleasedBtn] else []
|
||||
|
||||
otherwhise -> []
|
||||
where clickEvent = L.find (\evt -> case evt of
|
||||
SDL.MouseButtonEvent _ -> True
|
||||
otherwhise -> False
|
||||
) events
|
||||
|
||||
keyboardEvent :: [SDL.EventPayload] -> [W.SystemEvent]
|
||||
keyboardEvent events = activeKeys
|
||||
where
|
||||
activeKeys = map (\(SDL.KeyboardEvent k) -> W.KeyAction (keyCode k) (keyMotion k)) (unsafeCoerce keyboardEvents)
|
||||
keyCode event = fromIntegral $ SDL.unwrapKeycode $ SDL.keysymKeycode $ SDL.keyboardEventKeysym event
|
||||
keyMotion event = if SDL.keyboardEventKeyMotion event == SDL.Pressed then W.KeyPressed else W.KeyReleased
|
||||
keyboardEvents = filter (\e -> case e of
|
||||
SDL.KeyboardEvent k -> True
|
||||
_ -> False) events
|
||||
16
app/Types.hs
Normal file
16
app/Types.hs
Normal file
@ -0,0 +1,16 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Types where
|
||||
|
||||
import Lens.Micro.TH (makeLenses)
|
||||
|
||||
import Data.Default
|
||||
|
||||
data App = App {
|
||||
_clickCount :: !Int
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Default App where
|
||||
def = App 0
|
||||
|
||||
makeLenses ''App
|
||||
BIN
assets/fonts/Roboto-Bold.ttf
Normal file
BIN
assets/fonts/Roboto-Bold.ttf
Normal file
Binary file not shown.
BIN
assets/fonts/Roboto-Italic.ttf
Normal file
BIN
assets/fonts/Roboto-Italic.ttf
Normal file
Binary file not shown.
BIN
assets/fonts/Roboto-Regular.ttf
Normal file
BIN
assets/fonts/Roboto-Regular.ttf
Normal file
Binary file not shown.
17
cbits/glew.c
Normal file
17
cbits/glew.c
Normal file
@ -0,0 +1,17 @@
|
||||
#include <GL/glew.h>
|
||||
#include <stdio.h>
|
||||
#include "nanovg.h"
|
||||
#include "math.h"
|
||||
|
||||
void initGlew() {
|
||||
glewExperimental = GL_TRUE;
|
||||
GLenum err = glewInit();
|
||||
|
||||
if(err != GLEW_OK) {
|
||||
fprintf(stderr, "Could not init GLEW: %s\n", glewGetErrorString(err));
|
||||
printf("\n");
|
||||
}
|
||||
else {
|
||||
glGetError();
|
||||
}
|
||||
}
|
||||
85
package.yaml
Normal file
85
package.yaml
Normal file
@ -0,0 +1,85 @@
|
||||
name: hs-gui
|
||||
version: 0.1.0.0
|
||||
github: "fjvallarino/hs-gui"
|
||||
license: BSD3
|
||||
author: "Francisco Vallarino"
|
||||
maintainer: "fjvallarino@gmail.com"
|
||||
copyright: "2018 Francisco Vallarino"
|
||||
|
||||
extra-source-files:
|
||||
- README.md
|
||||
- ChangeLog.md
|
||||
|
||||
# Metadata used when publishing your package
|
||||
# synopsis: GUI Library
|
||||
# category: GUI
|
||||
|
||||
# To avoid duplicated efforts in documentation and dealing with the
|
||||
# complications of embedding Haddock markup inside cabal files, it is
|
||||
# common to point users to the README.md file.
|
||||
description: Please see the README on Github at <https://github.com/fjvallarino/hs-gui#readme>
|
||||
|
||||
default-extensions:
|
||||
- OverloadedStrings
|
||||
|
||||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- containers
|
||||
- data-default
|
||||
- ekg
|
||||
- extra
|
||||
- microlens
|
||||
- microlens-mtl
|
||||
- microlens-th
|
||||
- mtl
|
||||
- nanovg
|
||||
- OpenGL
|
||||
- sdl2
|
||||
- text
|
||||
- unordered-containers
|
||||
- vector
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
c-sources:
|
||||
- cbits/glew.c
|
||||
cc-options:
|
||||
- -fPIC
|
||||
ghc-options:
|
||||
- -fwarn-incomplete-patterns
|
||||
- -O0
|
||||
extra-libraries:
|
||||
- GLEW
|
||||
|
||||
executables:
|
||||
hs-gui-exe:
|
||||
main: Main.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -fwarn-incomplete-patterns
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
- -with-rtsopts=-T
|
||||
- -O0
|
||||
|
||||
dependencies:
|
||||
- hs-gui
|
||||
|
||||
tests:
|
||||
hs-gui-test:
|
||||
main: Spec.hs
|
||||
source-dirs: test/unit
|
||||
ghc-options:
|
||||
- -fwarn-incomplete-patterns
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- call-stack
|
||||
- hs-gui
|
||||
- hedgehog
|
||||
- hedgehog-classes
|
||||
- hspec
|
||||
- HUnit
|
||||
- silently
|
||||
1
profile.sh
Normal file
1
profile.sh
Normal file
@ -0,0 +1 @@
|
||||
stack build --profile && stack exec -- hs-music-exe +RTS -A128m -n2m -s -p
|
||||
100
src/GUI/Core.hs
Normal file
100
src/GUI/Core.hs
Normal file
@ -0,0 +1,100 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GUI.Core where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Default
|
||||
import Lens.Micro
|
||||
import Lens.Micro.TH (makeLenses)
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
data Align = Align AlignH AlignV deriving (Show, Eq)
|
||||
data AlignH = ALeft | ACenter | ARight deriving (Show, Eq)
|
||||
data AlignV = ATop | AMiddle | ABottom deriving (Show, Eq)
|
||||
|
||||
data Point = Point {
|
||||
_x :: !Double,
|
||||
_y :: !Double
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Default Point where
|
||||
def = Point 0 0
|
||||
|
||||
data Size = Size {
|
||||
_w :: !Double,
|
||||
_h :: !Double
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Default Size where
|
||||
def = Size 0 0
|
||||
|
||||
data Rect = Rect {
|
||||
_rx :: !Double,
|
||||
_ry :: !Double,
|
||||
_rw :: !Double,
|
||||
_rh :: !Double
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Default Rect where
|
||||
def = Rect 0 0 0 0
|
||||
|
||||
data Color =
|
||||
RGB !Double !Double !Double
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Semigroup Color where
|
||||
(<>) _ c2 = c2
|
||||
|
||||
instance Default Color where
|
||||
def = RGB 0 0 0
|
||||
|
||||
white = RGB 255 255 255
|
||||
black = RGB 0 0 0
|
||||
red = RGB 255 0 0
|
||||
green = RGB 0 255 0
|
||||
blue = RGB 0 0 255
|
||||
|
||||
makeLenses ''Point
|
||||
makeLenses ''Size
|
||||
makeLenses ''Rect
|
||||
|
||||
type Font = T.Text
|
||||
type FontSize = Double
|
||||
|
||||
data Renderer m = (Monad m) => Renderer {
|
||||
beginPath :: m (),
|
||||
stroke :: m (),
|
||||
fill :: m (),
|
||||
fillColor :: Color -> m (),
|
||||
fillLinearGradient :: Point -> Point -> Color -> Color -> m (),
|
||||
strokeColor :: Color -> m (),
|
||||
strokeWidth :: Double -> m (),
|
||||
moveTo :: Point -> m (),
|
||||
line :: Point -> Point -> m (),
|
||||
lineTo :: Point -> m (),
|
||||
rect :: Rect -> m (),
|
||||
arc :: Point -> Double -> Double -> Double -> m (),
|
||||
quadTo :: Point -> Point -> m (),
|
||||
ellipse :: Rect -> m (),
|
||||
text :: Rect -> Font -> FontSize -> Align -> T.Text -> m (),
|
||||
textBounds :: Font -> FontSize -> T.Text -> m Size
|
||||
}
|
||||
|
||||
inRect :: Rect -> Point -> Bool
|
||||
inRect (Rect x y w h) (Point x2 y2) = (x2 >= x && x2 < x + w) && (y2 >= y && y2 < y + h)
|
||||
|
||||
firstJust :: Maybe a -> Maybe a -> Maybe a
|
||||
firstJust (Just val) _ = Just val
|
||||
firstJust _ value = value
|
||||
|
||||
justDef :: (Default a) => Maybe a -> a
|
||||
justDef Nothing = def
|
||||
justDef (Just val) = val
|
||||
|
||||
midPoint :: Point -> Point -> Point
|
||||
midPoint (Point x1 y1) (Point x2 y2) = Point x3 y3 where
|
||||
x3 = (x2 + x1) / 2
|
||||
y3 = (y2 + y1) / 2
|
||||
46
src/GUI/Data/Tree.hs
Normal file
46
src/GUI/Data/Tree.hs
Normal file
@ -0,0 +1,46 @@
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
|
||||
module GUI.Data.Tree where
|
||||
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
import qualified Data.Foldable as F
|
||||
import qualified Data.Sequence as S
|
||||
|
||||
data Tree a = Node a (S.Seq (Tree a)) deriving (Functor, Foldable, Traversable)
|
||||
|
||||
type Path = [Int]
|
||||
|
||||
singleton :: a -> Tree a
|
||||
singleton value = Node value S.empty
|
||||
|
||||
nodeValue :: Tree a -> a
|
||||
nodeValue (Node value _) = value
|
||||
|
||||
nodeChildren :: Tree a -> S.Seq (Tree a)
|
||||
nodeChildren (Node _ children) = children
|
||||
|
||||
nodeChildrenList :: Tree a -> [a]
|
||||
nodeChildrenList (Node _ children) = seqToList children
|
||||
|
||||
seqToList :: (S.Seq (Tree a)) -> [a]
|
||||
seqToList children = (fmap nodeValue . F.toList) children
|
||||
|
||||
fromList :: a -> [Tree a] -> Tree a
|
||||
fromList value children = Node value (S.fromList children)
|
||||
|
||||
lookup :: Path -> Tree a -> Maybe a
|
||||
lookup [] (Node val _) = Just val
|
||||
lookup (idx:xs) (Node val seq) = case S.lookup idx seq of
|
||||
Just tree -> lookup xs tree
|
||||
otherwise -> Nothing
|
||||
|
||||
updateNode :: Path -> Tree a -> Tree a -> Tree a
|
||||
updateNode [] _ new = new
|
||||
updateNode (idx:xs) node@(Node val seq) new = case S.lookup idx seq of
|
||||
Just tree -> Node val newChildren where
|
||||
newChildren = S.update idx newNode seq
|
||||
newNode = updateNode xs tree new
|
||||
Nothing -> node
|
||||
105
src/GUI/NanoVGRenderer.hs
Normal file
105
src/GUI/NanoVGRenderer.hs
Normal file
@ -0,0 +1,105 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
module GUI.NanoVGRenderer where
|
||||
|
||||
import Data.Default
|
||||
|
||||
import qualified GUI.Core as C
|
||||
import qualified Data.Text as T
|
||||
import qualified NanoVG as VG
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import GHC.Float
|
||||
|
||||
makeRenderer :: (MonadIO m) => VG.Context -> C.Renderer m
|
||||
makeRenderer c = C.Renderer {..} where
|
||||
beginPath =
|
||||
liftIO $ VG.beginPath c
|
||||
|
||||
stroke =
|
||||
liftIO $ VG.stroke c
|
||||
|
||||
fill =
|
||||
liftIO $ VG.fill c
|
||||
|
||||
fillColor (C.RGB r g b) = do
|
||||
liftIO $ VG.fillColor c (VG.rgb (round r) (round g) (round b))
|
||||
|
||||
fillLinearGradient (C.Point x1 y1) (C.Point x2 y2) (C.RGB r1 g1 b1) (C.RGB r2 g2 b2) =
|
||||
let
|
||||
col1 = VG.rgb (round r1) (round g1) (round b1)
|
||||
col2 = VG.rgb (round r2) (round g2) (round b2)
|
||||
in do
|
||||
gradient <- liftIO $ VG.linearGradient c (realToFrac x1) (realToFrac y1) (realToFrac x2) (realToFrac y2) col1 col2
|
||||
liftIO $ VG.fillPaint c gradient
|
||||
|
||||
strokeColor (C.RGB r g b) = do
|
||||
liftIO $ VG.strokeColor c (VG.rgb (round r) (round g) (round b))
|
||||
|
||||
strokeWidth width = do
|
||||
liftIO $ VG.strokeWidth c (realToFrac width)
|
||||
|
||||
moveTo (C.Point x y) = do
|
||||
liftIO $ nvMoveTo c x y
|
||||
|
||||
line (C.Point x1 y1) (C.Point x2 y2) = do
|
||||
liftIO $ nvMoveTo c x1 y1
|
||||
liftIO $ nvLineTo c x2 y2
|
||||
|
||||
lineTo (C.Point x y) = do
|
||||
liftIO $ nvLineTo c x y
|
||||
|
||||
rect (C.Rect x y w h) = do
|
||||
liftIO $ VG.rect c (realToFrac x) (realToFrac y) (realToFrac w) (realToFrac h)
|
||||
|
||||
arc (C.Point x1 y1) rad angleStart angleEnd = do
|
||||
liftIO $ nvArc c x1 y1 rad angleStart angleEnd VG.CW
|
||||
|
||||
quadTo (C.Point x1 y1) (C.Point x2 y2) = do
|
||||
liftIO $ VG.quadTo c (realToFrac x1) (realToFrac y1) (realToFrac x2) (realToFrac y2)
|
||||
|
||||
ellipse (C.Rect x y w h) = do
|
||||
liftIO $ VG.ellipse c (realToFrac cx) (realToFrac cy) (realToFrac rx) (realToFrac ry)
|
||||
where cx = x + rx
|
||||
cy = y + ry
|
||||
rx = w / 2
|
||||
ry = h / 2
|
||||
|
||||
text _ _ _ _ "" = return ()
|
||||
text (C.Rect x y w h) font fontSize (C.Align ha va) message = do
|
||||
liftIO $ VG.fontFace c font
|
||||
liftIO $ VG.fontSize c $ realToFrac fontSize
|
||||
VG.Bounds (VG.V4 x1 _ x2 _) <- liftIO $ VG.textBounds c (realToFrac x) (realToFrac y) message
|
||||
(asc, desc, _) <- liftIO $ VG.textMetrics c
|
||||
|
||||
let tw = x2 - x1
|
||||
th = asc + desc
|
||||
tx | ha == C.ALeft = x
|
||||
| ha == C.ACenter = x + (w - realToFrac tw) / 2
|
||||
| otherwise = x + (w - realToFrac tw)
|
||||
ty | va == C.ATop = y + realToFrac th
|
||||
| va == C.AMiddle = y + (h + realToFrac th) / 2
|
||||
| otherwise = y + h
|
||||
|
||||
liftIO $ VG.text c (realToFrac tx) (realToFrac ty) message
|
||||
|
||||
textBounds _ _ "" = return def
|
||||
textBounds font fontSize message = do
|
||||
liftIO $ VG.fontFace c font
|
||||
liftIO $ VG.fontSize c $ realToFrac fontSize
|
||||
VG.Bounds (VG.V4 x1 y1 x2 y2) <- liftIO $ VG.textBounds c 0 0 message
|
||||
|
||||
return $ C.Size (realToFrac $ x2 - x1) (realToFrac $ y2 - y1)
|
||||
|
||||
nvMoveTo :: VG.Context -> Double -> Double -> IO ()
|
||||
nvMoveTo c x y = do
|
||||
VG.moveTo c (realToFrac x) (realToFrac y)
|
||||
|
||||
nvLineTo :: VG.Context -> Double -> Double -> IO ()
|
||||
nvLineTo c x y = do
|
||||
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
|
||||
VG.arc c (realToFrac cx) (realToFrac cy) (realToFrac radius) (VG.degToRad $ realToFrac angleStart) (VG.degToRad $ realToFrac angleEnd) winding
|
||||
231
src/GUI/Widget/Core.hs
Normal file
231
src/GUI/Widget/Core.hs
Normal file
@ -0,0 +1,231 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module GUI.Widget.Core where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Extra
|
||||
import Control.Monad.State
|
||||
import Lens.Micro
|
||||
import Lens.Micro.Mtl
|
||||
|
||||
import Data.Char
|
||||
import Data.Default
|
||||
import Data.String
|
||||
import Data.Typeable
|
||||
import Unsafe.Coerce
|
||||
|
||||
import System.IO.Unsafe
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
import GUI.Core
|
||||
import GUI.Data.Tree
|
||||
import GUI.Widget.Style
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Sequence as SQ
|
||||
|
||||
type Timestamp = Int
|
||||
|
||||
data Button = LeftBtn | RightBtn deriving (Show, Eq)
|
||||
data ButtonState = PressedBtn | ReleasedBtn deriving (Show, Eq)
|
||||
|
||||
type KeyCode = Int
|
||||
data KeyMotion = KeyPressed | KeyReleased deriving (Show, Eq)
|
||||
|
||||
data SystemEvent = Update Timestamp |
|
||||
Click Point Button ButtonState |
|
||||
KeyAction KeyCode KeyMotion deriving (Show, Eq)
|
||||
|
||||
data FontInstance = FontInstance
|
||||
|
||||
data Theme = Theme {
|
||||
_backgroundColor :: Color,
|
||||
_primaryColor :: Color,
|
||||
_secondaryColor :: Color,
|
||||
_palette :: [Color],
|
||||
_titleFont :: FontInstance,
|
||||
_subtitleFont :: FontInstance,
|
||||
_labelFont :: FontInstance,
|
||||
_messageFont :: FontInstance
|
||||
}
|
||||
|
||||
data EventResult e m = NoEvents | Events [e] | EventsState [e] (Widget e m)
|
||||
newtype WidgetType = WidgetType String deriving Eq
|
||||
newtype WidgetKey = WidgetKey String deriving Eq
|
||||
|
||||
instance IsString WidgetType where
|
||||
fromString string = WidgetType string
|
||||
|
||||
instance IsString WidgetKey where
|
||||
fromString string = WidgetKey string
|
||||
|
||||
newtype NodePath = NodePath [Int]
|
||||
data NodeInfo = NodeInfo WidgetType (Maybe WidgetKey)
|
||||
|
||||
instance Semigroup (EventResult e m) where
|
||||
(<>) NoEvents er2 = er2
|
||||
(<>) er1 NoEvents = er1
|
||||
(<>) (Events e1) (Events e2) = Events (e1 ++ e2)
|
||||
(<>) (EventsState e1 s1) (Events e2) = EventsState (e1 ++ e2) s1
|
||||
(<>) (Events e1) (EventsState e2 s2) = EventsState (e1 ++ e2) s2
|
||||
(<>) (EventsState e1 s1) (EventsState e2 s2) = EventsState (e1 ++ e2) s2
|
||||
|
||||
data Widget e m =
|
||||
(Monad m) => Widget {
|
||||
-- | Type of the widget
|
||||
_widgetType :: WidgetType,
|
||||
-- | Handles an event
|
||||
--
|
||||
-- Region assigned to the widget
|
||||
-- Event to handle
|
||||
--
|
||||
-- Returns: the list of generated events and, maybe, a new version of the widget if internal state changed
|
||||
_handleEvent :: Rect -> SystemEvent -> EventResult e m,
|
||||
-- | Minimum size desired by the widget
|
||||
--
|
||||
-- Style options
|
||||
-- Preferred size for each of the children widgets
|
||||
-- Renderer (mainly for text sizing functions)
|
||||
--
|
||||
-- Returns: the minimum size desired by the widget
|
||||
_preferredSize :: Renderer m -> Style -> [Size] -> m Size,
|
||||
-- | Resizes the children of this widget
|
||||
--
|
||||
-- Region assigned to the widget
|
||||
-- Style options
|
||||
-- Preferred size for each of the children widgets
|
||||
--
|
||||
-- Returns: the size assigned to each of the children
|
||||
_resizeChildren :: Rect -> Style -> [Size] -> [Rect],
|
||||
-- | Renders the widget
|
||||
--
|
||||
-- Region assigned to the widget
|
||||
-- Style options
|
||||
-- Renderer
|
||||
--
|
||||
-- Returns: unit
|
||||
_render :: Renderer m -> Timestamp -> Rect -> Style -> m ()
|
||||
}
|
||||
|
||||
-- | Complementary information to a Widget, forming a node in the view tree
|
||||
--
|
||||
-- Type variables:
|
||||
-- * n: Identifier for a node
|
||||
data WidgetNode e m =
|
||||
(Monad m) => WidgetNode {
|
||||
-- | Key/Identifier of the widget. If provided, it needs to be unique in the same hierarchy level (not globally)
|
||||
_widgetKey :: Maybe WidgetKey,
|
||||
_widget :: Widget e m,
|
||||
_viewport :: Rect,
|
||||
_style :: Style,
|
||||
_calculatedStyle :: Style,
|
||||
_calculatedSize :: Size
|
||||
}
|
||||
|
||||
key :: (Monad m) => WidgetKey -> WidgetNode e m -> WidgetNode e m
|
||||
key key wn = wn { _widgetKey = Just key }
|
||||
|
||||
style :: (Monad m) => Tree (WidgetNode e m) -> Style -> Tree (WidgetNode e m)
|
||||
style (Node value children) newStyle = Node (value { _style = newStyle }) children
|
||||
|
||||
children :: (Monad m) => Tree (WidgetNode e m) -> [Tree (WidgetNode e m)] -> Tree (WidgetNode e m)
|
||||
children (Node value _) newChildren = fromList value newChildren
|
||||
|
||||
cascadeStyle :: (Monad m) => Style -> Tree (WidgetNode e m) -> Tree (WidgetNode e m)
|
||||
cascadeStyle parentStyle (Node (wn@WidgetNode{..}) children) = newNode where
|
||||
newNode = Node (wn { _calculatedStyle = newStyle }) newChildren
|
||||
newStyle = _style <> parentStyle
|
||||
newChildren = fmap (cascadeStyle newStyle) children
|
||||
|
||||
defaultWidgetNode :: (Monad m) => Widget e m -> WidgetNode e m
|
||||
defaultWidgetNode widget = WidgetNode {
|
||||
_widgetKey = Nothing,
|
||||
_widget = widget,
|
||||
_viewport = def,
|
||||
_style = mempty,
|
||||
_calculatedStyle = mempty,
|
||||
_calculatedSize = def
|
||||
}
|
||||
|
||||
singleWidget :: (Monad m) => Widget e m -> Tree (WidgetNode e m)
|
||||
singleWidget widget = singleton (defaultWidgetNode widget)
|
||||
|
||||
parentWidget :: (Monad m) => Widget e m -> [Tree (WidgetNode e m)] -> Tree (WidgetNode e m)
|
||||
parentWidget widget = fromList (defaultWidgetNode widget)
|
||||
|
||||
widgetMatches :: (Monad m) => WidgetNode e m -> WidgetNode e m -> Bool
|
||||
widgetMatches wn1 wn2 = _widgetType (_widget wn1) == _widgetType (_widget wn2) && _widgetKey wn1 == _widgetKey wn2
|
||||
|
||||
mergeTrees :: (Monad m) => Tree (WidgetNode e m) -> Tree (WidgetNode e m) -> Tree (WidgetNode e m)
|
||||
mergeTrees node1@(Node widget1 seq1) (Node widget2 seq2) = newNode where
|
||||
matches = widgetMatches widget1 widget2
|
||||
newNode = if | matches -> Node widget2 newChildren
|
||||
| otherwise -> node1
|
||||
newChildren = mergedChildren SQ.>< addedChildren
|
||||
mergedChildren = fmap mergeChild (SQ.zip seq1 seq2)
|
||||
addedChildren = SQ.drop (SQ.length seq2) seq1
|
||||
mergeChild = \(c1, c2) -> mergeTrees c1 c2
|
||||
|
||||
handleWidgetEvents :: (Monad m, Traversable t) => Widget e m -> Rect -> t SystemEvent -> EventResult e m
|
||||
handleWidgetEvents (Widget {..}) viewport systemEvents =
|
||||
foldl (\eventResult event -> eventResult <> _handleEvent viewport event) NoEvents systemEvents
|
||||
|
||||
handleEvents :: (Monad m, Traversable t) => Tree (WidgetNode e m) -> t SystemEvent -> (Tree (WidgetNode e m), SQ.Seq e)
|
||||
handleEvents (Node (wn@WidgetNode { .. }) children) systemEvents = (newNode, childEvents) where
|
||||
(newWidget, events) = case handleWidgetEvents _widget _viewport systemEvents of
|
||||
NoEvents -> (_widget, [])
|
||||
Events evts -> (_widget, evts)
|
||||
EventsState evts wdt -> (wdt, evts)
|
||||
(newChildren, childEvents) = foldl (\(ws, evs) widgetNode -> case handleEvents widgetNode systemEvents of
|
||||
(ws2, evs2) -> (ws SQ.|> ws2, evs SQ.>< evs2)) (SQ.empty, SQ.fromList events) children
|
||||
newNode = Node (wn { _widget = newWidget }) newChildren
|
||||
|
||||
handleRender :: (Monad m) => Renderer m -> Timestamp -> WidgetNode e m -> m ()
|
||||
handleRender renderer ts (WidgetNode _ Widget{..} viewport _ calculatedStyle _) = _render renderer ts viewport calculatedStyle
|
||||
|
||||
resizeUI :: (Monad m) => Renderer m -> Rect -> Tree (WidgetNode e m) -> m (Tree (WidgetNode e m))
|
||||
resizeUI renderer assignedRect widgetNode = do
|
||||
preferredSizes <- buildPreferredSizes renderer widgetNode
|
||||
resizeNode renderer assignedRect preferredSizes widgetNode
|
||||
|
||||
buildPreferredSizes :: (Monad m) => Renderer m -> Tree (WidgetNode e m) -> m (Tree Size)
|
||||
buildPreferredSizes renderer (Node (WidgetNode {..}) children) = do
|
||||
childrenSizes <- mapM (buildPreferredSizes renderer) children
|
||||
size <- _preferredSize _widget renderer _style (seqToList childrenSizes)
|
||||
|
||||
return $ Node size childrenSizes
|
||||
|
||||
resizeNode :: (Monad m) => Renderer m -> Rect -> Tree Size -> Tree (WidgetNode e m) -> m (Tree (WidgetNode e m))
|
||||
resizeNode renderer assignedRect (Node _ {--widgetSize--} childrenSizes) (Node widgetNode childrenWns) = do
|
||||
let widget = _widget widgetNode
|
||||
let style = _style widgetNode
|
||||
let updatedNode = widgetNode { _viewport = assignedRect }
|
||||
let assignedRects = (_resizeChildren widget) assignedRect style (seqToList childrenSizes)
|
||||
let childrenPair = SQ.zip3 childrenSizes childrenWns (SQ.fromList assignedRects)
|
||||
let childResize = \(size, node, rect) -> resizeNode renderer rect size node
|
||||
|
||||
newChildren <- mapM childResize childrenPair
|
||||
|
||||
return (Node updatedNode newChildren)
|
||||
|
||||
-- _preferredSize :: Renderer m -> Style -> [Size] -> m Size,
|
||||
-- _resizeChildren :: Rect -> Style -> [Size] -> [Rect],
|
||||
|
||||
{--
|
||||
resizeNodeOld :: (Monad m) => Rect -> Tree (WidgetNode e m) -> Tree (WidgetNode e m)
|
||||
resizeNodeOld !rt@(Rect x y w h) (Node (WidgetNode widgetKey widget _ style calculatedStyle calculatedSize) children) = newNode where
|
||||
newNode = Node (WidgetNode widgetKey widget rt style calculatedStyle calculatedSize) newChildren
|
||||
rows = floor $ sqrt $ fromIntegral (length children)
|
||||
cols = (length children) `div` rows
|
||||
iw = w / fromIntegral cols
|
||||
ih = h / fromIntegral rows
|
||||
newChildren = fmap (\(w, i) -> resizeNodeOld (newRt i) w) widgetIdxPairs
|
||||
widgetIdxPairs = SQ.zip children (SQ.fromList [0..(length children)])
|
||||
newRt i = Rect (x + fromIntegral (i `mod` cols) * iw) (y + fromIntegral (i `div` cols) * ih) iw ih
|
||||
--}
|
||||
194
src/GUI/Widget/Drawing.hs
Normal file
194
src/GUI/Widget/Drawing.hs
Normal file
@ -0,0 +1,194 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module GUI.Widget.Drawing where
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.Default
|
||||
import Data.Maybe
|
||||
|
||||
import GUI.Core
|
||||
import GUI.Widget.Style
|
||||
|
||||
defaultColor :: Color
|
||||
defaultColor = RGB 255 255 255
|
||||
|
||||
defaultFont :: Font
|
||||
defaultFont = "sans"
|
||||
|
||||
defaultFontSize :: FontSize
|
||||
defaultFontSize = 32
|
||||
|
||||
defaultAlignH :: AlignH
|
||||
defaultAlignH = ACenter
|
||||
|
||||
defaultAlignV :: AlignV
|
||||
defaultAlignV = AMiddle
|
||||
|
||||
degToRad :: Double -> Double
|
||||
degToRad rad = rad * 3.1416 / 180.0
|
||||
|
||||
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)
|
||||
|
||||
drawRect :: (Monad m) => Renderer m -> Rect -> Maybe Color -> Maybe Radius -> m ()
|
||||
drawRect _ _ Nothing _ = pure ()
|
||||
drawRect renderer rt (Just color) Nothing = do
|
||||
beginPath renderer
|
||||
fillColor renderer color
|
||||
rect renderer rt
|
||||
fill renderer
|
||||
drawRect renderer rt (Just color) (Just radius) = do
|
||||
beginPath renderer
|
||||
fillColor renderer color
|
||||
drawRoundedRect renderer rt radius
|
||||
fill renderer
|
||||
|
||||
drawRoundedRect :: (Monad m) => Renderer m -> Rect -> Radius -> m ()
|
||||
drawRoundedRect renderer (Rect x y w h) Radius{..} =
|
||||
let
|
||||
xl = x
|
||||
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)
|
||||
in do
|
||||
arc renderer (Point x1 y1) (justDef _rTopLeft) 180 270
|
||||
lineTo renderer (Point x2 yt) --
|
||||
arc renderer (Point x2 y1) (justDef _rTopRight) 270 0
|
||||
lineTo renderer (Point xr y2) --
|
||||
arc renderer (Point x2 y2) (justDef _rBottomRight) 0 90
|
||||
lineTo renderer (Point x1 yb) --
|
||||
arc renderer (Point x1 y2) (justDef _rBottomLeft) 90 180
|
||||
lineTo renderer (Point xl y1) --
|
||||
|
||||
drawRoundedBorder :: (Monad m) => Renderer m -> Rect -> Border -> m ()
|
||||
drawRoundedBorder renderer (Rect x y w h) Border{..} =
|
||||
let
|
||||
Radius {..} = justDef _bRadius
|
||||
_minRadius = 0.5
|
||||
-- Border width
|
||||
btw = _bsWidth $ justDef _bTop
|
||||
bbw = _bsWidth $ justDef _bBottom
|
||||
blw = _bsWidth $ justDef _bLeft
|
||||
brw = _bsWidth $ justDef _bRight
|
||||
-- Radius
|
||||
rtl = justDef _rTopLeft
|
||||
rtr = justDef _rTopRight
|
||||
rbl = justDef _rBottomLeft
|
||||
rbr = justDef _rBottomRight
|
||||
-- Main points
|
||||
-- Top
|
||||
xtl1 = x + (if rtl > _minRadius then rtl else 0)
|
||||
xtl2 = x + (if rtl > _minRadius then rtl else 0) + blw
|
||||
xtr1 = x + w - (if rtr > _minRadius then rtr else 0)
|
||||
xtr2 = x + w - (if rtr > _minRadius then rtr else 0) - brw
|
||||
yt1 = y
|
||||
yt2 = y + btw
|
||||
-- Bottom
|
||||
xbl1 = x + (if rbl > _minRadius then rbl else 0)
|
||||
xbl2 = x + (if rbl > _minRadius then rbl else 0) + blw
|
||||
xbr1 = x + w - (if rbr > _minRadius then rbr else 0)
|
||||
xbr2 = x + w - (if rbr > _minRadius then rbr else 0) - brw
|
||||
yb1 = y + h
|
||||
yb2 = y + h - bbw
|
||||
-- Left
|
||||
xl1 = x
|
||||
xl2 = x + blw
|
||||
ytl1 = y + (if rtl > _minRadius then rtl else 0)
|
||||
ytl2 = y + (if rtl > _minRadius then rtl else 0) + btw
|
||||
ybl1 = y + h - (if rbl > _minRadius then rtl else 0)
|
||||
ybl2 = y + h - (if rbl > _minRadius then rtl else 0) - bbw
|
||||
-- Right
|
||||
xr1 = x + w
|
||||
xr2 = x + w - brw
|
||||
ytr1 = y + (if rtr > _minRadius then rtr else 0)
|
||||
ytr2 = y + (if rtr > _minRadius then rtr else 0) + btw
|
||||
ybr1 = y + h - (if rbr > _minRadius then rtr else 0)
|
||||
ybr2 = y + h - (if rbr > _minRadius then rtr else 0) - bbw
|
||||
drawTrapezoid borderSide p1 p2 p3 p4 =
|
||||
when (_bsWidth (justDef borderSide) > 0.5) $ do
|
||||
beginPath renderer
|
||||
fillColor renderer (_bsColor (fromJust borderSide))
|
||||
moveTo renderer p1
|
||||
lineTo renderer p2
|
||||
lineTo renderer p3
|
||||
lineTo renderer p4
|
||||
lineTo renderer p1
|
||||
fill renderer
|
||||
drawRadius s1 s2 p1 p2 p3 p4 cp1 cp2 = do
|
||||
beginPath renderer
|
||||
moveTo renderer p1
|
||||
quadTo renderer cp1 p2
|
||||
lineTo renderer p3
|
||||
quadTo renderer cp2 p4
|
||||
lineTo renderer p1
|
||||
|
||||
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
|
||||
fillColor renderer (_bsColor (fromJust s1))
|
||||
else
|
||||
fillColor renderer (_bsColor (fromJust s2))
|
||||
|
||||
fill renderer
|
||||
in do
|
||||
-- The 0.5 +/- are used to avoid breaks
|
||||
drawTrapezoid _bTop (Point (xtl1 - 0.5) yt1) (Point (xtr1 + 0.5) yt1) (Point (xtr2 + 0.5) yt2) (Point (xtl2 - 0.5) yt2)
|
||||
drawTrapezoid _bBottom (Point (xbl1 - 0.5) yb1) (Point (xbr1 + 0.5) yb1) (Point (xbr2 + 0.5) yb2) (Point (xbl2 - 0.5) yb2)
|
||||
drawTrapezoid _bLeft (Point xl1 (ytl1 - 0.5)) (Point xl1 (ybl1 + 0.5)) (Point xl2 (ybl2 + 0.5)) (Point xl2 (ytl2 - 0.5))
|
||||
drawTrapezoid _bRight (Point xr1 (ytr1 - 0.5)) (Point xr1 (ybr1 + 0.5)) (Point xr2 (ybr2 + 0.5)) (Point xr2 (ytr2 - 0.5))
|
||||
|
||||
when (rtl > 0.5) $
|
||||
drawRadius _bLeft _bTop (Point xl1 ytl1) (Point xtl1 yt1) (Point xtl2 yt2) (Point xl2 ytl2) (Point xl1 yt1) (Point xl2 yt2)
|
||||
when (rtr > 0.5) $
|
||||
drawRadius _bTop _bRight (Point xtr1 yt1) (Point xr1 ytr1) (Point xr2 ytr2) (Point xtr2 yt2) (Point xr1 yt1) (Point xr2 yt2)
|
||||
when (rbr > 0.5) $
|
||||
drawRadius _bRight _bBottom (Point xr1 ybr1) (Point xbr1 yb1) (Point xbr2 yb2) (Point xr2 ybr2) (Point xr1 yb1) (Point xr2 yb2)
|
||||
when (rbl > 0.5) $
|
||||
drawRadius _bBottom _bLeft (Point xbl1 yb1) (Point xl1 ybl1) (Point xl2 ybl2) (Point xbl2 yb2) (Point xl1 yb1) (Point xl2 yb2)
|
||||
|
||||
drawText :: (Monad m) => Renderer m -> Rect -> Maybe TextStyle -> T.Text -> m ()
|
||||
drawText renderer viewport Nothing txt = drawText renderer viewport (Just mempty) txt
|
||||
drawText renderer viewport (Just TextStyle{..}) txt = do
|
||||
let tsColor = fromMaybe defaultColor _tsColor
|
||||
tsFontSize = fromMaybe defaultFontSize _tsFontSize
|
||||
tsAlignH = fromMaybe defaultAlignH _tsAlignH
|
||||
tsAlignV = fromMaybe defaultAlignV _tsAlignV
|
||||
tsAlign = Align tsAlignH tsAlignV
|
||||
|
||||
fillColor renderer tsColor
|
||||
text renderer viewport defaultFont tsFontSize tsAlign txt
|
||||
|
||||
calcTextBounds :: (Monad m) => Renderer m -> Maybe TextStyle -> T.Text -> m Size
|
||||
calcTextBounds renderer Nothing txt = calcTextBounds renderer (Just mempty) txt
|
||||
calcTextBounds renderer (Just TextStyle{..}) txt =
|
||||
let
|
||||
tsFontSize = fromMaybe defaultFontSize _tsFontSize
|
||||
in
|
||||
textBounds renderer defaultFont tsFontSize 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))
|
||||
|
||||
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)
|
||||
402
src/GUI/Widget/Style.hs
Normal file
402
src/GUI/Widget/Style.hs
Normal file
@ -0,0 +1,402 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GUI.Widget.Style where
|
||||
|
||||
import Data.Default
|
||||
import Lens.Micro
|
||||
import Lens.Micro.TH (makeLenses)
|
||||
|
||||
import GUI.Core
|
||||
|
||||
-- | Basic styling attributes
|
||||
--
|
||||
-- Remember adjacent margin collapse behavior
|
||||
data Style =
|
||||
Style {
|
||||
_padding :: Maybe Padding,
|
||||
_bgRadius :: Maybe Radius,
|
||||
_bgColor :: Maybe Color,
|
||||
_border :: Maybe Border,
|
||||
_textStyle :: Maybe TextStyle
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Monoid Style where
|
||||
mempty = Style {
|
||||
_padding = Nothing,
|
||||
_bgRadius = Nothing,
|
||||
_bgColor = Nothing,
|
||||
_border = Nothing,
|
||||
_textStyle = Nothing
|
||||
}
|
||||
|
||||
instance Semigroup Style where
|
||||
(<>) style1 style2 = Style {
|
||||
_padding = (_padding style2) <> (_padding style1),
|
||||
_bgRadius = (_bgRadius style2) <> (_bgRadius style1),
|
||||
_bgColor = firstJust (_bgColor style2) (_bgColor style1),
|
||||
_border = (_border style2) <> (_border style1),
|
||||
_textStyle = (_textStyle style2) <> (_textStyle style1)
|
||||
}
|
||||
|
||||
data Padding = Padding {
|
||||
_pLeft :: Maybe Double,
|
||||
_pRight :: Maybe Double,
|
||||
_pTop :: Maybe Double,
|
||||
_pBottom :: Maybe Double
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Semigroup Padding where
|
||||
(<>) p1 p2 = Padding {
|
||||
_pLeft = firstJust (_pLeft p2) (_pLeft p1),
|
||||
_pRight = firstJust (_pRight p2) (_pRight p1),
|
||||
_pTop = firstJust (_pTop p2) (_pTop p1),
|
||||
_pBottom = firstJust (_pBottom p2) (_pBottom p1)
|
||||
}
|
||||
|
||||
instance Monoid Padding where
|
||||
mempty = Padding {
|
||||
_pLeft = Nothing,
|
||||
_pRight = Nothing,
|
||||
_pTop = Nothing,
|
||||
_pBottom = Nothing
|
||||
}
|
||||
|
||||
data BorderSide = BorderSide {
|
||||
_bsWidth :: Double,
|
||||
_bsColor :: Color
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Semigroup BorderSide where
|
||||
(<>) _ b2 = b2
|
||||
|
||||
instance Default BorderSide where
|
||||
def = BorderSide {
|
||||
_bsWidth = 0,
|
||||
_bsColor = def
|
||||
}
|
||||
|
||||
data Border = Border {
|
||||
_bLeft :: Maybe BorderSide,
|
||||
_bRight :: Maybe BorderSide,
|
||||
_bTop :: Maybe BorderSide,
|
||||
_bBottom :: Maybe BorderSide,
|
||||
_bRadius :: Maybe Radius
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Semigroup Border where
|
||||
(<>) b1 b2 = Border {
|
||||
_bLeft = (_bLeft b2) <> (_bLeft b1),
|
||||
_bRight = (_bRight b2) <> (_bRight b1),
|
||||
_bTop = (_bTop b2) <> (_bTop b1),
|
||||
_bBottom = (_bBottom b2) <> (_bBottom b1),
|
||||
_bRadius = (_bRadius b2) <> (_bRadius b1)
|
||||
}
|
||||
|
||||
instance Monoid Border where
|
||||
mempty = Border {
|
||||
_bLeft = def,
|
||||
_bRight = def,
|
||||
_bTop = def,
|
||||
_bBottom = def,
|
||||
_bRadius = def
|
||||
}
|
||||
|
||||
data Radius = Radius {
|
||||
_rTopLeft :: Maybe Double,
|
||||
_rTopRight :: Maybe Double,
|
||||
_rBottomLeft :: Maybe Double,
|
||||
_rBottomRight :: Maybe Double
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Semigroup Radius where
|
||||
(<>) _ br2 = br2
|
||||
|
||||
instance Default Radius where
|
||||
def = Radius {
|
||||
_rTopLeft = Nothing,
|
||||
_rTopRight = Nothing,
|
||||
_rBottomLeft = Nothing,
|
||||
_rBottomRight = Nothing
|
||||
}
|
||||
|
||||
data TextStyle = TextStyle {
|
||||
_tsFont :: Maybe String,
|
||||
_tsFontSize :: Maybe Double,
|
||||
_tsColor :: Maybe Color,
|
||||
_tsAlignH :: Maybe AlignH,
|
||||
_tsAlignV :: Maybe AlignV
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Semigroup TextStyle where
|
||||
(<>) ts1 ts2 = TextStyle {
|
||||
_tsFont = firstJust (_tsFont ts2) (_tsFont ts1),
|
||||
_tsFontSize = firstJust (_tsFontSize ts2) (_tsFontSize ts1),
|
||||
_tsColor = firstJust (_tsColor ts2) (_tsColor ts1),
|
||||
_tsAlignH = firstJust (_tsAlignH ts2) (_tsAlignH ts1),
|
||||
_tsAlignV = firstJust (_tsAlignV ts2) (_tsAlignV ts1)
|
||||
}
|
||||
|
||||
instance Monoid TextStyle where
|
||||
mempty = TextStyle {
|
||||
_tsFont = Nothing,
|
||||
_tsFontSize = Nothing,
|
||||
_tsColor = Nothing,
|
||||
_tsAlignH = Nothing,
|
||||
_tsAlignV = Nothing
|
||||
}
|
||||
|
||||
border :: Double -> Color -> Double -> Style
|
||||
border width color radius = mempty {
|
||||
_border = Just mempty {
|
||||
_bLeft = Just (BorderSide width color),
|
||||
_bRight = Just (BorderSide width color),
|
||||
_bTop = Just (BorderSide width color),
|
||||
_bBottom = Just (BorderSide width color),
|
||||
_bRadius = Just (Radius (Just radius) (Just radius) (Just radius) (Just radius))
|
||||
}
|
||||
}
|
||||
|
||||
borderTop :: Double -> Color -> Style
|
||||
borderTop width color = mempty {
|
||||
_border = Just mempty {
|
||||
_bTop = Just (BorderSide width color)
|
||||
}
|
||||
}
|
||||
|
||||
borderBottom :: Double -> Color -> Style
|
||||
borderBottom width color = mempty {
|
||||
_border = Just mempty {
|
||||
_bBottom = Just (BorderSide width color)
|
||||
}
|
||||
}
|
||||
|
||||
borderLeft :: Double -> Color -> Style
|
||||
borderLeft width color = mempty {
|
||||
_border = Just mempty {
|
||||
_bLeft = Just (BorderSide width color)
|
||||
}
|
||||
}
|
||||
|
||||
borderRight :: Double -> Color -> Style
|
||||
borderRight width color = mempty {
|
||||
_border = Just mempty {
|
||||
_bRight = Just (BorderSide width color)
|
||||
}
|
||||
}
|
||||
|
||||
bgColor :: Color -> Style
|
||||
bgColor color = mempty { _bgColor = (Just color) }
|
||||
|
||||
bgRadius :: Double -> Style
|
||||
bgRadius rad = mempty { _bgRadius = (Just (Radius jrad jrad jrad jrad)) } where
|
||||
jrad = Just rad
|
||||
|
||||
textSize :: Double -> Style
|
||||
textSize size = mempty {
|
||||
_textStyle = Just $ mempty {
|
||||
_tsFontSize = Just size
|
||||
}
|
||||
}
|
||||
|
||||
textAlignH :: AlignH -> Style
|
||||
textAlignH alignH = mempty {
|
||||
_textStyle = Just $ mempty {
|
||||
_tsAlignH = Just alignH
|
||||
}
|
||||
}
|
||||
|
||||
textAlignV :: AlignV -> Style
|
||||
textAlignV alignV = mempty {
|
||||
_textStyle = Just $ mempty {
|
||||
_tsAlignV = Just alignV
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
--makeLenses ''Style
|
||||
--makeLenses ''TextStyle
|
||||
--
|
||||
--textAlignV :: AlignV -> Style
|
||||
--textAlignV alignV = mempty & textStyle ?~ (mempty & tsAlignV ?~ alignV)
|
||||
|
||||
{--
|
||||
|
||||
minStyleSize = 0 :: Double
|
||||
maxStyleSize = 100000 :: Double
|
||||
|
||||
data Unit = Px | Pct deriving (Show, Eq)
|
||||
|
||||
data SizeReq = SizeReq Double Double Unit deriving (Show, Eq)
|
||||
|
||||
instance Semigroup SizeReq where
|
||||
(<>) (SizeReq min1 max1 Px) (SizeReq min2 max2 Px) = SizeReq (max min1 min2) (max max1 max2) Px
|
||||
(<>) (SizeReq min1 max1 Pct) (SizeReq min2 max2 Pct) = SizeReq (max min1 min2) (max max1 max2) Pct
|
||||
(<>) s1@(SizeReq _ _ Px) _ = s1
|
||||
(<>) _ s2@(SizeReq _ _ Px) = s2
|
||||
|
||||
instance Monoid SizeReq where
|
||||
mempty = SizeReq 0 maxStyleSize Pct
|
||||
|
||||
minSizePx size = SizeReq size maxStyleSize Px
|
||||
maxSizePx size = SizeReq minStyleSize size Px
|
||||
|
||||
minSizePct size = SizeReq size maxStyleSize Pct
|
||||
maxSizePct size = SizeReq minStyleSize size Pct
|
||||
|
||||
data Style = Style {
|
||||
_sWidth :: SizeReq,
|
||||
_sHeight :: SizeReq,
|
||||
_sBgColor :: C.Color,
|
||||
_sFont :: T.Text,
|
||||
_sFontSize :: Int,
|
||||
_sFontColor :: C.Color
|
||||
}
|
||||
|
||||
instance Semigroup Style where
|
||||
(<>) s1 s2 = Style {
|
||||
_sWidth = (_sWidth s1) <> (_sWidth s2),
|
||||
_sHeight = (_sHeight s1) <> (_sHeight s2),
|
||||
_sBgColor = (_sBgColor s2),
|
||||
_sFont = (_sFont s2),
|
||||
_sFontSize = (_sFontSize s2),
|
||||
_sFontColor = (_sFontColor s2)
|
||||
}
|
||||
|
||||
instance Monoid Style where
|
||||
mempty = Style mempty mempty C.black "sans" 16 C.white
|
||||
|
||||
data Stroke = Solid | Dashed deriving (Show, Eq)
|
||||
data Unit = Px | Pct deriving (Show, Eq)
|
||||
data Side = Top | Bottom | Left | Right | All deriving (Show, Eq)
|
||||
|
||||
data Corner = C_TL | C_TR | C_BL | C_BR | C_T | C_B | C_L | C_R | C_TBLR deriving (Show, Eq)
|
||||
|
||||
instance Semigroup Corner where
|
||||
(<>) _ b = b
|
||||
|
||||
instance Monoid Corner where
|
||||
mempty = C_TBLR
|
||||
|
||||
data Alignment = A_LT | A_LM | A_LB | A_CT | A_CM | A_CB | A_RT | A_RM | A_RB deriving (Show, Eq)
|
||||
|
||||
instance Semigroup Alignment where
|
||||
(<>) _ b = b
|
||||
|
||||
instance Monoid Alignment where
|
||||
mempty = A_LT
|
||||
|
||||
data SizeReq = SizeReq Double Double Unit deriving (Show, Eq)
|
||||
|
||||
instance Semigroup SizeReq where
|
||||
(<>) (SizeReq min1 max1 Px) (SizeReq min2 max2 Px) = SizeReq (max min1 min2) (max max1 max2) Px
|
||||
(<>) (SizeReq min1 max1 Pct) (SizeReq min2 max2 Pct) = SizeReq (max min1 min2) (max max1 max2) Pct
|
||||
(<>) s1@(SizeReq _ _ Px) _ = s1
|
||||
(<>) _ s2@(SizeReq _ _ Px) = s2
|
||||
|
||||
instance Monoid SizeReq where
|
||||
mempty = SizeReq 0 100000 Pct
|
||||
|
||||
data CornerShape = Normal | Straight | Rounded deriving (Show, Eq)
|
||||
|
||||
instance Semigroup CornerShape where
|
||||
(<>) Normal _ = Normal
|
||||
(<>) _ Normal = Normal
|
||||
(<>) cs1 _ = cs1
|
||||
|
||||
instance Monoid CornerShape where
|
||||
mempty = Normal
|
||||
|
||||
data CornerStyle = CornerStyle Corner CornerShape Double Unit deriving (Show, Eq)
|
||||
|
||||
instance Semigroup CornerStyle where
|
||||
(<>) _ b = b
|
||||
|
||||
instance Monoid CornerStyle where
|
||||
mempty = CornerStyle C_TBLR Normal 1 Px
|
||||
|
||||
data Border = Border {
|
||||
_bLeft :: (Stroke, Double, Unit),
|
||||
_bRight :: (Stroke, Double, Unit),
|
||||
_bTop :: (Stroke, Double, Unit),
|
||||
_bBottom :: (Stroke, Double, Unit)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Semigroup Border where
|
||||
(<>) (Border l1 r1 t1 b1) (Border l2 r2 t2 b2) = Border (bmax l1 l2) (bmax r1 r2) (bmax t1 t2) (bmax b1 b2) where
|
||||
bmax t1@(s1, v1, Px) t2@(s2, v2, Px) = if v1 > v2 then t1 else t2
|
||||
bmax t1@(s1, v1, Pct) t2@(s2, v2, Pct) = if v1 > v2 then t1 else t2
|
||||
bmax t1@(s1, v1, Px) _ = t1
|
||||
bmax _ t2@(s1, v1, Px) = t2
|
||||
|
||||
instance Monoid Border where
|
||||
mempty = Border ev ev ev ev where
|
||||
ev = (Solid, 0, Px)
|
||||
|
||||
data Padding = Padding {
|
||||
_pLeft :: Double,
|
||||
_pRight :: Double,
|
||||
_pTop :: Double,
|
||||
_pBottom :: Double
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Semigroup Padding where
|
||||
(<>) (Padding l1 r1 t1 b1) (Padding l2 r2 t2 b2) = Padding (max l1 l2) (max r1 r2) (max t1 t2) (max b1 b2)
|
||||
|
||||
instance Monoid Padding where
|
||||
mempty = Padding 0 0 0 0
|
||||
|
||||
data Offset = Offset {
|
||||
_oLeft :: Double,
|
||||
_oRight :: Double,
|
||||
_oTop :: Double,
|
||||
_oBottom :: Double
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Semigroup Offset where
|
||||
(<>) (Offset l1 r1 t1 b1) (Offset l2 r2 t2 b2) = Offset (max l1 l2) (max r1 r2) (max t1 t2) (max b1 b2)
|
||||
|
||||
instance Monoid Offset where
|
||||
mempty = Offset 0 0 0 0
|
||||
|
||||
--data Style = Width SizeReq | Height SizeReq | Padding [(Double, Side)] | Offset [(Double, Side)] | Border [Border] | Align [Alignment] | CornerStyle [CornerStyle]
|
||||
--data StyleClass = String [Style]
|
||||
|
||||
data Style = Style {
|
||||
_sWidth :: SizeReq,
|
||||
_sHeight :: SizeReq,
|
||||
_sPadding :: Padding,
|
||||
_sOffset :: Offset,
|
||||
_sBorder :: Border,
|
||||
_sAlignment :: Alignment,
|
||||
_sCorner :: CornerStyle
|
||||
}
|
||||
|
||||
instance Semigroup Style where
|
||||
(<>) = mappend
|
||||
|
||||
instance Monoid Style where
|
||||
mempty = Style mempty mempty mempty mempty mempty mempty mempty
|
||||
mappend (Style w1 h1 p1 o1 b1 a1 c1) (Style w2 h2 p2 o2 b2 a2 c2) = Style {
|
||||
_sWidth = w1 <> w2,
|
||||
_sHeight = h1 <> h2,
|
||||
_sPadding = p1 <> p2,
|
||||
_sOffset = o1 <> o2,
|
||||
_sBorder = b1 <> b2,
|
||||
_sAlignment = a1 <> a2,
|
||||
_sCorner = c1 <> c2
|
||||
}
|
||||
|
||||
--}
|
||||
{--
|
||||
|
||||
STYLES
|
||||
|
||||
- Width
|
||||
- Height
|
||||
- Padding
|
||||
- Offset
|
||||
- Border
|
||||
- Alignment
|
||||
- Corners
|
||||
|
||||
--}
|
||||
126
src/GUI/Widget/Widgets.hs
Normal file
126
src/GUI/Widget/Widgets.hs
Normal file
@ -0,0 +1,126 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module GUI.Widget.Widgets where
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Default
|
||||
import Data.Maybe
|
||||
import Data.Typeable
|
||||
import Debug.Trace
|
||||
|
||||
import GUI.Core
|
||||
import GUI.Data.Tree
|
||||
import GUI.Widget.Core
|
||||
import GUI.Widget.Drawing
|
||||
import GUI.Widget.Style
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
container_ :: (Monad m) => [Tree (WidgetNode e m)] -> Tree (WidgetNode e m)
|
||||
container_ = parentWidget makeContainer
|
||||
|
||||
emptyState :: Maybe ()
|
||||
emptyState = Nothing
|
||||
|
||||
makeContainer :: (Monad m) => Widget e m
|
||||
makeContainer = Widget widgetType handleEvent preferredSize resizeChildren render
|
||||
where
|
||||
widgetType = "container"
|
||||
handleEvent _ _ = NoEvents
|
||||
preferredSize _ _ _ = return def
|
||||
resizeChildren _ _ children = []
|
||||
render _ _ _ _ = return ()
|
||||
|
||||
button :: (Monad m) => e -> Tree (WidgetNode e m)
|
||||
button onClick = singleWidget (makeButton 0 onClick)
|
||||
|
||||
makeButton :: (Monad m) => Int -> e -> Widget e m
|
||||
makeButton state onClick = Widget widgetType handleEvent preferredSize resizeChildren render
|
||||
where
|
||||
widgetType = "button"
|
||||
handleEvent view evt = case evt of
|
||||
Click (Point x y) _ status -> EventsState events (makeButton newState onClick) where
|
||||
isPressed = status == PressedBtn && inRect view (Point x y)
|
||||
newState = if isPressed then state + 1 else state
|
||||
events = if isPressed then [onClick] else []
|
||||
_ -> NoEvents
|
||||
preferredSize renderer (style@Style{..}) _ = calcTextBounds renderer _textStyle (T.pack (show state))
|
||||
resizeChildren _ _ _ = []
|
||||
render renderer ts viewport (style@Style{..}) =
|
||||
do
|
||||
drawBgRect renderer viewport style
|
||||
drawText renderer viewport _textStyle (T.pack (show state))
|
||||
|
||||
data Direction = Horizontal | Vertical deriving (Show, Eq)
|
||||
|
||||
hgrid_ :: (Monad m) => [Tree (WidgetNode e m)] -> Tree (WidgetNode e m)
|
||||
hgrid_ = parentWidget makeHGrid
|
||||
|
||||
makeHGrid :: (Monad m) => Widget e m
|
||||
makeHGrid = makeFixedGrid "hgrid" Horizontal
|
||||
|
||||
vgrid_ :: (Monad m) => [Tree (WidgetNode e m)] -> Tree (WidgetNode e m)
|
||||
vgrid_ = parentWidget makeVGrid
|
||||
|
||||
makeVGrid :: (Monad m) => Widget e m
|
||||
makeVGrid = makeFixedGrid "vgrid" Vertical
|
||||
|
||||
makeFixedGrid :: (Monad m) => WidgetType -> Direction -> Widget e m
|
||||
makeFixedGrid widgetType direction = Widget widgetType handleEvent preferredSize resizeChildren render
|
||||
where
|
||||
handleEvent _ _ = NoEvents
|
||||
render _ _ _ _ = return ()
|
||||
preferredSize _ _ children = return $ Size width height where
|
||||
width = (fromIntegral wMul) * (maximum . map _w) children
|
||||
height = (fromIntegral hMul) * (maximum . map _h) children
|
||||
wMul = if direction == Horizontal then length children else 1
|
||||
hMul = if direction == Horizontal then 1 else length children
|
||||
resizeChildren (Rect l t w h) style children = newWidgets where
|
||||
cols = if direction == Horizontal then (length children) else 1
|
||||
rows = if direction == Horizontal then 1 else (length children)
|
||||
newWidgets = fmap resizeChild [0..(length children - 1)]
|
||||
resizeChild i = traceShow i $ Rect (cx i) (cy i) cw ch
|
||||
cw = w / fromIntegral cols
|
||||
ch = h / fromIntegral rows
|
||||
cx i = l + (fromIntegral $ i `div` rows) * cw
|
||||
cy i = t + (fromIntegral $ i `div` cols) * ch
|
||||
|
||||
{--
|
||||
makeSizedGrid :: (Monad m) => Direction -> Widget e m
|
||||
makeSizedGrid direction = Widget widgetType handleEvent preferredSize resizeChildren render
|
||||
where
|
||||
widgetType = "directionalLayout"
|
||||
handleEvent _ _ = NoEvents
|
||||
render _ _ _ _ = return ()
|
||||
preferredSize _ _ children = return $ Size (width children) (height children) where
|
||||
width = if direction == Horizontal then (sum . map _w) else (maximum . (map _w))
|
||||
height = if direction == Horizontal then (maximum . (map _h)) else (sum . (map _h))
|
||||
resizeChildren rect style children = []
|
||||
--}
|
||||
|
||||
{--
|
||||
hgrid :: (Monad m) => Rect -> [Widget s m] -> m Bool -> Widget s m
|
||||
hgrid rect widgets isVisible = makeGrid rect (length widgets) 1 widgets isVisible
|
||||
|
||||
vgrid :: (Monad m) => Rect -> [Widget s m] -> m Bool -> Widget s m
|
||||
vgrid rect widgets isVisible = makeGrid rect 1 (length widgets) widgets isVisible
|
||||
|
||||
makeGrid :: (Monad m) => Rect -> Int -> Int -> [Widget s m] -> m Bool -> Widget s m
|
||||
makeGrid r@(Rect l t w h) rows cols widgets iv = widget
|
||||
where
|
||||
widget = Widget widgetData iv (handleEvent widgets) (render widgets) resize showMe
|
||||
widgetData = WidgetData l t w h
|
||||
handleEvent widgets _ e = do
|
||||
newWidgets <- mapM (\wt -> _handleEvent wt (Rect l t w h) e) widgets
|
||||
pure $ makeGrid r rows cols newWidgets iv
|
||||
render widgets r _ = mapM_ (\Widget{..} -> whenM _isVisible $ _render r (widgetDataToRect _widgetData)) widgets
|
||||
showMe = show $ fmap _widgetData widgets
|
||||
resize _ = makeGrid r rows cols newWidgets iv
|
||||
where
|
||||
newWidgets = fmap resizeChild (zip [0..] widgets)
|
||||
resizeChild (i, child@(Widget {..})) = _resize $ child { _widgetData = (WidgetData (cx i) (cy i) cw ch) }
|
||||
cw = w / fromIntegral cols
|
||||
ch = h / fromIntegral rows
|
||||
cx i = l + (fromIntegral $ i `mod` rows) * cw
|
||||
cy i = t + (fromIntegral $ i `div` cols) * ch
|
||||
--}
|
||||
6
src/Lib.hs
Normal file
6
src/Lib.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Lib
|
||||
( someFunc
|
||||
) where
|
||||
|
||||
someFunc :: IO ()
|
||||
someFunc = putStrLn "someFunc"
|
||||
72
stack.yaml
Normal file
72
stack.yaml
Normal file
@ -0,0 +1,72 @@
|
||||
# This file was automatically generated by 'stack init'
|
||||
#
|
||||
# Some commonly used options have been documented as comments in this file.
|
||||
# For advanced use and comprehensive documentation of the format, please see:
|
||||
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||
|
||||
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||
# A snapshot resolver dictates the compiler version and the set of packages
|
||||
# to be used for project dependencies. For example:
|
||||
#
|
||||
# resolver: lts-3.5
|
||||
# resolver: nightly-2015-09-21
|
||||
# resolver: ghc-7.10.2
|
||||
# resolver: ghcjs-0.1.0_ghc-7.10.2
|
||||
# resolver:
|
||||
# name: custom-snapshot
|
||||
# location: "./custom-snapshot.yaml"
|
||||
resolver: lts-14.4
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
#
|
||||
# packages:
|
||||
# - some-directory
|
||||
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||
# - location:
|
||||
# git: https://github.com/commercialhaskell/stack.git
|
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
# extra-dep: true
|
||||
# subdirs:
|
||||
# - auto-update
|
||||
# - wai
|
||||
#
|
||||
# A package marked 'extra-dep: true' will only be built if demanded by a
|
||||
# non-dependency (i.e. a user package), and its test suites and benchmarks
|
||||
# will not be run. This is useful for tweaking upstream packages.
|
||||
packages:
|
||||
- .
|
||||
# Dependency packages to be pulled from upstream that are not in the resolver
|
||||
# (e.g., acme-missiles-0.3)
|
||||
extra-deps:
|
||||
- hedgehog-1.0
|
||||
- hedgehog-classes-0.2.1
|
||||
- nanovg-0.6.0.0
|
||||
- StateVar-1.1.1.1@sha256:cd3b516a49faf0627ea31885e012611e63600824976dcb276bcb2e92cdb0790f,1417
|
||||
- git: https://github.com/haskell-game/sdl2
|
||||
commit: 647c5611e23ad2822e974d9868faa481059258ca
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
# flags: {}
|
||||
|
||||
# Extra package databases containing global packages
|
||||
# extra-package-dbs: []
|
||||
|
||||
# Control whether we use the GHC we find on the path
|
||||
# system-ghc: true
|
||||
#
|
||||
# Require a specific version of stack, using version ranges
|
||||
# require-stack-version: -any # Default
|
||||
# require-stack-version: ">=1.6"
|
||||
#
|
||||
# Override the architecture used by stack, especially useful on Windows
|
||||
# arch: i386
|
||||
# arch: x86_64
|
||||
#
|
||||
# Extra directories used by stack for building
|
||||
# extra-include-dirs: [/path/to/dir]
|
||||
# extra-lib-dirs: [/path/to/dir]
|
||||
#
|
||||
# Allow a newer minor version of GHC than the snapshot specifies
|
||||
# compiler-check: newer-minor
|
||||
54
stack.yaml.lock
Normal file
54
stack.yaml.lock
Normal file
@ -0,0 +1,54 @@
|
||||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages:
|
||||
- completed:
|
||||
hackage: hedgehog-1.0@sha256:440dafedac48a34eac3871f8622b215462cfc0708536cb0458b7a8cf38247c69,4463
|
||||
pantry-tree:
|
||||
size: 2409
|
||||
sha256: 985f5ddc16bc1fd4b0c33d4b4e6f54d205fc63aa97b5912b0fcb370dc2a672e3
|
||||
original:
|
||||
hackage: hedgehog-1.0
|
||||
- completed:
|
||||
hackage: hedgehog-classes-0.2.1@sha256:17efa4f03e2de7936c119266d8b3710b167b2615a3455b45461c2dfa23b82fb6,5351
|
||||
pantry-tree:
|
||||
size: 4974
|
||||
sha256: 625a4d7494774e9d1f58420c3520dc652d36798c97d7018763435e42fb8908e8
|
||||
original:
|
||||
hackage: hedgehog-classes-0.2.1
|
||||
- completed:
|
||||
hackage: nanovg-0.6.0.0@sha256:326e73fe2c4ec56656fa42894c53a8e26b3e60449c69578f5f6da50c0ad60ed2,4146
|
||||
pantry-tree:
|
||||
size: 2477
|
||||
sha256: a5e327e2216aea778723aeb77d8868376ff4999d1b3cd4d4fe17d38d0ff04265
|
||||
original:
|
||||
hackage: nanovg-0.6.0.0
|
||||
- completed:
|
||||
hackage: StateVar-1.1.1.1@sha256:cd3b516a49faf0627ea31885e012611e63600824976dcb276bcb2e92cdb0790f,1417
|
||||
pantry-tree:
|
||||
size: 314
|
||||
sha256: d2b673886d4d8866aecb9b7f32ec6719fa9a8f8d2ccccea059edc3c45db4e1f0
|
||||
original:
|
||||
hackage: StateVar-1.1.1.1@sha256:cd3b516a49faf0627ea31885e012611e63600824976dcb276bcb2e92cdb0790f,1417
|
||||
- completed:
|
||||
cabal-file:
|
||||
size: 11219
|
||||
sha256: 036f43db9e3ac46d9c9b96b58b1b26defc6b39674633ff05886cb2159135520f
|
||||
name: sdl2
|
||||
version: 2.4.0.1
|
||||
git: https://github.com/haskell-game/sdl2
|
||||
pantry-tree:
|
||||
size: 6949
|
||||
sha256: d6ac403f4c9bf8622d1d2bb36276010c25bcb0a6f21db33f96f01af1d6ab6f7b
|
||||
commit: 647c5611e23ad2822e974d9868faa481059258ca
|
||||
original:
|
||||
git: https://github.com/haskell-game/sdl2
|
||||
commit: 647c5611e23ad2822e974d9868faa481059258ca
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 523884
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/4.yaml
|
||||
sha256: 16f24be248b42c9e16d59db84378836b1e7c239448a041cae46d32daffa45a8b
|
||||
original: lts-14.4
|
||||
13
test/unit/Music/Widget/CoreSpec.hs
Normal file
13
test/unit/Music/Widget/CoreSpec.hs
Normal file
@ -0,0 +1,13 @@
|
||||
module GUI.Widget.CoreSpec where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Widget.Core" $ do
|
||||
stubSpec
|
||||
|
||||
stubSpec :: Spec
|
||||
stubSpec =
|
||||
describe "Stub" $ do
|
||||
it "does not really test anything" $ do
|
||||
2 `shouldBe` (1 + 1)
|
||||
43
test/unit/Music/Widget/StyleSpec.hs
Normal file
43
test/unit/Music/Widget/StyleSpec.hs
Normal file
@ -0,0 +1,43 @@
|
||||
module GUI.Widget.StyleSpec where
|
||||
|
||||
import Hedgehog
|
||||
import Hedgehog.Classes
|
||||
import Test.Hspec
|
||||
import TestUtils
|
||||
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
|
||||
import GUI.Core
|
||||
import GUI.Widget.Style
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Style" $ do
|
||||
it "should do nothing, again" $ do
|
||||
1 `shouldBe` 1
|
||||
|
||||
it "should have require function that checks hedgehog properties" $ do
|
||||
require $ property $ do
|
||||
x <- forAll (Gen.int Range.constantBounded)
|
||||
x === x
|
||||
|
||||
it "should check BorderSide fulfills Semigroup laws" $ do
|
||||
1 `shouldBe` 1
|
||||
|
||||
it "should check Padding fulfills Semigroup laws" $ do
|
||||
checkLaws genPadding [monoidLaws]
|
||||
|
||||
genDouble :: Gen Double
|
||||
genDouble = Gen.double (Range.linearFrac (-10000) 10000)
|
||||
|
||||
genMDouble :: Gen (Maybe Double)
|
||||
genMDouble = Gen.maybe $ genDouble
|
||||
|
||||
genRGB :: Gen Color
|
||||
genRGB = RGB <$> genDouble <*> genDouble <*> genDouble
|
||||
|
||||
genBorderSide :: Gen BorderSide
|
||||
genBorderSide = BorderSide <$> genDouble <*> genRGB
|
||||
|
||||
genPadding :: Gen Padding
|
||||
genPadding = Padding <$> genMDouble <*> genMDouble <*> genMDouble <*> genMDouble
|
||||
1
test/unit/Spec.hs
Normal file
1
test/unit/Spec.hs
Normal file
@ -0,0 +1 @@
|
||||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
33
test/unit/TestUtils.hs
Normal file
33
test/unit/TestUtils.hs
Normal file
@ -0,0 +1,33 @@
|
||||
module TestUtils where
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.IO.Class
|
||||
import Data.CallStack
|
||||
import Hedgehog
|
||||
import Hedgehog.Classes
|
||||
import Test.HUnit.Lang
|
||||
import System.IO.Silently
|
||||
|
||||
import qualified Control.Exception as E
|
||||
|
||||
{-- Adapted from: http://hackage.haskell.org/package/hw-hspec-hedgehog --}
|
||||
location :: HasCallStack => Maybe SrcLoc
|
||||
location = case reverse callStack of
|
||||
(_, loc) : _ -> Just loc
|
||||
[] -> Nothing
|
||||
|
||||
require :: HasCallStack => Property -> Assertion
|
||||
require p = do
|
||||
(captured, result) <- capture $ liftIO $ check p
|
||||
|
||||
unless result $ do
|
||||
putStrLn captured
|
||||
E.throwIO (HUnitFailure location $ Reason "Hedgehog property test failed")
|
||||
|
||||
checkLaws :: HasCallStack => Gen a -> [Gen a -> Laws] -> Assertion
|
||||
checkLaws gen laws = do
|
||||
(captured, result) <- capture $ lawsCheckOne gen laws
|
||||
|
||||
unless result $ do
|
||||
putStrLn captured
|
||||
E.throwIO (HUnitFailure location $ Reason "Hedgehog classes property test failed")
|
||||
1
watch-tests.sh
Executable file
1
watch-tests.sh
Executable file
@ -0,0 +1 @@
|
||||
ghcid --command "stack ghci hs-music:lib hs-music:test:hs-music-test --ghci-options=-fobject-code"
|
||||
Loading…
Reference in New Issue
Block a user