import Scanner & Trammel from hack 505e832

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