summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Trammel.hs31
-rw-r--r--TreeViewRaw.hs13
-rw-r--r--test4.hs27
3 files changed, 50 insertions, 21 deletions
diff --git a/Trammel.hs b/Trammel.hs
index 36c1140..bd3cd32 100644
--- a/Trammel.hs
+++ b/Trammel.hs
@@ -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
diff --git a/test4.hs b/test4.hs
index b5336fe..3aed503 100644
--- a/test4.hs
+++ b/test4.hs
@@ -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 ()