{-# 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 Data.Sequence
  ( Seq (..),
    ViewL (..),
    ViewR (..),
    viewl,
    viewr,
    (<|)
  )
import qualified Data.Sequence as Seq
import GHC.Generics (Generic)
import Data.Text (Text)
import qualified Data.Text as Text
import Control.Monad.ST (runST)

-- | @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

-- | Renders an 'Alignment' as a pair of lines with "*" on the lower line
-- indicating the location of pattern matches.
-- highlight' :: Alignment -> Text
-- highlight' (Alignment s (Result segments)) =
--   foldMap prettySegment segments <> "\n" <> foldMap showGaps segments
--  where
--   prettySegment (Gap   xs) = xs
--   prettySegment (Match xs) = xs
--   showGaps (Gap   xs) = Text.pack $ replicate (Text.length xs) ' '
--   showGaps (Match xs) = Text.pack $ replicate (Text.length xs) '*'

-- highlight :: Alignment -> String
-- highlight = Text.unpack . 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)
-> (Seq ResultSegment -> Result) -> Seq ResultSegment -> Alignment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq ResultSegment -> Result
Result (Seq ResultSegment -> Alignment)
-> Maybe (Seq ResultSegment) -> Maybe Alignment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Seq 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 (Seq ResultSegment)
  traceback :: Maybe (Seq ResultSegment)
traceback = (Seq ResultSegment -> Seq ResultSegment -> Seq ResultSegment
forall a. Semigroup a => a -> a -> a
<> String -> Seq ResultSegment
gaps (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
nx String
str)) (Seq ResultSegment -> Seq ResultSegment)
-> Maybe (Seq ResultSegment) -> Maybe (Seq ResultSegment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq ResultSegment
-> String -> Integer -> Int -> Int -> Maybe (Seq ResultSegment)
forall t.
(Eq t, Num t) =>
Seq ResultSegment
-> String -> t -> Int -> Int -> Maybe (Seq ResultSegment)
go [] [] (-Integer
1) Int
m Int
nx
  go :: Seq ResultSegment
-> String -> t -> Int -> Int -> Maybe (Seq ResultSegment)
go Seq ResultSegment
r String
m t
currOp Int
0 Int
j = (String -> Seq ResultSegment
gaps (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
j String
str) Seq ResultSegment -> Seq ResultSegment -> Seq ResultSegment
forall a. Semigroup a => a -> a -> a
<>) (Seq ResultSegment -> Seq ResultSegment)
-> Maybe (Seq ResultSegment) -> Maybe (Seq ResultSegment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case String
m of
    [] -> Seq ResultSegment -> Maybe (Seq ResultSegment)
forall a. a -> Maybe a
Just Seq ResultSegment
r
    String
_  -> case t
currOp of
      t
1  -> Seq ResultSegment -> Maybe (Seq ResultSegment)
forall a. a -> Maybe a
Just (Seq ResultSegment
r Seq ResultSegment -> ResultSegment -> Seq ResultSegment
forall a. Seq a -> a -> Seq a
:|> String -> ResultSegment
Match (String -> String
forall a. [a] -> [a]
reverse String
m))
      t
0  -> Seq ResultSegment -> Maybe (Seq ResultSegment)
forall a. a -> Maybe a
Just (Seq ResultSegment
r Seq ResultSegment -> ResultSegment -> Seq ResultSegment
forall a. Seq a -> a -> Seq a
:|> String -> ResultSegment
Gap (String -> String
forall a. [a] -> [a]
reverse String
m))
      -1 -> Maybe (Seq ResultSegment)
forall a. Maybe a
Nothing
  go Seq ResultSegment
_ String
_ t
_ Int
_ Int
0 = Maybe (Seq ResultSegment)
forall a. Maybe a
Nothing
  go Seq 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 ->
          Seq ResultSegment
-> String -> t -> Int -> Int -> Maybe (Seq ResultSegment)
go (Seq ResultSegment
r Seq ResultSegment -> ResultSegment -> Seq ResultSegment
forall a. Seq a -> a -> Seq a
:|> String -> ResultSegment
Gap (String -> String
forall a. [a] -> [a]
reverse String
m)) [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
_ -> Seq ResultSegment
-> String -> t -> Int -> Int -> Maybe (Seq ResultSegment)
go Seq 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 -> Seq ResultSegment
-> String -> t -> Int -> Int -> Maybe (Seq ResultSegment)
go (Seq ResultSegment
r Seq ResultSegment -> ResultSegment -> Seq ResultSegment
forall a. Seq a -> a -> Seq a
:|> String -> ResultSegment
Match (String -> String
forall a. [a] -> [a]
reverse String
m)) [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
_ -> Seq ResultSegment
-> String -> t -> Int -> Int -> Maybe (Seq ResultSegment)
go Seq 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 :: String -> Seq ResultSegment
gaps String
s = [String -> ResultSegment
Gap String
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))