--------------------------------------------------------------------------------
-- |
-- Module      : XMonad.Prompt.FuzzyMatch
-- Description : A prompt for fuzzy completion matching in prompts akin to Emacs ido-mode.
-- Copyright   : (C) 2015 Norbert Zeh
-- License     : GPL
--
-- Maintainer  : Norbert Zeh <norbert.zeh@gmail.com>
-- Stability   : unstable
-- Portability : unportable
--
-- A module for fuzzy completion matching in prompts akin to emacs ido mode.
--
--------------------------------------------------------------------------------

module XMonad.Prompt.FuzzyMatch ( -- * Usage
                                  -- $usage
                                  fuzzyMatch
                                , fuzzySort
                                ) where

import XMonad.Prelude
import qualified Data.List.NonEmpty as NE

-- $usage
--
-- This module offers two aspects of fuzzy matching of completions offered by
-- XMonad.Prompt.
--
-- 'fuzzyMatch' can be used as the searchPredicate in the XPConfig.  The effect
-- is that any completion that contains the currently typed characters as a
-- subsequence is a valid completion; matching is case insensitive.  This means
-- that the sequence of typed characters can be obtained from the completion by
-- deleting an appropriate subset of its characters.  Example: "spr" matches
-- "FastSPR" but also "SuccinctParallelTrees" because it's a subsequence of the
-- latter: "S.......P.r..........".
--
-- While this type of inclusiveness is helpful most of the time, it sometimes
-- also produces surprising matches.  'fuzzySort' helps sorting matches by
-- relevance, using a simple heuristic for measuring relevance.  The matches are
-- sorted primarily by the length of the substring that contains the query
-- characters and secondarily the starting position of the match.  So, if the
-- search string is "spr" and the matches are "FastSPR", "FasterSPR", and
-- "SuccinctParallelTrees", then the order is "FastSPR", "FasterSPR",
-- "SuccinctParallelTrees" because both "FastSPR" and "FasterSPR" contain "spr"
-- within a substring of length 3 ("SPR") while the shortest substring of
-- "SuccinctParallelTrees" that matches "spr" is "SuccinctPar", which has length
-- 11.  "FastSPR" is ranked before "FasterSPR" because its match starts at
-- position 5 while the match in "FasterSPR" starts at position 7.
--
-- To use these functions in an XPrompt, for example, for windowPrompt:
--
-- > import XMonad.Prompt
-- > import XMonad.Prompt.Window ( windowPrompt )
-- > import XMonad.Prompt.FuzzyMatch
-- >
-- > myXPConfig = def { searchPredicate = fuzzyMatch
-- >                  , sorter          = fuzzySort
-- >                  }
--
-- then add this to your keys definition:
--
-- > , ((modm .|. shiftMask, xK_g), windowPrompt myXPConfig Goto allWindows)
--
-- For detailed instructions on editing the key bindings, see
-- "XMonad.Doc.Extending#Editing_key_bindings".

-- | Returns True if the first argument is a subsequence of the second argument,
-- that is, it can be obtained from the second sequence by deleting elements.
fuzzyMatch :: String -> String -> Bool
fuzzyMatch :: String -> String -> Bool
fuzzyMatch String
a String
b = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSubsequenceOf ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
a) ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
b)

