module Yoga (
Layout,
Children, startToEnd, endToStart, centered, spaceBetween, spaceAround,
wrapped,
hbox, vbox,
hboxLeftToRight, hboxRightToLeft,
vboxTopToBottom, vboxBottomToTop,
Size(..),
shrinkable, growable, exact, withDimensions,
Edge(..),
stretched, withMargin, withPadding,
LayoutInfo(..), RenderFn, render, foldRender,
) where
import Bindings.Yoga
import Bindings.Yoga.Enums
import Control.Applicative
import Control.Monad hiding (mapM, forM_)
import Data.Foldable
import Data.Traversable
import Data.Monoid
import Foreign.C.Types (CFloat, CInt)
import Foreign.ForeignPtr
import GHC.Ptr (Ptr)
import Numeric.IEEE
import System.IO.Unsafe
import Prelude hiding (foldl, foldr, mapM)
data Layout a
= Root { _payload :: a,
_children :: [Layout a],
_rootPtr :: ForeignPtr C'YGNode }
| Container { _payload :: a,
_children :: [Layout a] }
| Leaf { _payload :: a }
deriving (Show, Eq, Ord)
withNativePtr :: Layout a -> (Ptr C'YGNode -> IO b) -> IO b
withNativePtr (Root _ _ ptr) f = withForeignPtr ptr f
withNativePtr _ _ = error "Internal: Only root nodes have pointers"
data Children a
= StartToEnd [Layout a]
| EndToStart [Layout a]
| Centered [Layout a]
| SpaceBetween [Layout a]
| SpaceAround [Layout a]
| Wrap (Children a)
deriving (Show, Eq, Ord)
instance Functor Layout where
fmap f (Root x cs ptr) = Root (f x) (fmap (fmap f) cs) ptr
fmap f (Container x cs) = Container (f x) (fmap (fmap f) cs)
fmap f (Leaf x) = Leaf (f x)
instance Foldable Layout where
foldMap f (Root x cs _) = f x `mappend` (foldMap (foldMap f) cs)
foldMap f (Container x cs) = f x `mappend` (foldMap (foldMap f) cs)
foldMap f (Leaf x) = f x
foldl f z (Root x cs _) = foldl (foldl f) (f z x) cs
foldl f z (Container x cs) = foldl (foldl f) (f z x) cs
foldl f z (Leaf x) = f z x
foldr f z (Root x cs _) = f x $ foldr (flip $ foldr f) z cs
foldr f z (Container x cs) = f x $ foldr (flip $ foldr f) z cs
foldr f z (Leaf x) = f x z
instance Traversable Layout where
traverse f (Root x cs ptr) =
Root <$> f x <*> (sequenceA $ traverse f <$> cs) <*> pure ptr
traverse f (Container x cs) =
Container <$> f x <*> (sequenceA $ traverse f <$> cs)
traverse f (Leaf x) = Leaf <$> f x
sequenceA (Root x cs ptr) =
Root <$> x <*> sequenceA (sequenceA <$> cs) <*> pure ptr
sequenceA (Container x cs) =
Container <$> x <*> sequenceA (sequenceA <$> cs)
sequenceA (Leaf x) = Leaf <$> x
mkNode :: a -> IO (Layout a)
mkNode x = do
ptr <- c'YGNodeNew
Root x [] <$> newForeignPtr p'YGNodeFree ptr
startToEnd :: [Layout a] -> Children a
startToEnd = StartToEnd
endToStart :: [Layout a] -> Children a
endToStart = EndToStart
centered :: [Layout a] -> Children a
centered = Centered
spaceBetween :: [Layout a] -> Children a
spaceBetween = SpaceBetween
spaceAround :: [Layout a] -> Children a
spaceAround = SpaceAround
wrapped :: Children a -> Children a
wrapped (Wrap xs) = Wrap xs
wrapped childs = childs
justifiedContainer :: CInt -> [Layout a] -> a -> IO (Layout a)
justifiedContainer just cs x = do
ptr <- c'YGNodeNew
c'YGNodeStyleSetJustifyContent ptr just
c'YGNodeStyleSetFlexWrap ptr c'YGWrapNoWrap
cs' <- flip mapM (zip cs [0..]) $ \((Root p children fptr), idx) -> do
withForeignPtr fptr $ \oldptr -> do
newptr <- c'YGNodeClone oldptr
c'YGNodeInsertChild ptr newptr idx
return $ if null children
then Leaf p
else Container p children
Root x cs' <$> newForeignPtr p'YGNodeFreeRecursive ptr
assembleChildren :: Children a -> a -> IO (Layout a)
assembleChildren (StartToEnd cs) x = justifiedContainer c'YGJustifyFlexStart cs x
assembleChildren (EndToStart cs) x = justifiedContainer c'YGJustifyFlexEnd cs x
assembleChildren (Centered cs) x = justifiedContainer c'YGJustifyCenter cs x
assembleChildren (SpaceBetween cs) x =
justifiedContainer c'YGJustifySpaceBetween cs x
assembleChildren (SpaceAround cs) x =
justifiedContainer c'YGJustifySpaceAround cs x
assembleChildren (Wrap cs) x = assembleChildren cs x >>= wrapContainer
where
wrapContainer :: Layout a -> IO (Layout a)
wrapContainer lyt = do
withNativePtr lyt $ \ptr ->
c'YGNodeStyleSetFlexWrap ptr c'YGWrapWrap
return lyt
setContainerDirection :: CInt -> CInt -> Layout a -> IO ()
setContainerDirection dir flexDir lyt =
withNativePtr lyt $ \ptr -> do
c'YGNodeStyleSetDirection ptr dir
c'YGNodeStyleSetFlexDirection ptr flexDir
hbox :: Children a -> a -> Layout a
hbox cs x = unsafePerformIO $ do
node <- assembleChildren cs x
setContainerDirection c'YGDirectionInherit c'YGFlexDirectionRow node
return node
vbox :: Children a -> a -> Layout a
vbox cs x = unsafePerformIO $ do
node <- assembleChildren cs x
setContainerDirection c'YGDirectionInherit c'YGFlexDirectionColumn node
return node
hboxLeftToRight :: Children a -> a -> Layout a
hboxLeftToRight cs x = unsafePerformIO $ do
node <- assembleChildren cs x
setContainerDirection c'YGDirectionLTR c'YGFlexDirectionRow node
return node
hboxRightToLeft :: Children a -> a -> Layout a
hboxRightToLeft cs x = unsafePerformIO $ do
node <- assembleChildren cs x
setContainerDirection c'YGDirectionRTL c'YGFlexDirectionRow node
return node
vboxTopToBottom :: Children a -> a -> Layout a
vboxTopToBottom cs x = unsafePerformIO $ do
node <- assembleChildren cs x
setContainerDirection c'YGDirectionLTR c'YGFlexDirectionColumn node
return node
vboxBottomToTop :: Children a -> a -> Layout a
vboxBottomToTop cs x = unsafePerformIO $ do
node <- assembleChildren cs x
setContainerDirection c'YGDirectionRTL c'YGFlexDirectionColumn node
return node
data Size
= Exact Float
| Min Float
| Max Float
| Range Float Float
deriving (Read, Show, Eq, Ord)
setWidth :: Size -> Layout a -> IO ()
setWidth (Exact w) lyt =
withNativePtr lyt $ \ptr -> c'YGNodeStyleSetWidth ptr $ realToFrac w
setWidth (Min w) lyt =
withNativePtr lyt $ \ptr -> c'YGNodeStyleSetMinWidth ptr $ realToFrac w
setWidth (Max w) lyt =
withNativePtr lyt $ \ptr -> c'YGNodeStyleSetMaxWidth ptr $ realToFrac w
setWidth (Range minWidth maxWidth) lyt =
withNativePtr lyt $ \ptr -> do
c'YGNodeStyleSetMinWidth ptr $ realToFrac minWidth
c'YGNodeStyleSetMaxWidth ptr $ realToFrac maxWidth
setHeight :: Size -> Layout a -> IO ()
setHeight (Exact h) lyt =
withNativePtr lyt $ \ptr -> c'YGNodeStyleSetHeight ptr $ realToFrac h
setHeight (Min h) lyt =
withNativePtr lyt $ \ptr -> c'YGNodeStyleSetMinHeight ptr $ realToFrac h
setHeight (Max h) lyt =
withNativePtr lyt $ \ptr -> c'YGNodeStyleSetMaxHeight ptr $ realToFrac h
setHeight (Range minHeight maxHeight) lyt =
withNativePtr lyt $ \ptr -> do
c'YGNodeStyleSetMinHeight ptr $ realToFrac minHeight
c'YGNodeStyleSetMaxHeight ptr $ realToFrac maxHeight
shrinkable :: Float -> Size -> Size -> (b -> Layout a) -> b -> Layout a
shrinkable weight width height mkNodeFn x = unsafePerformIO $ do
let n = mkNodeFn x
setWidth width n
setHeight height n
withNativePtr n $ \ptr -> c'YGNodeStyleSetFlexShrink ptr $ realToFrac weight
return n
growable :: Float -> Size -> Size -> (b -> Layout a) -> b -> Layout a
growable weight width height mkNodeFn x = unsafePerformIO $ do
let n = mkNodeFn x
setWidth width n
setHeight height n
withNativePtr n $ \ptr -> c'YGNodeStyleSetFlexGrow ptr $ realToFrac weight
return n
exact :: Float -> Float -> a -> Layout a
exact width height x = unsafePerformIO $ do
n <- mkNode x
setWidth (Exact width) n
setHeight (Exact height) n
return n
withDimensions :: Float -> Float -> (a -> Layout b) -> a -> Layout b
withDimensions width height mkNodeFn x = unsafePerformIO $ do
let n = mkNodeFn x
setWidth (Exact width) n
setHeight (Exact height) n
return n
stretched :: (b -> Layout a) -> b -> Layout a
stretched mkNodeFn x =
let node = mkNodeFn x
in unsafePerformIO $ do
withNativePtr node $ \ptr -> c'YGNodeStyleSetAlignSelf ptr c'YGAlignStretch
return node
data Edge
= Edge'Left
| Edge'Top
| Edge'Right
| Edge'Bottom
| Edge'Start
| Edge'End
| Edge'Horizontal
| Edge'Vertical
| Edge'All
deriving (Eq, Ord, Bounded, Enum, Read, Show)
setMargin :: CInt -> Float -> Layout a -> IO (Layout a)
setMargin edge px node = do
withNativePtr node $ \ptr -> c'YGNodeStyleSetMargin ptr edge $ realToFrac px
return node
withMargin :: Edge -> Float -> (b -> Layout a) -> b -> Layout a
withMargin Edge'Left px mkNodeFn x =
unsafePerformIO $ setMargin c'YGEdgeLeft px (mkNodeFn x)
withMargin Edge'Top px mkNodeFn x =
unsafePerformIO $ setMargin c'YGEdgeTop px (mkNodeFn x)
withMargin Edge'Right px mkNodeFn x =
unsafePerformIO $ setMargin c'YGEdgeRight px (mkNodeFn x)
withMargin Edge'Bottom px mkNodeFn x =
unsafePerformIO $ setMargin c'YGEdgeBottom px (mkNodeFn x)
withMargin Edge'Start px mkNodeFn x =
unsafePerformIO $ setMargin c'YGEdgeStart px (mkNodeFn x)
withMargin Edge'End px mkNodeFn x =
unsafePerformIO $ setMargin c'YGEdgeEnd px (mkNodeFn x)
withMargin Edge'Horizontal px mkNodeFn x =
unsafePerformIO $ setMargin c'YGEdgeHorizontal px (mkNodeFn x)
withMargin Edge'Vertical px mkNodeFn x =
unsafePerformIO $ setMargin c'YGEdgeVertical px (mkNodeFn x)
withMargin Edge'All px mkNodeFn x =
unsafePerformIO $ setMargin c'YGEdgeAll px (mkNodeFn x)
setPadding :: CInt -> Float -> Layout a -> IO (Layout a)
setPadding edge px node = do
withNativePtr node $ \ptr ->
c'YGNodeStyleSetPadding ptr edge $ realToFrac px
return node
withPadding :: Edge -> Float -> (b -> Layout a) -> b -> Layout a
withPadding Edge'Left px mkNodeFn x =
unsafePerformIO $ setPadding c'YGEdgeLeft px (mkNodeFn x)
withPadding Edge'Top px mkNodeFn x =
unsafePerformIO $ setPadding c'YGEdgeTop px (mkNodeFn x)
withPadding Edge'Right px mkNodeFn x =
unsafePerformIO $ setPadding c'YGEdgeRight px (mkNodeFn x)
withPadding Edge'Bottom px mkNodeFn x =
unsafePerformIO $ setPadding c'YGEdgeBottom px (mkNodeFn x)
withPadding Edge'Start px mkNodeFn x =
unsafePerformIO $ setPadding c'YGEdgeStart px (mkNodeFn x)
withPadding Edge'End px mkNodeFn x =
unsafePerformIO $ setPadding c'YGEdgeEnd px (mkNodeFn x)
withPadding Edge'Horizontal px mkNodeFn x =
unsafePerformIO $ setPadding c'YGEdgeHorizontal px (mkNodeFn x)
withPadding Edge'Vertical px mkNodeFn x =
unsafePerformIO $ setPadding c'YGEdgeVertical px (mkNodeFn x)
withPadding Edge'All px mkNodeFn x =
unsafePerformIO $ setPadding c'YGEdgeAll px (mkNodeFn x)
data LayoutInfo = LayoutInfo {
nodeTop :: Float,
nodeLeft :: Float,
nodeWidth :: Float,
nodeHeight :: Float
} deriving (Eq, Show)
emptyInfo :: LayoutInfo
emptyInfo = LayoutInfo 0 0 0 0
layoutWithParent :: LayoutInfo -> LayoutInfo -> LayoutInfo
layoutWithParent parent child =
let (x, y) = (nodeLeft parent, nodeTop parent)
(x', y') = (nodeLeft child, nodeTop child)
in child { nodeLeft = x + x', nodeTop = y + y' }
type RenderFn m a b = LayoutInfo -> a -> m b
calculateLayout :: Ptr C'YGNode -> IO ()
calculateLayout ptr =
let n = (nan :: CFloat)
in c'YGNodeStyleGetDirection ptr >>= c'YGNodeCalculateLayout ptr n n
layoutInfo :: Ptr C'YGNode -> IO LayoutInfo
layoutInfo ptr = do
left <- realToFrac <$> c'YGNodeLayoutGetLeft ptr
top <- realToFrac <$> c'YGNodeLayoutGetTop ptr
width <- realToFrac <$> c'YGNodeLayoutGetWidth ptr
height <- realToFrac <$> c'YGNodeLayoutGetHeight ptr
return $ LayoutInfo top left width height
renderNodeWithChildren :: (Functor m, Applicative m, Monad m, Monoid b) =>
LayoutInfo -> a -> [Layout a] -> Ptr C'YGNode
-> RenderFn m a (b, c)
-> m (b, c, [Layout c])
renderNodeWithChildren parentInfo x children ptr f = do
info <- return $ unsafePerformIO $ layoutInfo ptr
let thisInfo = layoutWithParent parentInfo info
(m, y) <- f thisInfo x
cs <- flip mapM (zip children [0..]) $ \(child, childIdx) -> do
childPtr <- return $ unsafePerformIO $ c'YGNodeGetChild ptr childIdx
foldRenderTree thisInfo child childPtr f
return (mappend m . foldr mappend mempty . map fst $ cs, y, map snd cs)
foldRenderTree :: (Functor m, Applicative m, Monad m, Monoid b) =>
LayoutInfo -> Layout a -> Ptr C'YGNode -> RenderFn m a (b, c) ->
m (b, Layout c)
foldRenderTree parentInfo (Root x children fptr) ptr f = do
(result, y, cs) <- renderNodeWithChildren parentInfo x children ptr f
return $ (result, Root y cs fptr)
foldRenderTree parentInfo (Container x children) ptr f = do
(result, y, cs) <- renderNodeWithChildren parentInfo x children ptr f
return $ (result, Container y cs)
foldRenderTree parentInfo (Leaf x) ptr f = do
(result, y, cs) <- renderNodeWithChildren parentInfo x [] ptr f
return $ cs `seq` (result, Leaf y)
foldRender :: (Functor m, Applicative m, Monad m, Monoid b) =>
Layout a -> RenderFn m a (b, c) -> m (b, Layout c)
foldRender lyt@(Root _ _ fptr) f = do
rootPtr <- return $ unsafePerformIO $ withForeignPtr fptr $ \ptr -> do
calculateLayout ptr
return ptr
foldRenderTree emptyInfo lyt rootPtr f
foldRender _ _ = error "Internal: Rendering must be done from the root node"
render :: (Functor m, Applicative m, Monad m) =>
Layout a -> RenderFn m a b -> m (Layout b)
render lyt f =
let f' lytInfo x = ((,) ()) <$> f lytInfo x
in snd <$> foldRender lyt f'