{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

{-|
Module      : FuzzyFind
Description : Provides fuzzy matching on text
Copyright   : Unison Computing, 2021
License     : MIT
Maintainer  : runar.bjarnason@unison.cloud
Stability   : experimental

A package that provides an API for fuzzy text search in Haskell, using a
modified version of the Smith-Waterman algorithm. The search is intended to
behave similarly to the excellent fzf tool by Junegunn Choi.
-}
module Text.FuzzyFind where

import Control.Monad (join)
import Data.Massiv.Array
  ( Array,
    (!),
    Ix2(..),
    (...),
    forM,
    forM_
  )
import qualified Data.Massiv.Array as A
import qualified Data.Massiv.Array.Unsafe as A
import qualified Data.Massiv.Array.Mutable as M
import Data.Char (isAlphaNum, isLower, isUpper, toLower)
import Data.Foldable (maximumBy, toList, foldl')
import Data.Function (on)
import Data.Maybe (fromMaybe)
import GHC.Generics (Generic)
import Data.Text (Text)
import qualified Data.Text as Text
import Control.Monad.ST (runST)
import Data.Sequence
  ( Seq (..),
    ViewL (..),
    ViewR (..),
    viewl,
    viewr,
    (<|)
  )
import qualified Data.Sequence as Seq


-- | @bestMatch query string@ will return 'Nothing' if @query@ is not a
-- subsequence of @string@. Otherwise, it will return the "best" way to line up
-- the characters in @query@ with the characters in @string@. Lower-case
-- characters in the @query@ are assumed to be case-insensitive, and upper-case
-- characters are assumed to be case-sensitive.
--
-- For example:
--
-- @
-- > bestMatch "ff" \"FuzzyFind\"
-- Just (Alignment {score = 25, result = Result {[Match \"F\", Gap "uzzy", Match \"F\", Gap "ind"]}})
-- @
--
-- The score indicates how "good" the match is. Better matches have higher
-- scores. There's no maximum score (except for the upper limit of the 'Int'
-- datatype), but the lowest score is @0@.
--
-- A substring from the query will generate a 'Match', and any characters from
-- the input that don't result in a 'Match' will generate a 'Gap'.
-- Concatenating all the 'Match' and 'Gap' results should yield the original
-- input string.
--
-- Note that the matched characters in the input always occur in the same order
-- as they do in the query pattern.
--
-- The algorithm prefers (and will generate higher scores for) the following
-- kinds of matches:
--
--   1. Contiguous characters from the query string. For example, @bestMatch "pp"@
-- will find the last two ps in "pickled pepper".
--   2. Characters at the beginnings of words. For example, @bestMatch "pp"@
-- will find the first two Ps in \"Peter Piper\".
--   3. Characters at CamelCase humps. For example, @bestMatch "bm" \"BatMan\"@
-- will score higher than @bestMatch "bm" \"Batman\".@
--   4. The algorithm strongly prefers the first character of the query pattern
-- to be at the beginning of a word or CamelHump. For example,
-- @bestMatch "mn" \"Bat Man\"@ will score higher than @bestMatch "atn" \"Batman\"@.
--
-- All else being equal, matches that occur later in the input string are preferred.
bestMatch :: String -- ^ The query pattern.
          -> String -- ^ The input string.
          -> Maybe Alignment
bestMatch :: String -> String -> Maybe Alignment
bestMatch = Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> String
-> String
-> Maybe Alignment
bestMatch' Int
defaultMatchScore
                       Int
defaultMismatchScore
                       Int
defaultGapPenalty
                       Int
defaultBoundaryBonus
                       Int
defaultCamelCaseBonus
                       Int
defaultFirstCharBonusMultiplier
                       Int
defaultConsecutiveBonus

-- | Finds input strings that match all the given input patterns. For each input
-- that matches, it returns one 'Alignment'. The output is not sorted.
-- ascending.
--
-- For example:
--
-- @
-- > import Data.Foldable
-- > traverse_ (putStrLn . ("\\n" ++) . highlight) $ fuzzyFind ["dad", "mac", "dam"] ["red macadamia", "Madam Card"]
--
-- Madam Card
-- * *** ** *
--
-- red macadamia
--   * *******
-- @
fuzzyFind
  :: [String] -- ^ The query patterns.
  -> [String] -- ^ The input strings.
  -> [Alignment]
fuzzyFind :: [String] -> [String] -> [Alignment]
fuzzyFind = (((Alignment, String) -> Alignment)
-> [(Alignment, String)] -> [Alignment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Alignment, String) -> Alignment
forall a b. (a, b) -> a
fst ([(Alignment, String)] -> [Alignment])
-> ([String] -> [(Alignment, String)]) -> [String] -> [Alignment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([String] -> [(Alignment, String)]) -> [String] -> [Alignment])
-> ([String] -> [String] -> [(Alignment, String)])
-> [String]
-> [String]
-> [Alignment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String] -> [(Alignment, String)]
forall a. (a -> String) -> [String] -> [a] -> [(Alignment, a)]
fuzzyFindOn String -> String
forall a. a -> a
id

-- | A version of 'fuzzyFind' that searches on the given text field of the data.
fuzzyFindOn :: (a -> String) -> [String] -> [a] -> [(Alignment, a)]
fuzzyFindOn :: (a -> String) -> [String] -> [a] -> [(Alignment, a)]
fuzzyFindOn a -> String
f [String]
query [a]
d =
  [a]
d
    [a] -> (a -> [(Alignment, a)]) -> [(Alignment, a)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\a
s ->
          Maybe (Alignment, a) -> [(Alignment, a)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
            (Maybe (Alignment, a) -> [(Alignment, a)])
-> Maybe (Alignment, a) -> [(Alignment, a)]
forall a b. (a -> b) -> a -> b
$   (, a
s)
            (Alignment -> (Alignment, a))
-> Maybe Alignment -> Maybe (Alignment, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Alignment -> String -> Maybe Alignment)
-> Maybe Alignment -> [String] -> Maybe Alignment
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Maybe Alignment
a String
q -> Alignment -> Alignment -> Alignment
forall a. Semigroup a => a -> a -> a
(<>) (Alignment -> Alignment -> Alignment)
-> Maybe Alignment -> Maybe (Alignment -> Alignment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Alignment
a Maybe (Alignment -> Alignment)
-> Maybe Alignment -> Maybe Alignment
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> Maybe Alignment
bestMatch String
q (a -> String
f a
s))
                       (Alignment -> Maybe Alignment
forall a. a -> Maybe a
Just Alignment
forall a. Monoid a => a
mempty)
                       [String]
query
        )

instance Semigroup Alignment where
  Alignment Int
n Result
r <> :: Alignment -> Alignment -> Alignment
<> Alignment Int
m Result
s = Int -> Result -> Alignment
Alignment (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m) (Result -> Result -> Result
mergeResults Result
r Result
s)

instance Monoid Alignment where
  mempty :: Alignment
mempty = Int -> Result -> Alignment
Alignment Int
0 Result
forall a. Monoid a => a
mempty

type Score = Int

-- | An 'Alignment' is a 'Score' together with a 'Result'. Better results have
-- higher scores.
data Alignment
  = Alignment { Alignment -> Int
score :: !Score, Alignment -> Result
result :: !Result }
  deriving (Alignment -> Alignment -> Bool
(Alignment -> Alignment -> Bool)
-> (Alignment -> Alignment -> Bool) -> Eq Alignment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Alignment -> Alignment -> Bool
$c/= :: Alignment -> Alignment -> Bool
== :: Alignment -> Alignment -> Bool
$c== :: Alignment -> Alignment -> Bool
Eq, Eq Alignment
Eq Alignment
-> (Alignment -> Alignment -> Ordering)
-> (Alignment -> Alignment -> Bool)
-> (Alignment -> Alignment -> Bool)
-> (Alignment -> Alignment -> Bool)
-> (Alignment -> Alignment -> Bool)
-> (Alignment -> Alignment -> Alignment)
-> (Alignment -> Alignment -> Alignment)
-> Ord Alignment
Alignment -> Alignment -> Bool
Alignment -> Alignment -> Ordering
Alignment -> Alignment -> Alignment
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Alignment -> Alignment -> Alignment
$cmin :: Alignment -> Alignment -> Alignment
max :: Alignment -> Alignment -> Alignment
$cmax :: Alignment -> Alignment -> Alignment
>= :: Alignment -> Alignment -> Bool
$c>= :: Alignment -> Alignment -> Bool
> :: Alignment -> Alignment -> Bool
$c> :: Alignment -> Alignment -> Bool
<= :: Alignment -> Alignment -> Bool
$c<= :: Alignment -> Alignment -> Bool
< :: Alignment -> Alignment -> Bool
$c< :: Alignment -> Alignment -> Bool
compare :: Alignment -> Alignment -> Ordering
$ccompare :: Alignment -> Alignment -> Ordering
$cp1Ord :: Eq Alignment
Ord, Int -> Alignment -> String -> String
[Alignment] -> String -> String
Alignment -> String
(Int -> Alignment -> String -> String)
-> (Alignment -> String)
-> ([Alignment] -> String -> String)
-> Show Alignment
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Alignment] -> String -> String
$cshowList :: [Alignment] -> String -> String
show :: Alignment -> String
$cshow :: Alignment -> String
showsPrec :: Int -> Alignment -> String -> String
$cshowsPrec :: Int -> Alignment -> String -> String
Show, (forall x. Alignment -> Rep Alignment x)
-> (forall x. Rep Alignment x -> Alignment) -> Generic Alignment
forall x. Rep Alignment x -> Alignment
forall x. Alignment -> Rep Alignment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Alignment x -> Alignment
$cfrom :: forall x. Alignment -> Rep Alignment x
Generic)

-- | The base score given to a matching character
defaultMatchScore :: Int
defaultMatchScore :: Int
defaultMatchScore = Int
16

-- | The base score given to a mismatched character
defaultMismatchScore :: Int
defaultMismatchScore :: Int
defaultMismatchScore = Int
0

-- | Bonus points given to characters matching at the beginning of words
defaultBoundaryBonus :: Int
defaultBoundaryBonus :: Int
defaultBoundaryBonus = Int
defaultMatchScore Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

-- | Bonus points given to characters matching a hump of a CamelCase word.
-- We subtract a point from the word boundary score, since a word boundary will
-- incur a gap penalty.
defaultCamelCaseBonus :: Int
defaultCamelCaseBonus :: Int
defaultCamelCaseBonus = Int
defaultBoundaryBonus Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

-- | Double any bonus points for matching the first pattern of the character.
-- This way we strongly prefer starting the match at the beginning of a word.
defaultFirstCharBonusMultiplier :: Int
defaultFirstCharBonusMultiplier :: Int
defaultFirstCharBonusMultiplier = Int
2

-- | We prefer consecutive runs of matched characters in the pattern, so we
-- impose a penalty for any gaps, which is added to the size of the gap.
defaultGapPenalty :: Int
defaultGapPenalty :: Int
defaultGapPenalty = Int
3

-- | We give a bonus to consecutive matching characters.
-- A number about the same as the boundary bonus will prefer
-- runs of consecutive characters vs finding acronyms.
defaultConsecutiveBonus :: Int
defaultConsecutiveBonus :: Int
defaultConsecutiveBonus = Int
11

segmentToString :: ResultSegment -> String
segmentToString :: ResultSegment -> String
segmentToString (Gap   String
xs) = String
xs
segmentToString (Match String
xs) = String
xs

-- | Renders an 'Alignment' as a pair of lines with "*" on the lower line
-- indicating the location of pattern matches.
highlight :: Alignment -> String
highlight :: Alignment -> String
highlight (Alignment Int
s (Result Seq ResultSegment
segments)) =
  (ResultSegment -> String) -> Seq ResultSegment -> String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ResultSegment -> String
segmentToString Seq ResultSegment
segments String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (ResultSegment -> String) -> Seq ResultSegment -> String
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ResultSegment -> String
showGaps Seq ResultSegment
segments
 where
  showGaps :: ResultSegment -> String
showGaps (Gap   String
xs) = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) Char
' '
  showGaps (Match String
xs) = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xs) Char
'*'

highlight' :: Alignment -> Text
highlight' :: Alignment -> Text
highlight' = String -> Text
Text.pack (String -> Text) -> (Alignment -> String) -> Alignment -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alignment -> String
highlight

-- | A highly configurable version of 'bestMatch'.
bestMatch'
  :: Int -- ^ Base score for a matching character. See 'defaultMatchScore'.
  -> Int -- ^ Base score for a mismatched character. See 'defaultMismatchScore'.
  -> Int -- ^ Additional penalty for a gap. See 'defaultGapPenalty'.
  -> Int -- ^ Bonus score for a match at the beginning of a word. See 'defaultBoundaryBonus'.
  -> Int -- ^ Bonus score for a match on a CamelCase hump. See 'defaultCamelCaseBonus'.
  -> Int -- ^ Bonus multiplier for matching the first character of the pattern.
         --   See 'defaultFirstCharBonusMultiplier'.
  -> Int -- ^ Bonus score for each consecutive character matched.
         --   See 'defaultFirstCharBonusMultiplier'.
  -> String -- ^ The query pattern.
  -> String -- ^ The input string.
  -> Maybe Alignment
bestMatch' :: Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> String
-> String
-> Maybe Alignment
bestMatch' Int
matchScore Int
mismatchScore Int
gapPenalty Int
boundaryBonus Int
camelCaseBonus Int
firstCharBonusMultiplier Int
consecutiveBonus String
query String
str
  = Int -> Result -> Alignment
Alignment (Int -> Int -> Int
totalScore Int
m Int
nx) (Result -> Alignment)
-> ([ResultSegment] -> Result) -> [ResultSegment] -> Alignment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq ResultSegment -> Result
Result (Seq ResultSegment -> Result)
-> ([ResultSegment] -> Seq ResultSegment)
-> [ResultSegment]
-> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ResultSegment] -> Seq ResultSegment
forall a. [a] -> Seq a
Seq.fromList) ([ResultSegment] -> Alignment)
-> Maybe [ResultSegment] -> Maybe Alignment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [ResultSegment]
traceback
 where
  totalScore :: Int -> Int -> Int
totalScore Int
i Int
j =
    if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
m then Int
0 else (Array U Ix2 Int -> Ix2 -> Int
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Ix2 Int
hs (Int
i Int -> Int -> Ix2
:. Int
j)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Array U Ix2 Int -> Ix2 -> Int
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Ix2 Int
bonuses (Int
i Int -> Int -> Ix2
:. Int
j))
  -- table = unlines
  --   [ unwords
  --     $ (if y > 0 then show $ str' ! y else "   ")
  --     : [ show (totalScore x y) | x <- [0 .. m] ]
  --   | y <- [0 .. n]
  --   ]
  similarity :: Char -> Char -> Int
similarity Char
a Char
b =
    if Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
b Bool -> Bool -> Bool
|| Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Char
toLower Char
b then Int
matchScore else Int
mismatchScore
  traceback :: Maybe [ResultSegment]
  traceback :: Maybe [ResultSegment]
traceback = [ResultSegment]
-> String -> Integer -> Int -> Int -> Maybe [ResultSegment]
forall t.
(Eq t, Num t) =>
[ResultSegment]
-> String -> t -> Int -> Int -> Maybe [ResultSegment]
go [String -> ResultSegment
Gap (String -> ResultSegment) -> String -> ResultSegment
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
nx String
str] [] (-Integer
1) Int
m Int
nx
  go :: [ResultSegment]
-> String -> t -> Int -> Int -> Maybe [ResultSegment]
go [ResultSegment]
r String
m t
currOp Int
0 Int
j = (String -> ResultSegment
Gap (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
j String
str) ResultSegment -> [ResultSegment] -> [ResultSegment]
forall a. a -> [a] -> [a]
:) ([ResultSegment] -> [ResultSegment])
-> Maybe [ResultSegment] -> Maybe [ResultSegment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case String
m of
    [] -> [ResultSegment] -> Maybe [ResultSegment]
forall a. a -> Maybe a
Just [ResultSegment]
r
    String
_  -> case t
currOp of
      t
1  -> [ResultSegment] -> Maybe [ResultSegment]
forall a. a -> Maybe a
Just (String -> ResultSegment
Match String
m ResultSegment -> [ResultSegment] -> [ResultSegment]
forall a. a -> [a] -> [a]
: [ResultSegment]
r)
      t
0  -> [ResultSegment] -> Maybe [ResultSegment]
forall a. a -> Maybe a
Just (String -> ResultSegment
Gap String
m ResultSegment -> [ResultSegment] -> [ResultSegment]
forall a. a -> [a] -> [a]
: [ResultSegment]
r)
      -1 -> Maybe [ResultSegment]
forall a. Maybe a
Nothing
  go [ResultSegment]
_ String
_ t
_ Int
_ Int
0 = Maybe [ResultSegment]
forall a. Maybe a
Nothing
  go [ResultSegment]
r String
m t
currOp Int
i Int
j =
    if Char -> Char -> Int
similarity (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
query' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then case t
currOp of
        t
0 ->
          [ResultSegment]
-> String -> t -> Int -> Int -> Maybe [ResultSegment]
go (String -> ResultSegment
Gap String
m ResultSegment -> [ResultSegment] -> [ResultSegment]
forall a. a -> [a] -> [a]
: [ResultSegment]
r) [Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] t
1 (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        t
_ -> [ResultSegment]
-> String -> t -> Int -> Int -> Maybe [ResultSegment]
go [ResultSegment]
r (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char -> String -> String
forall a. a -> [a] -> [a]
: String
m) t
1 (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      else case t
currOp of
        t
1 -> [ResultSegment]
-> String -> t -> Int -> Int -> Maybe [ResultSegment]
go (String -> ResultSegment
Match String
m ResultSegment -> [ResultSegment] -> [ResultSegment]
forall a. a -> [a] -> [a]
: [ResultSegment]
r) [Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] t
0 Int
i (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        t
_ -> [ResultSegment]
-> String -> t -> Int -> Int -> Maybe [ResultSegment]
go [ResultSegment]
r (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char -> String -> String
forall a. a -> [a] -> [a]
: String
m) t
0 Int
i (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  nx :: Int
nx = Int -> Int -> Int -> Int -> Int -> Int
localMax Int
m Int
n Int
1 Int
0 Int
0
  localMax :: Int -> Int -> Int -> Int -> Int -> Int
localMax Int
m Int
n Int
j Int
r Int
s = if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n
    then Int
r
    else
      let s' :: Int
s' = Int -> Int -> Int
totalScore Int
m Int
j
      in  Int -> Int -> Int -> Int -> Int -> Int
localMax Int
m Int
n (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (if Int
s' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
s then Int
j else Int
r) Int
s'
  query' :: Array U Int Char
query' = Comp -> String -> Array U Int Char
forall r e. Mutable r Int e => Comp -> [e] -> Array r Int e
A.fromList Comp
A.Seq String
query :: Array A.U A.Ix1 Char
  str' :: Array U Int Char
str'   = Comp -> String -> Array U Int Char
forall r e. Mutable r Int e => Comp -> [e] -> Array r Int e
A.fromList Comp
A.Seq String
str :: Array A.U A.Ix1 Char
  m :: Int
m      = Sz Int -> Int
forall ix. Sz ix -> ix
A.unSz (Sz Int -> Int) -> Sz Int -> Int
forall a b. (a -> b) -> a -> b
$ Array U Int Char -> Sz Int
forall r ix e. Load r ix e => Array r ix e -> Sz ix
A.size Array U Int Char
query'
  n :: Int
n      = Sz Int -> Int
forall ix. Sz ix -> ix
A.unSz (Sz Int -> Int) -> Sz Int -> Int
forall a b. (a -> b) -> a -> b
$ Array U Int Char -> Sz Int
forall r ix e. Load r ix e => Array r ix e -> Sz ix
A.size Array U Int Char
str'
  hs :: Array A.U Ix2 Int
  hs :: Array U Ix2 Int
hs = Sz Ix2
-> (forall s. MArray s U Ix2 Int -> ST s ()) -> Array U Ix2 Int
forall r ix e a.
Mutable r ix e =>
Sz ix -> (forall s. MArray s r ix e -> ST s a) -> Array r ix e
M.createArrayST_ (Ix2 -> Sz Ix2
forall ix. Index ix => ix -> Sz ix
A.Sz (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Ix2
:. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) ((forall s. MArray s U Ix2 Int -> ST s ()) -> Array U Ix2 Int)
-> (forall s. MArray s U Ix2 Int -> ST s ()) -> Array U Ix2 Int
forall a b. (a -> b) -> a -> b
$ \MArray s U Ix2 Int
marr -> do
    Array D Ix2 Ix2 -> (Ix2 -> ST s ()) -> ST s ()
forall r ix a (m :: * -> *) b.
(Source r ix a, Monad m) =>
Array r ix a -> (a -> m b) -> m ()
A.forM_ ((Int
0 Int -> Int -> Ix2
:. Int
0) Ix2 -> Ix2 -> Array D Ix2 Ix2
forall ix. Index ix => ix -> ix -> Array D ix ix
... (Int
m Int -> Int -> Ix2
:. Int
n)) ((Ix2 -> ST s ()) -> ST s ()) -> (Ix2 -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Int
i :. Int
j) -> if (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
      then MArray (PrimState (ST s)) U Ix2 Int -> Ix2 -> Int -> ST s ()
forall r ix e (m :: * -> *).
(Mutable r ix e, PrimMonad m, MonadThrow m) =>
MArray (PrimState m) r ix e -> ix -> e -> m ()
M.writeM MArray s U Ix2 Int
MArray (PrimState (ST s)) U Ix2 Int
marr (Int
i Int -> Int -> Ix2
:. Int
j) Int
0
      else do
        Int
scoreMatch <- do
          Int
hprev <- MArray (PrimState (ST s)) U Ix2 Int -> Ix2 -> ST s Int
forall r ix e (m :: * -> *).
(Mutable r ix e, PrimMonad m, MonadThrow m) =>
MArray (PrimState m) r ix e -> ix -> m e
M.readM MArray s U Ix2 Int
MArray (PrimState (ST s)) U Ix2 Int
marr ((Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Ix2
:. (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
          Int -> ST s Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
hprev
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Char -> Int
similarity (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
query' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Array U Ix2 Int -> Ix2 -> Int
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Ix2 Int
bonuses (Int
i Int -> Int -> Ix2
:. Int
j)
        Int
scoreGap <- do
          (Array U Int Int
arr :: Array A.U A.Ix1 Int) <- Array D Int Int -> (Int -> ST s Int) -> ST s (Array U Int Int)
forall r ix b r' a (m :: * -> *).
(Source r' ix a, Mutable r ix b, Monad m) =>
Array r' ix a -> (a -> m b) -> m (Array r ix b)
forM (Int
1 Int -> Int -> Array D Int Int
forall ix. Index ix => ix -> ix -> Array D ix ix
... Int
j) ((Int -> ST s Int) -> ST s (Array U Int Int))
-> (Int -> ST s Int) -> ST s (Array U Int Int)
forall a b. (a -> b) -> a -> b
$ \Int
l ->
            (\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
gapPenalty)) (Int -> Int) -> ST s Int -> ST s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MArray (PrimState (ST s)) U Ix2 Int -> Ix2 -> ST s Int
forall r ix e (m :: * -> *).
(Mutable r ix e, PrimMonad m, MonadThrow m) =>
MArray (PrimState m) r ix e -> ix -> m e
M.readM MArray s U Ix2 Int
MArray (PrimState (ST s)) U Ix2 Int
marr (Int
i Int -> Int -> Ix2
:. (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l))
          Int -> ST s Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ST s Int) -> (Maybe Int -> Int) -> Maybe Int -> ST s Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> ST s Int) -> Maybe Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Array U Int Int -> Maybe Int
forall (m :: * -> *) r ix e.
(MonadThrow m, Source r ix e, Ord e) =>
Array r ix e -> m e
A.maximumM Array U Int Int
arr
        MArray (PrimState (ST s)) U Ix2 Int -> Ix2 -> Int -> ST s ()
forall r ix e (m :: * -> *).
(Mutable r ix e, PrimMonad m, MonadThrow m) =>
MArray (PrimState m) r ix e -> ix -> e -> m ()
M.writeM MArray s U Ix2 Int
MArray (PrimState (ST s)) U Ix2 Int
marr (Int
i Int -> Int -> Ix2
:. Int
j) (Int
scoreMatch Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
scoreGap Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
0)
  bonuses :: Array U Ix2 Int
bonuses = Comp -> Sz Ix2 -> (Ix2 -> Int) -> Array U Ix2 Int
forall r ix e.
Construct r ix e =>
Comp -> Sz ix -> (ix -> e) -> Array r ix e
A.makeArray Comp
A.Seq (Ix2 -> Sz Ix2
forall ix. Index ix => ix -> Sz ix
A.Sz (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Ix2
:. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Ix2 -> Int
f :: Array A.U Ix2 Int
    where f :: Ix2 -> Int
f (Int
i :. Int
j) = Int -> Int -> Int
bonus Int
i Int
j
  bonus :: Int -> Int -> Int
  bonus :: Int -> Int -> Int
bonus Int
0 Int
j = Int
0
  bonus Int
i Int
0 = Int
0
  bonus Int
i Int
j =
    if Char -> Char -> Int
similarity (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
query' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then Int
multiplier Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
boundary Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
camel Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
consecutive)
      else Int
0
   where
    boundary :: Int
boundary =
      if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Bool -> Bool -> Bool
&& Bool -> Bool
not
           (Char -> Bool
isAlphaNum (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)))
        then Int
boundaryBonus
        else Int
0
    camel :: Int
camel =
      if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Char -> Bool
isLower (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)) Bool -> Bool -> Bool
&& Char -> Bool
isUpper
         (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      then
        Int
camelCaseBonus
      else
        Int
0
    multiplier :: Int
multiplier = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Int
firstCharBonusMultiplier else Int
1
    consecutive :: Int
consecutive =
      let
        similar :: Bool
similar =
          Int
i
            Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
0
            Bool -> Bool -> Bool
&& Int
j
            Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
0
            Bool -> Bool -> Bool
&& Char -> Char -> Int
similarity (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
query' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
            Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
0
        afterMatch :: Bool
afterMatch =
          Int
i
            Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
1
            Bool -> Bool -> Bool
&& Int
j
            Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
1
            Bool -> Bool -> Bool
&& Char -> Char -> Int
similarity (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
query' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)) (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2))
            Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
0
        beforeMatch :: Bool
beforeMatch =
          Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
m Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n Bool -> Bool -> Bool
&& Char -> Char -> Int
similarity (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
query' Int
i) (Array U Int Char -> Int -> Char
forall r ix e. Manifest r ix e => Array r ix e -> ix -> e
A.index' Array U Int Char
str' Int
j) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      in
        if Bool
similar Bool -> Bool -> Bool
&& (Bool
afterMatch Bool -> Bool -> Bool
|| Bool
beforeMatch) then Int
consecutiveBonus else Int
0

-- gaps :: String -> Seq ResultSegment
-- gaps s = [Gap s]

data ResultSegment = Gap !String | Match !String
  deriving (ResultSegment -> ResultSegment -> Bool
(ResultSegment -> ResultSegment -> Bool)
-> (ResultSegment -> ResultSegment -> Bool) -> Eq ResultSegment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResultSegment -> ResultSegment -> Bool
$c/= :: ResultSegment -> ResultSegment -> Bool
== :: ResultSegment -> ResultSegment -> Bool
$c== :: ResultSegment -> ResultSegment -> Bool
Eq, Eq ResultSegment
Eq ResultSegment
-> (ResultSegment -> ResultSegment -> Ordering)
-> (ResultSegment -> ResultSegment -> Bool)
-> (ResultSegment -> ResultSegment -> Bool)
-> (ResultSegment -> ResultSegment -> Bool)
-> (ResultSegment -> ResultSegment -> Bool)
-> (ResultSegment -> ResultSegment -> ResultSegment)
-> (ResultSegment -> ResultSegment -> ResultSegment)
-> Ord ResultSegment
ResultSegment -> ResultSegment -> Bool
ResultSegment -> ResultSegment -> Ordering
ResultSegment -> ResultSegment -> ResultSegment
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ResultSegment -> ResultSegment -> ResultSegment
$cmin :: ResultSegment -> ResultSegment -> ResultSegment
max :: ResultSegment -> ResultSegment -> ResultSegment
$cmax :: ResultSegment -> ResultSegment -> ResultSegment
>= :: ResultSegment -> ResultSegment -> Bool
$c>= :: ResultSegment -> ResultSegment -> Bool
> :: ResultSegment -> ResultSegment -> Bool
$c> :: ResultSegment -> ResultSegment -> Bool
<= :: ResultSegment -> ResultSegment -> Bool
$c<= :: ResultSegment -> ResultSegment -> Bool
< :: ResultSegment -> ResultSegment -> Bool
$c< :: ResultSegment -> ResultSegment -> Bool
compare :: ResultSegment -> ResultSegment -> Ordering
$ccompare :: ResultSegment -> ResultSegment -> Ordering
$cp1Ord :: Eq ResultSegment
Ord, Int -> ResultSegment -> String -> String
[ResultSegment] -> String -> String
ResultSegment -> String
(Int -> ResultSegment -> String -> String)
-> (ResultSegment -> String)
-> ([ResultSegment] -> String -> String)
-> Show ResultSegment
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ResultSegment] -> String -> String
$cshowList :: [ResultSegment] -> String -> String
show :: ResultSegment -> String
$cshow :: ResultSegment -> String
showsPrec :: Int -> ResultSegment -> String -> String
$cshowsPrec :: Int -> ResultSegment -> String -> String
Show, (forall x. ResultSegment -> Rep ResultSegment x)
-> (forall x. Rep ResultSegment x -> ResultSegment)
-> Generic ResultSegment
forall x. Rep ResultSegment x -> ResultSegment
forall x. ResultSegment -> Rep ResultSegment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ResultSegment x -> ResultSegment
$cfrom :: forall x. ResultSegment -> Rep ResultSegment x
Generic)

-- | Concatenating all the 'ResultSegment's should yield the original input string.
newtype Result = Result { Result -> Seq ResultSegment
segments :: Seq ResultSegment }
  deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Eq Result
Eq Result
-> (Result -> Result -> Ordering)
-> (Result -> Result -> Bool)
-> (Result -> Result -> Bool)
-> (Result -> Result -> Bool)
-> (Result -> Result -> Bool)
-> (Result -> Result -> Result)
-> (Result -> Result -> Result)
-> Ord Result
Result -> Result -> Bool
Result -> Result -> Ordering
Result -> Result -> Result
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Result -> Result -> Result
$cmin :: Result -> Result -> Result
max :: Result -> Result -> Result
$cmax :: Result -> Result -> Result
>= :: Result -> Result -> Bool
$c>= :: Result -> Result -> Bool
> :: Result -> Result -> Bool
$c> :: Result -> Result -> Bool
<= :: Result -> Result -> Bool
$c<= :: Result -> Result -> Bool
< :: Result -> Result -> Bool
$c< :: Result -> Result -> Bool
compare :: Result -> Result -> Ordering
$ccompare :: Result -> Result -> Ordering
$cp1Ord :: Eq Result
Ord, Int -> Result -> String -> String
[Result] -> String -> String
Result -> String
(Int -> Result -> String -> String)
-> (Result -> String)
-> ([Result] -> String -> String)
-> Show Result
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Result] -> String -> String
$cshowList :: [Result] -> String -> String
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> String -> String
$cshowsPrec :: Int -> Result -> String -> String
Show, (forall x. Result -> Rep Result x)
-> (forall x. Rep Result x -> Result) -> Generic Result
forall x. Rep Result x -> Result
forall x. Result -> Rep Result x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Result x -> Result
$cfrom :: forall x. Result -> Rep Result x
Generic)

instance Monoid Result where
  mempty :: Result
mempty = Seq ResultSegment -> Result
Result []

instance Semigroup Result where
  Result Seq ResultSegment
Empty <> :: Result -> Result -> Result
<> Result
as = Result
as
  Result
as <> Result Seq ResultSegment
Empty = Result
as
  Result (Seq ResultSegment -> ViewR ResultSegment
forall a. Seq a -> ViewR a
viewr -> Seq ResultSegment
h :> Gap []) <> Result
as = Seq ResultSegment -> Result
Result Seq ResultSegment
h Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result
as
  Result
as <> Result (Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl -> Gap [] :< Seq ResultSegment
t) = Result
as Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Seq ResultSegment -> Result
Result Seq ResultSegment
t
  Result (Seq ResultSegment -> ViewR ResultSegment
forall a. Seq a -> ViewR a
viewr -> Seq ResultSegment
h :> Match []) <> Result
as = Seq ResultSegment -> Result
Result Seq ResultSegment
h Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result
as
  Result
as <> Result (Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl -> Match [] :< Seq ResultSegment
t) = Result
as Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Seq ResultSegment -> Result
Result Seq ResultSegment
t
  Result (Seq ResultSegment -> ViewR ResultSegment
forall a. Seq a -> ViewR a
viewr -> Seq ResultSegment
i :> Gap String
l) <> Result (Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl -> Gap String
h :< Seq ResultSegment
t) =
    Seq ResultSegment -> Result
Result (Seq ResultSegment
i Seq ResultSegment -> Seq ResultSegment -> Seq ResultSegment
forall a. Semigroup a => a -> a -> a
<> [String -> ResultSegment
Gap (String
l String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
h)] Seq ResultSegment -> Seq ResultSegment -> Seq ResultSegment
forall a. Semigroup a => a -> a -> a
<> Seq ResultSegment
t)
  Result (Seq ResultSegment -> ViewR ResultSegment
forall a. Seq a -> ViewR a
viewr -> Seq ResultSegment
i :> Match String
l) <> Result (Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl -> Match String
h :< Seq ResultSegment
t) =
    Seq ResultSegment -> Result
Result (Seq ResultSegment
i Seq ResultSegment -> Seq ResultSegment -> Seq ResultSegment
forall a. Semigroup a => a -> a -> a
<> [String -> ResultSegment
Match (String
l String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
h)] Seq ResultSegment -> Seq ResultSegment -> Seq ResultSegment
forall a. Semigroup a => a -> a -> a
<> Seq ResultSegment
t)
  Result Seq ResultSegment
a <> Result Seq ResultSegment
b = Seq ResultSegment -> Result
Result (Seq ResultSegment
a Seq ResultSegment -> Seq ResultSegment -> Seq ResultSegment
forall a. Semigroup a => a -> a -> a
<> Seq ResultSegment
b)

mergeResults :: Result -> Result -> Result
mergeResults :: Result -> Result -> Result
mergeResults Result
as Result
bs = Result -> Result -> Result
merge Result
as Result
bs
 where
  drop' :: Int -> Result -> Result
  drop' :: Int -> Result -> Result
drop' Int
n Result
m | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = Result
m
  drop' Int
n (Result (Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl -> Gap String
g :< Seq ResultSegment
t)) =
    Seq ResultSegment -> Result
Result [String -> ResultSegment
Gap (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
n String
g)] Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Int -> Result -> Result
drop' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
g) (Seq ResultSegment -> Result
Result Seq ResultSegment
t)
  drop' Int
n (Result (Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl -> Match String
g :< Seq ResultSegment
t)) =
    Seq ResultSegment -> Result
Result [String -> ResultSegment
Match (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
n String
g)] Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Int -> Result -> Result
drop' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
g) (Seq ResultSegment -> Result
Result Seq ResultSegment
t)
  merge :: Result -> Result -> Result
  merge :: Result -> Result -> Result
merge (Result Seq ResultSegment
Seq.Empty) Result
ys                 = Result
ys
  merge Result
xs                 (Result Seq ResultSegment
Seq.Empty) = Result
xs
  merge (Result Seq ResultSegment
xs)        (Result Seq ResultSegment
ys       ) = case (Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl Seq ResultSegment
xs, Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl Seq ResultSegment
ys) of
    (Gap String
g :< Seq ResultSegment
t, Gap String
g' :< Seq ResultSegment
t')
      | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
g Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
g' -> Seq ResultSegment -> Result
Result [String -> ResultSegment
Gap String
g]
      Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result -> Result -> Result
merge (Seq ResultSegment -> Result
Result Seq ResultSegment
t) (Int -> Result -> Result
drop' (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
g) (Seq ResultSegment -> Result
Result Seq ResultSegment
ys))
      | Bool
otherwise -> Seq ResultSegment -> Result
Result [String -> ResultSegment
Gap String
g']
      Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result -> Result -> Result
merge (Int -> Result -> Result
drop' (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
g') (Seq ResultSegment -> Result
Result Seq ResultSegment
xs)) (Seq ResultSegment -> Result
Result Seq ResultSegment
t')
    (Match String
m :< Seq ResultSegment
t, Match String
m' :< Seq ResultSegment
t')
      | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
m' -> Seq ResultSegment -> Result
Result [String -> ResultSegment
Match String
m]
      Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result -> Result -> Result
merge (Seq ResultSegment -> Result
Result Seq ResultSegment
t) (Int -> Result -> Result
drop' (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
m) (Seq ResultSegment -> Result
Result Seq ResultSegment
ys))
      | Bool
otherwise -> Seq ResultSegment -> Result
Result [String -> ResultSegment
Match String
m']
      Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result -> Result -> Result
merge (Int -> Result -> Result
drop' (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
m') (Seq ResultSegment -> Result
Result Seq ResultSegment
xs)) (Seq ResultSegment -> Result
Result Seq ResultSegment
t')
    (Gap String
g :< Seq ResultSegment
t, Match String
m' :< Seq ResultSegment
t') ->
      Seq ResultSegment -> Result
Result [String -> ResultSegment
Match String
m'] Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result -> Result -> Result
merge (Int -> Result -> Result
drop' (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
m') (Seq ResultSegment -> Result
Result Seq ResultSegment
xs)) (Seq ResultSegment -> Result
Result Seq ResultSegment
t')
    (Match String
m :< Seq ResultSegment
t, Gap String
g' :< Seq ResultSegment
t') ->
      Seq ResultSegment -> Result
Result [String -> ResultSegment
Match String
m] Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result -> Result -> Result
merge (Seq ResultSegment -> Result
Result Seq ResultSegment
t) (Int -> Result -> Result
drop' (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
m) (Seq ResultSegment -> Result
Result Seq ResultSegment
ys))