{-# Language UndecidableInstances #-}
module Reflex.Vty.Widget.Layout where
import Control.Applicative (liftA2)
import Control.Monad.Morph
import Control.Monad.NodeId (MonadNodeId(..), NodeId)
import Control.Monad.Reader
import Data.List (mapAccumL)
import Data.Map.Ordered (OMap)
import qualified Data.Map.Ordered as OMap
import Data.Maybe (fromMaybe, isNothing)
import Data.Ratio ((%))
import Data.Semigroup (First(..))
import Data.Set.Ordered (OSet)
import qualified Data.Set.Ordered as OSet
import qualified Graphics.Vty as V
import Reflex
import Reflex.Host.Class (MonadReflexCreateTrigger)
import Reflex.Vty.Widget
import Reflex.Vty.Widget.Input.Mouse
newtype FocusId = FocusId NodeId
deriving (Eq, Ord)
newtype FocusSet = FocusSet { unFocusSet :: OSet FocusId }
instance Semigroup FocusSet where
FocusSet a <> FocusSet b = FocusSet $ a OSet.|<> b
instance Monoid FocusSet where
mempty = FocusSet OSet.empty
singletonFS :: FocusId -> FocusSet
singletonFS = FocusSet . OSet.singleton
data Refocus = Refocus_Shift Int
| Refocus_Id FocusId
| Refocus_Clear
shiftFS :: FocusSet -> Maybe FocusId -> Int -> Maybe FocusId
shiftFS (FocusSet s) fid n = case OSet.findIndex <$> fid <*> pure s of
Nothing -> OSet.elemAt s 0
Just Nothing -> OSet.elemAt s 0
Just (Just ix) -> OSet.elemAt s $ mod (ix + n) (OSet.size s)
class (Monad m, Reflex t) => HasFocus t m | m -> t where
makeFocus :: m FocusId
requestFocus :: Event t Refocus -> m ()
isFocused :: FocusId -> m (Dynamic t Bool)
subFoci :: m a -> m (a, Dynamic t FocusSet)
focusedId :: m (Dynamic t (Maybe FocusId))
newtype Focus t m a = Focus
{ unFocus :: DynamicWriterT t FocusSet
(ReaderT (Dynamic t (Maybe FocusId))
(EventWriterT t (First Refocus) m)) a
}
deriving
( Functor
, Applicative
, Monad
, MonadHold t
, MonadSample t
, MonadFix
, TriggerEvent t
, PerformEvent t
, NotReady t
, MonadReflexCreateTrigger t
, HasDisplayRegion t
, PostBuild t
, MonadNodeId
, MonadIO
)
instance MonadTrans (Focus t) where
lift = Focus . lift . lift . lift
instance MFunctor (Focus t) where
hoist f = Focus . hoist (hoist (hoist f)) . unFocus
instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (Focus t m) where
runWithReplace (Focus a) e = Focus $ runWithReplace a $ fmap unFocus e
traverseIntMapWithKeyWithAdjust f m e = Focus $ traverseIntMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
traverseDMapWithKeyWithAdjust f m e = Focus $ traverseDMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e
instance (Reflex t, MonadFix m, HasInput t m) => HasInput t (Focus t m) where
localInput f = hoist (localInput f)
instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where
mapImages f = hoist (mapImages f)
instance (HasFocusReader t m, Monad m) => HasFocusReader t (Focus t m)
instance (HasTheme t m, Monad m) => HasTheme t (Focus t m)
instance (Reflex t, MonadFix m, MonadNodeId m) => HasFocus t (Focus t m) where
makeFocus = do
fid <- FocusId <$> lift getNextNodeId
Focus $ tellDyn $ pure $ singletonFS fid
pure fid
requestFocus = Focus . tellEvent . fmap First
isFocused fid = do
sel <- Focus ask
pure $ (== Just fid) <$> sel
subFoci (Focus child) = Focus $ do
(a, fs) <- lift $ runDynamicWriterT child
tellDyn fs
return (a, fs)
focusedId = Focus ask
runFocus
:: (MonadFix m, MonadHold t m, Reflex t)
=> Focus t m a
-> m (a, Dynamic t FocusSet)
runFocus (Focus x) = do
rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT sel $ runDynamicWriterT x
sel <- foldDyn f Nothing $ attach (current focusIds) focusRequests
pure (a, focusIds)
where
f :: (FocusSet, First Refocus) -> Maybe FocusId -> Maybe FocusId
f (fs, rf) mf = case getFirst rf of
Refocus_Clear -> Nothing
Refocus_Id fid -> Just fid
Refocus_Shift n -> if n < 0 && isNothing mf
then shiftFS fs (OSet.elemAt (unFocusSet fs) 0) n
else shiftFS fs mf n
anyChildFocused
:: (HasFocus t m, MonadFix m)
=> (Dynamic t Bool -> m a)
-> m a
anyChildFocused f = do
fid <- focusedId
rec (a, fs) <- subFoci (f b)
let b = liftA2 (\foc s -> case foc of
Nothing -> False
Just f' -> OSet.member f' $ unFocusSet s) fid fs
pure a
tabNavigation :: (Reflex t, HasInput t m, HasFocus t m) => m ()
tabNavigation = do
fwd <- fmap (const 1) <$> key (V.KChar '\t')
back <- fmap (const (-1)) <$> key V.KBackTab
requestFocus $ Refocus_Shift <$> leftmost [fwd, back]
data Constraint = Constraint_Fixed Int
| Constraint_Min Int
deriving (Show, Read, Eq, Ord)
fixed
:: Reflex t
=> Dynamic t Int
-> Dynamic t Constraint
fixed = fmap Constraint_Fixed
stretch
:: Reflex t
=> Dynamic t Int
-> Dynamic t Constraint
stretch = fmap Constraint_Min
flex
:: Reflex t
=> Dynamic t Constraint
flex = pure $ Constraint_Min 0
data Orientation = Orientation_Column
| Orientation_Row
deriving (Show, Read, Eq, Ord)
row
:: (Reflex t, MonadFix m, HasLayout t m)
=> m a
-> m a
row = axis (pure Orientation_Row) flex
col
:: (Reflex t, MonadFix m, HasLayout t m)
=> m a
-> m a
col = axis (pure Orientation_Column) flex
data LayoutTree a = LayoutTree a (LayoutForest a)
deriving (Show)
newtype LayoutForest a = LayoutForest { unLayoutForest :: OMap NodeId (LayoutTree a) }
deriving (Show)
instance Semigroup (LayoutForest a) where
LayoutForest a <> LayoutForest b = LayoutForest $ a OMap.|<> b
instance Monoid (LayoutForest a) where
mempty = LayoutForest OMap.empty
lookupLF :: NodeId -> LayoutForest a -> Maybe (LayoutTree a)
lookupLF n (LayoutForest a) = OMap.lookup n a
singletonLF :: NodeId -> LayoutTree a -> LayoutForest a
singletonLF n t = LayoutForest $ OMap.singleton (n, t)
fromListLF :: [(NodeId, LayoutTree a)] -> LayoutForest a
fromListLF = LayoutForest . OMap.fromList
rootLT :: LayoutTree a -> a
rootLT (LayoutTree a _) = a
childrenLT :: LayoutTree a -> LayoutForest a
childrenLT (LayoutTree _ a) = a
solve
:: Orientation
-> Region
-> LayoutForest (Constraint, Orientation)
-> LayoutTree (Region, Orientation)
solve o0 r0 (LayoutForest cs) =
let a = map (\(x, t@(LayoutTree (c, _) _)) -> ((x, t), c)) $ OMap.assocs cs
extent = case o0 of
Orientation_Row -> _region_width r0
Orientation_Column -> _region_height r0
sizes = computeEdges $ computeSizes extent a
chunks = [ (nodeId, solve o1 r1 f)
| ((nodeId, LayoutTree (_, o1) f), sz) <- sizes
, let r1 = chunk o0 r0 sz
]
in LayoutTree (r0, o0) $ fromListLF chunks
where
computeEdges :: [(a, Int)] -> [(a, (Int, Int))]
computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) ->
(((a, (offset, sz)) :) . m, sz + offset)) (id, 0)
computeSizes
:: Int
-> [(a, Constraint)]
-> [(a, Int)]
computeSizes available constraints =
let minTotal = sum $ ffor constraints $ \case
(_, Constraint_Fixed n) -> n
(_, Constraint_Min n) -> n
leftover = max 0 (available - minTotal)
numStretch = length $ filter (isMin . snd) constraints
szStretch = floor $ leftover % max numStretch 1
adjustment = max 0 $ available - minTotal - szStretch * numStretch
in snd $ mapAccumL (\adj (a, c) -> case c of
Constraint_Fixed n -> (adj, (a, n))
Constraint_Min n -> (max 0 (adj-1), (a, n + szStretch + signum adj))) adjustment constraints
isMin (Constraint_Min _) = True
isMin _ = False
chunk :: Orientation -> Region -> (Int, Int) -> Region
chunk o r (offset, sz) = case o of
Orientation_Column -> r
{ _region_top = _region_top r + offset
, _region_height = sz
}
Orientation_Row -> r
{ _region_left = _region_left r + offset
, _region_width = sz
}
class Monad m => HasLayout t m | m -> t where
axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a
region :: Dynamic t Constraint -> m (Dynamic t Region)
askOrientation :: m (Dynamic t Orientation)
newtype Layout t m a = Layout
{ unLayout :: DynamicWriterT t (LayoutForest (Constraint, Orientation))
(ReaderT (Dynamic t (LayoutTree (Region, Orientation))) m) a
}
deriving
( Functor
, Applicative
, HasDisplayRegion t
, Monad
, MonadFix
, MonadHold t
, MonadIO
, MonadNodeId
, MonadReflexCreateTrigger t
, MonadSample t
, NotReady t
, PerformEvent t
, PostBuild t
, TriggerEvent t
)
instance MonadTrans (Layout t) where
lift = Layout . lift . lift
instance MFunctor (Layout t) where
hoist f = Layout . hoist (hoist f) . unLayout
instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
hoistRunLayout
:: (HasDisplayRegion t m, MonadFix m, Monad n)
=> (m a -> n b)
-> Layout t m a
-> Layout t n b
hoistRunLayout f x = do
solution <- Layout ask
let orientation = snd . rootLT <$> solution
lift $ f $ do
dw <- displayWidth
dh <- displayHeight
let reg = Region 0 0 <$> dw <*> dh
runLayout orientation reg x
instance (HasInput t m, HasDisplayRegion t m, MonadFix m, Reflex t) => HasInput t (Layout t m) where
localInput = hoistRunLayout . localInput
instance (HasDisplayRegion t m, HasImageWriter t m, MonadFix m) => HasImageWriter t (Layout t m) where
mapImages f = hoistRunLayout (mapImages f)
instance (HasFocusReader t m, Monad m) => HasFocusReader t (Layout t m)
instance (HasTheme t m, Monad m) => HasTheme t (Layout t m)
instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => HasLayout t (Layout t m) where
axis o c (Layout x) = Layout $ do
nodeId <- getNextNodeId
let dummyParentLayout = LayoutTree (nilRegion, Orientation_Column) mempty
(result, forest) <- lift $ local (\t -> fromMaybe dummyParentLayout . lookupLF nodeId . childrenLT <$> t) $ runDynamicWriterT x
tellDyn $ singletonLF nodeId <$> (LayoutTree <$> ((,) <$> c <*> o) <*> forest)
pure result
region c = do
nodeId <- lift getNextNodeId
Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LayoutTree (c', Orientation_Row) mempty
solutions <- Layout ask
pure $ maybe nilRegion (fst . rootLT) . lookupLF nodeId . childrenLT <$> solutions
askOrientation = Layout $ asks $ fmap (snd . rootLT)
instance (MonadFix m, HasFocus t m) => HasFocus t (Layout t m) where
makeFocus = lift makeFocus
requestFocus = lift . requestFocus
isFocused = lift . isFocused
focusedId = lift focusedId
subFoci (Layout x) = Layout $ do
y <- ask
((a, w), sf) <- lift $ lift $ subFoci $ flip runReaderT y $ runDynamicWriterT x
tellDyn w
pure (a, sf)
runLayout
:: (MonadFix m, Reflex t)
=> Dynamic t Orientation
-> Dynamic t Region
-> Layout t m a
-> m a
runLayout o r (Layout x) = do
rec (result, w) <- runReaderT (runDynamicWriterT x) solutions
let solutions = solve <$> o <*> r <*> w
return result
initLayout :: (HasDisplayRegion t m, MonadFix m) => Layout t m a -> m a
initLayout f = do
dw <- displayWidth
dh <- displayHeight
let r = Region 0 0 <$> dw <*> dh
runLayout (pure Orientation_Column) r f
initManager
:: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)
=> Layout t (Focus t m) a
-> m (a, Dynamic t FocusSet)
initManager =
runFocus . initLayout
initManager_
:: (HasDisplayRegion t m, Reflex t, MonadHold t m, MonadFix m)
=> Layout t (Focus t m) a
-> m a
initManager_ = fmap fst . initManager
tile'
:: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
=> Dynamic t Constraint
-> m a
-> m (FocusId, a)
tile' c w = do
fid <- makeFocus
r <- region c
parentFocused <- isFocused fid
rec (click, result, childFocused) <- pane r focused $ anyChildFocused $ \childFoc -> do
m <- mouseDown V.BLeft
x <- w
pure (m, x, childFoc)
let focused = (||) <$> parentFocused <*> childFocused
requestFocus $ Refocus_Id fid <$ click
pure (fid, result)
tile
:: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
=> Dynamic t Constraint
-> m a
-> m a
tile c = fmap snd . tile' c
grout
:: (Reflex t, HasLayout t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
=> Dynamic t Constraint
-> m a
-> m a
grout c w = do
r <- region c
pane r (pure True) w