From 3aec3e6aa10c5e98950db9c0a64b0b5003cad4ac Mon Sep 17 00:00:00 2001
From: tv <tv@krebsco.de>
Date: Sun, 6 Aug 2017 21:42:01 +0200
Subject: use external blessings and scanner library
---
src/Main.hs | 22 ++---
src/Process.hs | 2 +-
src/Scanner.hs | 266 ---------------------------------------------------------
src/Trammel.hs | 216 ----------------------------------------------
4 files changed, 12 insertions(+), 494 deletions(-)
delete mode 100644 src/Scanner.hs
delete mode 100644 src/Trammel.hs
(limited to 'src')
diff --git a/src/Main.hs b/src/Main.hs
index d9a8aa1..61db22f 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE TemplateHaskell #-}
module Main where
-import Control.Lens hiding (imap)
+import Control.Lens hiding (Empty, imap)
import Control.Applicative
import Control.Concurrent
import Control.Monad
@@ -26,8 +26,8 @@ import qualified Data.Map as Map
import Buffer
import Process
-import Scanner (scan, runScanner, toChar)
-import Trammel
+import Scanner
+import Blessings
data Mode
@@ -104,8 +104,7 @@ uiThread cf putState getState = forever $ do
_ <- hLookAhead stdin -- wait for input
--t0 <- getCurrentTime
- -- ((res, s), _) <- runScanner scan
- ((_, s), _) <- runScanner scan
+ s <- scan stdin
--t1 <- getCurrentTime
--putStrLn $ "====> \ESC[32;1m" ++ show s ++ "\ESC[m in " ++
-- (show $ diffUTCTime t1 t0)
@@ -116,7 +115,8 @@ uiThread cf putState getState = forever $ do
-- Right _ -> return ()
-- TODO don't leak C
- let cmd = getCommand (_mode q0) (map toChar s)
+ let ScanKey k = s
+ let cmd = getCommand (_mode q0) k
--withOutput cf $ do
-- putStrLn $ show cmd
@@ -362,11 +362,11 @@ renderInputLine mb_cnt m (lhs, rhs) = do
moveCursorLeft $ length $ lit rhs
-renderLeft :: Trammel String -> IO ()
+renderLeft :: Blessings String -> IO ()
renderLeft = putStr . pp
-renderRight :: Trammel String -> IO ()
+renderRight :: Blessings String -> IO ()
renderRight a = do
saveCursor
moveCursorRight 1024 -- XXX obviously, this is a hack..^_^
@@ -376,7 +376,7 @@ renderRight a = do
-promptString :: Mode -> Trammel String
+promptString :: Mode -> Blessings String
promptString NormalMode = SGR [33,1] "@ "
promptString InsertMode = "> "
promptString SelectRegisterMode = "\" "
@@ -393,12 +393,12 @@ spans p xs = f_r (span p_r xs)
f_l (as, bs) = Left as : if null bs then [] else f_r (span p_r bs)
-gaudySpans :: [Int] -> (Char -> Bool) -> String -> Trammel String
+gaudySpans :: [Int] -> (Char -> Bool) -> String -> Blessings String
gaudySpans c p =
mconcat . map (either (SGR c . Plain . lit) Plain) . spans p
-gaudySpecial :: [Int] -> String -> Trammel String
+gaudySpecial :: [Int] -> String -> Blessings String
gaudySpecial c = gaudySpans c (not . isPrint)
diff --git a/src/Process.hs b/src/Process.hs
index 75040e1..df05155 100644
--- a/src/Process.hs
+++ b/src/Process.hs
@@ -12,7 +12,7 @@ import System.Exit
import System.IO
import System.Process
-import Trammel
+import Blessings
type OutputWrapper = IO () -> IO ()
diff --git a/src/Scanner.hs b/src/Scanner.hs
deleted file mode 100644
index 9f0b5ed..0000000
--- a/src/Scanner.hs
+++ /dev/null
@@ -1,266 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleContexts #-}
-module Scanner where
-
-import Control.Monad (forever)
-import System.IO
-
-import Data.Ord
-import Data.Bits
-import Data.Char
-
-import Prelude hiding ((/))
-
-import Control.Applicative
-import Control.Monad.Error
-import Control.Monad.State
-import Control.Monad.Writer
-
-import Data.Time.Clock
-
-
--- high level interface
-getKey :: IO String
-getKey = do
- _ <- hLookAhead stdin -- wait for input
- ((_, raw_s), _) <- runScanner scan
- return $ map toChar raw_s
-
-
-type P = C
-type I = C
-type F = C
-
-data Token
- = CS [P] [I] F
- | Chr C
- deriving (Show)
-
-type ScanLog = [C]
-
-type ScanError = String
-
-data ScanState = ScanState
- { result :: Maybe Token
- , buffer :: [C]
- }
-
-emptyScanState = ScanState Nothing []
-
-
-newtype Scanner m a = Scanner
- (ErrorT ScanError (WriterT ScanLog (StateT ScanState m)) a)
- deriving
- ( Applicative
- , Functor
- , Monad
- , MonadIO
- , MonadState ScanState
- , MonadError ScanError
- , MonadWriter ScanLog
- )
-
-runScanner :: Scanner m a -> m ((Either ScanError a, ScanLog), ScanState)
-runScanner (Scanner a) =
- runStateT (runWriterT (runErrorT a)) emptyScanState
-
-
--- TODO max timeout
-timeout = 1
-
-
-main :: IO ()
-main = do
- hSetEcho stdin False
- hSetBuffering stdin NoBuffering
- forever $ do
-
- _ <- hLookAhead stdin -- wait for input
-
- t0 <- getCurrentTime
- ((res, s), _) <- runScanner scan
- t1 <- getCurrentTime
-
- putStrLn $ "====> \ESC[32;1m" ++ show s ++ "\ESC[m in " ++
- (show $ diffUTCTime t1 t0)
- ++ ": \"\ESC[35m" ++ (s >>= colorize . toChar)
- ++ "\ESC[m\""
- case res of
- Left msg -> putStrLn $ " error: " ++ msg
- Right _ -> return ()
-
-
-scan, scanESC, scanCS ::
- ( Monad m
- , MonadIO m
- , MonadError ScanError m
- , MonadState ScanState m
- , MonadWriter ScanLog m
- ) => m ()
-
-
-scan = do
- c <- liftIO $ hGetC stdin
- tell [c]
- case () of _
- | c == 01/11 -> scanESC
- | otherwise -> return ()
-
-
-scanESC = do
- mb_c <- liftIO $ hWaitGetC timeout stdin
- whenJust mb_c $ \ c -> do
- tell [c]
- case () of _
- | c == 05/11 ->
- -- CSI
- scanCS
-
- | c == 01/11 ->
- -- XXX M-F1 and other crazy chords may cause
- -- \ESC\ESC... on wu, so we just recurse here...
- scanESC
-
- | c == 04/15 ->
- -- XXX Non-CSI SS3
- one $ between (04/00) (07/14)
-
- | otherwise -> return ()
-
-
-scanCS = do
- zeroOrMore $ between (03/00) (03/15) -- parameter bytes
- zeroOrMore $ between (02/00) (02/15) -- intermediate bytes
- one $ between (04/00) (07/14) -- final byte
-
-
-between :: C -> C -> (C -> Bool)
-between lo hi = \ x -> lo <= x && x <= hi
-
-
-zeroOrMore, one ::
- ( Monad m
- , MonadIO m
- , MonadError ScanError m
- , MonadState ScanState m
- , MonadWriter ScanLog m
- ) => (C -> Bool) -> m ()
-
-
-zeroOrMore p = do
- mb_c <- liftIO $ hWaitLookAheadC timeout stdin
- whenJust mb_c $ \ c ->
- when (p c) $ do
- _ <- liftIO $ hGetC stdin -- drop
- tell [c]
- modify $ \q -> q { buffer = buffer q ++ [c] }
- zeroOrMore p
-
-
-one p = do
- mb_c <- liftIO $ hWaitLookAheadC timeout stdin
- whenJust mb_c $ \ c -> do
- if p c
- then do
- _ <- liftIO getChar
- tell [c]
- modify $ \q -> q { buffer = buffer q ++ [c] }
- else do
- throwError "expected one TODO"
-
-
-
-
-
-
-
-
-whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
-whenJust mb f =
- case mb of
- Just a -> f a
- Nothing -> return ()
-
-
-
-
-c / r = C c r
-
-data C = C { column :: Int, row :: Int }
- deriving (Eq)
-
-instance Show C where
- show C{..} =
- (padl 2 '0' $ show column) ++ "/" ++ (padl 2 '0' $ show row)
- where
- padl n c s
- | length s < n = padl n c (c : s)
- | otherwise = s
-
-
-instance Ord C where
- compare (C c1 r1) (C c2 r2) =
- case compare c1 c2 of
- EQ -> compare r1 r2
- x -> x
-
-
-fromChar :: Char -> C
-fromChar c = let i = ord c in C ((shift i (-4)) .&. 0xf) (i .&. 0xf)
-
-toChar :: C -> Char
-toChar (C col row) = chr $ (shift col 4) .|. row
-
-
-
-
-
-colorize :: Char -> String
-colorize c
- | isPrint c = [c]
- | otherwise = "\ESC[1m" ++ (showLitChar c "") ++ "\ESC[22m"
-
-
-
-
-
---
-hWaitGetChar t h = do
- ready <- hWaitForInput h t
- if ready
- then hGetChar h >>= return . Just
- else return Nothing
-
-hGetC h = hGetChar h >>= return . fromChar
-hWaitGetC t h = do
- mb_ch <- hWaitGetChar t h
- case mb_ch of
- Nothing -> return Nothing
- Just ch -> return $ Just $ fromChar $ ch
-
-hWaitLookAheadC t h = do
- ready <- hWaitForInput h t
- if ready
- then hLookAhead h >>= return . Just . fromChar
- else return Nothing
-
-
--- CRUFT
---expect cx ca =
--- when (cx /= ca) $
--- throwError $ "expected: " ++ (show cx) ++ ", got: " ++ (show ca)
---
---
---
--- expect (01/11) c
---
--- c <- (liftIO getChar) >>= return . fromChar
---
--- tell [c]
---
--- expect (05/11) c
-
- --liftIO $ putStrLn $ (show c) ++ " -> " ++ (show s)
-
-
diff --git a/src/Trammel.hs b/src/Trammel.hs
deleted file mode 100644
index 36c1140..0000000
--- a/src/Trammel.hs
+++ /dev/null
@@ -1,216 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-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 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]) 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]) 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
--
cgit v1.2.3