summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Event.hs20
-rw-r--r--RenderTreeView.hs20
-rw-r--r--Scanner.hs141
-rw-r--r--Trammel.hs255
-rw-r--r--common.nix2
-rw-r--r--env.nix3
-rw-r--r--much.cabal4
-rw-r--r--test5.hs33
8 files changed, 38 insertions, 440 deletions
diff --git a/Event.hs b/Event.hs
index f316c13..1aa718a 100644
--- a/Event.hs
+++ b/Event.hs
@@ -1,23 +1,11 @@
module Event where
-import Trammel
-
+import Blessings
+import Scanner
data Event =
- EFlash (Trammel String) |
- EKey String |
- EMouse MouseInfo |
+ EFlash (Blessings String) |
+ EScan Scan |
EReload |
EResize Int Int
deriving Show
-
-
-data MouseInfo = MouseInfo
- { mouseButton :: Int -- 0 = release
- , mouseShift :: Bool
- , mouseMeta :: Bool
- , mouseControl :: Bool
- , mouseX :: Int
- , mouseY :: Int
- }
- deriving Show
diff --git a/RenderTreeView.hs b/RenderTreeView.hs
index a50bf37..21a6771 100644
--- a/RenderTreeView.hs
+++ b/RenderTreeView.hs
@@ -11,13 +11,13 @@ import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Tree.Zipper as Z
import qualified TreeZipperUtils as Z
+import Blessings
import Data.Char
import Data.Monoid
import Data.Time
import Data.Time.Format.Human
import Data.Tree
import TagUtils (Tag)
-import Trammel
import TreeView
@@ -47,7 +47,7 @@ renderTreeView
:: UTCTime
-> Z.TreePos Z.Full TreeView
-> Z.TreePos Z.Full TreeView
- -> [Trammel String]
+ -> [Blessings String]
renderTreeView now cur =
renderNode
where
@@ -69,7 +69,7 @@ renderTreeView now cur =
maybe mempty renderSubForest
-renderPrefix :: Z.TreePos Z.Full TreeView -> Trammel String
+renderPrefix :: Z.TreePos Z.Full TreeView -> Blessings String
renderPrefix =
mconcat . reverse . map prefix . zip [(1 :: Int)..] . Z.path
where
@@ -96,7 +96,7 @@ spacePrefix
, teePrefix
, pipePrefix
, endPrefix
- :: Trammel String
+ :: Blessings String
spacePrefix = prefixSGR " "
teePrefix = prefixSGR "├╴"
pipePrefix = prefixSGR "│ "
@@ -116,7 +116,7 @@ searchSGR
, unreadSearchSGR
, killedTagSGR
, starTagSGR
- :: Trammel String -> Trammel String
+ :: Blessings String -> Blessings String
searchSGR = SGR [38,5,162]
focusSGR = SGR [38,5,160]
quoteSGR = SGR [38,5,242]
@@ -133,7 +133,7 @@ unreadMessageSGR = SGR [38,5,117]
unreadSearchSGR = SGR [38,5,250]
-renderTreeView1 :: UTCTime -> Bool -> TreeView -> Trammel String
+renderTreeView1 :: UTCTime -> Bool -> TreeView -> Blessings String
renderTreeView1 now hasFocus x = case x of
TVSearch s ->
@@ -190,7 +190,7 @@ renderTreeView1 now hasFocus x = case x of
-renderDate :: UTCTime -> TreeView -> Trammel String
+renderDate :: UTCTime -> TreeView -> Blessings String
renderDate now = \case
TVSearchResult sr -> f humanTimeLocale (Notmuch.searchTime sr)
TVMessage m -> f humanTimeLocale (Notmuch.messageTime m)
@@ -200,19 +200,19 @@ renderDate now = \case
Plain $ humanReadableTimeI18N' timeLocale now time
-renderFrom :: Maybe T.Text -> Trammel String
+renderFrom :: Maybe T.Text -> Blessings String
renderFrom = \case
Just fromLine -> Plain $ dropAddress $ T.unpack fromLine
Nothing -> SGR [35,1] "Anonymous"
-renderTags :: [Tag] -> Trammel String
+renderTags :: [Tag] -> Blessings String
renderTags =
-- TODO sort somewhere else
mconcat . L.intersperse " " . map renderTag . L.sort
-renderTag :: Tag -> Trammel String
+renderTag :: Tag -> Blessings String
renderTag tag = case tag of
"draft" -> draftTagSGR plain
"killed" -> killedTagSGR plain
diff --git a/Scanner.hs b/Scanner.hs
deleted file mode 100644
index df48868..0000000
--- a/Scanner.hs
+++ /dev/null
@@ -1,141 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module Scanner
- ( scan
- ) where
-
-import Data.Bits ((.&.), testBit)
-import Data.Char (ord)
-import Data.Word (Word8)
-import Event
-import System.IO (Handle, hGetChar, hLookAhead, hWaitForInput)
-
-
-timeout :: Int
-timeout = 1
-
-
-scan :: Handle -> IO Event
-scan h =
- hGetChar h >>= \case
- '\ESC' -> scanESC h
- c -> return $ EKey [c]
-
-
-
-scanESC :: Handle -> IO Event
-scanESC h =
- hWaitGetChar timeout h >>= \case
- Nothing -> return $ EKey "\ESC"
- Just c
- | c == '[' -> -- 05/11
- scanCS h
- | c == '\ESC' -> -- 01/11
- -- XXX M-F1 and other crazy chords may cause
- -- \ESC\ESC... on wu, so we just recurse here...
- scanESC h
- | c == 'O' -> -- 04/15
- -- XXX Non-CSI SS3
- -- XXX finalByte is maybe calles somehow else here, but it's
- -- the same range
- one h finalByte ['O','\ESC'] >>=
- return . EKey . reverse
- | otherwise ->
- return $ EKey ['\ESC',c]
-
-
-scanCS :: Handle -> IO Event
-scanCS h =
- hWaitLookAhead timeout h >>= \case
- Nothing -> return $ EKey "\ESC" -- TODO move this to scanESC
- Just c
- | c == 'M' -> do
- _ <- hGetChar h -- drop 'M'
- b <- hGetChar h
- x <- hGetChar h
- y <- hGetChar h
- return $ parseNormalButton b x y
- | otherwise ->
- zeroOrMore h parameterByte ['[', '\ESC'] >>=
- zeroOrMore h intermediateByte >>=
- one h finalByte >>=
- return . EKey . reverse
-
-
-
-zeroOrMore :: Handle -> (Char -> Bool) -> [Char] -> IO [Char]
-zeroOrMore h p buf =
- hWaitLookAhead timeout h >>= \case
- Nothing -> return buf
- Just c
- | p c ->
- hGetChar h {-drop c-} >> zeroOrMore h p (c:buf)
- | otherwise ->
- return buf
-
-
-one :: Handle -> (Char -> Bool) -> [Char] -> IO [Char]
-one h p buf =
- hWaitLookAhead timeout h >>= \case
- Nothing -> return buf -- TODO error?
- Just c
- | p c -> do
- _ <- hGetChar h -- drop c
- return (c:buf)
- | otherwise ->
- error "expected one TODO"
-
-
-parameterByte :: Char -> Bool
-parameterByte = between '0' '?' -- 03/00 03/15
-
-intermediateByte :: Char -> Bool
-intermediateByte = between ' ' '/' -- 02/00 02/15
-
-finalByte :: Char -> Bool
-finalByte = between '@' '~' -- 04/00 07/14
-
-
-between :: Ord a => a -> a -> (a -> Bool)
-between lo hi = \ x -> lo <= x && x <= hi
-
-
-hWaitGetChar :: Int -> Handle -> IO (Maybe Char)
-hWaitGetChar t h = do
- ready <- hWaitForInput h t
- if ready
- then hGetChar h >>= return . Just
- else return Nothing
-
-
-hWaitLookAhead :: Int -> Handle -> IO (Maybe Char)
-hWaitLookAhead t h = do
- ready <- hWaitForInput h t
- if ready
- then hLookAhead h >>= return . Just
- else return Nothing
-
-
-parseNormalButton :: Char -> Char -> Char -> Event
-parseNormalButton cb cx cy = do
- let b = fromIntegral $ ord cb :: Word8
- x = ord cx - 32
- y = ord cy - 32
- button = case (b .&. 3) + (b .&. 64) of
- 0 -> 1
- 1 -> 2
- 2 -> 3
- 3 -> 0 -- release
- 64 -> 4 -- wheel up
- 65 -> 5 -- wheel down
- 66 -> 6 -- wheel left
- 67 -> 7 -- wheel right
- _ -> error "TODO proper parseNormalButton error"
- EMouse $ MouseInfo
- { mouseButton = button
- , mouseShift = testBit b 2
- , mouseMeta = testBit b 3
- , mouseControl = testBit b 4
- , mouseX = x
- , mouseY = y
- }
diff --git a/Trammel.hs b/Trammel.hs
deleted file mode 100644
index d1abedb..0000000
--- a/Trammel.hs
+++ /dev/null
@@ -1,255 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE LambdaCase #-}
-module Trammel where
-
-import Control.Applicative
-import Data.List
-import Data.String
-import Data.Monoid
-import Data.Ix (inRange)
-
-type Ps = Int
-type Pm = [Ps]
-
-data Trammel a
- = Plain a
- | SGR Pm (Trammel a)
- | Append (Trammel a) (Trammel a)
- | Empty
- deriving (Eq, Show)
-
-
-instance Functor Trammel where
- fmap f = \case
- Append t1 t2 -> Append (fmap f t1) (fmap f t2)
- Plain s -> Plain (f s)
- SGR pm t -> SGR pm (fmap f t)
- Empty -> Empty
-
-
-instance Monoid (Trammel a) where
- mappend = Append
- mempty = Empty
-
-
-instance IsString a => IsString (Trammel a) where
- fromString = Plain . fromString
-
-
-class IsPm a where
- toPm :: a -> Pm
- fromPm :: Pm -> Maybe a
-
-
-data FColor = ECMA48FColor Ps -- ECMA-48 / ISO 6429 / ANSI X3.64
- | Xterm256FColor Ps
- | ISO8613_3FColor Ps Ps Ps
- deriving (Eq, Show)
-
-instance IsPm FColor where
- toPm (ECMA48FColor i) = [i]
- toPm (Xterm256FColor i) = [38,5,i]
- toPm (ISO8613_3FColor r g b) = [38,2,r,g,b]
- fromPm = fromSGRPm SGRPm
- { def8Ps = 39
- , extPs = 38
- , lo8Ps = 30
- , hi8Ps = 37
- , makeECMA48Color = ECMA48FColor
- , makeXterm256Color = Xterm256FColor
- , makeISO8613_3Color = ISO8613_3FColor
- }
- . filterPm sgrBColor
-
-
-data BColor = ECMA48BColor Ps
- | Xterm256BColor Ps
- | ISO8613_3BColor Ps Ps Ps
- deriving (Eq, Show)
-
-
-instance IsPm BColor where
- toPm (ECMA48BColor i) = [i]
- toPm (Xterm256BColor i) = [48,5,i]
- toPm (ISO8613_3BColor r g b) = [48,2,r,g,b]
- fromPm = fromSGRPm SGRPm
- { def8Ps = 49
- , extPs = 48
- , lo8Ps = 40
- , hi8Ps = 47
- , makeECMA48Color = ECMA48BColor
- , makeXterm256Color = Xterm256BColor
- , makeISO8613_3Color = ISO8613_3BColor
- }
- . filterPm sgrFColor
-
-
-data Bold = Bold | NoBold
- deriving (Eq, Show)
-
-instance IsPm Bold where
- toPm Bold = [1]
- toPm NoBold = [22]
- fromPm = rec . filterPm sgrColor
- where
- rec xs = case filter (`elem` ([1,22] :: [Int])) xs of
- [] -> Nothing
- xs' -> case last xs' of
- 1 -> Just Bold
- 22 -> Just NoBold
- _ -> error "filter broken in fromPm :: Pm -> Maybe Bold"
-
-
-data Underline = Underline | NoUnderline
- deriving (Eq, Show)
-
-instance IsPm Underline where
- toPm Underline = [4]
- toPm NoUnderline = [24]
- fromPm = rec . filterPm sgrColor
- where
- rec xs = case filter (`elem` ([4,24] :: [Int])) xs of
- [] -> Nothing
- xs' -> case last xs' of
- 1 -> Just Underline
- 22 -> Just NoUnderline
- _ -> error "filter broken in fromPm :: Pm -> Maybe Underline"
-
-
-data SGRPm c = SGRPm
- { def8Ps :: Ps
- , extPs :: Ps
- , lo8Ps :: Ps
- , hi8Ps :: Ps
- , makeECMA48Color :: Ps -> c
- , makeXterm256Color :: Ps -> c
- , makeISO8613_3Color :: Ps -> Ps -> Ps -> c
- }
-
-
-fromSGRPm :: IsPm c => SGRPm c -> Pm -> Maybe c
-fromSGRPm SGRPm{..} = rec Nothing
- where
- rec mb_c (x:xs)
- | x == extPs = case xs of
- (2:r:g:b:xs') -> rec (Just $ makeISO8613_3Color r g b) xs'
- (5:i:xs') -> rec (Just $ makeXterm256Color i) xs'
- _ -> rec mb_c xs
- | x == def8Ps = rec (Just $ makeECMA48Color def8Ps) xs
- | inRange (lo8Ps, hi8Ps) x = rec (Just $ makeECMA48Color x) xs
- | otherwise = rec mb_c xs
- rec mb_c _ = mb_c
-
-
--- filterPm is used to preprocess Pm before searching with fromPm in
--- order to remove (longer) sequences that could contain subsequences
--- that look like the (shorter) sequences we're searching.
--- E.g. we could find [1] (bold) in any extended color sequence.
--- TODO Can we combine this whole from*Pm with Scanner?
-filterPm :: (Pm -> Maybe Int) -> Pm -> Pm
-filterPm f = rec []
- where
- rec ys xs@(xhead:xtail) = maybe (rec (ys ++ [xhead]) xtail)
- (rec ys . flip drop xs)
- (f xs)
- rec ys _ = ys
-
-sgrColor, sgrFColor, sgrBColor :: Pm -> Maybe Int
-
-sgrColor xs = sgrFColor xs <|> sgrBColor xs
-
-sgrFColor (38:5:_) = Just 3
-sgrFColor (38:2:_) = Just 5
-sgrFColor _ = Nothing
-
-sgrBColor (48:5:_) = Just 3
-sgrBColor (48:2:_) = Just 5
-sgrBColor _ = Nothing
-
-
-type RenderState = [(FColor, BColor, Bold, Underline)]
-
-
-emptyRenderState :: RenderState
-emptyRenderState = [(ECMA48FColor 39, ECMA48BColor 49, NoBold, NoUnderline)]
-
-renderString :: RenderState -> Trammel String -> String -> String
-
-renderString _ (Plain s) y = s ++ y
-
--- TODO merge successive sequences: \ESC[32m\ESC[1m -> \ESC[31;1m
-renderString rs@((fc, bc, b, u):_) (SGR c t) y =
- renderSGR bra ++ renderString rs' t (renderSGR ket ++ y)
- where
- fc' = maybe fc id $ fromPm c
- bc' = maybe bc id $ fromPm c
- b' = maybe b id $ fromPm c
- u' = maybe u id $ fromPm c
- rs' = (fc', bc', b', u') : rs
- bra = braket >>= fst
- ket = braket >>= snd
- braket =
- (if fc' /= fc then (toPm fc', toPm fc) else ([],[])) :
- (if bc' /= bc then (toPm bc', toPm bc) else ([],[])) :
- (if b' /= b then (toPm b', toPm b) else ([],[])) :
- (if u' /= u then (toPm u', toPm u) else ([],[])) : []
-
-renderString _ (SGR _ _) _ =
- error "renderString called w/o proper initial state"
- -- where a proper initial state is s.th. like emptyRenderState
-
-renderString r (Append t1 t2) y =
- renderString r t1 $ renderString r t2 y
-
-renderString _ Empty y = y
-
-
-len :: Trammel String -> Int
-len (Plain x) = length x
-len (SGR _ x) = len x
-len (Append t1 t2) = len t1 + len t2
-len Empty = 0
-
-
-pp :: Trammel String -> String
-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/common.nix b/common.nix
index 9590572..35b4e2c 100644
--- a/common.nix
+++ b/common.nix
@@ -1,5 +1,7 @@
{
haskell-overrides = self: super: {
+ blessings = self.callPackage ./nix/blessings.nix {};
email-header = self.callPackage ./nix/email-header.nix {};
+ scanner = self.callPackage ./nix/scanner.nix {};
};
}
diff --git a/env.nix b/env.nix
index 7f5a9bc..13038df 100644
--- a/env.nix
+++ b/env.nix
@@ -18,6 +18,8 @@ let
hsEnv = hsPkgs.ghcWithPackages (self: with self;
[
aeson
+ blaze-builder
+ blessings
cabal-install
case-insensitive
docopt
@@ -31,6 +33,7 @@ let
random
rosezipper
safe
+ scanner
split
temporary
terminal-size
diff --git a/much.cabal b/much.cabal
index 5f0bf0f..0f59590 100644
--- a/much.cabal
+++ b/much.cabal
@@ -1,5 +1,5 @@
name: much
-version: 0.0.0.0
+version: 1.0.0
license: MIT
author: tv <tv@shackspace.de>
maintainer: tv@shackspace.de
@@ -13,6 +13,7 @@ executable much
, attoparsec
, base64-bytestring
, blaze-builder
+ , blessings
, bytestring
, case-insensitive
, containers
@@ -29,6 +30,7 @@ executable much
, random
, rosezipper
, safe
+ , scanner
, split
, terminal-size
, text
diff --git a/test5.hs b/test5.hs
index 6ef1494..4838757 100644
--- a/test5.hs
+++ b/test5.hs
@@ -17,6 +17,7 @@ import qualified Notmuch
import qualified Notmuch.Message as Notmuch
import qualified Notmuch.SearchResult as Notmuch
import qualified System.Console.Terminal.Size as Term
+import Blessings
import Control.Applicative
import Control.Concurrent
import Control.Exception
@@ -32,7 +33,7 @@ import Data.Time
import Event
import ParseMail (readMail)
import RenderTreeView (renderTreeView)
-import Scanner (scan)
+import Scanner (scan,Scan(..))
import Safe
import System.Directory
import System.Console.Docopt.NoTH (getArgWithDefault, parseArgsOrExit, parseUsageOrExit, shortOption)
@@ -44,7 +45,6 @@ import System.Process
import TagUtils
import Text.Hyphenation
import Text.LineBreak
-import Trammel
import TreeSearch
import TreeView
import TreeZipperUtils (modifyFirstParentLabelWhere)
@@ -72,11 +72,11 @@ data State = State
{ cursor :: Z.TreePos Z.Full TreeView
, xoffset :: Int
, yoffset :: Int
- , flashMessage :: Trammel String
+ , flashMessage :: Blessings String
, screenWidth :: Int
, screenHeight :: Int
- , headBuffer :: [Trammel String]
- , treeBuffer :: [Trammel String]
+ , headBuffer :: [Blessings String]
+ , treeBuffer :: [Blessings String]
, now :: UTCTime
, decset :: [Int]
, decrst :: [Int]
@@ -165,7 +165,7 @@ startup q0 = do
]
threadIds <- mapM forkIO
- [ forever $ scan stdin >>= putEvent
+ [ forever $ scan stdin >>= putEvent . EScan
, run getEvent q0
]
@@ -199,14 +199,13 @@ run getEvent = rec where
redraw q' >> getEvent >>= processEvent q'
--- TODO merge EKey and EMouse?
processEvent :: State -> Event -> IO State
processEvent q = \case
EFlash t ->
return q { flashMessage = t }
- EKey s ->
+ EScan (ScanKey s) ->
keymap s q
- EMouse info ->
+ EScan info@ScanMouse{..} ->
mousemap info q
EResize w h ->
return q
@@ -235,10 +234,10 @@ render q@State{..} =
<> " " <> Plain (show (xoffset, yoffset))
]
-render0 :: State -> [Trammel String]
+render0 :: State -> [Blessings String]
render0 _q@State{..} = do
let buffer =
- map (trammelTake screenWidth . trammelDrop xoffset) $
+ map (blessingsTake screenWidth . blessingsDrop xoffset) $
take screenHeight $
headBuffer ++ drop yoffset treeBuffer
buffer ++ take (screenHeight - length buffer) (repeat "~")
@@ -341,13 +340,13 @@ keymap s = \q ->
return q { flashMessage = Plain $ show s }
-mousemap :: MouseInfo -> State -> IO State
+mousemap :: Scan -> State -> IO State
-mousemap MouseInfo{mouseButton=1,mouseY=y} = defaultMouse1Click y
-mousemap MouseInfo{mouseButton=3,mouseY=y} = \q -> defaultMouse1Click y q >>= toggleFold
-mousemap MouseInfo{mouseButton=4} = moveTreeDown 3
-mousemap MouseInfo{mouseButton=5} = moveTreeUp 3
-mousemap MouseInfo{mouseButton=0} = return
+mousemap ScanMouse{mouseButton=1,mouseY=y} = defaultMouse1Click y
+mousemap ScanMouse{mouseButton=3,mouseY=y} = \q -> defaultMouse1Click y q >>= toggleFold
+mousemap ScanMouse{mouseButton=4} = moveTreeDown 3
+mousemap ScanMouse{mouseButton=5} = moveTreeUp 3
+mousemap ScanMouse{mouseButton=0} = return
mousemap info = \q ->
return q { flashMessage = SGR [38,5,202] $ Plain $ show info }