├── Setup.hs ├── demonstration.gif ├── stack.yaml ├── watch ├── .gitignore ├── README.md ├── src ├── Utils.hs ├── HfArgs.hs ├── SimpleFormatter.hs ├── ResultSet.hs ├── Write.hs ├── Scorer.hs └── Main.hs ├── hf.cabal └── LICENSE /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /demonstration.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Refefer/hf/HEAD/demonstration.gif -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - '.' 5 | extra-deps: 6 | - ncurses-0.2.14 7 | resolver: lts-3.5 8 | -------------------------------------------------------------------------------- /watch: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | while [ 1 ]; do 3 | inotifywait src/*.hs *.cabal -e modify -e move -e create -e delete 4 | cabal build 5 | done 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.swp 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .virtualenv 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Haskell Find 2 | ===== 3 | 4 | A simple command line utility that allows filtering for an input on a set of keystrokes. 5 | 6 | Install 7 | ------- 8 | 9 | You'll need to have the ncursesw library installed, which will vary from operating system to operating system. 10 | 11 | `cabal build` or `cabal install` should be sufficient after setting up the sandbox. 12 | 13 | To Use 14 | ------ 15 | 16 | Using _hf_ is simple: simply pipe input into hf: 17 | 18 | find . -type f | hf 19 | 20 | or even more simply: 21 | 22 | hf 23 | 24 | and start typing 25 | 26 | The Up/Down (or Alt-P/Alt-N) keys selects which file to open. Enter opens selects the highlighted file. 27 | 28 | Sometimes a single query isn't enough to differentiate between the files. By pressing Tab, _hf_ will add another 'searcher' query for additional filtering. 29 | 30 | There are currently two modes of searching: substring and slop, both with case sensitive varieties: 31 | ![Demonstration](demonstration.gif) 32 | 33 | Enter selects the current item. 34 | 35 | -------------------------------------------------------------------------------- /src/Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils ( 2 | toLower 3 | , chunkV 4 | , merge 5 | ) where 6 | 7 | import qualified Data.Char as C 8 | import qualified Data.Vector as V 9 | import Prelude hiding (map, any) 10 | import Data.ByteString.Char8 (map, ByteString) 11 | 12 | -- Faster toLower 13 | toLower :: ByteString -> ByteString 14 | toLower b = map lower b 15 | where lower c 16 | | C.isAsciiUpper c = C.toLower c 17 | | otherwise = c 18 | 19 | -- Chunks items into groups 20 | chunkV :: Int -> V.Vector a -> [V.Vector a] 21 | chunkV amt v 22 | | V.null v = [] 23 | | otherwise = c1:(chunkV amt rest) 24 | where (c1, rest) = V.splitAt amt v 25 | 26 | -- Merge facilities for lazy top elements, instead of sorting them all 27 | merge :: Ord b => (a -> b) -> [[a]] -> [a] 28 | merge _ [] = [] 29 | merge _ [a] = a 30 | merge f ss = foldr (merge2 f) [] ss 31 | 32 | merge2 :: Ord b => (a -> b) -> [a] -> [a] -> [a] 33 | merge2 f (a:as) (b:bs) 34 | | f(a) < f(b) = a : merge2 f as (b:bs) 35 | | otherwise = b : merge2 f (a:as) bs 36 | merge2 _ [] rs = rs 37 | merge2 _ rs [] = rs 38 | -------------------------------------------------------------------------------- /src/HfArgs.hs: -------------------------------------------------------------------------------- 1 | module HfArgs ( 2 | compilerOpts, 3 | Flag(..), 4 | ) where 5 | 6 | import System.Console.GetOpt 7 | import Data.Maybe (fromMaybe) 8 | 9 | data Flag = CaseSensitive 10 | | SlopSearch 11 | | SFormat String 12 | | ExecVP 13 | deriving (Show, Eq) 14 | 15 | options :: [OptDescr Flag] 16 | options = [ 17 | Option ['c'] ["case-sensitive"] (NoArg CaseSensitive) "Case-sensitive searching", 18 | Option ['s'] ["slop-search"] (NoArg SlopSearch) "Allow gaps in the search string", 19 | Option ['e'] ["Executes output"] (NoArg ExecVP) "Executes the output of hf as a bash command", 20 | Option ['f'] ["Format the output"] (OptArg strFormat "Output Format") "Format the output" 21 | ] 22 | 23 | strFormat :: Maybe String -> Flag 24 | strFormat f = SFormat $ fromMaybe "{0}" f 25 | 26 | compilerOpts :: [String] -> IO ([Flag], [String]) 27 | compilerOpts argv = 28 | case getOpt Permute options argv of 29 | (o,n,[] ) -> return (o,n) 30 | (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) 31 | where header = "Usage: hf [OPTION...]" 32 | 33 | -------------------------------------------------------------------------------- /hf.cabal: -------------------------------------------------------------------------------- 1 | -- Initial hf.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hf 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: Apache-2.0 9 | license-file: LICENSE 10 | author: Andrew Stanton 11 | maintainer: Refefer@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable hf 19 | --ghc-options: -Wall -O2 -rtsopts -auto-all -caf-all -fforce-recomp -threaded -prof 20 | ghc-options: -Wall -O2 -rtsopts -threaded -fllvm "-with-rtsopts=-N -H1G -A10m" 21 | main-is: Main.hs 22 | -- other-modules: 23 | -- other-extensions: 24 | build-depends: base >=4.7 && <4.9, 25 | bytestring == 0.10.6.0, 26 | edit-distance == 0.2.2.1, 27 | mtl == 2.2.1, 28 | ncurses >= 0.2.11, 29 | parallel == 3.2.0.6, 30 | parsec == 3.1.9, 31 | process == 1.2.3.0, 32 | text == 1.2.1.3, 33 | unix == 2.7.1.0, 34 | vector == 0.10.12.3, 35 | vector-algorithms == 0.7.0.1 36 | 37 | hs-source-dirs: src 38 | default-language: Haskell2010 39 | -------------------------------------------------------------------------------- /src/SimpleFormatter.hs: -------------------------------------------------------------------------------- 1 | module SimpleFormatter ( 2 | fauxLookup, 3 | format 4 | ) where 5 | 6 | import Data.List (find) 7 | import Data.Maybe (fromMaybe) 8 | import Text.Parsec (Parsec, parse, char, many1, digit, alphaNum, noneOf, (<|>), eof) 9 | 10 | type SParsec u = Parsec String () u 11 | type FauxMap = [(String, String)] 12 | 13 | data Expr = Env String 14 | | Pos Int 15 | | Raw String 16 | deriving (Show, Eq) 17 | 18 | data FormatArgs = FormatArgs FauxMap [String] deriving (Show, Eq) 19 | 20 | pos :: SParsec Expr 21 | pos = do 22 | _ <- char '{' 23 | digits <- many1 digit 24 | _ <- char '}' 25 | return $ Pos (read digits) 26 | 27 | env :: SParsec Expr 28 | env = do 29 | _ <- char '$' 30 | name <- many1 alphaNum 31 | return $ Env name 32 | 33 | raw :: SParsec Expr 34 | raw = do 35 | other <- many1 $ noneOf ['$', '{'] 36 | return $ Raw other 37 | 38 | someEOF :: SParsec [a] 39 | someEOF = do 40 | eof 41 | return [] 42 | 43 | simpleFormat :: SParsec [Expr] 44 | simpleFormat = do 45 | exprs <- (many1 $ raw <|> env <|> pos) <|> someEOF 46 | return exprs 47 | 48 | parseF :: String -> Maybe [Expr] 49 | parseF s = case (parse simpleFormat "(source)" s) of 50 | Right exps -> Just exps 51 | _ -> Nothing 52 | 53 | fauxLookup :: String -> FauxMap -> Maybe String 54 | fauxLookup k = fmap snd . find keyF 55 | where keyF (k2,_) = k2 == k 56 | 57 | rawFormat :: [Expr] -> FormatArgs -> [String] 58 | rawFormat [] _ = [] 59 | rawFormat (x:xs) fa@(FormatArgs fenv fargs) = item:(rawFormat xs fa) 60 | where formatExpr (Raw s) = s 61 | formatExpr (Pos p) = fargs !! p 62 | formatExpr (Env n) = fromMaybe "" $ fauxLookup n fenv 63 | item = formatExpr x 64 | 65 | -- String to format, user Arguments 66 | format :: String -> [String] -> FauxMap -> String 67 | format str as envs = concat $ rawFormat parsed fargs 68 | where parsed = fromMaybe [] $ parseF str 69 | fargs = FormatArgs envs as 70 | 71 | -------------------------------------------------------------------------------- /src/ResultSet.hs: -------------------------------------------------------------------------------- 1 | module ResultSet ( 2 | build 3 | , ResultSet(..) 4 | , Results 5 | ) where 6 | 7 | import Control.Parallel.Strategies 8 | import Control.Monad 9 | import Control.Monad.ST 10 | import Data.Maybe (isJust) 11 | import qualified Data.ByteString.Char8 as B 12 | import qualified Data.Vector as V 13 | import qualified Data.Vector.Mutable as MV 14 | import Data.Vector.Algorithms.Intro (sort) 15 | import Scorer 16 | import Utils (merge, chunkV) 17 | 18 | type ScoredList = V.Vector (Double, B.ByteString) 19 | 20 | data Results = ParVec [ScoredList] 21 | deriving (Show, Eq) 22 | 23 | class ResultSet a where 24 | size :: a -> Int 25 | items :: a -> [B.ByteString] 26 | refine :: ScoreStrategy s => a -> s -> a 27 | 28 | instance ResultSet Results where 29 | size (ParVec sl) = sum . fmap V.length $ sl 30 | items (ParVec sl) = fmap snd . merge fst . fmap V.toList $ sl 31 | 32 | refine (ParVec sl) sc = ParVec newSet 33 | where rl = fmap (fmap snd) sl 34 | newSet = scoreRL (score sc) rl 35 | 36 | -- Create 37 | build :: [B.ByteString] -> Results 38 | build lst = ParVec chunks 39 | where initVec = V.fromList $ zip [1..] lst 40 | len = length lst 41 | chunkSize = fst . divMod len $ 5000 42 | chunks = chunkV (chunkSize + 1) $ initVec 43 | 44 | -- Score line accordingly 45 | scoreRL :: Scorer -> [V.Vector B.ByteString] -> [ScoredList] 46 | scoreRL f rl = parMap rdeepseq cms rl 47 | where fo x = fmap (\i -> (i, x)) $ f x 48 | cms x = runST $ do 49 | let remaining = V.filter isJust . fmap fo $ x 50 | let vsize = V.length remaining 51 | -- Copy the array to a mutable one 52 | mv <- MV.new vsize 53 | 54 | forM_ [0..(vsize - 1)] $ \idx -> do 55 | e <- V.indexM remaining idx 56 | case e of 57 | Just el -> MV.write mv idx el 58 | _ -> return () 59 | 60 | -- Sort 61 | sort mv 62 | V.unsafeFreeze mv 63 | 64 | -------------------------------------------------------------------------------- /src/Write.hs: -------------------------------------------------------------------------------- 1 | module Write ( 2 | Justify(..) 3 | , Row(..) 4 | , ExactWrite(..) 5 | , Write 6 | , simple 7 | , split 8 | , content 9 | , constrain 10 | ) where 11 | 12 | data Justify = LJustify 13 | | RJustify 14 | | Column Int 15 | | LeftRelative Write 16 | | RightRelative Write 17 | deriving (Show, Eq) 18 | 19 | data Row = Line Int 20 | | Bottom 21 | | Top 22 | deriving (Show, Eq) 23 | 24 | data Write = RelWrite { justify :: Justify 25 | , row :: Row 26 | , contents :: String 27 | } 28 | | EWrite ExactWrite 29 | deriving (Show, Eq) 30 | 31 | data ExactWrite = ExactWrite (Int, Int) String deriving (Show, Eq) 32 | 33 | -- Simple Write 34 | simple :: Justify -> Row -> String -> Write 35 | simple j r s = RelWrite j r s 36 | 37 | -- get string contents 38 | content :: Write -> String 39 | content (RelWrite _ _ s) = s 40 | content (EWrite(ExactWrite _ s)) = s 41 | 42 | -- Given dimensions, constrains writes to within that range 43 | constrain :: (Int, Int) -> Write -> Maybe ExactWrite 44 | 45 | constrain coords@(r,_) w@(RelWrite _ Bottom _) = constrain coords nw 46 | where nw = w { row = Line (r - 1) } 47 | 48 | constrain coords w@(RelWrite (LeftRelative ow) _ _) = do 49 | (ExactWrite (_,col) s) <- constrain coords ow 50 | constrain coords w { justify = Column (col + (length s)) } 51 | 52 | constrain coords w@(RelWrite (RightRelative ow) _ s) = do 53 | (ExactWrite (_,col) _) <- constrain coords ow 54 | constrain coords w { justify = Column (col - (length s)) } 55 | 56 | constrain coords w@(RelWrite _ Top _) = constrain coords nw 57 | where nw = w { row = Line 0 } 58 | 59 | constrain coords w@(RelWrite LJustify _ _) = constrain coords nw 60 | where nw = w { justify = Column 0 } 61 | 62 | constrain coords@(_,c) w@(RelWrite RJustify _ s) = constrain coords nw 63 | where col = fromIntegral . max 0 $ c - (length s) - 1 64 | nw = w { justify = Column col } 65 | 66 | constrain coords (RelWrite (Column off) (Line line) s) = constrain coords ew 67 | where ew = EWrite $ ExactWrite (line, off) s 68 | 69 | constrain (r,c) (EWrite (ExactWrite (line, off) s)) 70 | | line >= r = Nothing 71 | | off >= (c + 1) = Nothing 72 | | otherwise = Just $ ExactWrite (line, off) (take (c - off - 1) s) 73 | 74 | -- Splits a Write at the given index 75 | split :: Int -> Write -> (Write, Write) 76 | split idx rw@(RelWrite RJustify _ s) = splitRight rw $ splitAt idx s 77 | split idx rw@(RelWrite (RightRelative _) _ s) = splitRight rw $ splitAt idx s 78 | split idx rw@(RelWrite _ _ s) = splitLeft rw $ splitAt idx s 79 | split idx (EWrite (ExactWrite c s)) = (leftEW, rightEW) 80 | where (leftS, rightS) = splitAt idx s 81 | leftEW = EWrite (ExactWrite c leftS) 82 | rightEW = RelWrite (LeftRelative leftEW) (Line (fst c)) rightS 83 | 84 | splitLeft :: Write -> (String, String) -> (Write, Write) 85 | splitLeft w (leftS, rightS) = (leftEW, rightEW) 86 | where leftEW = w { contents = leftS } 87 | rightEW = w { justify = LeftRelative leftEW, contents = rightS } 88 | 89 | splitRight :: Write -> (String, String) -> (Write, Write) 90 | splitRight w (leftS, rightS) = (leftEW, rightEW) 91 | where rightEW = w { contents = rightS } 92 | leftEW = w { justify = RightRelative rightEW, contents = leftS } 93 | 94 | -------------------------------------------------------------------------------- /src/Scorer.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | module Scorer ( 3 | ScoreStrat(..) 4 | , ScoreStrategy(..) 5 | , liftSS 6 | , Scorer 7 | , CQuery 8 | , variance 9 | ) where 10 | 11 | import Prelude hiding (break) 12 | import qualified Data.ByteString.Char8 as B 13 | import Control.Applicative 14 | import Data.Maybe (catMaybes) 15 | import Text.EditDistance (levenshteinDistance, defaultEditCosts) 16 | import Utils (toLower) 17 | 18 | data ScoreStrat = EditDist 19 | | InfixLength 20 | | SlopLength 21 | | CILength ScoreStrat 22 | deriving (Show, Eq) 23 | 24 | data EditDistC = EditDistC String 25 | data InfixLengthC = InfixLengthC B.ByteString Int 26 | data SlopLengthC = SlopLengthC ([Int] -> Double) B.ByteString 27 | 28 | data CQuery = EditStrat EditDistC 29 | | InfixStrat InfixLengthC 30 | | SlopStrat SlopLengthC 31 | | CIStrat CQuery 32 | 33 | type Scorer = B.ByteString -> Maybe Double 34 | 35 | class ScoreStrategy a where 36 | -- Takes a query and a title and scores whether or not it matches 37 | score :: a -> Scorer 38 | -- Indicates the bounding area of the query 39 | range :: a -> B.ByteString -> Maybe [(Int, Int)] 40 | 41 | instance ScoreStrategy CQuery where 42 | score (EditStrat e) = score e 43 | score (InfixStrat ilc) = score ilc 44 | score (SlopStrat l) = score l 45 | score (CIStrat cs) = score cs . toLower 46 | 47 | range (EditStrat e) = range e 48 | range (InfixStrat ilc) = range ilc 49 | range (SlopStrat l) = range l 50 | range (CIStrat cs) = range cs . toLower 51 | 52 | instance ScoreStrategy EditDistC where 53 | score (EditDistC [c]) t 54 | | B.elem c t = Just $ tlen - 1 55 | | otherwise = Nothing 56 | where tlen = fromIntegral . B.length $ t 57 | 58 | score (EditDistC qs) t = Just $ fromIntegral . min dist $ (tlen - 1) 59 | where tlen = B.length t 60 | raw_t = B.unpack t 61 | dist = levenshteinDistance defaultEditCosts qs raw_t 62 | 63 | range _ _ = Nothing 64 | 65 | instance ScoreStrategy InfixLengthC where 66 | 67 | score (InfixLengthC c 1) t 68 | | B.isInfixOf c t = Just $ fromIntegral $ 1 + (B.length t) 69 | | otherwise = Nothing 70 | 71 | score (InfixLengthC qs _) t 72 | | B.isInfixOf qs t = Just $ lenScore + prefScore + suffScore 73 | | otherwise = Nothing 74 | where tLen = fromIntegral . B.length $ t 75 | lenScore = tLen ** 0.5 76 | prefScore = if B.isPrefixOf qs t then -0.5 else 0 77 | suffScore = if B.isSuffixOf qs t then -1 else 0 78 | 79 | range (InfixLengthC "" _) _ = Nothing 80 | range (InfixLengthC qs qsl) t = do 81 | let (leftS, rightS) = B.breakSubstring qs t 82 | let len = B.length leftS 83 | case rightS of 84 | "" -> Nothing 85 | _ -> Just $ [(len, len + qsl)] 86 | 87 | instance ScoreStrategy SlopLengthC where 88 | 89 | score (SlopLengthC f qs) t = do 90 | scores <- fmap (fmap fromIntegral) $ findQ qs t 91 | let total = f $ if null scores then [] else init scores 92 | let lenScore = (fromIntegral . B.length $ t) ** 0.5 93 | return $ lenScore + total 94 | 95 | range (SlopLengthC _ "") _ = Nothing 96 | range (SlopLengthC _ qs) t = do 97 | locs <- fmap reverse $ findQ qs t 98 | let indexes = scanl (+) 0 locs 99 | --let total = case locs of 100 | -- [] -> (0, 0) 101 | -- (x:xs) -> (x-1, x + (sum xs)) 102 | return [(idx - 1, idx) | idx <- indexes] 103 | 104 | variance :: [Int] -> Double 105 | variance [] = 0.0 106 | variance xs = (sum . diff $ total) / (tLen) 107 | where ixs = fmap fromIntegral xs 108 | total = sum ixs 109 | diff t = fmap (\x -> (x - t) ** 2) ixs 110 | tLen = fromIntegral $ length xs 111 | 112 | findQ :: B.ByteString -> B.ByteString -> Maybe [Int] 113 | findQ qs t = sequence . loop t qs $ [] 114 | where break r c = case B.break (== c) r of 115 | (_, "") -> (Nothing, "") 116 | (h, rest) -> (Just (B.length h + 1), B.drop 1 rest) 117 | 118 | loop :: B.ByteString -> B.ByteString -> [Maybe Int] -> [Maybe Int] 119 | loop remT qss acc 120 | | B.null qss = acc 121 | | otherwise = case break remT (B.head qss) of 122 | (s, rest) -> loop rest (B.tail qss) (s:acc) 123 | 124 | instance (ScoreStrategy a) => ScoreStrategy [a] where 125 | score [x] t = score x t 126 | score xs t = do 127 | scores <- sequence $ score <$> xs <*> (return t) 128 | return $ sum scores 129 | 130 | range [x] t = range x t 131 | range xs t = do 132 | case catMaybes $ range <$> xs <*> (return t) of 133 | [] -> Nothing 134 | as -> return . concat $ as 135 | 136 | liftSS :: ScoreStrat -> String -> CQuery 137 | liftSS EditDist q = EditStrat $ EditDistC q 138 | liftSS InfixLength q = InfixStrat $ InfixLengthC (B.pack q) (length q) 139 | liftSS SlopLength q = SlopStrat . SlopLengthC variance . B.pack $ q 140 | liftSS (CILength ss) q = CIStrat $ liftSS ss (B.unpack . toLower . B.pack $ q) 141 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# Language OverloadedStrings #-} 2 | module Main where 3 | 4 | --import Debug.Trace (trace) 5 | import Data.Bits ((.&.)) 6 | import Data.Maybe (catMaybes, fromMaybe) 7 | import GHC.IO.Handle (hDuplicateTo, hDuplicate) 8 | import qualified Data.ByteString.Char8 as B 9 | import Prelude hiding (sequence) 10 | import System.Environment (getArgs, getEnvironment) 11 | import System.IO (stdin, stdout, stderr, hSetBuffering, openFile, 12 | IOMode( ReadMode ), BufferMode ( NoBuffering ) ) 13 | import System.Posix (executeFile, getFdStatus, fileMode) 14 | import System.Process (waitForProcess, createProcess, CreateProcess(std_out), shell, StdStream( CreatePipe )) 15 | import UI.NCurses 16 | 17 | import Scorer 18 | import HfArgs (compilerOpts, Flag(..)) 19 | import SimpleFormatter 20 | import Write 21 | import ResultSet 22 | 23 | data Query = Query { q :: String 24 | } 25 | deriving (Show, Eq) 26 | 27 | data QueriedSet = QueriedSet { query :: Query 28 | , strat :: ScoreStrat 29 | , results :: Results 30 | } 31 | deriving (Show, Eq) 32 | 33 | data SystemState = SystemState { current :: QueriedSet 34 | , history :: [QueriedSet] 35 | , cursorPos :: Int 36 | , rCount :: Int 37 | } deriving (Show, Eq) 38 | 39 | data Terminal = Exit 40 | | Updated SystemState 41 | | Selected B.ByteString 42 | deriving (Show, Eq) 43 | 44 | data AttrWrite = AttrWrite { write :: Write 45 | , attrs :: [Attribute] 46 | , highlighted :: Bool 47 | } deriving (Show, Eq) 48 | 49 | type UIFunc = SystemState -> Curses (Maybe B.ByteString) 50 | 51 | iSimple :: Justify -> Row -> String -> AttrWrite 52 | iSimple j r s = AttrWrite (simple j r s) [] False 53 | 54 | main :: IO () 55 | main = do 56 | flags <- getArgs >>= fmap fst . compilerOpts 57 | ss <- getStrat flags 58 | res <- readLines 59 | bs <- initUI $ SystemState (QueriedSet (Query "") ss res) [] 0 (size res) 60 | env <- getEnvironment 61 | let retval = fmap (formatOutput env flags . B.unpack) bs 62 | case retval of 63 | Nothing -> return () 64 | Just s -> if ExecVP `elem` flags 65 | then simpleExec env s 66 | else putStrLn s 67 | 68 | -- Execvp into the editor 69 | simpleExec :: [(String, String)] -> String -> IO () 70 | simpleExec fm s = case words s of 71 | [x] -> executeFile (fromMaybe "vim" $ fauxLookup "EDITOR" fm) True [x] (Just fm) 72 | (x:xs) -> executeFile x True xs (Just fm) 73 | -- Hmm, should never get here. Need to encode that 74 | [] -> return () 75 | 76 | -- Format according to the format string 77 | formatOutput :: [(String, String)] -> [Flag] -> String -> String 78 | formatOutput _ [] o = o 79 | formatOutput env ((SFormat sf):_) o = format sf (o:pieces) env 80 | where pieces = words o 81 | formatOutput env (_:xs) o = formatOutput env xs o 82 | 83 | readLines :: IO Results 84 | readLines = do 85 | piped <- isPiped 86 | bLines <- if piped 87 | then readLinesStdin 88 | else runFind "." 89 | return $ build bLines 90 | 91 | runFind :: FilePath -> IO [B.ByteString] 92 | runFind dir = do 93 | let cmd = concat ["find ", dir, " -type f"] 94 | -- I can't seem to get proc to correctly build the args, so using shell 95 | (_, Just hout, _, ph) <- createProcess (shell cmd) { std_out = CreatePipe} 96 | input <- fmap B.lines . B.hGetContents $ hout 97 | _ <- waitForProcess ph 98 | return input 99 | 100 | -- Check if our stdin is piped. conversion song and dance 101 | isPiped :: IO Bool 102 | isPiped = do 103 | -- Normally, I'd like to call something like handleToFd on stdin, but 104 | -- that has the side effect of closing the handle 105 | fs <- getFdStatus 0 106 | -- Have to mask the filemode 107 | let fm = (fileMode fs) .&. 61440 108 | -- 4096, on linux at least, indicates the input is fifo 109 | let piped = fm .&. 4096 110 | return $ 0 /= piped 111 | 112 | -- Read lines from stdin 113 | readLinesStdin :: IO [B.ByteString] 114 | readLinesStdin = do 115 | inp <- B.getContents 116 | reOpenStdin 117 | return . B.lines $ inp 118 | 119 | -- Have to reopen stdin since getContents closes it 120 | reOpenStdin :: IO () 121 | reOpenStdin = do 122 | tty <- openFile "/dev/tty" ReadMode 123 | hSetBuffering tty NoBuffering 124 | hDuplicateTo tty stdin 125 | 126 | -- Run the Curses UI 127 | initUI :: SystemState -> IO (Maybe B.ByteString) 128 | initUI rs = do 129 | redirect . runCurses $ do 130 | w <- defaultWindow 131 | cid <- newColorID ColorGreen ColorDefault 1 132 | ui w cid rs 133 | 134 | -- Redirects the stdout to stderr 135 | redirect :: IO a -> IO a 136 | redirect io = do 137 | oldStdout <- hDuplicate stdout 138 | hDuplicateTo stderr stdout 139 | res <- io 140 | hDuplicateTo oldStdout stdout 141 | return res 142 | 143 | ui :: Window -> ColorID -> UIFunc 144 | ui w cid ss@(SystemState r _ cp rc) = do 145 | coords <- iScreenSize 146 | let top_items = take ((fst coords) - 2) . printTopItems $ r 147 | renderWith w $ do 148 | clearScreen coords 149 | let item_set = updateAt boldWrite cp top_items 150 | applyWrites cid coords $ concat [ 151 | item_set >>= (highlight r), 152 | [printStatus rc r], 153 | [printQuery . query $ r] 154 | ] 155 | event <- readInput w 156 | -- We grab it again in case they resized their screen 157 | c2 <- iScreenSize 158 | renderWith w $ applyWrites cid c2 [iSimple LJustify Bottom "Searching..."] 159 | updateState ss (length top_items) event (ui w cid) 160 | where renderWith win up = updateWindow win up >> render 161 | 162 | -- Handles updating the system state 163 | updateState :: SystemState -> Int -> Event -> UIFunc -> Curses (Maybe B.ByteString) 164 | updateState ss itemCount event f = case processEvent ss event of 165 | Exit -> return Nothing 166 | Selected bs -> return $ Just bs 167 | Updated newSs -> do 168 | let newCP = min (itemCount - 1) (cursorPos newSs) 169 | let safeSs = newSs {cursorPos = newCP} 170 | f safeSs 171 | 172 | -- Update an element in the list at the given index 173 | updateAt :: (a -> a) -> Int -> [a] -> [a] 174 | updateAt f idx = loop idx 175 | where loop _ [] = [] 176 | loop 0 (x:xs) = (f x):xs 177 | loop i (x:xs) = x:(loop (i - 1) xs) 178 | 179 | -- Because Integers are inconvenient 180 | iScreenSize :: Curses (Int, Int) 181 | iScreenSize = do 182 | (r, c) <- screenSize 183 | return (fromIntegral r, fromIntegral c) 184 | 185 | -- Evaluates the Writes 186 | applyWrites :: ColorID -> (Int, Int) -> [AttrWrite] -> Update () 187 | applyWrites cid c ws = do 188 | let realWrites = catMaybes . fmap (constrainAW c) $ ws 189 | mapM_ (displayWrite cid) realWrites 190 | 191 | -- Constrains based on AttrWrite 192 | constrainAW :: (Int, Int) -> AttrWrite -> Maybe ([Attribute], Bool, ExactWrite) 193 | constrainAW coords (AttrWrite e atts hled) = do 194 | ew <- constrain coords e 195 | return (atts, hled, ew) 196 | 197 | -- Write it out 198 | displayWrite :: ColorID -> ([Attribute], Bool, ExactWrite) -> Update () 199 | displayWrite cid (atts, hl, (ExactWrite (r, col) s)) = do 200 | moveCursor (fromIntegral r) (fromIntegral col) 201 | applyColor cid hl $ applyAttributes atts $ drawString s 202 | 203 | -- Apply an attribute for a given amount 204 | applyAttributes :: [Attribute] -> Update () -> Update () 205 | applyAttributes atts up = do 206 | setAttrs True atts 207 | up 208 | setAttrs False atts 209 | where setAttrs b = mapM_ ((flip setAttribute) b) 210 | 211 | applyColor :: ColorID -> Bool -> Update () -> Update () 212 | applyColor _ False up = up 213 | applyColor cid _ up = do 214 | setColor cid 215 | up 216 | setColor defaultColorID 217 | 218 | -- We don't have a clear screen in this version of the library, so write one 219 | clearScreen :: (Int, Int) -> Update () 220 | clearScreen (rows, cols) = do 221 | let coords = [(fromIntegral r, fromIntegral c) | r <- [0..(rows - 1)], c <- [0..(cols - 2)]] 222 | let clearPixel (r,c) = (moveCursor r c) >> (drawString " ") 223 | mapM_ clearPixel coords 224 | 225 | -- Reads from input 226 | readInput :: Window -> Curses Event 227 | readInput w = do 228 | ev <- getEvent w . Just $ 1000 -- Nothing doesn't work. 229 | case ev of 230 | Nothing -> readInput w 231 | -- Alt keys 232 | Just (EventCharacter '\ESC') -> do 233 | ev2 <- readInput w 234 | case ev2 of 235 | EventCharacter 'n' -> return $ EventSpecialKey KeyDownArrow 236 | EventCharacter 'p' -> return $ EventSpecialKey KeyUpArrow 237 | _ -> readInput w 238 | 239 | Just ev' -> return ev' 240 | 241 | processEvent :: SystemState -> Event -> Terminal 242 | 243 | -- Delete 244 | processEvent ss (EventSpecialKey KeyBackspace) = case ss of 245 | (SystemState _ (r:rs) _ _) -> Updated $ ss { current = r, history = rs, cursorPos = 0 } 246 | _ -> Updated ss 247 | 248 | -- Down Arrow 249 | processEvent ss (EventSpecialKey KeyDownArrow) = Updated $ newSS 250 | where newSS = ss { cursorPos = (cursorPos ss) + 1 } 251 | 252 | -- Up Arrow 253 | processEvent ss (EventSpecialKey KeyUpArrow) = Updated $ newSS 254 | where newSS = ss { cursorPos = max 0 ((cursorPos ss) - 1) } 255 | 256 | -- Enter 257 | processEvent (SystemState qs _ cp _) (EventCharacter '\n') = res 258 | where res = case (items . results) qs of 259 | [] -> Exit 260 | itemSet -> Selected $ itemSet !! cp 261 | 262 | -- Ctrl D 263 | processEvent _ (EventCharacter '\EOT') = Exit 264 | 265 | -- Add Char 266 | processEvent ss@(SystemState r rs _ _) (EventCharacter c) = Updated newSS 267 | where newQ = addChar . query $ r 268 | sStrat = compileSS (strat r) 269 | newR = refine (results r) . sStrat $ newQ 270 | newQS = r { query = newQ, results = newR } 271 | newSS = ss { current = newQS, history = r:rs, cursorPos = 0 } 272 | addChar (Query qry) = Query (qry ++ [c]) 273 | 274 | processEvent ss _ = Updated ss 275 | 276 | printQuery :: Query -> AttrWrite 277 | printQuery qry = writeAtLine 0 $ "$ " ++ (fmap f . q $ qry) 278 | where f '\t' = '~' 279 | f c = c 280 | 281 | boldWrite :: AttrWrite -> AttrWrite 282 | boldWrite = addAttr AttributeBold 283 | 284 | addAttr :: Attribute -> AttrWrite -> AttrWrite 285 | addAttr attr aw@(AttrWrite _ attrset _) 286 | | attr `elem` attrset = aw 287 | | otherwise = aw { attrs = (attr:attrset) } 288 | 289 | printTopItems :: QueriedSet -> [AttrWrite] 290 | printTopItems = zipWith writeAtLine [1..] . topItems 291 | where topItems = fmap B.unpack . items . results 292 | 293 | printStatus :: Int -> QueriedSet -> AttrWrite 294 | printStatus total = iSimple RJustify Bottom . status . count 295 | where count = show . size . results 296 | status c = "[" ++ c ++ "/" ++ (show total) ++ "]" 297 | 298 | writeAtLine :: Int -> String -> AttrWrite 299 | writeAtLine r = iSimple LJustify (Line r) 300 | 301 | -- Get query as first argument 302 | getStrat :: [Flag] -> IO ScoreStrat 303 | getStrat flags = return $ if CaseSensitive `elem` flags 304 | then ss 305 | else CILength ss 306 | where ss = getSearchStrat flags 307 | 308 | getSearchStrat :: [Flag] -> ScoreStrat 309 | getSearchStrat flags 310 | | SlopSearch `elem` flags = SlopLength 311 | | otherwise = InfixLength 312 | 313 | compileSS :: ScoreStrat -> Query -> [CQuery] 314 | compileSS ss = fmap (liftSS ss) . splitQ 315 | where splitQ = fmap B.unpack . pieces 316 | pieces = B.split '\t' . B.pack . q 317 | 318 | highlight :: QueriedSet -> AttrWrite -> [AttrWrite] 319 | highlight (QueriedSet qry ss _) at = do 320 | let scorer = compileSS ss qry 321 | let res = range scorer . B.pack . content $ write at 322 | maybe [at] (splitWrites at) res 323 | 324 | splitWrites :: AttrWrite -> [(Int, Int)] -> [AttrWrite] 325 | splitWrites atw [] = [atw] 326 | splitWrites atw locs = foldr loop [atw] locs 327 | where loop loc (at:rest) = (splitWrite at loc) ++ rest 328 | loop _ ats = ats 329 | 330 | splitWrite :: AttrWrite -> (Int, Int) -> [AttrWrite] 331 | splitWrite at (lIdx, rIdx) = [lift left, newCenter, lift right] 332 | where w = write at 333 | (remaining, right) = split rIdx w 334 | (left, center) = split lIdx remaining 335 | lift w2 = at { write = w2 } 336 | newCenter = at { write = center, highlighted = True } 337 | --------------------------------------------------------------------------------