diff options
| -rw-r--r-- | Scanner.hs | 266 | ||||
| -rw-r--r-- | Trammel.hs | 216 |
2 files changed, 482 insertions, 0 deletions
diff --git a/Scanner.hs b/Scanner.hs new file mode 100644 index 0000000..9f0b5ed --- /dev/null +++ b/Scanner.hs @@ -0,0 +1,266 @@ +{-# 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/Trammel.hs b/Trammel.hs new file mode 100644 index 0000000..36c1140 --- /dev/null +++ b/Trammel.hs @@ -0,0 +1,216 @@ +{-# 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 |