diff options
| -rw-r--r-- | Event.hs | 20 | ||||
| -rw-r--r-- | RenderTreeView.hs | 20 | ||||
| -rw-r--r-- | Scanner.hs | 141 | ||||
| -rw-r--r-- | Trammel.hs | 255 | ||||
| -rw-r--r-- | common.nix | 2 | ||||
| -rw-r--r-- | env.nix | 3 | ||||
| -rw-r--r-- | much.cabal | 4 | ||||
| -rw-r--r-- | test5.hs | 33 |
8 files changed, 38 insertions, 440 deletions
@@ -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 @@ -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 {}; }; } @@ -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 @@ -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 @@ -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 } |