{-# 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 :: [Char] -> [Char] -> Maybe Alignment
bestMatch = Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> [Char]
-> [Char]
-> Maybe Alignment
bestMatch' Int
defaultMatchScore
                       Int
defaultMismatchScore
                       Int
defaultGapPenalty
                       Int
defaultBoundaryBonus
                       Int
defaultCamelCaseBonus
                       Int
defaultFirstCharBonusMultiplier
                       Int
defaultConsecutiveBonus
                       Int
defaultLaterBonusMultiplier

-- | 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 :: [[Char]] -> [[Char]] -> [Alignment]
fuzzyFind = (((Alignment, [Char]) -> Alignment)
-> [(Alignment, [Char])] -> [Alignment]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Alignment, [Char]) -> Alignment
forall a b. (a, b) -> a
fst ([(Alignment, [Char])] -> [Alignment])
-> ([[Char]] -> [(Alignment, [Char])]) -> [[Char]] -> [Alignment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([[Char]] -> [(Alignment, [Char])]) -> [[Char]] -> [Alignment])
-> ([[Char]] -> [[Char]] -> [(Alignment, [Char])])
-> [[Char]]
-> [[Char]]
-> [Alignment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> [[Char]] -> [[Char]] -> [(Alignment, [Char])]
forall a. (a -> [Char]) -> [[Char]] -> [a] -> [(Alignment, a)]
fuzzyFindOn [Char] -> [Char]
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 :: forall a. (a -> [Char]) -> [[Char]] -> [a] -> [(Alignment, a)]
fuzzyFindOn a -> [Char]
f [[Char]]
query [a]
d =
  [a]
d
    [a] -> (a -> [(Alignment, a)]) -> [(Alignment, a)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\a
s ->
          Maybe (Alignment, a) -> [(Alignment, a)]
forall a. Maybe a -> [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 -> [Char] -> Maybe Alignment)
-> Maybe Alignment -> [[Char]] -> Maybe Alignment
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Maybe Alignment
a [Char]
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 a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> [Char] -> Maybe Alignment
bestMatch [Char]
q (a -> [Char]
f a
s))
                       (Alignment -> Maybe Alignment
forall a. a -> Maybe a
Just Alignment
forall a. Monoid a => a
mempty)
                       [[Char]]
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
$c== :: Alignment -> Alignment -> Bool
== :: Alignment -> Alignment -> Bool
$c/= :: Alignment -> Alignment -> Bool
/= :: 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
$ccompare :: Alignment -> Alignment -> Ordering
compare :: Alignment -> Alignment -> Ordering
$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
>= :: Alignment -> Alignment -> Bool
$cmax :: Alignment -> Alignment -> Alignment
max :: Alignment -> Alignment -> Alignment
$cmin :: Alignment -> Alignment -> Alignment
min :: Alignment -> Alignment -> Alignment
Ord, Int -> Alignment -> [Char] -> [Char]
[Alignment] -> [Char] -> [Char]
Alignment -> [Char]
(Int -> Alignment -> [Char] -> [Char])
-> (Alignment -> [Char])
-> ([Alignment] -> [Char] -> [Char])
-> Show Alignment
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Alignment -> [Char] -> [Char]
showsPrec :: Int -> Alignment -> [Char] -> [Char]
$cshow :: Alignment -> [Char]
show :: Alignment -> [Char]
$cshowList :: [Alignment] -> [Char] -> [Char]
showList :: [Alignment] -> [Char] -> [Char]
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
$cfrom :: forall x. Alignment -> Rep Alignment x
from :: forall x. Alignment -> Rep Alignment x
$cto :: forall x. Rep Alignment x -> Alignment
to :: forall x. Rep Alignment x -> Alignment
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

-- | We give a bonus for matches that occur later in the input string.
-- If this is e.g. 100, we give one bonus point for each percentage of the
-- length of the input that the match occurs at (100 points for the last
-- character, 50 for characters in the middle, and so on).
defaultLaterBonusMultiplier :: Int
defaultLaterBonusMultiplier :: Int
defaultLaterBonusMultiplier = Int
5

segmentToString :: ResultSegment -> String
segmentToString :: ResultSegment -> [Char]
segmentToString (Gap   [Char]
xs) = [Char]
xs
segmentToString (Match [Char]
xs) = [Char]
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 -> [Char]
highlight (Alignment Int
s (Result Seq ResultSegment
segments)) =
  (ResultSegment -> [Char]) -> Seq ResultSegment -> [Char]
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ResultSegment -> [Char]
segmentToString Seq ResultSegment
segments [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (ResultSegment -> [Char]) -> Seq ResultSegment -> [Char]
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ResultSegment -> [Char]
showGaps Seq ResultSegment
segments
 where
  showGaps :: ResultSegment -> [Char]
showGaps (Gap   [Char]
xs) = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
xs) Char
' '
  showGaps (Match [Char]
xs) = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
xs) Char
'*'

highlight' :: Alignment -> Text
highlight' :: Alignment -> Text
highlight' = [Char] -> Text
Text.pack ([Char] -> Text) -> (Alignment -> [Char]) -> Alignment -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alignment -> [Char]
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'.
  -> Int -- ^ Bonus multiplier for matching later characters of the input.
         --   E.g. if this is 10, the bonus for matching the last character of
         --   the input is 10, and 5 for characters close to the middle, and so on.
  -> String -- ^ The query pattern.
  -> String -- ^ The input string.
  -> Maybe Alignment
bestMatch' :: Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> [Char]
-> [Char]
-> Maybe Alignment
bestMatch' Int
matchScore Int
mismatchScore Int
gapPenalty Int
boundaryBonus Int
camelCaseBonus Int
firstCharBonusMultiplier Int
consecutiveBonus Int
laterBonusMultiplier [Char]
query [Char]
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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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]
-> [Char] -> Integer -> Int -> Int -> Maybe [ResultSegment]
forall {t}.
(Eq t, Num t) =>
[ResultSegment]
-> [Char] -> t -> Int -> Int -> Maybe [ResultSegment]
go (if Int
nx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n then [[Char] -> ResultSegment
Gap ([Char] -> ResultSegment) -> [Char] -> ResultSegment
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
nx [Char]
str] else []) [] (-Integer
1) Int
m Int
nx
  go :: [ResultSegment]
