-- Copyright (C) 2008 JP Bernardy -- | Utilities shared by various UIs module Yi.UI.Utils where import Prelude hiding (mapM) import Yi.Buffer import Yi.Window import Control.Arrow (second) import Control.Applicative import Control.Lens import Data.Function (on) import Data.Monoid import Data.Traversable (Traversable, mapM) import Data.Foldable (maximumBy) import Yi.Style import Data.List (transpose) import Yi.Syntax (Span(..)) import Data.List.Split (chunksOf) import Yi.String (padLeft) import Control.Monad.State (evalState,modify) import Control.Monad.State.Class (gets) indexedAnnotatedStreamB :: Point -> BufferM [(Point, Char)] indexedAnnotatedStreamB p = do text <- indexedStreamB Forward p annots <- withSyntaxB modeGetAnnotations return $ spliceAnnots text (dropWhile (\s -> spanEnd s < p) (annots p)) applyHeights :: Traversable t => [Int] -> t Window -> t Window applyHeights heights ws = evalState (mapM distribute ws) heights where distribute win = if isMini win then return win{height = 1} else (do h <- gets head modify tail return win{height = h}) spliceAnnots :: [(Point,Char)] -> [Span String] -> [(Point,Char)] spliceAnnots text [] = text spliceAnnots text (Span start x stop:anns) = l ++ zip (repeat start) x ++ spliceAnnots r anns where (l,rest) = span ((start >) . fst) text (_,r) = span ((stop >) . fst) rest -- | Turn a sequence of (from,style,to) strokes into a sequence -- of picture points (from,style), taking special care to -- ensure that the points are strictly increasing and introducing -- padding segments where neccessary. -- Precondition: Strokes are ordered and not overlapping. strokePicture :: [Span (Endo a)] -> [(Point,a -> a)] strokePicture [] = [] strokePicture wholeList@(Span leftMost _ _:_) = helper leftMost wholeList where helper :: Point -> [Span (Endo a)] -> [(Point,a -> a)] helper prev [] = [(prev,id)] helper prev (Span l f r:xs) | prev < l = (prev, id) : (l,appEndo f) : helper r xs | otherwise = (l,appEndo f) : helper r xs -- | Paint the given stroke-picture on top of an existing picture paintStrokes :: (a -> a) -> a -> [(Point,a -> a)] -> [(Point,a)] -> [(Point,a)] paintStrokes f0 _ [] lx = fmap (second f0) lx paintStrokes _ x0 lf [] = fmap (second ($ x0)) lf paintStrokes f0 x0 lf@((pf,f):tf) lx@((px,x):tx) = case pf `compare` px of LT -> (pf, f x0):paintStrokes f x0 tf lx EQ -> (pf, f x ):paintStrokes f x tf tx GT -> (px, f0 x ):paintStrokes f0 x lf tx paintPicture :: a -> [[Span (Endo a)]] -> [(Point,a)] paintPicture a = foldr (paintStrokes id a . strokePicture) [] attributesPictureB :: UIStyle -> Maybe SearchExp -> Region -> [[Span StyleName]] -> BufferM [(Point,Attributes)] attributesPictureB sty mexp region extraLayers = paintPicture (baseAttributes sty) <$> fmap (fmap (fmap ($ sty))) <$> (extraLayers ++) <$> strokesRangesB mexp region attributesPictureAndSelB :: UIStyle -> Maybe SearchExp -> Region -> BufferM [(Point,Attributes)] attributesPictureAndSelB sty mexp region = do selReg <- getSelectRegionB showSel <- use highlightSelectionA rectSel <- use rectangleSelectionA let styliseReg reg = Span (regionStart reg) selectedStyle (regionEnd reg) extraLayers | rectSel && showSel = (:[]) . fmap styliseReg <$> blockifyRegion selReg | showSel = return [[styliseReg selReg]] | otherwise = return [] attributesPictureB sty mexp region =<< extraLayers -- | Arrange a list of items in columns over maximum @maxNumberOfLines@ lines arrangeItems :: [String] -> Int -> Int -> [String] arrangeItems items maxWidth maxNumberOfLines = take maxNumberOfLines $ snd choice where choice = maximumBy (compare `on` fst) arrangements arrangements = fmap (arrangeItems' items maxWidth) (reverse [1..maxNumberOfLines]) -- | Arrange a list of items in columns over @numberOfLines@ lines. arrangeItems' :: [String] -> Int -> Int -> (Int, [String]) arrangeItems' items maxWidth numberOfLines = (fittedItems,theLines) where columns = chunksOf numberOfLines items columnsWidth = fmap (maximum . fmap length) columns totalWidths = scanl (\x y -> 1 + x + y) 0 columnsWidth shownItems = scanl (+) 0 (fmap length columns) fittedItems = snd $ last $ takeWhile ((<= maxWidth) . fst) $ zip totalWidths shownItems theLines = fmap (unwords . zipWith padLeft columnsWidth) $ transpose columns