module Graphics.UI.Threepenny.Editors.Layout
(
Renderable(..)
, Layout(Grid, Single)
, beside
, above
, Vertical(..)
, vertical
, Horizontal(..)
, horizontal
, Columns (Break, Next)
, type (|*|)(..)
, type (-*-)(..)
) where
import Data.Biapplicative
import Data.Bifoldable
import Data.Foldable (length)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Monoid
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import GHC.Exts (IsList (..))
import Graphics.UI.Threepenny.Core as UI
import Graphics.UI.Threepenny.Elements
import Graphics.UI.Threepenny.Widgets
class Renderable w where
render :: w -> UI Element
getLayout :: w -> Layout
render = runLayout . getLayout
getLayout = Cell . Just . render
instance Renderable Element where
render = return
instance Renderable a => Renderable (UI a) where
render = (>>= render)
instance Renderable TextEntry where
render = return . getElement
instance Renderable (ListBox a) where
render = return . getElement
instance Renderable String where
render = string
data Layout
= Grid (Seq (Seq Layout))
| Cell (Maybe (UI Element))
pattern Empty :: Layout
pattern Empty = Cell Nothing
pattern Single :: UI Element -> Layout
pattern Single x = Cell (Just x)
above, beside :: Layout -> Layout -> Layout
above (Grid rows@(length.head.toList -> l1)) (Grid rows'@(length.head.toList -> l2)) =
Grid $ fmap pad1 rows <> fmap pad2 rows'
where
pad l1 l2 | l1 >= l2 = id
| otherwise = (<> Seq.replicate (l2l1) (Cell Nothing))
pad1 = pad l1 l2
pad2 = pad l2 l1
above x (Cell Nothing) = x
above (Cell Nothing) x = x
above cell@(Cell Just{}) x = above (Grid [[cell]]) x
above x cell@(Cell Just{}) = above x (Grid [[cell]])
beside (Grid rows@(length -> l1)) (Grid rows'@(length -> l2)) =
Grid $ Seq.zipWith (<>) (pad1 rows) (pad2 rows')
where
pad l1 l2
| l1 >= l2 = id
| otherwise = \x ->
let padding = Seq.replicate (length $ head $ toList x) (Cell Nothing)
in x <> Seq.replicate (l2 l1) padding
pad1 = pad l1 l2
pad2 = pad l2 l1
beside x (Cell Nothing) = x
beside (Cell Nothing) x = x
beside cell@(Cell Just{}) x = beside (Grid [[cell]]) x
beside x cell@(Cell Just{}) = beside x (Grid [[cell]])
instance Renderable Layout where
getLayout = id
runLayout :: Layout -> UI Element
runLayout (Grid rows) = grid (toList $ fmap (fmap runLayout . toList) rows)
runLayout (Cell el) = fromMaybe new el
newtype Vertical = Vertical { getVertical :: Layout}
vertical :: Renderable w => w -> Vertical
vertical = Vertical . getLayout
instance Monoid Vertical where
mempty = Vertical Empty
mappend (Vertical a) (Vertical b)= Vertical $ above a b
instance Renderable Vertical where
getLayout = getVertical
newtype Horizontal = Horizontal { getHorizontal :: Layout}
horizontal :: Renderable w => w -> Horizontal
horizontal = Horizontal . getLayout
instance Monoid Horizontal where
mempty = Horizontal Empty
mappend (Horizontal a) (Horizontal b)= Horizontal $ beside a b
instance Renderable Horizontal where
getLayout = getHorizontal
data Columns
= Next Layout
| Break Layout
| Columns { next :: (Int, Int)
, acc :: Map (Int, Int) Layout
}
instance Renderable Columns where
getLayout = layoutColumns
instance Show Columns where
show(Next _) = "Next"
show(Break _) = "Break"
show Columns{..} = unwords ["Columns", show next, show (Map.keys acc)]
layoutColumns :: Columns -> Layout
layoutColumns (Next l) = l
layoutColumns (Break l) = l
layoutColumns Columns{acc}
| Map.null acc = Empty
| otherwise =
getLayout $
foldMap Vertical
[ getLayout $
foldMap Horizontal $ catMaybes [Map.lookup (i, j) acc | j <- [0 .. c]]
| i <- [0 .. r]
]
where
r = maximum $ fst <$> Map.keys acc
c = maximum $ snd <$> Map.keys acc
instance Monoid Columns where
mempty = Columns (1,1) mempty
mappend (Next a) (Columns (r,c) g) = let xy = (r+1, max 0 c) in Columns xy (Map.insert xy a g)
mappend (Break a) (Columns (_,c) g) = let xy = (0, c + 1) in Columns xy (Map.insert xy a g)
mappend (Columns (r,c) g) (Columns (r',_) g') = Columns (r+r'+1, 1) (Map.union g (Map.mapKeys (\(x,y) -> (x+r+1,y+c+1)) g'))
mappend c@Columns{} other = mappend other c
mappend (Next a) (Next b) = Columns ( 1,0) (Map.fromList [((0,0),a), ((1,0),b)])
mappend (Next a) (Break b) = Columns ( 0,1) (Map.fromList [((0,0),a), ((0,1),b)])
mappend (Break a) (Break b) = mappend (Next a) (Break b)
mappend (Break a) (Next b) = mappend (Next a) (Next b)
data a |*| b = a :|*| b
instance Bifunctor (|*|) where
bimap f g (a :|*| b) = f a :|*| g b
instance Bifoldable (|*|) where
bifoldMap f g (a :|*| b) = f a `mappend` g b
instance Biapplicative (|*|) where
bipure a b = a :|*| b
fa :|*| fb <<*>> a :|*| b = fa a :|*| fb b
instance (Renderable a, Renderable b) => Renderable (a |*| b) where
getLayout (a :|*| b) = getLayout a `beside` getLayout b
data a -*- b = a :-*- b
instance Bifunctor (-*-) where
bimap f g (a :-*- b) = f a :-*- g b
instance Bifoldable (-*-) where
bifoldMap f g (a :-*- b) = f a `mappend` g b
instance Biapplicative (-*-) where
bipure a b = a :-*- b
fa :-*- fb <<*>> a :-*- b = fa a :-*- fb b
instance (Renderable a, Renderable b) => Renderable (a -*- b) where
getLayout (a :-*- b) = getLayout a `above` getLayout b