diff options
| -rw-r--r-- | Trammel.hs | 31 | ||||
| -rw-r--r-- | TreeViewRaw.hs | 13 | ||||
| -rw-r--r-- | test4.hs | 27 |
3 files changed, 50 insertions, 21 deletions
@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} module Trammel where import Control.Applicative @@ -214,3 +215,33 @@ pp t = renderString emptyRenderState t "" renderSGR :: Pm -> String renderSGR [] = [] renderSGR xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs + + +trammelDrop :: Int -> Trammel String -> Trammel String +trammelDrop n = \case + Append t1 t2 -> + case compare n (len t1) of + LT -> Append (trammelDrop n t1) t2 + EQ -> t2 + GT -> trammelDrop (n - len t1) t2 + Plain s -> + Plain (drop n s) + SGR pm t -> + SGR pm (trammelDrop n t) + Empty -> + Empty + + +trammelTake :: Int -> Trammel String -> Trammel String +trammelTake n = \case + Append t1 t2 -> + case compare n (len t1) of + LT -> trammelTake n t1 + EQ -> t1 + GT -> Append t1 (trammelTake (n - len t1) t2) + Plain s -> + Plain (take n s) + SGR pm t -> + SGR pm (trammelTake n t) + Empty -> + Empty diff --git a/TreeViewRaw.hs b/TreeViewRaw.hs index babd42d..9fc6c9e 100644 --- a/TreeViewRaw.hs +++ b/TreeViewRaw.hs @@ -1,7 +1,9 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module TreeViewRaw where +import Data.Monoid import TreeView import Data.Tree import Trammel @@ -13,20 +15,17 @@ import qualified Data.List as L import qualified Data.Map as M import qualified Data.Text as T --- Maybe TreeView -> Tree TreeView -> Image ---hPutTreeView h cur tv = --- treeImage (Just $ Z.label cursor) (Z.toTree cursor) -renderTreeView :: TreeView -> Tree TreeView -> [String] +renderTreeView :: TreeView -> Tree TreeView -> [Trammel String] renderTreeView cur _loc@(Node label children) = [ colorize $ renderTreeView1 hasFocus label ] ++ - concatMap (map (" "++) . renderTreeView cur) children + concatMap (map (" "<>) . renderTreeView cur) children where hasFocus = cur == label colorize s = if hasFocus - then pp $ SGR [31] s - else pp s + then SGR [31] s + else s renderTreeView1 :: Bool -> TreeView -> Trammel String @@ -1,9 +1,11 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} import Control.Applicative import Control.Exception import Data.Maybe +import Data.Monoid import Scanner (scan, runScanner, toChar) import System.Directory import System.Environment @@ -12,6 +14,7 @@ import System.IO import System.Posix.Files import System.Posix.Signals import System.Process +import Trammel import TreeSearch import TreeView import TreeViewRaw @@ -32,8 +35,8 @@ data State = State , flashMessage :: String , screenWidth :: Int , screenHeight :: Int - , headBuffer :: [String] - , treeBuffer :: [String] + , headBuffer :: [Trammel String] + , treeBuffer :: [Trammel String] } @@ -108,15 +111,11 @@ render q@State{..} = where newTreeBuf = renderTreeView (Z.label cursor) (Z.toTree cursor) newHeadBuf = - [ show screenWidth ++ "x" ++ show screenHeight - --show (linearPos cursor + 1) ++ "/" ++ show (length uncut) - ++ " " ++ show (linearPos cursor - yoffset) - ++ " " ++ show (topOverrun q) - ++ " " ++ show (botOverrun q) - ++ " " ++ flashMessage - , "--" - , "--" - , "--" + [ Plain (show screenWidth) <> "x" <> Plain (show screenHeight) + <> " " <> Plain (show $ linearPos cursor - yoffset) + <> " " <> Plain (show $ topOverrun q) + <> " " <> Plain (show $ botOverrun q) + <> " " <> Plain flashMessage ] @@ -125,15 +124,15 @@ redraw :: State -> IO () redraw _q@State{..} = do let image = - map (take screenWidth . drop xoffset) $ + map (trammelTake screenWidth . trammelDrop xoffset) $ take screenHeight $ headBuffer ++ drop yoffset treeBuffer screen = image ++ take (screenHeight - length image) (repeat "~") - case map (++"\ESC[K") screen of + case map (<>"\ESC[K") screen of (first : rest) -> - putStr $ "\ESC[H" ++ first ++ concatMap ("\n"++) rest + putStr $ pp $ "\ESC[H" <> first <> mconcat (map ("\n"<>) rest) _ -> return () |