diff options
| -rw-r--r-- | hack.cabal | 2 | ||||
| -rw-r--r-- | src/Main.hs | 22 | ||||
| -rw-r--r-- | src/Process.hs | 2 | ||||
| -rw-r--r-- | src/Scanner.hs | 266 | ||||
| -rw-r--r-- | src/Trammel.hs | 216 |
5 files changed, 14 insertions, 494 deletions
@@ -15,11 +15,13 @@ Executable hack main-is: Main.hs Build-depends: + blessings, containers, lens, mtl, old-locale, process, + scanner, time, base 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 |