diff --git a/System/Console/Haskeline/Backend/IConv.hsc b/System/Console/Haskeline/Backend/IConv.hsc --- a/System/Console/Haskeline/Backend/IConv.hsc +++ b/System/Console/Haskeline/Backend/IConv.hsc @@ -91,7 +91,7 @@ type IConvT = ForeignPtr () type IConvTPtr = Ptr () -foreign import ccall "h_iconv_open" iconv_open +foreign import ccall "haskeline_iconv_open" iconv_open :: CString -> CString -> IO IConvTPtr iconvOpen :: String -> String -> IO IConvT @@ -105,9 +105,9 @@ else newForeignPtr iconv_close res -- really this returns a CInt, but it's easiest to just ignore that, I think. -foreign import ccall "& h_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ()) +foreign import ccall "& haskeline_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ()) -foreign import ccall "h_iconv" c_iconv :: IConvTPtr -> Ptr CString -> Ptr CSize +foreign import ccall "haskeline_iconv" c_iconv :: IConvTPtr -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize -> IO CSize data Result = Successful diff --git a/System/Console/Haskeline/Backend/Terminfo.hs b/System/Console/Haskeline/Backend/Terminfo.hs --- a/System/Console/Haskeline/Backend/Terminfo.hs +++ b/System/Console/Haskeline/Backend/Terminfo.hs @@ -6,7 +6,7 @@ import System.Console.Terminfo import Control.Monad -import Data.List(intersperse, foldl') +import Data.List(foldl') import System.IO import qualified Control.Exception.Extensible as Exception import qualified Data.ByteString.Char8 as B @@ -21,6 +21,8 @@ import System.Console.Haskeline.Backend.WCWidth import System.Console.Haskeline.Key +import qualified Control.Monad.Writer as Writer + ---------------------------------------------------------------- -- Low-level terminal output @@ -66,30 +68,6 @@ return (termText " " <#> left1) ) `mplus` return mempty -type TermAction = Actions -> TermOutput - -text :: B.ByteString -> TermAction -text str _ = termText $ B.unpack str - -left,right,up :: Int -> TermAction -left = flip leftA -right = flip rightA -up = flip upA - -clearAll :: LinesAffected -> TermAction -clearAll = flip clearAllA - -mreplicate :: Monoid m => Int -> m -> m -mreplicate n m - | n <= 0 = mempty - | otherwise = m `mappend` mreplicate (n-1) m - --- We don't need to bother encoding the spaces. -spaces :: Int -> TermAction -spaces 0 = mempty -spaces 1 = const $ termText " " -- share when possible -spaces n = const $ termText $ replicate n ' ' - ---------------------------------------------------------------- -- The Draw monad @@ -121,8 +99,6 @@ lookupCells :: TermRows -> Int -> Int lookupCells (TermRows rc _) r = Map.findWithDefault 0 r rc -sum' :: [Int] -> Int - newtype Draw m a = Draw {unDraw :: (ReaderT Actions (ReaderT Terminal (StateT TermRows @@ -133,8 +109,6 @@ MonadState TermRows, MonadReader Handles, MonadReader Encoders) -type DrawM a = forall m . (MonadReader Layout m, MonadIO m) => Draw m a - instance MonadTrans Draw where lift = Draw . lift . lift . lift . lift . lift . lift @@ -198,41 +172,80 @@ ] -output :: MonadIO m => TermAction -> Draw m () -output f = do - toutput <- asks f + +---------------------------------------------------------------- +-- Terminal output actions +-- +-- We combine all of the drawing commands into one big TermAction, +-- via a writer monad, and then output them all at once. +-- This prevents flicker, i.e., the cursor appearing briefly +-- in an intermediate position. + +type TermAction = Actions -> TermOutput + +type ActionT = Writer.WriterT TermAction + +type ActionM a = forall m . (MonadReader Layout m, MonadIO m) => ActionT (Draw m) a + +runActionT :: MonadIO m => ActionT (Draw m) a -> Draw m a +runActionT m = do + (x,action) <- Writer.runWriterT m + toutput <- asks action term <- ask ttyh <- liftM hOut ask liftIO $ hRunTermOutput ttyh term toutput + return x +output :: TermAction -> ActionM () +output = Writer.tell ----------------------------------------------------------------- --- Movement actions +outputText :: String -> ActionM () +outputText str = posixEncode str >>= output . const . termText . B.unpack +left,right,up :: Int -> TermAction +left = flip leftA +right = flip rightA +up = flip upA + +clearAll :: LinesAffected -> TermAction +clearAll = flip clearAllA + +mreplicate :: Monoid m => Int -> m -> m +mreplicate n m + | n <= 0 = mempty + | otherwise = m `mappend` mreplicate (n-1) m + +-- We don't need to bother encoding the spaces. +spaces :: Int -> TermAction +spaces 0 = mempty +spaces 1 = const $ termText " " -- share when possible +spaces n = const $ termText $ replicate n ' ' + + changePos :: TermPos -> TermPos -> TermAction changePos TermPos {termRow=r1, termCol=c1} TermPos {termRow=r2, termCol=c2} | r1 == r2 = if c1 < c2 then right (c2-c1) else left (c1-c2) | r1 > r2 = cr <#> up (r1-r2) <#> right c2 | otherwise = cr <#> mreplicate (r2-r1) nl <#> right c2 --- TODO: when drawLineDiffT calls this, shouldn't move if same. -moveToPos :: TermPos -> DrawM TermAction +moveToPos :: TermPos -> ActionM () moveToPos p = do oldP <- get put p - return $ changePos oldP p + output $ changePos oldP p -moveRelative :: Int -> DrawM () +moveRelative :: Int -> ActionM () moveRelative n = liftM3 (advancePos n) ask get get - >>= moveToPos >>= output + >>= moveToPos -- Note that these move by a certain number of cells, not graphemes. -changeRight, changeLeft :: Int -> DrawM () +changeRight, changeLeft :: Int -> ActionM () changeRight n | n <= 0 = return () | otherwise = moveRelative n changeLeft n | n <= 0 = return () | otherwise = moveRelative (negate n) + -- TODO: this could be more efficient by only checking intermediate rows. -- TODO: this is worth handling with QuickCheck. advancePos :: Int -> Layout -> TermRows -> TermPos -> TermPos @@ -250,98 +263,83 @@ then TermPos {termRow=r, termCol=m} else loopFindRow (r+1) (m-thisRowSize) +sum' :: [Int] -> Int sum' = foldl' (+) 0 ---------------------------------------------------------------- -- Text printing actions -encodeGraphemes :: MonadIO m => [Grapheme] -> Draw m TermAction -encodeGraphemes = liftM text . posixEncode . graphemesToString - -printText :: [Grapheme] -> DrawM TermAction -printText = textAction mempty - -textAction :: TermAction -> [Grapheme] -> DrawM TermAction -textAction prevOutput [] = return prevOutput -textAction prevOutput gs = do +printText :: [Grapheme] -> ActionM () +printText [] = return () +printText gs = do -- First, get the monadic parameters: w <- asks width TermPos {termRow=r, termCol=c} <- get -- Now, split off as much as will fit on the rest of this row: let (thisLine,rest,thisWidth) = splitAtWidth (w-c) gs let lineWidth = c + thisWidth - ts <- encodeGraphemes thisLine -- Finally, actually print out the relevant text. + outputText (graphemesToString thisLine) modify $ setRow r lineWidth if null rest && lineWidth < w - then do -- everything fits on one line without wrapping + then -- everything fits on one line without wrapping put TermPos {termRow=r, termCol=lineWidth} - return (prevOutput <#> ts) else do -- Must wrap to the next line put TermPos {termRow=r+1,termCol=0} - let wrap = if lineWidth == w then wrapLine else spaces (w-lineWidth) - textAction (prevOutput <#> ts <#> wrap) rest + output $ if lineWidth == w then wrapLine else spaces (w-lineWidth) + printText rest ---------------------------------------------------------------- -- High-level Term implementation --- --- To prevent flicker, we combine all of the drawing commands into one big --- TermAction, and output them all at once. -drawLineDiffT :: LineChars -> LineChars -> DrawM () +drawLineDiffT :: LineChars -> LineChars -> ActionM () drawLineDiffT (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of ([],[]) | ys1 == ys2 -> return () (xs1',[]) | xs1' ++ ys1 == ys2 -> changeLeft (gsWidth xs1') ([],xs2') | ys1 == xs2' ++ ys2 -> changeRight (gsWidth xs2') (xs1',xs2') -> do oldRS <- get - -- TODO: this changeLeft could be merged with the rest of the output. - -- For now, we'll leave it separate since xs1' is often empty - -- (e.g. when typing new characters). changeLeft (gsWidth xs1') - xsOut <- printText xs2' + printText xs2' p <- get - restOut <- liftM mconcat $ sequence - [ printText ys2 - , clearDeadText oldRS - , moveToPos p - ] - output (xsOut <#> restOut) + printText ys2 + clearDeadText oldRS + moveToPos p -- The number of nonempty lines after the current row position. -getLinesLeft :: DrawM Int +getLinesLeft :: ActionM Int getLinesLeft = do p <- get rc <- get return $ max 0 (lastRow rc - termRow p) -clearDeadText :: TermRows -> DrawM TermAction +clearDeadText :: TermRows -> ActionM () clearDeadText oldRS = do TermPos {termRow = r, termCol = c} <- get let extraRows = lastRow oldRS - r if extraRows < 0 || (extraRows == 0 && lookupCells oldRS r <= c) - then return mempty + then return () else do modify $ setRow r c when (extraRows /= 0) $ put TermPos {termRow = r + extraRows, termCol=0} - return $ clearToLineEnd <#> mreplicate extraRows (nl <#> clearToLineEnd) + output $ clearToLineEnd <#> mreplicate extraRows (nl <#> clearToLineEnd) -clearLayoutT :: DrawM () +clearLayoutT :: ActionM () clearLayoutT = do h <- asks height output (clearAll h) put initTermPos -moveToNextLineT :: LineChars -> DrawM () -moveToNextLineT _ = do +moveToNextLineT :: ActionM () +moveToNextLineT = do lleft <- getLinesLeft output $ mreplicate (lleft+1) nl put initTermPos put initTermRows -repositionT :: Layout -> LineChars -> DrawM () +repositionT :: Layout -> LineChars -> ActionM () repositionT _ s = do oldPos <- get l <- getLinesLeft @@ -352,14 +350,13 @@ drawLineDiffT ([],[]) s instance (MonadException m, MonadReader Layout m) => Term (Draw m) where - drawLineDiff = drawLineDiffT - reposition = repositionT + drawLineDiff xs ys = runActionT $ drawLineDiffT xs ys + reposition layout lc = runActionT $ repositionT layout lc - printLines [] = return () - printLines ls = do - bls <- mapM posixEncode ls - output $ mconcat $ intersperse nl (map text bls) ++ [nl] - clearLayout = clearLayoutT - moveToNextLine = moveToNextLineT - ringBell True = output bellAudible - ringBell False = output bellVisual + printLines = mapM_ $ \line -> runActionT $ do + outputText line + output nl + clearLayout = runActionT clearLayoutT + moveToNextLine _ = runActionT moveToNextLineT + ringBell True = runActionT $ output bellAudible + ringBell False = runActionT $ output bellVisual diff --git a/System/Console/Haskeline/Backend/WCWidth.hs b/System/Console/Haskeline/Backend/WCWidth.hs --- a/System/Console/Haskeline/Backend/WCWidth.hs +++ b/System/Console/Haskeline/Backend/WCWidth.hs @@ -13,10 +13,10 @@ import Data.List import Foreign.C.Types -foreign import ccall unsafe mk_wcwidth :: CWchar -> CInt +foreign import ccall unsafe haskeline_mk_wcwidth :: CWchar -> CInt wcwidth :: Char -> Int -wcwidth c = case mk_wcwidth $ toEnum $ fromEnum c of +wcwidth c = case haskeline_mk_wcwidth $ toEnum $ fromEnum c of -1 -> 0 -- Control characters have zero width. (Used by the -- "\SOH...\STX" hack in LineState.stringToGraphemes.) w -> fromIntegral w diff --git a/System/Console/Haskeline/Backend/Win32.hsc b/System/Console/Haskeline/Backend/Win32.hsc --- a/System/Console/Haskeline/Backend/Win32.hsc +++ b/System/Console/Haskeline/Backend/Win32.hsc @@ -170,7 +170,7 @@ (#poke COORD, Y) p (toEnum (coordY c) :: CShort) -foreign import ccall "SetPosition" +foreign import ccall "haskeline_SetPosition" c_SetPosition :: HANDLE -> Ptr Coord -> IO Bool setPosition :: HANDLE -> Coord -> IO () diff --git a/cbits/h_iconv.c b/cbits/h_iconv.c --- a/cbits/h_iconv.c +++ b/cbits/h_iconv.c @@ -1,15 +1,15 @@ #include "h_iconv.h" // Wrapper functions, since iconv_open et al are macros in libiconv. -iconv_t h_iconv_open(const char *tocode, const char *fromcode) { +iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode) { return iconv_open(tocode, fromcode); } -void h_iconv_close(iconv_t cd) { +void haskeline_iconv_close(iconv_t cd) { iconv_close(cd); } -size_t h_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, +size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, char **outbuf, size_t *outbytesleft) { // Cast inbuf to (void*) so that it works both on Solaris, which expects // a (const char**), and on other platforms (e.g. Linux), which expect diff --git a/cbits/h_wcwidth.c b/cbits/h_wcwidth.c --- a/cbits/h_wcwidth.c +++ b/cbits/h_wcwidth.c @@ -67,7 +67,7 @@ }; /* auxiliary function for binary search in interval table */ -static int bisearch(wchar_t ucs, const struct interval *table, int max) { +static int haskeline_bisearch(wchar_t ucs, const struct interval *table, int max) { int min = 0; int mid; @@ -119,7 +119,7 @@ * in ISO 10646. */ -int mk_wcwidth(wchar_t ucs) +int haskeline_mk_wcwidth(wchar_t ucs) { /* sorted list of non-overlapping intervals of non-spacing characters */ /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */ @@ -181,7 +181,7 @@ return -1; /* binary search in table of non-spacing characters */ - if (bisearch(ucs, combining, + if (haskeline_bisearch(ucs, combining, sizeof(combining) / sizeof(struct interval) - 1)) return 0; @@ -204,12 +204,12 @@ } -int mk_wcswidth(const wchar_t *pwcs, size_t n) +int haskeline_mk_wcswidth(const wchar_t *pwcs, size_t n) { int w, width = 0; for (;*pwcs && n-- > 0; pwcs++) - if ((w = mk_wcwidth(*pwcs)) < 0) + if ((w = haskeline_mk_wcwidth(*pwcs)) < 0) return -1; else width += w; @@ -227,7 +227,7 @@ * the traditional terminal character-width behaviour. It is not * otherwise recommended for general use. */ -int mk_wcwidth_cjk(wchar_t ucs) +int haskeline_mk_wcwidth_cjk(wchar_t ucs) { /* sorted list of non-overlapping intervals of East Asian Ambiguous * characters, generated by "uniset +WIDTH-A -cat=Me -cat=Mn -cat=Cf c" */ @@ -287,20 +287,20 @@ }; /* binary search in table of non-spacing characters */ - if (bisearch(ucs, ambiguous, + if (haskeline_bisearch(ucs, ambiguous, sizeof(ambiguous) / sizeof(struct interval) - 1)) return 2; - return mk_wcwidth(ucs); + return haskeline_mk_wcwidth(ucs); } -int mk_wcswidth_cjk(const wchar_t *pwcs, size_t n) +int haskeline_mk_wcswidth_cjk(const wchar_t *pwcs, size_t n) { int w, width = 0; for (;*pwcs && n-- > 0; pwcs++) - if ((w = mk_wcwidth_cjk(*pwcs)) < 0) + if ((w = haskeline_mk_wcwidth_cjk(*pwcs)) < 0) return -1; else width += w; diff --git a/cbits/win_console.c b/cbits/win_console.c --- a/cbits/win_console.c +++ b/cbits/win_console.c @@ -1,5 +1,5 @@ #include "win_console.h" -BOOL SetPosition(HANDLE h, COORD* c) { +BOOL haskeline_SetPosition(HANDLE h, COORD* c) { return SetConsoleCursorPosition(h,*c); } diff --git a/haskeline.cabal b/haskeline.cabal --- a/haskeline.cabal +++ b/haskeline.cabal @@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.6 -Version: 0.6.4.6 +Version: 0.6.4.7 Category: User Interfaces License: BSD3 License-File: LICENSE @@ -50,15 +50,15 @@ } else { if impl(ghc>=6.11) { - Build-depends: base >=4.1 && < 4.6, containers>=0.1 && < 0.5, directory>=1.0 && < 1.2, - bytestring==0.9.* + Build-depends: base >=4.1 && < 4.6, containers>=0.1 && < 0.6, directory>=1.0 && < 1.2, + bytestring>=0.9 && < 0.11 } else { Build-depends: base>=3 && <4.1 , containers>=0.1 && < 0.3, directory==1.0.*, bytestring==0.9.* } } - Build-depends: filepath >= 1.1 && < 1.4, mtl >= 1.1 && < 2.1, + Build-depends: filepath >= 1.1 && < 1.4, mtl >= 1.1 && < 2.2, utf8-string==0.3.* && >=0.3.6, extensible-exceptions==0.1.* && >=0.1.1.0 Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances, diff --git a/includes/h_iconv.h b/includes/h_iconv.h --- a/includes/h_iconv.h +++ b/includes/h_iconv.h @@ -1,9 +1,9 @@ #include -iconv_t h_iconv_open(const char *tocode, const char *fromcode); +iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode); -void h_iconv_close(iconv_t cd); +void haskeline_iconv_close(iconv_t cd); -size_t h_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, +size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, char **outbuf, size_t *outbytesleft); diff --git a/includes/win_console.h b/includes/win_console.h --- a/includes/win_console.h +++ b/includes/win_console.h @@ -2,6 +2,6 @@ #define _WIN_CONSOLE_H #include -BOOL SetPosition(HANDLE h, COORD* c); +BOOL haskeline_SetPosition(HANDLE h, COORD* c); #endif