use external blessings and scanner library

5 files changed, 14 insertions, 494 deletions

diff --git a/hack.cabal b/hack.cabal
index 846fb59..9a3e283 100644
--- a/hack.cabal
+++ b/hack.cabal
@@ -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