-> [Char] -> t -> Int -> Int -> Maybe [ResultSegment]
go [ResultSegment]
r [Char]
m t
currOp Int
0 Int
j =
    (if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then ([Char] -> ResultSegment
Gap (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
j [Char]
str) ResultSegment -> [ResultSegment] -> [ResultSegment]
forall a. a -> [a] -> [a]
:) else [ResultSegment] -> [ResultSegment]
forall a. a -> a
id) ([ResultSegment] -> [ResultSegment])
-> Maybe [ResultSegment] -> Maybe [ResultSegment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case [Char]
m of
      [] -> [ResultSegment] -> Maybe [ResultSegment]
forall a. a -> Maybe a
Just [ResultSegment]
r
      [Char]
_  -> case t
currOp of
        t
1  -> [ResultSegment] -> Maybe [ResultSegment]
forall a. a -> Maybe a
Just ([Char] -> ResultSegment
Match [Char]
m ResultSegment -> [ResultSegment] -> [ResultSegment]
forall a. a -> [a] -> [a]
: [ResultSegment]
r)
        t
0  -> [ResultSegment] -> Maybe [ResultSegment]
forall a. a -> Maybe a
Just ([Char] -> ResultSegment
Gap [Char]
m ResultSegment -> [ResultSegment] -> [ResultSegment]
forall a. a -> [a] -> [a]
: [ResultSegment]
r)
        -1 -> Maybe [ResultSegment]
forall a. Maybe a
Nothing
  go [ResultSegment]
_ [Char]
_ t
_ Int
_ Int
0 = Maybe [ResultSegment]
forall a. Maybe a
Nothing
  go [ResultSegment]
r [Char]
m t
currOp Int
i Int
j =
    if Char -> Char -> Int
similarity (Array U Int Char -> Int -> Char
forall ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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]
-> [Char] -> t -> Int -> Int -> Maybe [ResultSegment]
go ([Char] -> ResultSegment
Gap [Char]
m ResultSegment -> [ResultSegment] -> [ResultSegment]
forall a. a -> [a] -> [a]
: [ResultSegment]
r) [Array U Int Char -> Int -> Char
forall ix r e.
(HasCallStack, Index ix, Manifest r 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]
-> [Char] -> t -> Int -> Int -> Maybe [ResultSegment]
go [ResultSegment]
r (Array U Int Char -> Int -> Char
forall ix r e.
(HasCallStack, Index ix, Manifest r 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 -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
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]
-> [Char] -> t -> Int -> Int -> Maybe [ResultSegment]
go ([Char] -> ResultSegment
Match [Char]
m ResultSegment -> [ResultSegment] -> [ResultSegment]
forall a. a -> [a] -> [a]
: [ResultSegment]
r) [Array U Int Char -> Int -> Char
forall ix r e.
(HasCallStack, Index ix, Manifest r 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]
-> [Char] -> t -> Int -> Int -> Maybe [ResultSegment]
go [ResultSegment]
r (Array U Int Char -> Int -> Char
forall ix r e.
(HasCallStack, Index ix, Manifest r 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 -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
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 -> [Char] -> Array U Int Char
forall r e. Manifest r e => Comp -> [e] -> Vector r e
A.fromList Comp
A.Seq [Char]
query :: Array A.U A.Ix1 Char
  str' :: Array U Int Char
str'   = Comp -> [Char] -> Array U Int Char
forall r e. Manifest r e => Comp -> [e] -> Vector r e
A.fromList Comp
A.Seq [Char]
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. Size r => Array r ix e -> Sz ix
forall ix e. Array U 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. Size r => Array r ix e -> Sz ix
forall ix e. Array U 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.
(Manifest r e, Index ix) =>
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 a ix (m :: * -> *) b.
(Source r a, Index ix, 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 e ix (m :: * -> *).
(Manifest r e, Index ix, 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 e ix (m :: * -> *).
(Manifest r e, Index ix, 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 a. a -> ST s a
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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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' a, Manifest r b, Index ix, 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 e ix (m :: * -> *).
(Manifest r e, Index ix, 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 a. a -> ST s a
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, Shape r ix, Source r 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 e ix (m :: * -> *).
(Manifest r e, Index ix, 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.
Load 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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
laterBonusMultiplier) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
n else Int
0)
            )
      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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r 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 ix r e.
(HasCallStack, Index ix, Manifest r e) =>
Array r ix e -> ix -> e
A.index' Array U Int Char
query' Int
i) (Array U Int Char -> Int -> Char
forall ix r e.
(HasCallStack, Index ix, Manifest r 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
$c== :: ResultSegment -> ResultSegment -> Bool
== :: ResultSegment -> ResultSegment -> Bool
$c/= :: ResultSegment -> ResultSegment -> Bool
/= :: 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
$ccompare :: ResultSegment -> ResultSegment -> Ordering
compare :: ResultSegment -> ResultSegment -> Ordering
$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
>= :: ResultSegment -> ResultSegment -> Bool
$cmax :: ResultSegment -> ResultSegment -> ResultSegment
max :: ResultSegment -> ResultSegment -> ResultSegment
$cmin :: ResultSegment -> ResultSegment -> ResultSegment
min :: ResultSegment -> ResultSegment -> ResultSegment
Ord, Int -> ResultSegment -> [Char] -> [Char]
[ResultSegment] -> [Char] -> [Char]
ResultSegment -> [Char]
(Int -> ResultSegment -> [Char] -> [Char])
-> (ResultSegment -> [Char])
-> ([ResultSegment] -> [Char] -> [Char])
-> Show ResultSegment
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ResultSegment -> [Char] -> [Char]
showsPrec :: Int -> ResultSegment -> [Char] -> [Char]
$cshow :: ResultSegment -> [Char]
show :: ResultSegment -> [Char]
$cshowList :: [ResultSegment] -> [Char] -> [Char]
showList :: [ResultSegment] -> [Char] -> [Char]
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
$cfrom :: forall x. ResultSegment -> Rep ResultSegment x
from :: forall x. ResultSegment -> Rep ResultSegment x
$cto :: forall x. Rep ResultSegment x -> ResultSegment
to :: forall x. Rep ResultSegment x -> ResultSegment
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
$c== :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
/= :: 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
$ccompare :: Result -> Result -> Ordering
compare :: Result -> Result -> Ordering
$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
>= :: Result -> Result -> Bool
$cmax :: Result -> Result -> Result
max :: Result -> Result -> Result
$cmin :: Result -> Result -> Result
min :: Result -> Result -> Result
Ord, Int -> Result -> [Char] -> [Char]
[Result] -> [Char] -> [Char]
Result -> [Char]
(Int -> Result -> [Char] -> [Char])
-> (Result -> [Char])
-> ([Result] -> [Char] -> [Char])
-> Show Result
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Result -> [Char] -> [Char]
showsPrec :: Int -> Result -> [Char] -> [Char]
$cshow :: Result -> [Char]
show :: Result -> [Char]
$cshowList :: [Result] -> [Char] -> [Char]
showList :: [Result] -> [Char] -> [Char]
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
$cfrom :: forall x. Result -> Rep Result x
from :: forall x. Result -> Rep Result x
$cto :: forall x. Rep Result x -> Result
to :: forall x. Rep Result x -> Result
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 [Char]
l) <> Result (Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl -> Gap [Char]
h :< Seq ResultSegment
t) =
    Seq ResultSegment -> Result
Result (Seq ResultSegment
i Seq ResultSegment -> Seq ResultSegment -> Seq ResultSegment
forall a. Semigroup a => a -> a -> a
<> [[Char] -> ResultSegment
Gap ([Char]
l [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
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 [Char]
l) <> Result (Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl -> Match [Char]
h :< Seq ResultSegment
t) =
    Seq ResultSegment -> Result
Result (Seq ResultSegment
i Seq ResultSegment -> Seq ResultSegment -> Seq ResultSegment
forall a. Semigroup a => a -> a -> a
<> [[Char] -> ResultSegment
Match ([Char]
l [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
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 [Char]
g :< Seq ResultSegment
t)) =
    Seq ResultSegment -> Result
Result [[Char] -> ResultSegment
Gap (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
n [Char]
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
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
g) (Seq ResultSegment -> Result
Result Seq ResultSegment
t)
  drop' Int
n (Result (Seq ResultSegment -> ViewL ResultSegment
forall a. Seq a -> ViewL a
viewl -> Match [Char]
g :< Seq ResultSegment
t)) =
    Seq ResultSegment -> Result
Result [[Char] -> ResultSegment
Match (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
n [Char]
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
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
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 [Char]
g :< Seq ResultSegment
t, Gap [Char]
g' :< Seq ResultSegment
t')
      | [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
g Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
g' -> Seq ResultSegment -> Result
Result [[Char] -> ResultSegment
Gap [Char]
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' ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
g) (Seq ResultSegment -> Result
Result Seq ResultSegment
ys))
      | Bool
otherwise -> Seq ResultSegment -> Result
Result [[Char] -> ResultSegment
Gap [Char]
g']
      Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result -> Result -> Result
merge (Int -> Result -> Result
drop' ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
g') (Seq ResultSegment -> Result
Result Seq ResultSegment
xs)) (Seq ResultSegment -> Result
Result Seq ResultSegment
t')
    (Match [Char]
m :< Seq ResultSegment
t, Match [Char]
m' :< Seq ResultSegment
t')
      | [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
m' -> Seq ResultSegment -> Result
Result [[Char] -> ResultSegment
Match [Char]
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' ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
m) (Seq ResultSegment -> Result
Result Seq ResultSegment
ys))
      | Bool
otherwise -> Seq ResultSegment -> Result
Result [[Char] -> ResultSegment
Match [Char]
m']
      Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result -> Result -> Result
merge (Int -> Result -> Result
drop' ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
m') (Seq ResultSegment -> Result
Result Seq ResultSegment
xs)) (Seq ResultSegment -> Result
Result Seq ResultSegment
t')
    (Gap [Char]
g :< Seq ResultSegment
t, Match [Char]
m' :< Seq ResultSegment
t') ->
      Seq ResultSegment -> Result
Result [[Char] -> ResultSegment
Match [Char]
m'] Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result -> Result -> Result
merge (Int -> Result -> Result
drop' ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
m') (Seq ResultSegment -> Result
Result Seq ResultSegment
xs)) (Seq ResultSegment -> Result
Result Seq ResultSegment
t')
    (Match [Char]
m :< Seq ResultSegment
t, Gap [Char]
g' :< Seq ResultSegment
t') ->
      Seq ResultSegment -> Result
Result [[Char] -> ResultSegment
Match [Char]
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' ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
m) (Seq ResultSegment -> Result
Result Seq ResultSegment
ys))