packages feed

wybor (empty) → 0.1.0

raw patch · 11 files changed

+1140/−0 lines, 11 filesdep +ansi-terminaldep +basedep +conduitsetup-changed

Dependencies added: ansi-terminal, base, conduit, containers, hspec, lens, process, resourcet, semigroups, terminal-size, text, transformers, unix

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2014, Matvey Aksenov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the+   distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,27 @@+wybor+=====+[![Hackage](https://budueba.com/hackage/wybor)](https://hackage.haskell.org/package/wybor)+[![Build Status](https://secure.travis-ci.org/supki/wybor.png?branch=master)](https://travis-ci.org/supki/wybor)++Anyone familiar with [selecta][selecta] should figure out what's being offered.++[Haddocks][haddocks] and more [haddocks][more-haddocks] in case Hackage feels like being dead today.++Install+-------++To install the library:++    % cabal install wybor.cabal++To install `wybor`, a simple `selecta` clone:++    % cabal install example/wybor-bin/wybor-bin.cabal++To install `gnoodle`, a GNU software downloader:++    % cabal install example/gnoodle/gnoodle.cabal++  [selecta]: https://github.com/garybernhardt/selecta+  [haddocks]: http://supki.github.io/wybor+  [more-haddocks]: https://budueba.com/wybor
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/wcwidth.c view
@@ -0,0 +1,161 @@+/*+ * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c+ */++#include <wchar.h>++struct interval {+  int first;+  int last;+};++/* auxiliary function for binary search in interval table */+static int wybor_bisearch(wchar_t ucs, const struct interval *table, int max) {+  int min = 0;+  int mid;++  if (ucs < table[0].first || ucs > table[max].last)+    return 0;+  while (max >= min) {+    mid = (min + max) / 2;+    if (ucs > table[mid].last)+      min = mid + 1;+    else if (ucs < table[mid].first)+      max = mid - 1;+    else+      return 1;+  }++  return 0;+}+++/* The following two functions define the column width of an ISO 10646+ * character as follows:+ *+ *    - The null character (U+0000) has a column width of 0.+ *+ *    - Other C0/C1 control characters and DEL will lead to a return+ *      value of -1.+ *+ *    - Non-spacing and enclosing combining characters (general+ *      category code Mn or Me in the Unicode database) have a+ *      column width of 0.+ *+ *    - SOFT HYPHEN (U+00AD) has a column width of 1.+ *+ *    - Other format characters (general category code Cf in the Unicode+ *      database) and ZERO WIDTH SPACE (U+200B) have a column width of 0.+ *+ *    - Hangul Jamo medial vowels and final consonants (U+1160-U+11FF)+ *      have a column width of 0.+ *+ *    - Spacing characters in the East Asian Wide (W) or East Asian+ *      Full-width (F) category as defined in Unicode Technical+ *      Report #11 have a column width of 2.+ *+ *    - All remaining characters (including all printable+ *      ISO 8859-1 and WGL4 characters, Unicode control characters,+ *      etc.) have a column width of 1.+ *+ * This implementation assumes that wchar_t characters are encoded+ * in ISO 10646.+ */++int wybor_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" */+  static const struct interval combining[] = {+    { 0x0300, 0x036F }, { 0x0483, 0x0486 }, { 0x0488, 0x0489 },+    { 0x0591, 0x05BD }, { 0x05BF, 0x05BF }, { 0x05C1, 0x05C2 },+    { 0x05C4, 0x05C5 }, { 0x05C7, 0x05C7 }, { 0x0600, 0x0603 },+    { 0x0610, 0x0615 }, { 0x064B, 0x065E }, { 0x0670, 0x0670 },+    { 0x06D6, 0x06E4 }, { 0x06E7, 0x06E8 }, { 0x06EA, 0x06ED },+    { 0x070F, 0x070F }, { 0x0711, 0x0711 }, { 0x0730, 0x074A },+    { 0x07A6, 0x07B0 }, { 0x07EB, 0x07F3 }, { 0x0901, 0x0902 },+    { 0x093C, 0x093C }, { 0x0941, 0x0948 }, { 0x094D, 0x094D },+    { 0x0951, 0x0954 }, { 0x0962, 0x0963 }, { 0x0981, 0x0981 },+    { 0x09BC, 0x09BC }, { 0x09C1, 0x09C4 }, { 0x09CD, 0x09CD },+    { 0x09E2, 0x09E3 }, { 0x0A01, 0x0A02 }, { 0x0A3C, 0x0A3C },+    { 0x0A41, 0x0A42 }, { 0x0A47, 0x0A48 }, { 0x0A4B, 0x0A4D },+    { 0x0A70, 0x0A71 }, { 0x0A81, 0x0A82 }, { 0x0ABC, 0x0ABC },+    { 0x0AC1, 0x0AC5 }, { 0x0AC7, 0x0AC8 }, { 0x0ACD, 0x0ACD },+    { 0x0AE2, 0x0AE3 }, { 0x0B01, 0x0B01 }, { 0x0B3C, 0x0B3C },+    { 0x0B3F, 0x0B3F }, { 0x0B41, 0x0B43 }, { 0x0B4D, 0x0B4D },+    { 0x0B56, 0x0B56 }, { 0x0B82, 0x0B82 }, { 0x0BC0, 0x0BC0 },+    { 0x0BCD, 0x0BCD }, { 0x0C3E, 0x0C40 }, { 0x0C46, 0x0C48 },+    { 0x0C4A, 0x0C4D }, { 0x0C55, 0x0C56 }, { 0x0CBC, 0x0CBC },+    { 0x0CBF, 0x0CBF }, { 0x0CC6, 0x0CC6 }, { 0x0CCC, 0x0CCD },+    { 0x0CE2, 0x0CE3 }, { 0x0D41, 0x0D43 }, { 0x0D4D, 0x0D4D },+    { 0x0DCA, 0x0DCA }, { 0x0DD2, 0x0DD4 }, { 0x0DD6, 0x0DD6 },+    { 0x0E31, 0x0E31 }, { 0x0E34, 0x0E3A }, { 0x0E47, 0x0E4E },+    { 0x0EB1, 0x0EB1 }, { 0x0EB4, 0x0EB9 }, { 0x0EBB, 0x0EBC },+    { 0x0EC8, 0x0ECD }, { 0x0F18, 0x0F19 }, { 0x0F35, 0x0F35 },+    { 0x0F37, 0x0F37 }, { 0x0F39, 0x0F39 }, { 0x0F71, 0x0F7E },+    { 0x0F80, 0x0F84 }, { 0x0F86, 0x0F87 }, { 0x0F90, 0x0F97 },+    { 0x0F99, 0x0FBC }, { 0x0FC6, 0x0FC6 }, { 0x102D, 0x1030 },+    { 0x1032, 0x1032 }, { 0x1036, 0x1037 }, { 0x1039, 0x1039 },+    { 0x1058, 0x1059 }, { 0x1160, 0x11FF }, { 0x135F, 0x135F },+    { 0x1712, 0x1714 }, { 0x1732, 0x1734 }, { 0x1752, 0x1753 },+    { 0x1772, 0x1773 }, { 0x17B4, 0x17B5 }, { 0x17B7, 0x17BD },+    { 0x17C6, 0x17C6 }, { 0x17C9, 0x17D3 }, { 0x17DD, 0x17DD },+    { 0x180B, 0x180D }, { 0x18A9, 0x18A9 }, { 0x1920, 0x1922 },+    { 0x1927, 0x1928 }, { 0x1932, 0x1932 }, { 0x1939, 0x193B },+    { 0x1A17, 0x1A18 }, { 0x1B00, 0x1B03 }, { 0x1B34, 0x1B34 },+    { 0x1B36, 0x1B3A }, { 0x1B3C, 0x1B3C }, { 0x1B42, 0x1B42 },+    { 0x1B6B, 0x1B73 }, { 0x1DC0, 0x1DCA }, { 0x1DFE, 0x1DFF },+    { 0x200B, 0x200F }, { 0x202A, 0x202E }, { 0x2060, 0x2063 },+    { 0x206A, 0x206F }, { 0x20D0, 0x20EF }, { 0x302A, 0x302F },+    { 0x3099, 0x309A }, { 0xA806, 0xA806 }, { 0xA80B, 0xA80B },+    { 0xA825, 0xA826 }, { 0xFB1E, 0xFB1E }, { 0xFE00, 0xFE0F },+    { 0xFE20, 0xFE23 }, { 0xFEFF, 0xFEFF }, { 0xFFF9, 0xFFFB },+    { 0x10A01, 0x10A03 }, { 0x10A05, 0x10A06 }, { 0x10A0C, 0x10A0F },+    { 0x10A38, 0x10A3A }, { 0x10A3F, 0x10A3F }, { 0x1D167, 0x1D169 },+    { 0x1D173, 0x1D182 }, { 0x1D185, 0x1D18B }, { 0x1D1AA, 0x1D1AD },+    { 0x1D242, 0x1D244 }, { 0xE0001, 0xE0001 }, { 0xE0020, 0xE007F },+    { 0xE0100, 0xE01EF }+  };++  /* test for 8-bit control characters */+  if (ucs == 0)+    return 0;+  if (ucs < 32 || (ucs >= 0x7f && ucs < 0xa0))+    return -1;++  /* binary search in table of non-spacing characters */+  if (wybor_bisearch(ucs, combining,+	       sizeof(combining) / sizeof(struct interval) - 1))+    return 0;++  /* if we arrive here, ucs is not a combining or C0/C1 control character */++  return 1 ++    (ucs >= 0x1100 &&+     (ucs <= 0x115f ||                    /* Hangul Jamo init. consonants */+      ucs == 0x2329 || ucs == 0x232a ||+      (ucs >= 0x2e80 && ucs <= 0xa4cf &&+       ucs != 0x303f) ||                  /* CJK ... Yi */+      (ucs >= 0xac00 && ucs <= 0xd7a3) || /* Hangul Syllables */+      (ucs >= 0xf900 && ucs <= 0xfaff) || /* CJK Compatibility Ideographs */+      (ucs >= 0xfe10 && ucs <= 0xfe19) || /* Vertical forms */+      (ucs >= 0xfe30 && ucs <= 0xfe6f) || /* CJK Compatibility Forms */+      (ucs >= 0xff00 && ucs <= 0xff60) || /* Fullwidth Forms */+      (ucs >= 0xffe0 && ucs <= 0xffe6) ||+      (ucs >= 0x20000 && ucs <= 0x2fffd) ||+      (ucs >= 0x30000 && ucs <= 0x3fffd)));+}+++int wybor_mk_wcswidth(const wchar_t *pwcs, size_t n)+{+  int w, width = 0;++  for (;n-- > 0; pwcs++)+    if ((w = wybor_mk_wcwidth(*pwcs)) < 0)+      return -1;+    else+      width += w;++  return width;+}
+ src/Ansi.hs view
@@ -0,0 +1,56 @@+-- | Collection of utilities to make @wybor@ customization palatable+--+-- Those are mostly thin wrappers over things in "System.Console.ANSI" from @ansi-terminal@+module Ansi+  ( reset+  , bold+  , regular+  , underlining+  , swap+  , unswap+  , fgcolor+  , bgcolor+  , Ansi.Underlining(..)+  , Ansi.ColorIntensity(..)+  , Ansi.Color(..)+  ) where++import           Data.Text (Text)+import qualified Data.Text as Text+import qualified System.Console.ANSI as Ansi+++-- | Sets all attributes off+reset :: Text+reset = sgr Ansi.Reset++-- | Set bold font style+bold :: Text+bold = sgr (Ansi.SetConsoleIntensity Ansi.BoldIntensity)++-- | Set regular font style+regular :: Text+regular = sgr (Ansi.SetConsoleIntensity Ansi.NormalIntensity)++-- | Set underlining style+underlining :: Ansi.Underlining -> Text+underlining = sgr . Ansi.SetUnderlining++-- | Swap foreground and background colors+swap :: Text+swap = sgr (Ansi.SetSwapForegroundBackground True)++-- | Unswap foreground and background colors+unswap :: Text+unswap = sgr (Ansi.SetSwapForegroundBackground False)++-- | Set foreground color+fgcolor :: Ansi.ColorIntensity -> Ansi.Color -> Text+fgcolor i c = sgr (Ansi.SetColor Ansi.Foreground i c)++-- | Set background color+bgcolor :: Ansi.ColorIntensity -> Ansi.Color -> Text+bgcolor i c = sgr (Ansi.SetColor Ansi.Background i c)++sgr :: Ansi.SGR -> Text+sgr = Text.pack . Ansi.setSGRCode . return
+ src/Score.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+module Score+  ( Score+  , Input(..)+  , Choice(..)+  , score+  , positive+#ifdef TEST+  , minimum+#endif+  ) where++import           Control.Applicative+import           Control.Monad+import           Data.Maybe (mapMaybe)+import           Data.Text (Text)+import qualified Data.Text as Text+import           Prelude hiding (minimum)+++newtype Score = Score Double deriving (Show, Eq, Ord)++instance Bounded Score where+  minBound = Score 0.0+  maxBound = Score 1.0++newtype Input = Input Text deriving (Show, Eq)++newtype Choice = Choice Text deriving (Show, Eq)++score :: Input -> Choice -> Score+score (Input q) (Choice c)+  | Nothing      <- Text.uncons (Text.toLower q) = maxBound+  | Just (x, xs) <- Text.uncons (Text.toLower q)+  , Just ml      <- sub x xs (Text.toLower c)    = Score ((fi ql / fi ml) / fi cl)+  | otherwise = minBound+ where+  fi = fromIntegral+  ql = Text.length q+  cl = Text.length c++-- | The shortest substring match length+sub :: Char -> Text -> Text -> Maybe Int+sub q qs = minimum . mapMaybe (rec qs <=< Text.stripPrefix (Text.singleton q)) . Text.tails++rec :: Text -> Text -> Maybe Int+rec = go 0+ where+  go !len xs bs = case Text.uncons xs of+    Nothing      -> Just len+    Just (a, as) -> case Text.findIndex (== a) bs of+      Nothing -> Nothing+      Just i  -> go (len + i) as (Text.drop (i + 1) bs)++-- | The score is at least a little bit greater than the absolute minimum+--+-- This means it will be presented to user, even if at the bottom of the list+positive :: Score -> Bool+positive n = n > minBound++minimum :: Ord a => [a] -> Maybe a+minimum = foldr (\x a -> liftA2 min (Just x) a <|> Just x) Nothing
+ src/TTY.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+module TTY+#ifdef TEST+  ( TTY(..)+  , nullDevice+#else+  ( TTY+  , winHeight+  , winWidth+#endif+  , TTYException(..)+  , withTTY+  , Key(..)+  , getKey+  , putText+  , putTextLine+  , putLine+  , clearScreenBottom+  , withHiddenCursor+  , getCursorRow+  , moveCursor+  ) where++import           Control.Exception (Exception(..), IOException)+import qualified Control.Exception as E+import           Control.Monad+import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.Trans.Resource (MonadResource)+import           Data.Char (isPrint, isDigit, chr, ord)+import           Data.Conduit (Conduit)+import qualified Data.Conduit as C+import           Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import           Data.Typeable (Typeable)+import           Prelude hiding (getChar)+import           System.Console.ANSI as Ansi+import           System.Console.Terminal.Size (Window(..), hSize)+import qualified System.IO as IO+import qualified System.IO.Error as IO+import qualified System.Posix as Posix+import           System.Timeout (timeout)+import           Text.Read (readMaybe)+++data TTY = TTY+  { inHandle, outHandle :: IO.Handle+  , winHeight, winWidth :: Int+  } deriving (Show, Eq)++-- | Exceptions thrown while manipulating @\/dev\/tty@ device+newtype TTYException = TTYIOException IOException deriving (Show, Eq, Typeable, Exception)++withTTY :: MonadResource m => (TTY -> Conduit i m o) -> Conduit i m o+withTTY f =+  withFile ttyDevice IO.ReadMode  $ \inHandle  ->+  withFile ttyDevice IO.WriteMode $ \outHandle -> do+    setBuffering outHandle IO.NoBuffering+    withConfiguredTTY $ do+      mw <- hWindow outHandle+      case mw of+        Nothing ->+          liftIO (ioError (notATTY outHandle))+        Just Window { height, width } ->+          f TTY { inHandle, outHandle, winHeight = height, winWidth = width }++withFile :: MonadResource m => FilePath -> IO.IOMode -> (IO.Handle -> Conduit i m o) -> Conduit i m o+withFile name mode = C.bracketP (IO.openFile name mode) IO.hClose++withConfiguredTTY :: MonadResource m => Conduit i m o -> Conduit i m o+withConfiguredTTY = C.bracketP+  (withFd ttyDevice Posix.ReadOnly $ \fd -> do s <- getAttrs fd; configure fd s; return s)+  (\as -> withFd ttyDevice Posix.ReadOnly (\fd -> setAttrs fd as)) . const++withFd :: FilePath -> Posix.OpenMode -> (Posix.Fd -> IO a) -> IO a+withFd name mode = E.bracket (Posix.openFd name mode Nothing Posix.defaultFileFlags) Posix.closeFd++setBuffering :: MonadIO m => IO.Handle -> IO.BufferMode -> m ()+setBuffering h m = liftIO (IO.hSetBuffering h m)++hWindow :: (Integral n, MonadIO m) => IO.Handle -> m (Maybe (Window n))+hWindow = liftIO . hSize++getAttrs :: Posix.Fd -> IO Posix.TerminalAttributes+getAttrs = Posix.getTerminalAttributes++configure :: Posix.Fd -> Posix.TerminalAttributes -> IO ()+configure fd as = setAttrs fd (withoutModes as [Posix.EnableEcho, Posix.ProcessInput])++withoutModes :: Posix.TerminalAttributes -> [Posix.TerminalMode] -> Posix.TerminalAttributes+withoutModes = foldr (flip Posix.withoutMode)++setAttrs :: Posix.Fd -> Posix.TerminalAttributes -> IO ()+setAttrs fd as = Posix.setTerminalAttributes fd as Posix.Immediately++data Key =+    Print Char+  | Ctrl Char -- invariant: this character is in ['A'..'Z'] range+  | Bksp+  | ArrowUp+  | ArrowDown+  | ArrowLeft+  | ArrowRight+    deriving (Show, Eq)++getKey :: MonadIO m => TTY -> m (Maybe Key)+getKey tty = liftIO . fmap join . timeout 100000 $+  getChar tty >>= \case+    '\DEL' -> return (Just Bksp)+    '\ESC' -> getChar tty >>= \case+      '[' -> getChar tty >>= \case+        'A' -> return (Just ArrowUp)+        'B' -> return (Just ArrowDown)+        'C' -> return (Just ArrowRight)+        'D' -> return (Just ArrowLeft)+        _   -> return Nothing+      _ -> return Nothing+    c | c `elem` ['\SOH'..'\SUB'] -> return (Just (Ctrl (chr (ord c + 64))))+      | isPrint c -> return (Just (Print c))+      | otherwise -> return Nothing++getChar :: MonadIO m => TTY -> m Char+getChar = liftIO . IO.hGetChar . inHandle++putText :: MonadIO m => TTY -> Text -> m ()+putText TTY { outHandle } = liftIO . Text.hPutStr outHandle++putTextLine :: MonadIO m => TTY -> Text -> m ()+putTextLine TTY { outHandle } = liftIO . Text.hPutStrLn outHandle++putLine :: MonadIO m => TTY -> m ()+putLine TTY { outHandle } = liftIO (Text.hPutStrLn outHandle Text.empty)++clearScreenBottom :: MonadIO m => TTY -> m ()+clearScreenBottom TTY { outHandle } = liftIO $ do+  Ansi.hSetCursorColumn outHandle 0+  Ansi.hClearFromCursorToScreenEnd outHandle++withHiddenCursor :: TTY -> IO a -> IO a+withHiddenCursor TTY { outHandle = h } = E.bracket_ (Ansi.hHideCursor h) (Ansi.hShowCursor h)++getCursorRow :: MonadIO m => TTY -> m Int+getCursorRow tty = do+  putText tty magicCursorPositionSequence+  res <- parseAnsiResponse tty+  case res of+    Just r  -> return (r - 1) -- the response is 1-based+    Nothing -> liftIO (ioError (notATTY (inHandle tty)))+ where+  magicCursorPositionSequence = Text.pack "\ESC[6n"++parseAnsiResponse :: (MonadIO m, Read a) => TTY -> m (Maybe a)+parseAnsiResponse tty = liftM parse (go [])+ where+  go acc = do+    c <- getChar tty+    if c == 'R' then return (reverse acc) else go (c : acc)++  parse ('\ESC' : '[' : xs) = readMaybe (takeWhile isDigit xs)+  parse _                   = Nothing++moveCursor :: TTY -> Int -> Int -> IO ()+moveCursor = Ansi.hSetCursorPosition . outHandle++notATTY :: IO.Handle -> IOException+notATTY h = IO.mkIOError IO.illegalOperationErrorType "Not a TTY" (Just h) Nothing++ttyDevice, nullDevice :: FilePath+ttyDevice  = "/dev/tty"+nullDevice = "/dev/null"
+ src/Wybor.hs view
@@ -0,0 +1,479 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Console line fuzzy search as a library.+--+-- It's probably easier to toy with the library through+-- the @wybor@ executable, although this example uses @ghci@, which is+-- also a pretty capable environment for toying+--+-- First, we need a bit of setup. Both extensions aren't strictly necessary+-- but they make our life considerably easier. Imports, on the other hand, are+-- essential.+--+-- /Note:/ @-XOverloadedLists@ requires GHC >= 7.8+--+-- @+-- >>> :set -XOverloadedStrings+-- >>> :set -XOverloadedLists+-- >>> import Control.Lens+-- >>> import Wybor+-- @+--+-- So, this starts a sligtly customized selection process (more settings are avaliable,+-- please see 'HasWybor' class):+--+-- @+-- >>> select (fromTexts ["foo", "bar", "baz"] & prefix .~ "λ> ")+-- λ>+-- __foo__+-- bar+-- baz+-- @+--+-- This new prompt (@λ>@) expects us to enter symbols to narrow the list of outcomes, e.g.:+--+-- @+-- λ> b+-- __bar__+-- baz+-- @+--+-- @+-- λ> bz+-- __baz__+-- @+--+-- At this point there is only one acceptable outcome, so we press @Enter@ and end up with:+--+-- @+-- Right (Just "baz")+-- @+--+-- Of course, we can press @Enter@ at any point of the process, selecting+-- the focused alternative (marked bold here). Other hotkeys:+--+--   - @C-j@ selects the focused alternative (like @Enter@)+--   - @C-u@ clears the line+--   - @C-w@ deletes last word+--   - @C-h@ deletes last character (as does @Backspace@)+--   - @C-n@ focuses the next alternative+--   - @C-p@ focuses the previous alternative+--   - @C-d@ aborts the selection+--+module Wybor+  ( select+  , selections+  , Wybor+  , fromAssoc+  , fromTexts+  , fromIO+  , HasWybor(..)+  , TTYException(..)+#ifdef TEST+  , pipeline+#endif+  -- * A bunch of helpers to use with 'focused' and 'normal'+  , module Ansi+  ) where++import           Control.Exception (try)+import           Control.Lens hiding (lined)+import           Control.Monad+import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.Trans.Resource (MonadResource, runResourceT)+import           Data.Conduit (Source, Conduit, (=$=), ($$))+import qualified Data.Conduit as C+import           Data.Char (isSpace)+import           Data.Data (Typeable)+import           Data.Foldable (Foldable, toList)+import           Data.Function (on)+import           Data.List (sortBy)+import           Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Monoid (Monoid(..), (<>))+import           Data.Sequence (Seq, (><))+import qualified Data.Sequence as Seq+import           Data.Sequence.Lens (seqOf)+import           Data.Text (Text)+import qualified Data.Text as Text+import           Prelude hiding (unlines)+import qualified System.Console.ANSI as Ansi++import           Score (score, Input(..), Choice(..))+import qualified Score+import           TTY (TTY, TTYException)+import qualified TTY+import           Zipper (Zipper, focus, zipperN)+import qualified Zipper+import           Ansi+++-- | Select an item from 'Wybor' once+--+-- The user can interrupt the process with @C-d@ and then you get 'Nothing'.+-- Exceptions result in @'Left' _@+select :: Wybor a -> IO (Either TTYException (Maybe a))+select c = try . runResourceT $ selections c $$ C.await++-- | Continuously select items from 'Wybor'+--+-- Exceptions (see 'TTYException') aren't caught+selections :: MonadResource m => Wybor a -> Source m a+selections = TTY.withTTY . pipeline++-- | The description of the alternative choices, see 'HasWybor'+data Wybor a = Wybor+  { _alts :: Alternatives (NonEmpty (Text, a))+  , _conf :: Conf Text+  } deriving (+    Functor+#if __GLASGOW_HASKELL__ >= 708+  , Typeable+#endif+  )++alts :: Lens (Wybor a) (Wybor b) (Alternatives (NonEmpty (Text, a))) (Alternatives (NonEmpty (Text, b)))+alts f x = f (_alts x) <&> \y -> x { _alts = y }+{-# INLINE alts #-}++conf :: Lens' (Wybor a) (Conf Text)+conf f x = f (_conf x) <&> \y -> x { _conf = y }+{-# INLINE conf #-}++data Alternatives a+  = Static a+  | Dynamic (IO (Maybe (Maybe a)))++instance Functor Alternatives where+  fmap f (Static a) = Static (f a)+  fmap f (Dynamic k) = Dynamic (fmap (fmap (fmap f)) k)++data Conf a = Conf+  { _visible, _height :: Int+  , _initial, _prefix :: a+  , _focused, _normal :: a -> a+  } deriving (Typeable)++-- | A bunch of lenses to pick and configure Wybor+class HasWybor t a | t -> a where+  wybor :: Lens' t (Wybor a)++  -- | How many alternative choices to show at once? (default: @10@)+  visible :: Lens' t Int+  visible = wybor.conf. \f x -> f (_visible x) <&> \y -> x { _visible = y }+  {-# INLINE visible #-}++  -- | How many lines every alternative takes on the screen? (default: @1@)+  height :: Lens' t Int+  height = wybor.conf. \f x -> f (_height x) <&> \y -> x { _height = y }+  {-# INLINE height #-}++  -- | Initial search string (default: @""@)+  initial :: Lens' t Text+  initial = wybor.conf. \f x -> f (_initial x) <&> \y -> x { _initial = y }+  {-# INLINE initial #-}++  -- | Prompt prefix (default: @">>> "@)+  prefix :: Lens' t Text+  prefix = wybor.conf. \f x -> f (_prefix x) <&> \y -> x { _prefix = y }+  {-# INLINE prefix #-}++  -- | Decoration applied to the focused item (swaps foreground and background colors by default)+  --+  -- /Note:/ should not introduce any printable symbols+  focused :: Lens' t (Text -> Text)+  focused = wybor.conf. \f x -> f (_focused x) <&> \y -> x { _focused = y }+  {-# INLINE focused #-}++  -- | Decoration applied to other items (is @id@ by default)+  --+  -- /Note:/ should not introduce any printable symbols+  normal :: Lens' t (Text -> Text)+  normal = wybor.conf. \f x -> f (_normal x) <&> \y -> x { _normal = y }+  {-# INLINE normal #-}++instance HasWybor (Wybor a) a where+  wybor = id+  {-# INLINE wybor #-}++-- | Construct 'Wybor' from the nonempty list of strings+--+-- The strings are used both as keys and values+fromTexts :: NonEmpty Text -> Wybor Text+fromTexts = fromAssoc . fmap (\x -> (x, x))++-- | Construct 'Wybor' from the nonempty list of key-value pairs+fromAssoc :: NonEmpty (Text, a) -> Wybor a+fromAssoc = fromAlternatives . Static++-- | Construct 'Wybor' from the 'IO' action that streams choices+--+-- It's useful when the list of alternatives is populated over+-- time from multiple sources (for instance, from HTTP responses)+--+-- The interface is tailored for the use with closeable queues from the "stm-chans" package:+--+-- >>> q <- newTMQueueIO+-- >>> ... {- a bunch of threads populating and eventually closing the queue -}+-- >>> c <- 'select' ('fromIO' (atomically (tryReadTMQueue q)))+-- >>> print c+--+-- That is, if the 'IO' action returns @'Nothing'@ the queue will never be read from again+-- and it can return @'Just' 'Nothing'@ when there's nothing to add to the choices __yet__+--+-- It's still possible to use non-fancy queues:+--+-- >>> q <- newTQueueIO+-- >>> ... {- a bunch of threads populating the queue -}+-- >>> c <- 'select' ('fromIO' (fmap Just (atomically (tryReadTQueue q))))+-- >>> print c+--+-- If choices are static, you will be served better by 'fromAssoc' and 'fromTexts'+fromIO :: IO (Maybe (Maybe (NonEmpty (Text, a)))) -> Wybor a+fromIO = fromAlternatives . Dynamic++fromAlternatives :: Alternatives (NonEmpty (Text, a)) -> Wybor a+fromAlternatives xs = Wybor+  { _alts = xs+  , _conf = defaultConf+  }++defaultConf :: Conf Text+defaultConf = Conf+  { _visible = 10+  , _height  = 1+  , _prefix  = ">>> "+  , _initial = ""+  , _focused = \t -> Text.concat [swap, t, unswap]+  , _normal  = id+  }++pipeline :: MonadIO m => Wybor a -> TTY -> Source m a+pipeline w tty = do+  pos <- prerenderUI w tty+  sourceInput (view alts w) tty =$= renderUI tty pos w++sourceInput :: MonadIO m => Alternatives (NonEmpty (Text, a)) -> TTY -> Source m (Event a)+sourceInput (Static p)   tty = do yieldChoices p; loop where loop = keyEvent tty loop+sourceInput (Dynamic io) tty = interleaving+ where+  interleaving = liftIO io >>= \case+    Nothing       -> let loop = keyEvent tty loop in loop+    Just Nothing  -> keyEvent tty interleaving+    Just (Just p) -> do yieldChoices p; keyEvent tty interleaving++keyEvent :: MonadIO m => TTY -> Source m (Event a) -> Source m (Event a)+keyEvent tty c = TTY.getKey tty >>= \case+  Nothing -> c+  Just k  -> case parseKey k of+    Nothing       -> return ()+    Just Nothing  ->                     c+    Just (Just e) -> do yieldKeyEvent e; c++yieldChoices :: MonadIO m => NonEmpty (Text, a) -> Source m (Event a)+yieldChoices = C.yield . Left . AppendChoices++yieldKeyEvent :: MonadIO m => KeyEvent -> Source m (Event a)+yieldKeyEvent = C.yield . Right++type Event a = Either (GenEvent a) KeyEvent++newtype GenEvent a = AppendChoices (NonEmpty (Text, a)) deriving (Show, Eq, Functor)++data KeyEvent =+    Done+  | Abort+  | Down+  | Up+  | Clear+  | DeleteWord+  | DeleteChar+  | AppendChar Char+    deriving (Show, Eq)++parseKey :: TTY.Key -> Maybe (Maybe KeyEvent)+parseKey = \case+  TTY.Ctrl 'J'  -> Just (Just Done)+  TTY.Ctrl 'D'  -> Nothing+  TTY.Ctrl 'N'  -> Just (Just Down)+  TTY.ArrowDown -> Just (Just Down)+  TTY.Ctrl 'P'  -> Just (Just Up)+  TTY.ArrowUp   -> Just (Just Up)+  TTY.Ctrl 'U'  -> Just (Just Clear)+  TTY.Ctrl 'W'  -> Just (Just DeleteWord)+  TTY.Bksp      -> Just (Just DeleteChar)+  TTY.Ctrl 'H'  -> Just (Just DeleteChar)+  TTY.Print c   -> Just (Just (AppendChar c))+  _             -> Just Nothing++newtype Choices a = Choices+  { unChoices :: Seq (Text, a)+  }++choices :: Iso (Choices a) (Choices b) (Seq (Text, a)) (Seq (Text, b))+choices = iso unChoices Choices++data Query a b = Query+  { _matches :: Maybe (Zipper (a, b))+  , _input   :: a+  } deriving (Show, Eq)++matches :: Lens' (Query a b) (Maybe (Zipper (a, b)))+matches f x = f (_matches x) <&> \y -> x { _matches = y }++input :: Lens' (Query a b) a+input f x = f (_input x) <&> \y -> x { _input = y }++handleEvent :: Choices a -> Query Text a -> KeyEvent -> Maybe (Either a (Query Text a))+handleEvent c s = \case+  Done         -> Just (maybe (Right s) Left (done s))+  Abort        -> Nothing+  Down         -> Just (Right (down s))+  Up           -> Just (Right (up s))+  Clear        -> Just (Right (clear c))+  DeleteChar   -> Just (Right (deleteChar c s))+  DeleteWord   -> Just (Right (deleteWord c s))+  AppendChar x -> Just (Right (append s x))++done :: Query a b -> Maybe b+done = preview (matches.traverse.focus._2)++down :: Query a b -> Query a b+down = over (matches.traverse) Zipper.right++up :: Query a b -> Query a b+up = over (matches.traverse) Zipper.left++clear :: Choices a -> Query Text a+clear c = fromInput c mempty++append :: Query Text a -> Char -> Query Text a+append s x = fromInput (Choices (seqOf (matches.folded.folded) s)) (view input s |> x)++deleteChar :: Choices a -> Query Text a -> Query Text a+deleteChar c = maybe (clear c) (fromInput c . fst) . unsnoc . view input++deleteWord :: Choices a -> Query Text a -> Query Text a+deleteWord c = fromInput c . view (input.to (Text.dropWhileEnd (not . isSpace) . Text.stripEnd))++fromInput :: Choices a -> Text -> Query Text a+fromInput c q = Query { _matches = view (choices.to (computeMatches q)) c, _input = q }++fromNothing :: Wybor a -> Query Text b+fromNothing c = Query { _matches = Nothing, _input = view initial c }++computeMatches :: Foldable f => Text -> f (Text, a) -> Maybe (Zipper (Text, a))+computeMatches "" = Zipper.fromList . toList+computeMatches q  = Zipper.fromList . sortOnByOf choiceScore (flip compare) Score.positive . toList+ where+  choiceScore = score (Input q) . Choice . fst++sortOnByOf :: (Foldable f, Ord b) => (a -> b) -> (b -> b -> Ordering) -> (b -> Bool) -> f a -> [a]+sortOnByOf f c p = map fst . sortBy (c `on` snd) . filter (p . snd) . map (\x -> (x, f x)) . toList+++prerenderUI :: MonadIO m => Wybor a -> TTY -> m Int+prerenderUI c tty = do+  row <- TTY.getCursorRow tty+  let offset = max 0 (linesTaken c - (TTY.winHeight tty - row))+  replicateM_ offset (TTY.putLine tty)+  return (row - offset)++renderUI :: MonadIO m => TTY -> Int -> Wybor a -> Conduit (Event b) m b+renderUI tty p c = rendering (Choices Seq.empty) (fromNothing c)+ where+  rendering cs s = renderQuery tty c p s >> C.await >>= \case+    Nothing ->+      cleanUp+    Just (Left (AppendChoices xs)) ->+      let+        f   = NonEmpty.filter (\x -> Score.positive (score (Input (view input s)) (Choice (fst x))))+        cs' = over choices (>< Seq.fromList (toList xs)) cs+        s'  = over matches (maybe (Zipper.fromList (f xs)) (Just . Zipper.append (f xs))) s+      in+        rendering cs' s'+    Just (Right e) -> case handleEvent cs s e of+      Nothing         -> cleanUp+      Just (Left x)   -> do cleanUp; C.yield x; rendering cs s+      Just (Right s') -> rendering cs s'++  cleanUp = TTY.clearScreenBottom tty++renderQuery :: MonadIO m => TTY -> Wybor a -> Int -> Query Text b -> m ()+renderQuery tty c top s =+  liftIO . TTY.withHiddenCursor tty $ renderContent tty top (columnsTaken c s) (content tty c s)++renderContent :: TTY -> Int -> Int -> Text -> IO ()+renderContent tty x y t = do+  TTY.moveCursor tty x 0+  TTY.putText tty t+  TTY.moveCursor tty x y++content :: TTY -> Wybor a -> Query Text b -> Text+content tty c = review lined+  . map (text . unline . clean . line . decorate c . unline . expand tty c . line) . items c++data Item s = Plain s | Chosen s | Prefix s deriving (Functor)++item :: (s -> a) -> (s -> a) -> (s -> a) -> Item s -> a+item f _ _ (Plain s)  = f s+item _ g _ (Chosen s) = g s+item _ _ h (Prefix s) = h s++text :: Item s -> s+text = item id id id++lined :: Iso' Text [Text]+lined = iso Text.lines (Text.intercalate "\n")++line :: Item Text -> Item [Text]+line = fmap (view lined)++expand :: TTY -> Wybor a -> Item [Text] -> Item [Text]+expand tty c = \case+  Plain  xs -> Plain  (compose h w xs)+  Chosen xs -> Chosen (compose h w xs)+  Prefix xs -> Prefix (compose 1 w xs)+ where+  compose x y xs = take x (map (crop w y) (map notabs xs ++ repeat ""))+  notabs  = Text.replace "\t" (Text.replicate 8 " ")+  w = TTY.winWidth tty+  h = view height c++crop :: Int -> Int -> Text -> Text+crop w n = Text.pack . go 0 . Text.unpack+ where+  go k (x : xs) = let k' = k + wcwidth x in if k' <= n then x : go k' xs else replicate (w - k) ' '+  go k []       = replicate (w - k) ' '++foreign import ccall unsafe "wybor_mk_wcwidth" wcwidth :: Char -> Int++clean :: Item [Text] -> Item [Text]+clean = fmap (map (\l -> l <> Text.pack Ansi.clearFromCursorToLineEndCode))++decorate :: Wybor a -> Item Text -> Item Text+decorate c (Plain xs)  = Plain  (view normal c xs)+decorate c (Chosen xs) = Chosen (view focused c xs)+decorate _ (Prefix xs) = Prefix xs++unline :: Item [Text] -> Item Text+unline = fmap (review lined)++items :: Wybor a -> Query Text b -> [Item Text]+items c s = take (view visible c + 1) $+     Prefix (view prefix c <> view input s)+  :  maybe [] (zipperN (view visible c) combine . fmap fst) (preview (matches.traverse) s)+  ++ repeat (Plain "")+ where+  combine xs y zs = map Plain xs ++ [Chosen y] ++ map Plain zs++linesTaken :: Wybor a -> Int+linesTaken c = view visible c * view height c + 1++columnsTaken :: Wybor a -> Query Text b -> Int+columnsTaken c s = lengthOf (beside (prefix.each) (input.each)) (c, s)
+ src/Zipper.hs view
@@ -0,0 +1,73 @@+-- | Non-empty list zipper+{-# LANGUAGE DeriveFunctor #-}+module Zipper+  ( Zipper+  , fromNonEmpty+  , fromList+  , zipperN+  , zipper+  , before+  , focus+  , after+  , left+  , right+  , prepend+  , append+  ) where++import           Control.Lens+import           Data.Foldable (Foldable(foldMap), toList)+import           Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Monoid ((<>))++data Zipper a = Zipper [a] a [a] deriving (Show, Eq, Functor)++instance Foldable Zipper where+  foldMap f (Zipper xs y zs) = foldMap f (reverse xs) <> f y <> foldMap f zs++-- | @zipperN n f z@ applies the function @f@ to the 'Zipper' @z@+-- at *at most @n@* points around its 'focus'+zipperN :: Int -> ([a] -> a -> [a] -> b) -> Zipper a -> b+zipperN n f (Zipper xs y zs) = zipper f $+  case (drop q xs, drop q zs) of+    ([], _) -> Zipper xs y (take (n - length xs - 1) zs)+    (_, []) -> Zipper (take (n - length zs - 1) xs) y zs+    _       -> Zipper (take q xs) y (take (q + r) zs)+ where+  (q, r) = (n - 1) `quotRem` 2+{-# ANN zipperN "HLint: ignore Redundant lambda" #-}++zipper :: ([a] -> a -> [a] -> b) -> Zipper a -> b+zipper f (Zipper xs y zs) = f (reverse xs) y zs++fromList :: [a] -> Maybe (Zipper a)+fromList = fmap fromNonEmpty . NonEmpty.nonEmpty++fromNonEmpty :: NonEmpty a -> Zipper a+fromNonEmpty (x :| xs) = Zipper [] x xs++focus :: Lens' (Zipper a) a+focus f (Zipper xs y zs) = f y <&> \y' -> Zipper xs y' zs++before, after :: Lens' (Zipper a) [a]+before f (Zipper xs y zs) = f xs <&> \xs' -> Zipper xs' y zs+after  f (Zipper xs y zs) = f zs <&> \zs' -> Zipper xs  y zs'++left :: Zipper a -> Zipper a+left z@(Zipper xs y ys) =+  case xs of+    []     -> z+    u : us -> Zipper us u (y : ys)++right :: Zipper a -> Zipper a+right z@(Zipper xs x ys) =+  case ys of+    []     -> z+    u : us -> Zipper (x : xs) u us++prepend :: Foldable f => f a -> Zipper a -> Zipper a+prepend xs = over before (reverse (toList xs) ++)++append :: Foldable f => f a -> Zipper a -> Zipper a+append xs = over after (++ toList xs)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ wybor.cabal view
@@ -0,0 +1,78 @@+name:                wybor+version:             0.1.0+synopsis:            Console line fuzzy search+description:         Console line fuzzy search as a library+homepage:            https://github.com/supki/wybor+license:             BSD2+license-file:        LICENSE+author:              Matvey Aksenov+maintainer:          matvey.aksenov@gmail.com+copyright:           Matvey Aksenov 2014+category:            Text+build-type:          Simple+cabal-version:       >= 1.10+tested-with:         GHC == 7.6.3, GHC == 7.8.2+extra-source-files:+  README.markdown++source-repository head+  type: git+  location: https://github.com/supki/wybor++library+  default-language:+    Haskell2010+  build-depends:+      ansi-terminal >= 0.6+    , base          >= 4.6 && < 5+    , conduit       >= 1.1+    , containers+    , lens          >= 4.3+    , resourcet     >= 1.1+    , text          >= 1.1+    , transformers  >= 0.3+    , semigroups    >= 0.15+    , terminal-size >= 0.2.1+    , unix+  hs-source-dirs:+    src+  exposed-modules:+    Wybor+  other-modules:+    Score+    TTY+    Zipper+    Ansi+  c-sources:+    cbits/wcwidth.c++test-suite spec+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0+  build-depends:+      ansi-terminal+    , base          >= 4.6 && < 5+    , conduit+    , containers+    , hspec         >= 1.10+    , lens+    , process+    , resourcet+    , semigroups+    , terminal-size+    , text+    , transformers+    , unix+  hs-source-dirs:+    test+    src+  main-is:+    Spec.hs+  ghc-options:+    -threaded+  cpp-options:+    -DTEST+  c-sources:+    cbits/wcwidth.c