{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
module Yi.Layout
(
Layout(..),
Orientation(..),
DividerPosition,
DividerRef,
RelativeSize,
dividerPositionA,
findDivider,
LayoutManager(..),
AnyLayoutManager(..),
layoutManagerSameType,
wide,
tall,
slidyTall,
slidyWide,
hPairNStack,
vPairNStack,
Rectangle(..),
HasNeighborWest,
layoutToRectangles,
Transposable(..),
Transposed(..),
LayoutM,
pair,
singleWindow,
stack,
evenStack,
runLayoutM,
)
where
import Control.Applicative ((<|>))
import Control.Arrow (first)
import Lens.Micro.Platform (Lens', lens)
import qualified Control.Monad.State.Strict as Monad (State, evalState, get, put)
import Data.Default (Default, def)
import Data.List (foldl', mapAccumL)
import Data.Maybe (fromMaybe, isNothing)
import Data.Typeable (Typeable, cast, typeOf)
data Layout a
= SingleWindow a
| Stack {
orientation :: !Orientation,
wins :: [(Layout a, RelativeSize)]
}
| Pair {
orientation :: !Orientation,
divPos :: !DividerPosition,
divRef :: !DividerRef,
pairFst :: !(Layout a),
pairSnd :: !(Layout a)
}
deriving(Typeable, Eq, Functor)
dividerPositionA :: DividerRef -> Lens' (Layout a) DividerPosition
dividerPositionA ref = lens getter (flip setter) where
setter pos = set'
where
set' s@(SingleWindow _) = s
set' p@Pair{} | divRef p == ref = p{ divPos = pos }
| otherwise = p{ pairFst = set' (pairFst p), pairSnd = set' (pairSnd p) }
set' s@Stack{} = s{ wins = fmap (first set') (wins s) }
getter = fromMaybe invalidRef . get'
get' (SingleWindow _) = Nothing
get' p@Pair{} | divRef p == ref = Just (divPos p)
| otherwise = get' (pairFst p) <|> get' (pairSnd p)
get' s@Stack{} = foldl' (<|>) Nothing (fmap (get' . fst) (wins s))
invalidRef = error "Yi.Layout.dividerPositionA: invalid DividerRef"
findDivider :: Eq a => Maybe a -> Layout a -> Maybe DividerRef
findDivider mbw = go [] where
go path (SingleWindow w) = maybe Nothing (\w' ->
if w == w' && not (null path)
then Just (head path) else Nothing) mbw
go path (Pair _ _ ref l1 l2) = if isNothing mbw then Just ref
else let p' = ref : path
in go p' l1 <|> go p' l2
go path (Stack _ ws) = foldr (<|>) Nothing $ map (go path . fst) ws
instance Show a => Show (Layout a) where
show (SingleWindow a) = show a
show (Stack o s) = show o ++ " stack " ++ show s
show p@(Pair{}) = show (orientation p) ++ " " ++ show (pairFst p, pairSnd p)
instance Default a => Default (Layout a) where
def = SingleWindow def
data Orientation
= Horizontal
| Vertical
deriving(Eq, Show)
type DividerRef = Int
type DividerPosition = Double
type RelativeSize = Double
class (Typeable m, Eq m) => LayoutManager m where
pureLayout :: m -> Layout a -> [a] -> Layout a
describeLayout :: m -> String
nextVariant :: m -> m
nextVariant = id
previousVariant :: m -> m
previousVariant = id
data AnyLayoutManager = forall m. LayoutManager m => AnyLayoutManager !m
deriving(Typeable)
instance Eq AnyLayoutManager where
(AnyLayoutManager l1) == (AnyLayoutManager l2) = maybe False (== l2) (cast l1)
instance LayoutManager (AnyLayoutManager) where
pureLayout (AnyLayoutManager l) = pureLayout l
describeLayout (AnyLayoutManager l) = describeLayout l
nextVariant (AnyLayoutManager l) = AnyLayoutManager (nextVariant l)
previousVariant (AnyLayoutManager l) = AnyLayoutManager (previousVariant l)
instance Default AnyLayoutManager where
def = hPairNStack 1
layoutManagerSameType :: AnyLayoutManager -> AnyLayoutManager -> Bool
layoutManagerSameType (AnyLayoutManager l1) (AnyLayoutManager l2) = typeOf l1 == typeOf l2
data Tall = Tall
deriving(Eq, Typeable)
tall :: AnyLayoutManager
tall = AnyLayoutManager Tall
instance LayoutManager Tall where
pureLayout Tall _oldLayout ws = runLayoutM $ evenStack Horizontal (fmap singleWindow ws)
describeLayout Tall = "Windows positioned side-by-side"
data Wide = Wide
deriving(Eq, Typeable)
instance LayoutManager Wide where
pureLayout Wide _oldLayout ws = runLayoutM $ evenStack Vertical (fmap singleWindow ws)
describeLayout Wide = "Windows positioned above one another"
wide :: AnyLayoutManager
wide = AnyLayoutManager Wide
data SlidyTall = SlidyTall
deriving(Eq, Typeable)
slidyTall :: AnyLayoutManager
slidyTall = AnyLayoutManager SlidyTall
instance LayoutManager SlidyTall where
pureLayout SlidyTall _oldLayout [] = error "Yi.Layout: empty window list unexpected"
pureLayout SlidyTall oldLayout xs = runLayoutM (go (Just oldLayout) xs) where
go _layout [x] = singleWindow x
go layout (splitList -> (lxs, rxs)) =
case layout of
Just (Pair Horizontal pos _ l r) -> pair Horizontal pos (go (Just l) lxs) (go (Just r) rxs)
_ -> pair Horizontal 0.5 (go Nothing lxs) (go Nothing rxs)
describeLayout SlidyTall = "Slidy tall windows, with balanced-position sliders"
splitList :: [a] -> ([a], [a])
splitList xs = splitAt ((length xs + 1) `div` 2) xs
newtype SlidyWide = SlidyWide (Transposed SlidyTall)
deriving(Eq, Typeable)
slidyWide :: AnyLayoutManager
slidyWide = AnyLayoutManager (SlidyWide (Transposed SlidyTall))
instance LayoutManager SlidyWide where
pureLayout (SlidyWide w) = pureLayout w
describeLayout _ = "Slidy wide windows, with balanced-position sliders"
data HPairNStack = HPairNStack !Int
deriving(Eq, Typeable)
hPairNStack :: Int -> AnyLayoutManager
hPairNStack n | n < 1 = error "Yi.Layout.hPairNStackLayout: n must be at least 1"
| otherwise = AnyLayoutManager (HPairNStack n)
instance LayoutManager HPairNStack where
pureLayout (HPairNStack n) oldLayout (fmap singleWindow -> xs)
| length xs <= n = runLayoutM $ evenStack Vertical xs
| otherwise = runLayoutM $ case splitAt n xs of
(ls, rs) -> pair Horizontal pos
(evenStack Vertical ls)
(evenStack Vertical rs)
where
pos = case oldLayout of
Pair Horizontal pos' _ _ _ -> pos'
_ -> 0.5
describeLayout (HPairNStack n) = show n ++ " windows on the left; remaining windows on the right"
nextVariant (HPairNStack n) = HPairNStack (n+1)
previousVariant (HPairNStack n) = HPairNStack (max (n-1) 1)
newtype VPairNStack = VPairNStack (Transposed HPairNStack)
deriving(Eq, Typeable)
vPairNStack :: Int -> AnyLayoutManager
vPairNStack n = AnyLayoutManager (VPairNStack (Transposed (HPairNStack n)))
instance LayoutManager VPairNStack where
pureLayout (VPairNStack lm) = pureLayout lm
previousVariant (VPairNStack lm) = VPairNStack (previousVariant lm)
nextVariant (VPairNStack lm) = VPairNStack (nextVariant lm)
describeLayout (VPairNStack (Transposed (HPairNStack n))) = show n ++ " windows on top; remaining windows beneath"
data Rectangle = Rectangle { rectX, rectY, rectWidth, rectHeight :: !Double }
deriving(Eq, Show)
type HasNeighborWest = Bool
layoutToRectangles :: HasNeighborWest -> Rectangle -> Layout a -> [(a, Rectangle, HasNeighborWest)]
layoutToRectangles nb bounds (SingleWindow a) = [(a, bounds, nb)]
layoutToRectangles nb bounds (Stack o ts) = handleStack o bounds ts'
where ts' = if o == Vertical then setNbs nb ts
else case ts of
(l, s) : xs -> (l, s, nb) : setNbs True xs
[] -> []
setNbs val = map (\(l, s) -> (l, s, val))
layoutToRectangles nb bounds (Pair o p _ a b) = handleStack o bounds [(a,p,nb), (b,1-p,nb')]
where nb' = if o == Horizontal then True else nb
handleStack :: Orientation -> Rectangle
-> [(Layout a, RelativeSize, HasNeighborWest)]
-> [(a, Rectangle, HasNeighborWest)]
handleStack o bounds tiles = concat . snd . mapAccumL doTile startPos $ tiles
where
(totalSpace, startPos, mkBounds) = case o of
Vertical -> (rectHeight bounds, rectY bounds,
\pos size -> bounds { rectY = pos, rectHeight = size })
Horizontal -> (rectWidth bounds, rectX bounds,
\pos size -> bounds { rectX = pos, rectWidth = size })
totalWeight' = sum . fmap (\(_, s, _) -> s) $ tiles
totalWeight = if totalWeight' > 0 then totalWeight'
else error "Yi.Layout: Stacks must have positive weights"
spacePerWeight = totalSpace / totalWeight
doTile pos (t, wt, nb) = (pos + wt * spacePerWeight,
layoutToRectangles nb (mkBounds pos (wt * spacePerWeight)) t)
class Transposable r where transpose :: r -> r
instance Transposable Orientation where { transpose Horizontal = Vertical; transpose Vertical = Horizontal }
instance Transposable (Layout a) where
transpose (SingleWindow a) = SingleWindow a
transpose (Stack o ws) = Stack (transpose o) (fmap (first transpose) ws)
transpose (Pair o p r a b) = Pair (transpose o) p r (transpose a) (transpose b)
newtype Transposed lm = Transposed lm
deriving(Eq, Typeable)
instance LayoutManager lm => LayoutManager (Transposed lm) where
pureLayout (Transposed lm) l ws = transpose (pureLayout lm (transpose l) ws)
describeLayout (Transposed lm) = "Transposed version of: " ++ describeLayout lm
nextVariant (Transposed lm) = Transposed (nextVariant lm)
previousVariant (Transposed lm) = Transposed (previousVariant lm)
newtype LayoutM a = LayoutM (Monad.State DividerRef (Layout a))
singleWindow :: a -> LayoutM a
singleWindow a = LayoutM (pure (SingleWindow a))
pair :: Orientation -> DividerPosition -> LayoutM a -> LayoutM a -> LayoutM a
pair o p (LayoutM l1) (LayoutM l2) = LayoutM $ do
ref <- Monad.get
Monad.put (ref+1)
Pair o p ref <$> l1 <*> l2
stack :: Orientation -> [(LayoutM a, RelativeSize)] -> LayoutM a
stack _ [] = error "Yi.Layout: Length-0 stack"
stack _ [l] = fst l
stack o ls = LayoutM (Stack o <$> mapM (\(LayoutM lm,rs) -> (,rs) <$> lm) ls)
evenStack :: Orientation -> [LayoutM a] -> LayoutM a
evenStack o ls = stack o (fmap (\l -> (l,1)) ls)
runLayoutM :: LayoutM a -> Layout a
runLayoutM (LayoutM l) = Monad.evalState l 0