Use external Blessings and Scanner libraries

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 }