-- | Sort the given set of strings by how well they match.  Match quality is
-- measured first by the length of the substring containing the match and second
-- by the positions of the matching characters in the string.
fuzzySort :: String -> [String] -> [String]
fuzzySort :: String -> [String] -> [String]
fuzzySort String
q = (((Int, Int), String) -> String)
-> [((Int, Int), String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Int), String) -> String
forall a b. (a, b) -> b
snd ([((Int, Int), String)] -> [String])
-> ([String] -> [((Int, Int), String)]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((Int, Int), String)] -> [((Int, Int), String)]
forall a. Ord a => [a] -> [a]
sort ([((Int, Int), String)] -> [((Int, Int), String)])
-> ([String] -> [((Int, Int), String)])
-> [String]
-> [((Int, Int), String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ((Int, Int), String))
-> [String] -> [((Int, Int), String)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> ((Int, Int), String)
rankMatch String
q)

rankMatch :: String -> String -> ((Int, Int), String)
rankMatch :: String -> String -> ((Int, Int), String)
rankMatch String
q String
s = (if [(Int, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int)]
matches then (Int
forall a. Bounded a => a
maxBound, Int
forall a. Bounded a => a
maxBound) else [(Int, Int)] -> (Int, Int)
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [(Int, Int)]
matches, String
s)
  where matches :: [(Int, Int)]
matches = String -> String -> [(Int, Int)]
rankMatches String
q String
s

rankMatches :: String -> String -> [(Int, Int)]
rankMatches :: String -> String -> [(Int, Int)]
rankMatches [] String
_ = [(Int
0, Int
0)]
rankMatches (Char
q:String
qs) String
s = ((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
l, Int
r) -> (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l, Int
l)) ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ NonEmpty Char -> String -> [(Int, Int)]
findShortestMatches (Char
q Char -> String -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:| String
qs) String
s

findShortestMatches :: NonEmpty Char -> String -> [(Int, Int)]
findShortestMatches :: NonEmpty Char -> String -> [(Int, Int)]
findShortestMatches NonEmpty Char
q String
s = ([(Int, Int)] -> [Int] -> [(Int, Int)])
-> [(Int, Int)] -> [[Int]] -> [(Int, Int)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [(Int, Int)] -> [Int] -> [(Int, Int)]
extendMatches [(Int, Int)]
spans [[Int]]
oss
  where ([Int]
os :| [[Int]]
oss) = (Char -> [Int]) -> NonEmpty Char -> NonEmpty [Int]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (String -> Char -> [Int]
findOccurrences String
s) NonEmpty Char
q
        spans :: [(Int, Int)]
spans       = [(Int
o, Int
o) | Int
o <- [Int]
os]

findOccurrences :: String -> Char -> [Int]
findOccurrences :: String -> Char -> [Int]
findOccurrences String
s Char
c = ((Char, Int) -> Int) -> [(Char, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Char, Int) -> Int
forall a b. (a, b) -> b
snd ([(Char, Int)] -> [Int]) -> [(Char, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Char, Int) -> Bool) -> [(Char, Int)] -> [(Char, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) (Char -> Bool) -> ((Char, Int) -> Char) -> (Char, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toLower (Char -> Char) -> ((Char, Int) -> Char) -> (Char, Int) -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, Int) -> Char
forall a b. (a, b) -> a
fst) ([(Char, Int)] -> [(Char, Int)]) -> [(Char, Int)] -> [(Char, Int)]
forall a b. (a -> b) -> a -> b
$ String -> [Int] -> [(Char, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip String
s [Int
0..]

extendMatches :: [(Int, Int)] -> [Int] -> [(Int, Int)]
extendMatches :: [(Int, Int)] -> [Int] -> [(Int, Int)]
extendMatches [(Int, Int)]
spans = ([(Int, Int)] -> (Int, Int)) -> [[(Int, Int)]] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, Int)] -> (Int, Int)
forall a. [a] -> a
last ([[(Int, Int)]] -> [(Int, Int)])
-> ([Int] -> [[(Int, Int)]]) -> [Int] -> [(Int, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> (Int, Int) -> Bool)
-> [(Int, Int)] -> [[(Int, Int)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Int -> Int -> Bool)
-> ((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, Int) -> Int
forall a b. (a, b) -> b
snd) ([(Int, Int)] -> [[(Int, Int)]])
-> ([Int] -> [(Int, Int)]) -> [Int] -> [[(Int, Int)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Int)] -> [Int] -> [(Int, Int)]
extendMatches' [(Int, Int)]
spans

extendMatches' :: [(Int, Int)] -> [Int] -> [(Int, Int)]
extendMatches' :: [(Int, Int)] -> [Int] -> [(Int, Int)]
extendMatches' []                    [Int]
_          = []
extendMatches' [(Int, Int)]
_                     []         = []
extendMatches' spans :: [(Int, Int)]
spans@((Int
l, Int
r):[(Int, Int)]
spans') xs :: [Int]
xs@(Int
x:[Int]
xs') | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
x     = (Int
l, Int
x) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
: [(Int, Int)] -> [Int] -> [(Int, Int)]
extendMatches' [(Int, Int)]
spans' [Int]
xs
                                                | Bool
otherwise = [(Int, Int)] -> [Int] -> [(Int, Int)]
extendMatches' [(Int, Int)]
spans [Int]
xs'