diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 134 | ||||
| -rw-r--r-- | src/Trammel.hs | 108 |
2 files changed, 166 insertions, 76 deletions
diff --git a/src/Main.hs b/src/Main.hs index ed52ba1..747b269 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Applicative @@ -24,6 +25,7 @@ import qualified Data.Map as Map import Buffer import Process import Scanner (scan, runScanner, toChar) +import Trammel data VTConfig = VTConfig @@ -155,27 +157,15 @@ data ExecError instance Error ExecError where noMsg = OtherError "something went wrong" -prettyError :: ExecError -> String -prettyError e = rec e - where - color cc s = "\x1b[" ++ cc ++ "m" ++ s ++ "\x1b[m" - - rec (UnhandledInputError s) = - color "31" $ "unhandled input: <" ++ (s >>= pp "31;1") ++ "\x1b[;31m>" - rec (OtherError s) = - color "31" $ "error: " ++ s - - -- TODO cc is ColorCode - pp cc c - | isPrint c = [c] - | otherwise = specialChar cc $ - case c of - '\x1b' -> "^[" - _ -> charToCode c - specialChar cc s = "\x1b[1;35m" ++ s ++ "\x1b[;" ++ cc ++ "m" +prettyError :: ExecError -> String +prettyError (UnhandledInputError s) = + pp $ Gaudy [31] $ + "unhandled input: <" <> Gaudy [1] (gaudySpecial [35,1] s) <> ">" +prettyError (OtherError s) = + pp $ Gaudy [31] $ gaudySpecial [35] s modifyBuffer :: (Buffer -> Buffer) -> VT () @@ -254,6 +244,8 @@ execCommand ExecuteInputBuffer = do st <- get case showBuffer (buffer st) of + ":c" -> do + tell [intercalate " " $ map (\i -> pp $ Gaudy [38,5,i] $ Plain $ padl 3 '0' $ show i) [0..255] ] ":r" -> do tell [ "--- Registers ---" ] tell $ map (\(r, s) -> ['"', r] ++ " " ++ s) -- TODO pp @@ -274,7 +266,8 @@ execCommand ExecuteInputBuffer = do "" -> do liftIO ringBell s -> do - tell [ "input: <" ++ (s >>= reform 32) ++ ">" ] + let s' = pp $ "input: <" <> (Gaudy [32] (gaudySpecial [1] s)) <> ">" + tell [ s', show s' ] modifyBuffer (const emptyBuffer) @@ -344,78 +337,63 @@ execCommand DeleteEntireLine = modify $ \q -> } -reform :: Int -> Char -> String -reform colorCode c = - if isPrint c - then normal colorCode [c] - else - special colorCode $ - case ord c of - 27 -> "^[" - _ -> charToCode c - -normal :: Int -> String -> String -normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m" - -special :: Int -> String -> String -special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m" - - -- XXX assumes that the cursor is already at the (cleared) input line -- TODO renderInputLine looks like it wants to be -> VT () renderInputLine :: Maybe Int -> Mode -> Buffer -> IO () renderInputLine mb_cnt m (lhs, rhs) = do - clearLine -- TODO this is required for drawing the mode on the right side + renderRight $ + Gaudy [30,1] $ + Plain (show m) <> + maybe Empty + (("["<>) . (<>"]") . Gaudy [33,1] . Plain . show) + mb_cnt + renderLeft $ promptString m <> gaudySpecial [35] (lhs ++ rhs) + moveCursorLeft $ length $ lit rhs + + +renderLeft :: Trammel String -> IO () +renderLeft = putStr . pp + + +renderRight :: Trammel String -> IO () +renderRight a = do saveCursor - moveCursorRight 1024 - let (infoLen, info) = - case mb_cnt of - Nothing -> - let gaudy = "\x1b[1;30m" ++ show m ++ "\x1b[m" - plain = show m - in (length plain, gaudy) - Just cnt -> - let gaudy = "\x1b[1;30m" ++ show m ++ - "[\x1b[33m" ++ show cnt ++ "\x1b[30m]\x1b[m" - plain = show m ++ "[" ++ show cnt ++ "]" - in (length plain, gaudy) - moveCursorLeft $ infoLen - 1 - putStr info + moveCursorRight 1024 -- XXX obviously, this is a hack..^_^ + moveCursorLeft $ len a - 1 + renderLeft a unsaveCursor - let promptString = case m of - NormalMode -> "\x1b[33;1m@\x1b[m " - InsertMode -> "> " - VerbatimMode -> "\x1b[34;1m^\x1b[m " - SelectRegisterMode -> "\" " - DeleteMode -> "\x1b[31;1m>\x1b[m " - putStr $ promptString ++ (lhs >>= reform') ++ (rhs >>= reform') - moveCursorLeft (length $ rhs >>= reformVis) + +promptString :: Mode -> Trammel String +promptString NormalMode = Gaudy [33,1] "@ " +promptString InsertMode = "> " +promptString SelectRegisterMode = "\" " +promptString DeleteMode = Gaudy [31,1] "> " +promptString VerbatimMode = Gaudy [34,1] "^ " + + +spans :: (a -> Bool) -> [a] -> [Either [a] [a]] +spans p xs = f_r (span p_r xs) where - -- TODO unify reform and reform' - reform' c = - if isPrint c - then [c] - else - "\x1b[35m" ++ ( - case ord c of - 27 -> "^[" - _ -> charToCode c - ) ++ "\x1b[m" + p_r = not . p + p_l = p + f_r (as, bs) = Right as : if null bs then [] else f_l (span p_l bs) + f_l (as, bs) = Left as : if null bs then [] else f_r (span p_r bs) + - reformVis c = - if isPrint c - then [c] - else - case ord c of - 27 -> "^[" - _ -> charToCode c +gaudySpans :: [Int] -> (Char -> Bool) -> String -> Trammel String +gaudySpans c p = + mconcat . map (either (Gaudy c . Plain . lit) Plain) . spans p +gaudySpecial :: [Int] -> String -> Trammel String +gaudySpecial c = gaudySpans c (not . isPrint) +lit :: String -> String +lit = (>>= flip showLitChar "") clearLine :: IO () @@ -564,3 +542,7 @@ whenLeft (Left x) f = f x whenLeft _ _ = return () +padl :: Int -> a -> [a] -> [a] +padl n c s + | length s < n = padl n c (c : s) + | otherwise = s diff --git a/src/Trammel.hs b/src/Trammel.hs new file mode 100644 index 0000000..41f0117 --- /dev/null +++ b/src/Trammel.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +module Trammel where + +import Data.List +import Data.String +import Data.Monoid +import Data.Maybe (catMaybes) +import Data.Ix (inRange) + + +data Trammel a + = Plain a + | Gaudy [Int] (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 + + +data Color = AnsiColor Int | Xterm256 Int | XtermRGB Int Int Int + deriving (Eq, Show) + + +getColor :: Color -> [Int] -> Color +getColor c0 [] = c0 +getColor c0 (c:s) + | inRange (30, 37) c = getColor (AnsiColor c) s + | c == 38 = case s of + (5:i:s') -> getColor (Xterm256 i) s' + (2:r:g:b:s') -> getColor (XtermRGB r g b) s' + _ -> getColor c0 s + | c == 39 = getColor (AnsiColor 39) s + | otherwise = getColor c0 s + + +toGR :: Color -> [Int] +toGR (AnsiColor i) = [i] +toGR (Xterm256 i) = [38,5,i] +toGR (XtermRGB r g b) = [38,2,r,g,b] + + +-- TODO maybe bold and underline could be simply Bools +type RenderState = [(Color,Int,Int)] + +emptyRenderState :: RenderState +emptyRenderState = [(AnsiColor 39,22,24)] + +renderString :: RenderState -> Trammel String -> String -> String + +renderString _ (Plain s) y = s ++ y + +renderString rs@((fc0, b0, u0):_) (Gaudy c t) y = + let fc = getColor fc0 c + b = f (`elem`[1,22]) b0 c + u = f (`elem`[4,24]) u0 c + gr = catMaybes $ + ( if fc /= fc0 then map Just (toGR fc) else [] ) ++ + [ if b /= b0 then Just b else Nothing + , if u /= u0 then Just u else Nothing + ] + ungr = catMaybes $ + ( if fc /= fc0 then map Just (toGR fc0) else [] ) ++ + [ if b /= b0 then Just b0 else Nothing + , if u /= u0 then Just u0 else Nothing + ] + in sgr gr ++ renderString ((fc, b, u):rs) t (sgr ungr ++ y) + where + f p alt xs = + case filter p xs of + [] -> alt + xs' -> last xs' + +renderString _ (Gaudy _ _) _ = + 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 (Gaudy _ x) = len x +len (Append t1 t2) = len t1 + len t2 +len Empty = 0 + + +pp :: Trammel String -> String +pp t = renderString emptyRenderState t "" + + +sgr :: [Int] -> String +sgr [] = [] +sgr xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs |