M Mondrian.cabal => Mondrian.cabal +8 -0
@@ 33,6 33,8 @@ library
hs-source-dirs: lib
default-language: Haskell2010
+ ghc-options: -Wall
+
executable Mondrian
main-is: Main.hs
-- other-modules:
@@ 42,15 44,21 @@ executable Mondrian
hs-source-dirs: app
default-language: Haskell2010
+ ghc-options: -Wall
+
executable Convert
main-is: Convert.hs
build-depends: base >= 4.13 && <4.14, JuicyPixels
hs-source-dirs: app
default-language: Haskell2010
+ ghc-options: -Wall
+
test-suite Mondrian-test
default-language: Haskell2010
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: MyLibTest.hs
build-depends: base >=4.13 && <4.14
+
+ ghc-options: -Wall
M app/Main.hs => app/Main.hs +7 -5
@@ 10,21 10,21 @@ import Data.CSS.Syntax.Tokens (tokenize, serialize, Token(Whitespace))
import SDL hiding (trace)
import Graphics.GL.Core32
import System.Environment (getArgs)
-import Linear.Projection (ortho)
import Data.Function (fix)
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO (..))
-import Codec.Picture (DynamicImage(..), Image(..), PixelRGBA8(..),
+import Codec.Picture (DynamicImage(..), PixelRGBA8(..),
readImage, generateImage)
import Debug.Trace (trace) -- To warn about invalid args
+parseStyle :: PropertyParser p => String -> p
parseStyle syn
| (ret, []) <- parseProperties' toks = apply ret
- | (ret, tail) <- parseProperties' toks =
- trace ("Extraneous chars: " ++ unpack (serialize tail)) $ apply ret
+ | (ret, rest) <- parseProperties' toks =
+ trace ("Extraneous chars: " ++ unpack (serialize rest)) $ apply ret
where
toks = tokenize $ pack syn
apply ((key, val):props)
@@ 36,6 36,7 @@ parseStyle syn
val' = filter (/= Whitespace) val
apply [] = temp
+orthoProjection :: (Fractional a1, Integral a2) => V2 a2 -> M44 a1
orthoProjection (V2 ww wh) =
let (hw,hh) = (fromIntegral ww, fromIntegral wh)
in ortho 0 hw hh 0 0 1
@@ 79,10 80,11 @@ main = do
liftIO $ glSwapWindow w
unless (QuitEvent `elem` events) loop
-loadImage "" = return $ ImageRGBA8 $ generateImage transparent 1 1
+loadImage :: Text -> IO DynamicImage
loadImage path = do
ret <- readImage $ unpack path
return $ case ret of
Right x -> x
Left _ -> ImageRGBA8 $ generateImage transparent 1 1
+transparent :: p1 -> p2 -> PixelRGBA8
transparent _ _ = PixelRGBA8 0 0 0 0
M lib/Graphics/Rendering/Rect.hs => lib/Graphics/Rendering/Rect.hs +1 -0
@@ 36,6 36,7 @@ styleResolveImages atlas self =
atlasLookup' None = None
atlasLookup' (Img path) = Img $ atlasLookup path atlas
atlasLookup' (Linear a b) = Linear a b
+ atlasLookup' (Radial a) = Radial a
atlasFromStyles :: MonadIO m =>
(Text -> IO DynamicImage) -> [RectStyle Text] -> m Atlas
M lib/Graphics/Rendering/Rect/Backgrounds.hs => lib/Graphics/Rendering/Rect/Backgrounds.hs +45 -1
@@ 11,6 11,7 @@ import Control.Monad.IO.Class (MonadIO(..))
import Data.Maybe (fromMaybe, listToMaybe)
import Control.Monad (forM)
+baseFragmentShader :: B8.ByteString
baseFragmentShader = B8.pack $ unlines [
"#version 330 core",
"out vec4 fcolour;",
@@ 18,6 19,7 @@ baseFragmentShader = B8.pack $ unlines [
"void main() { fcolour = colour; }"
]
+imageFragmentShader :: B8.ByteString
imageFragmentShader = B8.pack $ unlines [
"#version 330 core",
"in vec2 coord;",
@@ 27,6 29,7 @@ imageFragmentShader = B8.pack $ unlines [
"void main() { fcolour = texture(image, coord/size); }"
]
+linearFragmentShader :: B8.ByteString
linearFragmentShader = B8.pack $ unlines [
"#version 330 core",
"in vec2 coord;",
@@ 36,6 39,7 @@ linearFragmentShader = B8.pack $ unlines [
"uniform float stopPoints[10];",
"uniform int nStops;",
"uniform float angle;",
+ "",
"void main() {",
" vec2 pos = coord/size;", -- Range 0..1
" pos -= 0.5; pos *= 2;", -- Range -1..1
@@ 58,6 62,36 @@ linearFragmentShader = B8.pack $ unlines [
"}"
]
+radialFragmentShader :: B8.ByteString
+radialFragmentShader = B8.pack $ unlines [
+ "#version 330 core",
+ "in vec2 coord;",
+ "out vec4 fcolour;",
+ "uniform vec2 size;",
+ "uniform vec4 stops[10];",
+ "uniform float stopPoints[10];",
+ "uniform int nStops;",
+ "",
+ "void main() {",
+ " vec2 pos = coord/size;",
+ " float a = distance(pos, vec2(0.5)) * 2;",
+ "",
+ " int i = 0;",
+ -- Workaround for buggy GPU drivers on test machine.
+ " if (8 < nStops - 1 && a > stopPoints[8]) i = 8;",
+ " else if (7 < nStops - 1 && a > stopPoints[7]) i = 7;",
+ " else if (6 < nStops - 1 && a > stopPoints[6]) i = 6;",
+ " else if (5 < nStops - 1 && a > stopPoints[5]) i = 5;",
+ " else if (4 < nStops - 1 && a > stopPoints[4]) i = 4;",
+ " else if (3 < nStops - 1 && a > stopPoints[3]) i = 3;",
+ " else if (2 < nStops - 1 && a > stopPoints[2]) i = 2;",
+ " else if (1 < nStops - 1 && a > stopPoints[1]) i = 1;",
+ "",
+ " a = smoothstep(stopPoints[i], stopPoints[i+1], a);",
+ " fcolour = mix(stops[i], stops[i+1], a);",
+ "}"
+ ]
+
renderBackgrounds :: (MonadIO m, MonadIO n) =>
n (Backgrounds Texture -> Rects -> M44 Float -> m ())
renderBackgrounds = do
@@ 65,11 99,13 @@ renderBackgrounds = do
layer <- renderRectWith imageFragmentShader ["size"]
linear <- renderRectWith linearFragmentShader ["size", "angle",
"stops", "stopPoints", "nStops"]
+ radial <- renderRectWith radialFragmentShader
+ ["size", "nStops", "stops", "stopPoints"]
return $ \self a b -> do
base [] [c $ background self] (headDef borderBox $ clip self) a b
let layers = image self `zip` (clip self ++ repeat borderBox)
`zip` (bgSize self ++ repeat (Size Auto Auto))
- forM layers $ \((pat0, clip0), size0) -> case pat0 of
+ _ <- forM layers $ \((pat0, clip0), size0) -> case pat0 of
None -> return ()
Img img0 -> layer [img0] [
u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0
@@ 78,11 114,18 @@ renderBackgrounds = do
u $ v2 $ size', u angle, cs 10 $ map fst stops,
us $ ls2fs size' $ map snd $ take 10 stops, u $ length stops
] clip0 a b
+ Radial stops -> let size'@(_,h) = size $ clip0 a in radial [] [
+ u $ v2 $ size', u $ length stops, cs 10 $ map fst stops,
+ us $ ls2fs (0,h/2) $ map snd $ take 10 stops
+ ] clip0 a b
return ()
+headDef :: c -> [c] -> c
headDef def = fromMaybe def . listToMaybe
+v2 :: (a, a) -> V2 a
v2 = uncurry V2
-- Easier to express this algorithm on CPU-side...
+ls2fs :: (Float, Float) -> [Length] -> [Float]
ls2fs (_,h) ls = resolveAutos 0 $ inner True 0 ls
where
-- https://drafts.csswg.org/css-images/#color-stop-fixup Step 1.
@@ 94,6 137,7 @@ ls2fs (_,h) ls = resolveAutos 0 $ inner True 0 ls
inner _ _ (Scale x:ls') = Scale x:inner False x ls'
inner _ _ (Absolute x:ls') = Absolute x:inner False (x/h) ls'
inner _ prev (Auto:ls') = Auto:inner False prev ls'
+ inner _ _ [] = []
-- Step 3
resolveAutos :: Float -> [Length] -> [Float]
resolveAutos _ (Scale x:ls') = x:resolveAutos x ls'
M lib/Graphics/Rendering/Rect/CSS.hs => lib/Graphics/Rendering/Rect/CSS.hs +2 -0
@@ 5,11 5,13 @@ import Stylist (PropertyParser(..))
import Graphics.Rendering.Rect.CSS.Colour (ColourPallet(foreground))
import Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..))
import Data.Text (Text)
+import Data.Colour(AlphaColour)
data RectStyle img = RectStyle {
colours :: ColourPallet,
backgrounds :: Backgrounds img
} deriving (Eq, Show, Read)
+colour :: RectStyle img -> AlphaColour Float
colour = foreground . colours
instance PropertyParser (RectStyle Text) where
M lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs => lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs +40 -35
@@ 12,8 12,6 @@ import Graphics.Rendering.Rect.CSS.Colour (ColourPallet, parseColour)
import Data.Colour (AlphaColour, transparent)
import Graphics.Rendering.Rect.Types (Rects(..), Rect(..))
-import Debug.Trace (traceShow)
-
data Backgrounds img = Backgrounds {
pallet :: ColourPallet,
background :: C,
@@ 24,7 22,8 @@ data Backgrounds img = Backgrounds {
type C = AlphaColour Float
-data Pattern img = None | Img img | Linear Float [(C, Length)] deriving (Eq, Show, Read)
+data Pattern img = None | Img img | Linear Float [(C, Length)]
+ | Radial [(C, Length)] deriving (Eq, Show, Read)
-- We need to resolve images before we can compute the actual lengths!
data Resize = Cover | Contain | Size Length Length deriving (Eq, Show, Read)
@@ 48,23 47,23 @@ instance PropertyParser (Backgrounds Text) where
inner [Ident "border-box"] = Just borderBox
inner [Ident "initial"] = Just borderBox -- To aid shorthand implementation.
inner _ = Nothing
- longhand _ self "background-image" t | val@(_:_) <- parseCSSList inner t =
- Just self { image = reverse val }
+ longhand _ self@Backgrounds { pallet = pp } "background-image" t
+ | val@(_:_) <- parseCSSList inner t = Just self { image = reverse val }
where
inner [Ident "none"] = Just None
inner [Ident "initial"] = Just None
inner [Url ret] = Just $ Img ret
inner [Function "url", String ret, RightParen] = Just $ Img ret
inner (Function "linear-gradient":toks)
- | Just cs@(_:_:_) <- colourStops (Comma:toks) = Just $ Linear pi cs
+ | Just cs@(_:_:_)<-colourStops pp (Comma:toks) = Just $ Linear pi cs
inner (Function "linear-gradient":Dimension _ x unit:toks)
| Just s <- lookup unit [("deg", pi/180), ("grad", pi/200),
("rad", 1), ("turn", 2*pi)],
- Just cs@(_:_:_) <- colourStops toks = Just $ Linear (f x*s) cs
+ Just cs@(_:_:_) <- colourStops pp toks = Just $ Linear (f x*s) cs
inner (Function "linear-gradient":Ident "to":Ident a:Ident b:toks)
- | Just angle <- corner a b, Just stops@(_:_:_) <- colourStops toks =
+ | Just angle<-corner a b, Just stops@(_:_:_)<-colourStops pp toks =
Just $ Linear angle stops
- | Just angle <- corner b a, Just stops@(_:_:_) <- colourStops toks =
+ | Just angle<-corner b a, Just stops@(_:_:_)<-colourStops pp toks =
Just $ Linear angle stops
where
corner "top" "right" = Just $ 0.25*pi
@@ 75,37 74,24 @@ instance PropertyParser (Backgrounds Text) where
inner (Function "linear-gradient":Ident "to":Ident side:toks)
| Just angle <- lookup side [
("top", 0), ("right", pi/2), ("bottom", pi), ("left", pi*1.5)],
- Just cs@(_:_:_) <- colourStops toks = Just $ Linear angle cs
+ Just cs@(_:_:_) <- colourStops pp toks = Just $ Linear angle cs
+ inner (Function "radial-gradient":toks)
+ | Just cs@(_:_:_) <- colourStops pp (Comma:toks) = Just $ Radial cs
inner _ = Nothing
- colourStops [RightParen] = Just []
- colourStops (Comma:toks)
- | Just (Percentage _ x:toks', c) <- parseColour (pallet self) toks,
- Just ret <- colourStops toks' = Just $ (c, Scale $ p x):ret
- | Just (Dimension _ x "px":toks', c) <- parseColour (pallet self) toks,
- Just ret <- colourStops toks' = Just $ (c, Absolute $ f x):ret
- | Just (toks', c) <- parseColour (pallet self) toks,
- Just ret <- colourStops toks' = Just $ (c, Auto):ret
- colourStops (Comma:Percentage _ x:toks)
- | Just (toks', c) <- parseColour (pallet self) toks,
- Just ret <- colourStops toks' = Just $ (c, Scale $ p x):ret
- colourStops (Comma:Dimension _ x "px":toks)
- | Just (toks', c) <- parseColour (pallet self) toks,
- Just ret <- colourStops toks' = Just $ (c, Absolute $ f x):ret
- colourStops _ = Nothing
longhand _ self "background-size" t | val@(_:_) <- parseCSSList inner t =
Just self { bgSize = reverse val }
where -- TODO: Add shorthand support, after background-position.
- inner [x, y] | Just a <- length x, Just b <- length y = Just $ Size a b
+ inner [x, y] | Just a <- l x, Just b <- l y = Just $ Size a b
inner [Ident "contain"] = Just Contain
inner [Ident "cover"] = Just Cover
inner [Ident "auto"] = Just $ Size Auto Auto
inner [Ident "initial"] = Just $ Size Auto Auto
inner _ = Nothing
-- NOTE: Leave lowering other units to CatTrap.
- length (Ident "auto") = Just Auto
- length (Dimension _ x "px") = Just $ Absolute $ f x
- length (Percentage _ x) = Just $ Scale $ p x
- length _ = Nothing
+ l (Ident "auto") = Just Auto
+ l (Dimension _ x "px") = Just $ Absolute $ f x
+ l (Percentage _ x) = Just $ Scale $ p x
+ l _ = Nothing
longhand _ _ _ _ = Nothing
-- The multi-layered shorthand is one source of parsing complexity.
@@ 128,6 114,25 @@ instance PropertyParser (Backgrounds Text) where
shorthand self key val | Just _ <- longhand self self key val = [(key, val)]
| otherwise = []
+colourStops :: ColourPallet
+ -> [Token] -> Maybe [(AlphaColour Float, Length)]
+colourStops _ [RightParen] = Just []
+colourStops cs (Comma:toks)
+ | Just (Percentage _ x:toks', c) <- parseColour cs toks,
+ Just ret <- colourStops cs toks' = Just $ (c, Scale $ p x):ret
+ | Just (Dimension _ x "px":toks', c) <- parseColour cs toks,
+ Just ret <- colourStops cs toks' = Just $ (c, Absolute $ f x):ret
+ | Just (toks', c) <- parseColour cs toks,
+ Just ret <- colourStops cs toks' = Just $ (c, Auto):ret
+colourStops cs (Comma:Percentage _ x:toks)
+ | Just (toks', c) <- parseColour cs toks,
+ Just ret <- colourStops cs toks' = Just $ (c, Scale $ p x):ret
+colourStops cs (Comma:Dimension _ x "px":toks)
+ | Just (toks', c) <- parseColour cs toks,
+ Just ret <- colourStops cs toks' = Just $ (c, Absolute $ f x):ret
+colourStops _ _ = Nothing
+
+parseCSSList :: ([Token] -> Maybe a) -> [Token] -> [a]
parseCSSList cb toks | all isJust ret = catMaybes ret
| otherwise = []
where ret = map cb $ concat $ splitList [Comma] $ parseOperands toks
@@ 152,10 157,10 @@ splitList sep list = h:splitList sep t
-- | Split is like break, but the matching element is dropped.
split :: (a -> Bool) -> [a] -> ([a], [a])
-split f s = (left,right)
+split filt s = (x,y)
where
- (left,right')=break f s
- right = if null right' then [] else tail right'
+ (x,y')=break filt s
+ y = if null y' then [] else tail y'
------
--- Dynamically-computed properties
@@ 167,7 172,7 @@ resolveSize (owidth, oheight) (width, height) Contain
| width > owidth = (width*sw, height*sw)
| height > oheight = (width*sh, height*sh)
| height > width = (width*sw, height*sw)
- | width > height = (width*sh, height*sh)
+ | otherwise = (width*sh, height*sh)
where
sh = oheight/height
sw = owidth/width
@@ 179,7 184,7 @@ resolveSize (owidth, oheight) (width, height) Cover
| oheight > height*sw = (width*sh, height*sh)
| owidth > width*sh = (width*sw, height*sw)
| height > width = (width*sw, height*sw)
- | width > height = (width*sh, height*sh)
+ | otherwise = (width*sh, height*sh)
where
sh = oheight/height
sw = owidth/width
M lib/Graphics/Rendering/Rect/CSS/Colour.hs => lib/Graphics/Rendering/Rect/CSS/Colour.hs +18 -18
@@ 13,14 13,14 @@ import Data.Scientific (toRealFloat)
import qualified Data.Text as Txt
import Data.Word (Word8)
-import Data.Bits (toIntegralSized)
-import Data.Char (isHexDigit, toLower, isUpper)
+import Data.Char (isHexDigit, toLower)
import Data.List (elemIndex)
import Debug.Trace (trace) -- For warning messages.
import Stylist (PropertyParser(..))
-hsl' h s l = uncurryRGB rgb $ hsl h s l
+hsl' :: RealFrac a => a -> a -> a -> Colour a
+hsl' hue s l = uncurryRGB rgb $ hsl hue s l
data ColourPallet = ColourPallet {
foreground :: AlphaColour Float,
@@ 238,21 238,21 @@ parseColour self@ColourPallet { foreground = colour} (Ident x:toks)
| Txt.toLower x `elem` ["currentcolor", "initial"] = Just (toks, colour)
| Txt.toLower x == "accentcolor" = Just (toks, accent self)
-parseColour _ (Function "hsl":h':Comma:
- Percentage _ s:Comma:Percentage _ l:RightParen:toks) | Just h <- d h' =
- Just (toks, opaque $ hsl' h (pc s) (pc l))
-parseColour _ (Function "hsl":h':Comma:Percentage _ s:Comma:Percentage _ l:
- Comma:a':RightParen:toks) | Just h <- d h', Just a <- f' a' =
- Just (toks, hsl' h (pc s) (pc l) `withOpacity` a)
-parseColour _ (Function "hsla":h':Comma:Percentage _ s:Comma:Percentage _ l:
- Comma:a':RightParen:toks) | Just h <- d h', Just a <- f' a' =
- Just (toks, hsl' h (pc s) (pc l) `withOpacity` a)
-parseColour _ (Function "hsl":h':s':l':RightParen:toks)
- | Just h <- d' h', Just s <- pc' s', Just l <- pc' l' =
- Just (toks, opaque $ hsl' h s l)
-parseColour _ (Function "hsl":h':s':l':Delim '/':a':RightParen:toks)
- | Just h <- d' h', Just s <- pc' s', Just l <- pc' l', Just a <- f' a' =
- Just (toks, hsl' h s l `withOpacity` a)
+parseColour _ (Function "hsl":hue':Comma:Percentage _ s:Comma:Percentage _ l:
+ RightParen:toks)
+ | Just hue <- d hue' = Just (toks, opaque $ hsl' hue (pc s) (pc l))
+parseColour _ (Function "hsl":hue':Comma:Percentage _ s:Comma:Percentage _ l:
+ Comma:a':RightParen:toks) | Just hue <- d hue', Just a <- f' a' =
+ Just (toks, hsl' hue (pc s) (pc l) `withOpacity` a)
+parseColour _ (Function "hsla":hue':Comma:Percentage _ s:Comma:Percentage _ l:
+ Comma:a':RightParen:toks) | Just hue <- d hue', Just a <- f' a' =
+ Just (toks, hsl' hue (pc s) (pc l) `withOpacity` a)
+parseColour _ (Function "hsl":hue':s':l':RightParen:toks)
+ | Just hue <- d' hue', Just s <- pc' s', Just l <- pc' l' =
+ Just (toks, opaque $ hsl' hue s l)
+parseColour _ (Function "hsl":hue':s':l':Delim '/':a':RightParen:toks)
+ | Just hue <- d' hue', Just s <- pc' s', Just l <- pc' l', Just a <- f' a' =
+ Just (toks, hsl' hue s l `withOpacity` a)
parseColour _ _ = Nothing
M lib/Graphics/Rendering/Rect/Image.hs => lib/Graphics/Rendering/Rect/Image.hs +4 -4
@@ 4,15 4,13 @@ module Graphics.Rendering.Rect.Image(
import qualified Data.HashMap.Lazy as HM
import Data.Text (Text)
-import Codec.Picture (DynamicImage(..), Image(..), PixelRGBA8(..), PixelF,
- pixelMap, generateImage)
+import Codec.Picture (DynamicImage(..), Image(..), PixelF, pixelMap)
import Codec.Picture.Types (promoteImage, dynamicMap, convertImage)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (forM)
import Data.Maybe (fromMaybe)
-import Typograffiti.GL
import Graphics.GL.Core32
import Graphics.GL.Types
import Graphics.GL.Ext.EXT.Cmyka
@@ 26,7 24,7 @@ import Foreign.Marshal.Array (allocaArray, peekArray)
data Atlas = Atlas { unAtlas :: HM.HashMap Text Texture }
buildAtlas :: MonadIO m => (Text -> IO DynamicImage) -> [Text] -> m Atlas
-buildAtlas cb [] = return $ Atlas HM.empty
+buildAtlas _ [] = return $ Atlas HM.empty
buildAtlas cb srcs = do
-- TODO Merge textures into an actual atlas.
let len = length srcs
@@ 57,6 55,7 @@ buildAtlas cb srcs = do
return $ Atlas $ HM.fromList $ zip srcs textures'
data Texture = Texture { unTexture :: GLuint, texSize :: (Float, Float) }
+nilTexture :: Texture
nilTexture = Texture 0 (0, 0)
atlasLookup :: Text -> Atlas -> Texture
atlasLookup key = fromMaybe nilTexture . HM.lookup key . unAtlas
@@ 79,6 78,7 @@ convertDyn (ImageYCbCr8 img) = ImageRGB8 $ convertImage img
convertDyn (ImageCMYK8 img) = ImageRGB8 $ convertImage img
convertDyn (ImageCMYK16 img) = ImageRGB16 $ convertImage img
+glFormat :: DynamicImage -> (GLenum, GLenum)
glFormat (ImageY8 _) = (GL_LUMINANCE, GL_UNSIGNED_BYTE)
glFormat (ImageY16 _) = (GL_LUMINANCE, GL_UNSIGNED_SHORT)
glFormat (ImageY32 _) = (GL_LUMINANCE, GL_UNSIGNED_INT)
M lib/Graphics/Rendering/Rect/Types.hs => lib/Graphics/Rendering/Rect/Types.hs +12 -6
@@ 28,10 28,12 @@ data Rect = Rect {
left :: Float, top :: Float,
right :: Float, bottom :: Float
} deriving (Read, Show, Eq, Ord)
+rect2geom :: Rect -> UV.Vector (V2 Float)
rect2geom Rect{..} = UV.fromList [tl, tr, br, tl, br, bl]
where
(tl, tr) = (V2 left top, V2 right top)
(bl, br) = (V2 left bottom, V2 right bottom)
+size :: Rect -> (Float, Float)
size Rect {..} = (right - left, bottom - top)
data Rects = Rects {
@@ 40,6 42,7 @@ data Rects = Rects {
borderBox :: Rect,
marginBox :: Rect
} deriving (Read, Show, Eq, Ord)
+rect :: Float -> Rect
rect x = Rect x x x x
type BoxSelector = Rects -> Rect
@@ 51,6 54,7 @@ instance Show BoxSelector where
| a rects == rect 1 = "paddingBox"
| a rects == rect 2 = "borderBox"
| a rects == rect 3 = "marginBox"
+ | otherwise = "?"
where rects = Rects (rect 0) (rect 1) (rect 2) (rect 3)
instance Read BoxSelector where
readsPrec _ ('c':'o':'n':'t':'e':'n':'t':'B':'o':'x':t) = [(contentBox, t)]
@@ 59,6 63,7 @@ instance Read BoxSelector where
readsPrec _ ('m':'a':'r':'g':'i':'n':'B':'o':'x':t) = [(marginBox, t)]
readsPrec _ _ = []
+vertexShader :: ByteString
vertexShader = B8.pack $ unlines [
"#version 330 core",
"uniform mat4 transform;",
@@ 106,15 111,15 @@ renderRectWith fragmentShader uniformNames = do
glEnable GL_BLEND
glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
return $ \textures uniforms getter rects mat -> do
- let rect = getter rects
+ let r = getter rects
vao <- liftIO $ newBoundVAO
pbuf <- newBuffer
- bufferGeometry 0 pbuf $ rect2geom rect
+ bufferGeometry 0 pbuf $ rect2geom r
glUseProgram prog
liftIO $ updateUniform prog matID $ mflip mat
- liftIO $ updateUniform prog originID $ V2 (left rect) (top rect)
- forM (zip uniformIDs uniforms) $ \(slot, cb) -> cb prog slot
+ liftIO $ updateUniform prog originID $ V2 (left r) (top r)
+ _ <- forM (zip uniformIDs uniforms) $ \(slot, cb) -> cb prog slot
withBoundTextures (map unTexture textures) $ do
glBindVertexArray vao
@@ 131,5 136,6 @@ liftGL n = do
Left err -> liftIO $ die err
Right x -> return x
-mflip (V4 (V4 a b c d) (V4 e f g h) (V4 i j k l) (V4 m n o p)) =
- V4 (V4 a e i m) (V4 b f j n) (V4 c g k o) (V4 d h l p)
+mflip :: V4 (V4 a) -> V4 (V4 a)
+mflip (V4 (V4 a b cc d) (V4 e f g h) (V4 i j k l) (V4 m n o p)) =
+ V4 (V4 a e i m) (V4 b f j n) (V4 cc g k o) (V4 d h l p)