packages feed

dustme (empty) → 0.1.0.0

raw patch · 11 files changed

+480/−0 lines, 11 filesdep +ansi-terminaldep +ansi-wl-pprintdep +asyncsetup-changed

Dependencies added: ansi-terminal, ansi-wl-pprint, async, attoparsec, base, bytestring, containers, deepseq, dustme, extra, hashable, hspec, safe, semigroups, terminfo, text, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Mark Wotton (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Mark Wotton nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import           Dustme++main :: IO ()+main = dustme 1
+ dustme.cabal view
@@ -0,0 +1,63 @@+name:                dustme+version:             0.1.0.0+synopsis:            Initial project template from stack+description:         Please see README.md+homepage:            https://github.com/mwotton/dustme#readme+license:             BSD3+license-file:        LICENSE+author:              Mark Wotton+maintainer:          mwotton@gmail.com+copyright:           AllRightsReserved+category:            Web+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Dustme+                       Dustme.Score+                       Dustme.Types+                       Dustme.Search+                       Dustme.Renderer+                       Dustme.TTY+  build-depends: ansi-terminal+               , ansi-wl-pprint+               , async+               , attoparsec+               , base >= 4.7 && < 5+               , bytestring+               , containers+               , deepseq+               , extra+               , hashable+               , safe+               , semigroups+               , terminfo >= 0.4.0.2 && < 0.5+               , text+               , unordered-containers+++  default-language:    Haskell2010++executable dustme+  hs-source-dirs:      app+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , dustme+  default-language:    Haskell2010++test-suite dustme-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , hspec+                     , dustme+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/mwotton/dustme
+ src/Dustme.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+module Dustme where++import           Control.Concurrent       (newEmptyMVar, takeMVar)+import           Control.Concurrent.Async (async, cancel, race)+import           Control.DeepSeq          (force)+import           Control.Exception        (bracket, evaluate)+import qualified Data.Text                as T+import qualified Data.Text.IO             as TIO+import           Dustme.Renderer+import           Dustme.Search+import           Dustme.TTY               (withTTY)+import           Dustme.Types+import           System.IO++dustme config = do+  hSetBuffering stdout NoBuffering+  input <- T.lines <$> TIO.getContents+  let applyOp' = applyOp input+  withTTY "/dev/tty0" (setup applyOp' (map mkTrivialMatch input))++mkTrivialMatch = Match 10000 1 0++setup applyOp' initMatch tty = go 0 initMatch (Search "") emptyCache+  where+    getCommand = takeMVar (ttyGetCommand tty)++    go :: Int -> SearchResult -> Search -> SearchCache -> IO ()+    go    index  matches'         search    cache = do+      let matches = case search of+            (Search "") -> initMatch+            _ -> matches'++      -- the idea here is that that ttyGetCommand can always take+      -- priority over printing. This means that if we type a bunch+      -- of keys in in quick succession, the UI will remain responsive.+      r <- race (evaluate $ force matches) getCommand+      s <- case r of+             Left matches' -> renderSearch tty index matches search >> getCommand+             Right x -> return x++      case s of+        Accept  -> TIO.putStrLn (matchText $ matches !! index)+        Up      -> go (clamp (length matches) (index-1)) matches search cache+        Down    -> go (clamp (length matches) (index+1)) matches search cache+        Edit op ->+          let (newsearch,newcandidates) = applyOp'  op  search matches+              (searchResult, newcache) =+                getResults newcandidates cache newsearch+          in go 0 searchResult newsearch newcache++clamp hi i+ | i < 0     = 0+ | i >= hi   = hi - 1+ | otherwise = i
+ src/Dustme/Renderer.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+module Dustme.Renderer where+import           Data.Char                    (chr)+import           Data.List                    (intersperse)+import           Data.Monoid                  ((<>))+import qualified Data.Text                    as T+import           Dustme.TTY+import           Dustme.Types+import           System.Console.ANSI          (hClearFromCursorToScreenEnd,+                                               hClearLine, hClearScreen,+                                               hCursorDown, hCursorUp,+                                               hSetCursorColumn, hShowCursor)+import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))++buildMatch :: Int -> Int -> Match -> Int -> Doc+buildMatch width selected match current =+  let (normal,highlight) =+        if  selected == current+        then (onwhite,onred . black)+        else (id,red)+      fulltext = matchText match+      before = ttext $ T.take (matchStart match) fulltext+      matching = ttext $ T.drop (matchStart match) (T.take (matchEnd match + 1) fulltext)+      end = ttext $ T.drop (matchEnd match + 1) fulltext+  in normal before <> highlight matching <> normal end++tshow :: Show a => a -> T.Text+tshow = T.pack . show++ttext :: T.Text -> Doc+ttext = text . T.unpack++-- renderSearch :: TTY -> Int -> [Match] -> IO ()+renderSearch tty index matches (Search search) = do+  let width = getWidth tty+      height = getHeight tty+      body :: Doc+      body = linebreak <> (mconcat . intersperse linebreak+             $ zipWith (buildMatch width index) matches [0..height - 2])+      searchLine :: T.Text+      searchLine =  tshow (length matches) <> " > " <> search+      h = ttyHandle tty+  hClearFromCursorToScreenEnd h+  termPrint tty body+  hCursorUp h (length matches)+  hSetCursorColumn h 0+  hClearLine h+  termPrint tty (ttext searchLine)+  hShowCursor h++termPrint (TTY handle term _ _ ) = hPutDoc handle
+ src/Dustme/Score.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Dustme.Score where+import           Data.Char          (isSpace, toLower)+import           Data.List          (minimumBy, sortBy)+import           Data.List.NonEmpty (NonEmpty (..))+import           Data.Map           (Map)+import qualified Data.Map           as Map+import           Data.Maybe         (fromMaybe, listToMaybe, mapMaybe)+import           Data.Ord           (comparing)+import           Data.Set           (Set)+import qualified Data.Set           as Set+import           Data.Text          (Text, pack)+import qualified Data.Text          as T+import           Dustme.Types+import           Prelude            hiding ((!!))+import           Safe++type Score = Int+type Position = Int++getIndices :: Text -> Map Char (Set Int)+getIndices =+  snd . T.foldl'+  (\(i::Int,dict) c ->+      (i+1, Map.insertWith Set.union (toLower c) (Set.singleton i) dict))+  (0, Map.empty)++matchComparison m1 m2 =+  case compare (matchScore m1) (matchScore m2) of+    EQ -> compare (matchStart m1) (matchStart m2)+    x -> x++mkMatch :: Text -> ([Int], Int) -> Maybe Match+mkMatch _ ([],_) = Nothing+mkMatch t (xs,cost) = Just $ Match cost (head xs) (last xs) t++bestMatches :: Text -> Text -> [Match] -- [([Int], Int)]+bestMatches t keys =+    sortBy matchComparison+  $ mapMaybe (mkMatch keys . (\(p,_) -> (reverse p, scorePath p)))+  $ T.foldl' search [([],0)] t+  where+    dict = getIndices keys++    initials :: Set Int+    -- we add 1 because we want the value _after_ whitespace.+    initials = Set.unions . map (Set.map (+1) . snd)  . Map.toList+             $ Map.filterWithKey (\k _ -> isSpace k)  dict++    scorePath :: [Int] -> Int+    scorePath [] = 10000+    scorePath [_] = 0+    scorePath (x:y:xs)+      | Set.member y initials = 1 + scorePath (y:xs)+      | otherwise             = x - y + scorePath (y:xs)++    search :: [([Int], Int)] -> Char -> [([Int], Int)]+    search paths c =+      concatMap+      (\(path, earliest) ->+         let next = Set.toList $ okPaths earliest continuations+         in map (\j -> (j:path, j+1)) next+      ) paths+      where continuations = fromMaybe Set.empty $ Map.lookup (toLower c) dict++okPaths :: Ord a => a -> Set a -> Set a+okPaths x xs = case Set.splitMember x xs of+  (_,True,b) -> Set.insert x b+  (_,_,b)    -> b
+ src/Dustme/Search.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TupleSections #-}+module Dustme.Search where++import           Control.Monad       (guard)+import           Data.Char           (isSpace)+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import           Data.List           (sortBy)+import           Data.Maybe          (mapMaybe)+import           Data.Monoid         ((<>))+import           Data.Ord            (comparing)+import           Data.Text           (Text)+import qualified Data.Text           as T+import           Dustme.Score        (bestMatches, getIndices, matchComparison)+import           Dustme.Types+import           Safe                (headMay)++-- Could be more sophisticated here+isBoundaryChar = isSpace++emptyCache = HM.empty++getResults :: [Text]+           -> SearchCache+           -> Search+           -> (SearchResult, SearchCache)+getResults candidates cache search = case HM.lookup search cache of+  Nothing -> let result = runSearch search candidates in+               (result, HM.insert search result cache)+  Just cached -> (cached, cache)++runSearch :: Search -> [Text] -> SearchResult+runSearch (Search st) candidates =+  sortBy matchComparison $+  mapMaybe (headMay .  bestMatches st) candidates+++applyOp ::  [Text] ->  SearchOp -> Search -> SearchResult -> (Search,[Text])+applyOp candidates op (Search st) matches =+  case op of+    AddText t ->  ( Search (st <> t)+                  , map matchText matches)+    Backspace ->  ( Search (T.dropEnd 1 st)+                  , candidates)+    DeleteWord -> ( Search $ T.dropWhileEnd (not . isBoundaryChar) st+                  , candidates)
+ src/Dustme/TTY.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+module Dustme.TTY+  ( withTTY+  , TermOutput(..)+  , getWidth+  , getHeight+  )+where+import           Control.Applicative              ((<|>))+import           Control.Concurrent               (newEmptyMVar, putMVar)+import           Control.Concurrent.Async         (async, cancel)+import           Control.Exception                (bracket)+import           Control.Monad                    (forever)+import           Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString.Char8            as BS8+import           Data.IORef+import           Data.Maybe                       (fromMaybe)+import           Data.Text                        (Text)+import qualified Data.Text                        as T+import           Dustme.Types+import           System.Console.Terminfo+import           System.IO                        (BufferMode (NoBuffering),+                                                   Handle (..), IOMode (..),+                                                   hGetChar, hReady,+                                                   hSetBuffering, openFile)+import qualified Text.PrettyPrint.ANSI.Leijen     as PP++withTTY :: FilePath -> (TTY -> IO ()) -> IO ()+withTTY fp  = bracket setup teardown+  where setup = do+          t <- setupTermFromEnv+          h <- openFile "/dev/tty" ReadWriteMode+          hSetBuffering h NoBuffering+          mv <- newEmptyMVar+          p <- mkCommandReader h+          reader <- async $ forever  (p >>= putMVar mv)+          return (TTY h t mv reader)++        teardown (TTY h t mv reader) = cancel reader++mkCommandReader h = parser <$> newIORef ""+  where+    parser ref = do+      leftovers <- atomicModifyIORef ref (\x -> (x,""))+      res <- parseWith (getFromHandle h) commParser leftovers+      case res of+        Fail s a b -> error (show ("can't happen error", s, a, b))+        Partial _ -> error "shouldn't happen - parseWith can resupply"+        Done bs a -> do+          writeIORef ref bs+          return a++commParser = choice+  [ Edit . const Backspace <$> string "\DEL"+  , Edit . const DeleteWord <$> string "\ETB"+  , const Down <$> string "\SO"+  , const Up <$> string "\DLE"+  , const Accept <$> string "\n"+  , Edit . AddText . T.pack . listify <$> anyChar+  ]+  where listify a = [a]+-- still need to treat any of these specially?+-- KEY_CTRL_C = ?\C-c+-- KEY_CTRL_N = ?\C-n+-- KEY_CTRL_P = ?\C-p+-- KEY_CTRL_U = ?\C-u+-- KEY_CTRL_H = ?\C-h+-- KEY_CTRL_W = ?\C-w+-- KEY_CTRL_J = ?\C-j+-- KEY_CTRL_M = ?\C-m+-- KEY_DELETE = 127.chr # Equivalent to ?\C-?++dowhile :: IO Bool -> IO a -> IO [a]+dowhile p f = (:) <$> f <*> while p f++while :: IO Bool -> IO a -> IO [a]+while p f = do+  go <- p+  if go+    then (:) <$> f <*> while p f+    else return []++getFromHandle :: Handle -> IO BS8.ByteString+getFromHandle h = BS8.pack <$> dowhile (hReady h) (hGetChar h)++getWidth :: TTY -> Int+getWidth t = fromMaybe (error "width not defined") (getCapability (ttyTerm t) termColumns)++getHeight :: TTY -> Int+getHeight t = fromMaybe (error "heighnot defined") (getCapability (ttyTerm t) termLines)
+ src/Dustme/Types.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DeriveGeneric #-}+module Dustme.Types where+import           Control.Concurrent.Async (Async)+import           Control.Concurrent.MVar  (MVar)+import           Control.DeepSeq          (NFData)+import           Data.Hashable            (Hashable)+import           Data.HashMap.Strict      (HashMap)+import           Data.Text                (Text)+import           GHC.Generics+import           System.Console.Terminfo+import           System.IO                (Handle)++data  TTY = TTY+  { ttyHandle     :: Handle+  , ttyTerm       :: Terminal+  , ttyGetCommand :: MVar Command+  , ttyProcess    :: Async ()+  }++data Match =+  Match+  { matchScore :: Int+  , matchStart :: Int+  , matchEnd   :: Int+  , matchText  :: Text+  } deriving (Show,Eq,Generic)++instance NFData Match++newtype Search = Search Text+  deriving (Generic, Eq, Show)++instance Hashable Search++type SearchResult = [Match]++data SearchOp = AddText Text+              | Backspace+              | DeleteWord+  deriving (Eq,Show)++data Command+  = Accept+  | Edit SearchOp+  | Up+  | Down++type SearchCache = HashMap Search SearchResult
+ test/Spec.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+import           Dustme+import           Dustme.Score+import           Dustme.Search+import           Dustme.Types+import           Test.Hspec++main :: IO ()+main = hspec spec++spec = describe "applyOp" $ do+  let applyOp' = applyOp ["a", "ab", "abc", "xyzzy"]+  it "can apply an op" $ do+    applyOp' (AddText "foo") (Search "") (map mkTrivialMatch ["a"])+      `shouldBe` (Search "foo", ["a"])+++  it "can apply a complex op" $ do+    applyOp' (AddText "b") (Search "a") (map mkTrivialMatch ["ab"])+      `shouldBe` (Search "ab", ["ab"])