module Yi.Layout
(
Layout(..),
Orientation(..),
DividerPosition,
DividerRef,
RelativeSize,
dividerPositionA,
LayoutManager(..),
AnyLayoutManager(..),
layoutManagerSameType,
wide,
tall,
slidyTall,
slidyWide,
hPairNStack,
vPairNStack,
Rectangle(..),
layoutToRectangles,
Transposable(..),
Transposed(..),
LayoutM,
pair,
singleWindow,
stack,
evenStack,
runLayoutM,
)
where
import Prelude()
import Data.Accessor.Basic
import Yi.Prelude
import Data.Typeable
import Data.Maybe
import Data.List(length, splitAt)
import qualified Control.Monad.State.Strict as Monad
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 -> Accessor (Layout a) DividerPosition
dividerPositionA ref = fromSetGet setter getter 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 (\(l, r) -> (set' l, r)) (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"
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 Initializable a => Initializable (Layout a) where
initial = SingleWindow initial
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 Initializable AnyLayoutManager where
initial = 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 (n1) 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)
layoutToRectangles :: Rectangle -> Layout a -> [(a, Rectangle)]
layoutToRectangles bounds (SingleWindow a) = [(a, bounds)]
layoutToRectangles bounds (Stack o ts) = handleStack o bounds ts
layoutToRectangles bounds (Pair o p _ a b) = handleStack o bounds [(a,p), (b,1p)]
handleStack :: Orientation -> Rectangle -> [(Layout a, RelativeSize)] -> [(a, Rectangle)]
handleStack o bounds tiles =
let (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 snd tiles)
totalWeight = if totalWeight' > 0 then totalWeight' else error "Yi.Layout: Stacks must have positive weights"
spacePerWeight = totalSpace / totalWeight
doTile pos (t, wt) = (pos + wt * spacePerWeight,
layoutToRectangles (mkBounds pos (wt * spacePerWeight)) t)
in
concat . snd . mapAccumL doTile startPos $ tiles
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 (\(l,r) -> (transpose l,r)) 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