{-
    Copyright 2018-2019 Vidar Holen, Ng Zhi An

    This file is part of ShellCheck.
    https://www.shellcheck.net

    ShellCheck is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    ShellCheck is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <https://www.gnu.org/licenses/>.
-}

{-# LANGUAGE TemplateHaskell #-}
module ShellCheck.Fixer (applyFix, removeTabStops, mapPositions, Ranged(..), runTests) where

import ShellCheck.Interface
import Control.Monad.State
import Data.Array
import Data.List
import Data.Semigroup
import GHC.Exts (sortWith)
import Test.QuickCheck

-- The Ranged class is used for types that has a start and end position.
class Ranged a where
    start   :: a -> Position
    end     :: a -> Position
    overlap :: a -> a -> Bool
    overlap a
x a
y =
        (Position
yStart Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Position
xStart Bool -> Bool -> Bool
&& Position
yStart Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
< Position
xEnd) Bool -> Bool -> Bool
|| (Position
yStart Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
< Position
xStart Bool -> Bool -> Bool
&& Position
yEnd Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
> Position
xStart)
        where
            yStart :: Position
yStart = a -> Position
forall a. Ranged a => a -> Position
start a
y
            yEnd :: Position
yEnd = a -> Position
forall a. Ranged a => a -> Position
end a
y
            xStart :: Position
xStart = a -> Position
forall a. Ranged a => a -> Position
start a
x
            xEnd :: Position
xEnd = a -> Position
forall a. Ranged a => a -> Position
end a
x
    -- Set a new start and end position on a Ranged
    setRange :: (Position, Position) -> a -> a

-- Tests auto-verify that overlap commutes
assertOverlap :: a -> a -> Bool
assertOverlap a
x a
y = a -> a -> Bool
forall a. Ranged a => a -> a -> Bool
overlap a
x a
y Bool -> Bool -> Bool
&& a -> a -> Bool
forall a. Ranged a => a -> a -> Bool
overlap a
y a
x
assertNoOverlap :: a -> a -> Bool
assertNoOverlap a
x a
y = Bool -> Bool
not (a -> a -> Bool
forall a. Ranged a => a -> a -> Bool
overlap a
x a
y) Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> a -> Bool
forall a. Ranged a => a -> a -> Bool
overlap a
y a
x)

prop_overlap_contiguous :: Bool
prop_overlap_contiguous = Replacement -> Replacement -> Bool
forall a. Ranged a => a -> a -> Bool
assertNoOverlap
        (Int -> Int -> String -> Int -> Replacement
tFromStart Int
10 Int
12 String
"foo" Int
1)
        (Int -> Int -> String -> Int -> Replacement
tFromStart Int
12 Int
14 String
"bar" Int
2)

prop_overlap_adjacent_zerowidth :: Bool
prop_overlap_adjacent_zerowidth = Replacement -> Replacement -> Bool
forall a. Ranged a => a -> a -> Bool
assertNoOverlap
        (Int -> Int -> String -> Int -> Replacement
tFromStart Int
3 Int
3 String
"foo" Int
1)
        (Int -> Int -> String -> Int -> Replacement
tFromStart Int
3 Int
3 String
"bar" Int
2)

prop_overlap_enclosed :: Bool
prop_overlap_enclosed = Replacement -> Replacement -> Bool
forall a. Ranged a => a -> a -> Bool
assertOverlap
        (Int -> Int -> String -> Int -> Replacement
tFromStart Int
3 Int
5 String
"foo" Int
1)
        (Int -> Int -> String -> Int -> Replacement
tFromStart Int
1 Int
10 String
"bar" Int
2)

prop_overlap_partial :: Bool
prop_overlap_partial = Replacement -> Replacement -> Bool
forall a. Ranged a => a -> a -> Bool
assertOverlap
        (Int -> Int -> String -> Int -> Replacement
tFromStart Int
1 Int
5 String
"foo" Int
1)
        (Int -> Int -> String -> Int -> Replacement
tFromStart Int
3 Int
7 String
"bar" Int
2)


instance Ranged PositionedComment where
    start :: PositionedComment -> Position
start = PositionedComment -> Position
pcStartPos
    end :: PositionedComment -> Position
end = PositionedComment -> Position
pcEndPos
    setRange :: (Position, Position) -> PositionedComment -> PositionedComment
setRange (Position
s, Position
e) PositionedComment
pc = PositionedComment
pc {
        pcStartPos :: Position
pcStartPos = Position
s,
        pcEndPos :: Position
pcEndPos = Position
e
    }

instance Ranged Replacement where
    start :: Replacement -> Position
start = Replacement -> Position
repStartPos
    end :: Replacement -> Position
end   = Replacement -> Position
repEndPos
    setRange :: (Position, Position) -> Replacement -> Replacement
setRange (Position
s, Position
e) Replacement
r = Replacement
r {
        repStartPos :: Position
repStartPos = Position
s,
        repEndPos :: Position
repEndPos = Position
e
    }

-- The Monoid instance for Fix merges fixes that do not conflict.
-- TODO: Make an efficient 'mconcat'
instance Monoid Fix where
    mempty :: Fix
mempty = Fix
newFix
    mappend :: Fix -> Fix -> Fix
mappend = Fix -> Fix -> Fix
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup Fix where
    Fix
f1 <> :: Fix -> Fix -> Fix
<> Fix
f2 =
        -- FIXME: This might need to also discard adjacent zero-width ranges for
        --        when two fixes change the same AST node, e.g. `foo` -> "$(foo)"
        if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Replacement
r2 Replacement -> Replacement -> Bool
forall a. Ranged a => a -> a -> Bool
`overlap` Replacement
r1 | Replacement
r1 <- Fix -> [Replacement]
fixReplacements Fix
f1, Replacement
r2 <- Fix -> [Replacement]
fixReplacements Fix
f2 ]
        then Fix
f1
        else Fix
newFix {
            fixReplacements :: [Replacement]
fixReplacements = Fix -> [Replacement]
fixReplacements Fix
f1 [Replacement] -> [Replacement] -> [Replacement]
forall a. [a] -> [a] -> [a]
++ Fix -> [Replacement]
fixReplacements Fix
f2
            }

-- Conveniently apply a transformation to positions in a Fix
mapPositions :: (Position -> Position) -> Fix -> Fix
mapPositions :: (Position -> Position) -> Fix -> Fix
mapPositions Position -> Position
f = Fix -> Fix
adjustFix
  where
    adjustReplacement :: Replacement -> Replacement
adjustReplacement Replacement
rep =
        Replacement
rep {
            repStartPos :: Position
repStartPos = Position -> Position
f (Position -> Position) -> Position -> Position
forall a b. (a -> b) -> a -> b
$ Replacement -> Position
repStartPos Replacement
rep,
            repEndPos :: Position
repEndPos = Position -> Position
f (Position -> Position) -> Position -> Position
forall a b. (a -> b) -> a -> b
$ Replacement -> Position
repEndPos Replacement
rep
        }
    adjustFix :: Fix -> Fix
adjustFix Fix
fix =
        Fix
fix {
            fixReplacements :: [Replacement]
fixReplacements = (Replacement -> Replacement) -> [Replacement] -> [Replacement]
forall a b. (a -> b) -> [a] -> [b]
map Replacement -> Replacement
adjustReplacement ([Replacement] -> [Replacement]) -> [Replacement] -> [Replacement]
forall a b. (a -> b) -> a -> b
$ Fix -> [Replacement]
fixReplacements Fix
fix
        }

-- Rewrite a Ranged from a tabstop of 8 to 1
removeTabStops :: Ranged a => a -> Array Int String -> a
removeTabStops :: a -> Array Int String -> a
removeTabStops a
range Array Int String
ls =
    let startColumn :: Integer
startColumn = (a -> Integer) -> (a -> Integer) -> a -> Integer
forall p a t.
(Integral p, Integral a) =>
(t -> a) -> (t -> p) -> t -> p
realignColumn a -> Integer
lineNo a -> Integer
colNo a
range
        endColumn :: Integer
endColumn = (a -> Integer) -> (a -> Integer) -> a -> Integer
forall p a t.
(Integral p, Integral a) =>
(t -> a) -> (t -> p) -> t -> p
realignColumn a -> Integer
endLineNo a -> Integer
endColNo a
range
        startPosition :: Position
startPosition = (a -> Position
forall a. Ranged a => a -> Position
start a
range) { posColumn :: Integer
posColumn = Integer
startColumn }
        endPosition :: Position
endPosition = (a -> Position
forall a. Ranged a => a -> Position
end a
range) { posColumn :: Integer
posColumn = Integer
endColumn } in
    (Position, Position) -> a -> a
forall a. Ranged a => (Position, Position) -> a -> a
setRange (Position
startPosition, Position
endPosition) a
range
  where
    realignColumn :: (t -> a) -> (t -> p) -> t -> p
realignColumn t -> a
lineNo t -> p
colNo t
c =
      if t -> a
lineNo t
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 Bool -> Bool -> Bool
&& t -> a
lineNo t
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Array Int String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Array Int String
ls)
      then String -> p -> p -> p -> p
forall a. Integral a => String -> a -> a -> a -> a
real (Array Int String
ls Array Int String -> Int -> String
forall i e. Ix i => Array i e -> i -> e
! a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t -> a
lineNo t
c)) p
0 p
0 (t -> p
colNo t
c)
      else t -> p
colNo t
c
    real :: String -> a -> a -> a -> a
real String
_ a
r a
v a
target | a
target a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
v = a
r
    -- hit this case at the end of line, and if we don't hit the target
    -- return real + (target - v)
    real [] a
r a
v a
target = a
r a -> a -> a
forall a. Num a => a -> a -> a
+ (a
target a -> a -> a
forall a. Num a => a -> a -> a
- a
v)
    real (Char
'\t':String
rest) a
r a
v a
target = String -> a -> a -> a -> a
real String
rest (a
ra -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
8 a -> a -> a
forall a. Num a => a -> a -> a
- (a
v a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
8)) a
target
    real (Char
_:String
rest) a
r a
v a
target = String -> a -> a -> a -> a
real String
rest (a
ra -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a
va -> a -> a
forall a. Num a => a -> a -> a
+a
1) a
target
    lineNo :: a -> Integer
lineNo = Position -> Integer
posLine (Position -> Integer) -> (a -> Position) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Position
forall a. Ranged a => a -> Position
start
    endLineNo :: a -> Integer
endLineNo = Position -> Integer
posLine (Position -> Integer) -> (a -> Position) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Position
forall a. Ranged a => a -> Position
end
    colNo :: a -> Integer
colNo = Position -> Integer
posColumn (Position -> Integer) -> (a -> Position) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Position
forall a. Ranged a => a -> Position
start
    endColNo :: a -> Integer
endColNo = Position -> Integer
posColumn (Position -> Integer) -> (a -> Position) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Position
forall a. Ranged a => a -> Position
end


-- A replacement that spans multiple line is applied by:
-- 1. merging the affected lines into a single string using `unlines`
-- 2. apply the replacement as if it only spanned a single line
-- The tricky part is adjusting the end column of the replacement
-- (the end line doesn't matter because there is only one line)
--
--   aaS  <--- start of replacement (row 1 column 3)
--   bbbb
--   cEc
--    \------- end of replacement (row 3 column 2)
--
-- a flattened string will look like:
--
--   "aaS\nbbbb\ncEc\n"
--
-- The column of E has to be adjusted by:
-- 1. lengths of lines to be replaced, except the end row itself
-- 2. end column of the replacement
-- 3. number of '\n' by `unlines`
multiToSingleLine :: [Fix] -> Array Int String -> ([Fix], String)
multiToSingleLine :: [Fix] -> Array Int String -> ([Fix], String)
multiToSingleLine [Fix]
fixes Array Int String
lines =
    ((Fix -> Fix) -> [Fix] -> [Fix]
forall a b. (a -> b) -> [a] -> [b]
map ((Position -> Position) -> Fix -> Fix
mapPositions Position -> Position
adjust) [Fix]
fixes, [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Array Int String -> [String]
forall i e. Array i e -> [e]
elems Array Int String
lines)
  where
    -- A prefix sum tree from line number to column shift.
    -- FIXME: The tree will be totally unbalanced.
    shiftTree :: PSTree Int
    shiftTree :: PSTree Int
shiftTree =
        (PSTree Int -> (Int, String) -> PSTree Int)
-> PSTree Int -> [(Int, String)] -> PSTree Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\PSTree Int
t (Int
n,String
s) -> Int -> Int -> PSTree Int -> PSTree Int
forall n. (Ord n, Num n) => n -> n -> PSTree n -> PSTree n
addPSValue (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) PSTree Int
t) PSTree Int
forall n. Num n => PSTree n
newPSTree ([(Int, String)] -> PSTree Int) -> [(Int, String)] -> PSTree Int
forall a b. (a -> b) -> a -> b
$
            Array Int String -> [(Int, String)]
forall i e. Ix i => Array i e -> [(i, e)]
assocs Array Int String
lines
    singleString :: String
singleString = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Array Int String -> [String]
forall i e. Array i e -> [e]
elems Array Int String
lines
    adjust :: Position -> Position
adjust Position
pos =
        Position
pos {
            posLine :: Integer
posLine = Integer
1,
            posColumn :: Integer
posColumn = (Position -> Integer
posColumn Position
pos) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+
                (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> PSTree Int -> Int
forall n. (Ord n, Num n) => n -> PSTree n -> n
getPrefixSum (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Position -> Integer
posLine Position
pos) PSTree Int
shiftTree)
        }

-- Apply a fix and return resulting lines.
-- The number of lines can increase or decrease with no obvious mapping back, so
-- the function does not return an array.
applyFix :: Fix -> Array Int String -> [String]
applyFix :: Fix -> Array Int String -> [String]
applyFix Fix
fix Array Int String
fileLines =
    let
        untabbed :: Fix
untabbed = Fix
fix {
            fixReplacements :: [Replacement]
fixReplacements =
                (Replacement -> Replacement) -> [Replacement] -> [Replacement]
forall a b. (a -> b) -> [a] -> [b]
map (\Replacement
c -> Replacement -> Array Int String -> Replacement
forall a. Ranged a => a -> Array Int String -> a
removeTabStops Replacement
c Array Int String
fileLines) ([Replacement] -> [Replacement]) -> [Replacement] -> [Replacement]
forall a b. (a -> b) -> a -> b
$
                    Fix -> [Replacement]
fixReplacements Fix
fix
            }
        ([Fix]
adjustedFixes, String
singleLine) = [Fix] -> Array Int String -> ([Fix], String)
multiToSingleLine [Fix
untabbed] Array Int String
fileLines
    in
        String -> [String]
lines (String -> [String])
-> (Fixer String -> String) -> Fixer String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixer String -> String
forall a. Fixer a -> a
runFixer (Fixer String -> [String]) -> Fixer String -> [String]
forall a b. (a -> b) -> a -> b
$ [Fix] -> String -> Fixer String
applyFixes2 [Fix]
adjustedFixes String
singleLine


-- start and end comes from pos, which is 1 based
prop_doReplace1 :: Bool
prop_doReplace1 = Integer -> Integer -> String -> String -> String
forall a a a.
(Integral a, Integral a) =>
a -> a -> [a] -> [a] -> [a]
doReplace Integer
0 Integer
0 String
"1234" String
"A" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"A1234" -- technically not valid
prop_doReplace2 :: Bool
prop_doReplace2 = Integer -> Integer -> String -> String -> String
forall a a a.
(Integral a, Integral a) =>
a -> a -> [a] -> [a] -> [a]
doReplace Integer
1 Integer
1 String
"1234" String
"A" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"A1234"
prop_doReplace3 :: Bool
prop_doReplace3 = Integer -> Integer -> String -> String -> String
forall a a a.
(Integral a, Integral a) =>
a -> a -> [a] -> [a] -> [a]
doReplace Integer
1 Integer
2 String
"1234" String
"A" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"A234"
prop_doReplace4 :: Bool
prop_doReplace4 = Integer -> Integer -> String -> String -> String
forall a a a.
(Integral a, Integral a) =>
a -> a -> [a] -> [a] -> [a]
doReplace Integer
3 Integer
3 String
"1234" String
"A" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"12A34"
prop_doReplace5 :: Bool
prop_doReplace5 = Integer -> Integer -> String -> String -> String
forall a a a.
(Integral a, Integral a) =>
a -> a -> [a] -> [a] -> [a]
doReplace Integer
4 Integer
4 String
"1234" String
"A" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"123A4"
prop_doReplace6 :: Bool
prop_doReplace6 = Integer -> Integer -> String -> String -> String
forall a a a.
(Integral a, Integral a) =>
a -> a -> [a] -> [a] -> [a]
doReplace Integer
5 Integer
5 String
"1234" String
"A" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"1234A"
doReplace :: a -> a -> [a] -> [a] -> [a]
doReplace a
start a
end [a]
o [a]
r =
    let si :: Int
si = a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
starta -> a -> a
forall a. Num a => a -> a -> a
-a
1)
        ei :: Int
ei = a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
enda -> a -> a
forall a. Num a => a -> a -> a
-a
1)
        ([a]
x, [a]
xs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
si [a]
o
        z :: [a]
z = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
ei Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
si) [a]
xs
    in
    [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
r [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
z

-- Fail if the 'expected' string is not result when applying 'fixes' to 'original'.
testFixes :: String -> String -> [Fix] -> Bool
testFixes :: String -> String -> [Fix] -> Bool
testFixes String
expected String
original [Fix]
fixes =
    String
actual String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
expected
  where
    actual :: String
actual = Fixer String -> String
forall a. Fixer a -> a
runFixer ([Fix] -> String -> Fixer String
applyFixes2 [Fix]
fixes String
original)


-- A Fixer allows doing repeated modifications of a string where each
-- replacement automatically accounts for shifts from previous ones.
type Fixer a =  State (PSTree Int) a

-- Apply a single replacement using its indices into the original string.
-- It does not handle multiple lines, all line indices must be 1.
applyReplacement2 :: Replacement -> String -> Fixer String
applyReplacement2 :: Replacement -> String -> Fixer String
applyReplacement2 Replacement
rep String
string = do
    PSTree Int
tree <- StateT (PSTree Int) Identity (PSTree Int)
forall s (m :: * -> *). MonadState s m => m s
get
    let transform :: Int -> Int
transform Int
pos = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> PSTree Int -> Int
forall n. (Ord n, Num n) => n -> PSTree n -> n
getPrefixSum Int
pos PSTree Int
tree
    let originalPos :: (Position, Position)
originalPos = (Replacement -> Position
repStartPos Replacement
rep, Replacement -> Position
repEndPos Replacement
rep)
        (Int
oldStart, Int
oldEnd) = (Position -> Int) -> (Position, Position) -> (Int, Int)
forall t b. (t -> b) -> (t, t) -> (b, b)
tmap (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (Position -> Integer) -> Position -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Integer
posColumn) (Position, Position)
originalPos
        (Int
newStart, Int
newEnd) = (Int -> Int) -> (Int, Int) -> (Int, Int)
forall t b. (t -> b) -> (t, t) -> (b, b)
tmap Int -> Int
transform (Int
oldStart, Int
oldEnd)

    let (Integer
l1, Integer
l2) = (Position -> Integer) -> (Position, Position) -> (Integer, Integer)
forall t b. (t -> b) -> (t, t) -> (b, b)
tmap Position -> Integer
posLine (Position, Position)
originalPos in
        Bool
-> StateT (PSTree Int) Identity ()
-> StateT (PSTree Int) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
l1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1 Bool -> Bool -> Bool
|| Integer
l2 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1) (StateT (PSTree Int) Identity ()
 -> StateT (PSTree Int) Identity ())
-> StateT (PSTree Int) Identity ()
-> StateT (PSTree Int) Identity ()
forall a b. (a -> b) -> a -> b
$
            String -> StateT (PSTree Int) Identity ()
forall a. HasCallStack => String -> a
error String
"ShellCheck internal error, please report: bad cross-line fix"

    let replacer :: String
replacer = Replacement -> String
repString Replacement
rep
    let shift :: Int
shift = (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
replacer) Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
oldEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldStart)
    let insertionPoint :: Int
insertionPoint =
          case Replacement -> InsertionPoint
repInsertionPoint Replacement
rep of
              InsertionPoint
InsertBefore -> Int
oldStart
              InsertionPoint
InsertAfter  -> Int
oldEndInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
    PSTree Int -> StateT (PSTree Int) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (PSTree Int -> StateT (PSTree Int) Identity ())
-> PSTree Int -> StateT (PSTree Int) Identity ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> PSTree Int -> PSTree Int
forall n. (Ord n, Num n) => n -> n -> PSTree n -> PSTree n
addPSValue Int
insertionPoint Int
shift PSTree Int
tree

    String -> Fixer String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Fixer String) -> String -> Fixer String
forall a b. (a -> b) -> a -> b
$ Int -> Int -> String -> String -> String
forall a a a.
(Integral a, Integral a) =>
a -> a -> [a] -> [a] -> [a]
doReplace Int
newStart Int
newEnd String
string String
replacer
  where
    tmap :: (t -> b) -> (t, t) -> (b, b)
tmap t -> b
f (t
a,t
b) = (t -> b
f t
a, t -> b
f t
b)

-- Apply a list of Replacements in the correct order
applyReplacements2 :: [Replacement] -> String -> Fixer String
applyReplacements2 :: [Replacement] -> String -> Fixer String
applyReplacements2 [Replacement]
reps String
str =
    (String -> Replacement -> Fixer String)
-> String -> [Replacement] -> Fixer String
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Replacement -> String -> Fixer String)
-> String -> Replacement -> Fixer String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Replacement -> String -> Fixer String
applyReplacement2) String
str ([Replacement] -> Fixer String) -> [Replacement] -> Fixer String
forall a b. (a -> b) -> a -> b
$
        [Replacement] -> [Replacement]
forall a. [a] -> [a]
reverse ([Replacement] -> [Replacement]) -> [Replacement] -> [Replacement]
forall a b. (a -> b) -> a -> b
$ (Replacement -> Int) -> [Replacement] -> [Replacement]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith Replacement -> Int
repPrecedence [Replacement]
reps

-- Apply all fixes with replacements in the correct order
applyFixes2 :: [Fix] -> String -> Fixer String
applyFixes2 :: [Fix] -> String -> Fixer String
applyFixes2 [Fix]
fixes = [Replacement] -> String -> Fixer String
applyReplacements2 ((Fix -> [Replacement]) -> [Fix] -> [Replacement]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Fix -> [Replacement]
fixReplacements [Fix]
fixes)

-- Get the final value of a Fixer.
runFixer :: Fixer a -> a
runFixer :: Fixer a -> a
runFixer Fixer a
f = Fixer a -> PSTree Int -> a
forall s a. State s a -> s -> a
evalState Fixer a
f PSTree Int
forall n. Num n => PSTree n
newPSTree



-- A Prefix Sum Tree that lets you look up the sum of values at and below an index.
-- It's implemented essentially as a Fenwick tree without the bit-based balancing.
-- The last Num is the sum of the left branch plus current element.
data PSTree n = PSBranch n (PSTree n) (PSTree n) n | PSLeaf
    deriving (Int -> PSTree n -> String -> String
[PSTree n] -> String -> String
PSTree n -> String
(Int -> PSTree n -> String -> String)
-> (PSTree n -> String)
-> ([PSTree n] -> String -> String)
-> Show (PSTree n)
forall n. Show n => Int -> PSTree n -> String -> String
forall n. Show n => [PSTree n] -> String -> String
forall n. Show n => PSTree n -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [PSTree n] -> String -> String
$cshowList :: forall n. Show n => [PSTree n] -> String -> String
show :: PSTree n -> String
$cshow :: forall n. Show n => PSTree n -> String
showsPrec :: Int -> PSTree n -> String -> String
$cshowsPrec :: forall n. Show n => Int -> PSTree n -> String -> String
Show)

newPSTree :: Num n => PSTree n
newPSTree :: PSTree n
newPSTree = PSTree n
forall n. PSTree n
PSLeaf

-- Get the sum of values whose keys are <= 'target'
getPrefixSum :: (Ord n, Num n) => n -> PSTree n -> n
getPrefixSum :: n -> PSTree n -> n
getPrefixSum = n -> n -> PSTree n -> n
forall a. (Ord a, Num a) => a -> a -> PSTree a -> a
f n
0
  where
    f :: a -> a -> PSTree a -> a
f a
sum a
_ PSTree a
PSLeaf = a
sum
    f a
sum a
target (PSBranch a
pivot PSTree a
left PSTree a
right a
cumulative) =
        case a
target a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
pivot of
            Ordering
LT -> a -> a -> PSTree a -> a
f a
sum a
target PSTree a
left
            Ordering
GT -> a -> a -> PSTree a -> a
f (a
suma -> a -> a
forall a. Num a => a -> a -> a
+a
cumulative) a
target PSTree a
right
            Ordering
EQ -> a
suma -> a -> a
forall a. Num a => a -> a -> a
+a
cumulative

-- Add a value to the Prefix Sum tree at the given index.
-- Values accumulate: addPSValue 42 2 . addPSValue 42 3 == addPSValue 42 5
addPSValue :: (Ord n, Num n) => n -> n -> PSTree n -> PSTree n
addPSValue :: n -> n -> PSTree n -> PSTree n
addPSValue n
key n
value PSTree n
tree = if n
value n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
0 then PSTree n
tree else PSTree n -> PSTree n
f PSTree n
tree
  where
    f :: PSTree n -> PSTree n
f PSTree n
PSLeaf = n -> PSTree n -> PSTree n -> n -> PSTree n
forall n. n -> PSTree n -> PSTree n -> n -> PSTree n
PSBranch n
key PSTree n
forall n. PSTree n
PSLeaf PSTree n
forall n. PSTree n
PSLeaf n
value
    f (PSBranch n
pivot PSTree n
left PSTree n
right n
sum) =
        case n
key n -> n -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` n
pivot of
            Ordering
LT -> n -> PSTree n -> PSTree n -> n -> PSTree n
forall n. n -> PSTree n -> PSTree n -> n -> PSTree n
PSBranch n
pivot (PSTree n -> PSTree n
f PSTree n
left) PSTree n
right (n
sum n -> n -> n
forall a. Num a => a -> a -> a
+ n
value)
            Ordering
GT -> n -> PSTree n -> PSTree n -> n -> PSTree n
forall n. n -> PSTree n -> PSTree n -> n -> PSTree n
PSBranch n
pivot PSTree n
left (PSTree n -> PSTree n
f PSTree n
right) n
sum
            Ordering
EQ -> n -> PSTree n -> PSTree n -> n -> PSTree n
forall n. n -> PSTree n -> PSTree n -> n -> PSTree n
PSBranch n
pivot PSTree n
left PSTree n
right (n
sum n -> n -> n
forall a. Num a => a -> a -> a
+ n
value)

prop_pstreeSumsCorrectly :: [(Int, Int)] -> [Int] -> Bool
prop_pstreeSumsCorrectly [(Int, Int)]
kvs [Int]
targets =
  let
    -- Trivial O(n * m) implementation
    dumbPrefixSums :: [(Int, Int)] -> [Int] -> [Int]
    dumbPrefixSums :: [(Int, Int)] -> [Int] -> [Int]
dumbPrefixSums [(Int, Int)]
kvs [Int]
targets =
        let prefixSum :: Int -> Int
prefixSum Int
target = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
v | (Int
k,Int
v) <- [(Int, Int)]
kvs, Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
target]
        in (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
prefixSum [Int]
targets
    -- PSTree O(n * log m) implementation
    smartPrefixSums :: [(Int, Int)] -> [Int] -> [Int]
    smartPrefixSums :: [(Int, Int)] -> [Int] -> [Int]
smartPrefixSums [(Int, Int)]
kvs [Int]
targets =
        let tree :: PSTree Int
tree = (PSTree Int -> (Int, Int) -> PSTree Int)
-> PSTree Int -> [(Int, Int)] -> PSTree Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\PSTree Int
tree (Int
pos, Int
shift) -> Int -> Int -> PSTree Int -> PSTree Int
forall n. (Ord n, Num n) => n -> n -> PSTree n -> PSTree n
addPSValue Int
pos Int
shift PSTree Int
tree) PSTree Int
forall n. PSTree n
PSLeaf [(Int, Int)]
kvs
        in (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> Int -> PSTree Int -> Int
forall n. (Ord n, Num n) => n -> PSTree n -> n
getPrefixSum Int
x PSTree Int
tree) [Int]
targets
  in [(Int, Int)] -> [Int] -> [Int]
smartPrefixSums [(Int, Int)]
kvs [Int]
targets [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [(Int, Int)] -> [Int] -> [Int]
dumbPrefixSums [(Int, Int)]
kvs [Int]
targets


-- Semi-convenient functions for constructing tests.
testFix :: [Replacement] -> Fix
testFix :: [Replacement] -> Fix
testFix [Replacement]
list = Fix
newFix {
        fixReplacements :: [Replacement]
fixReplacements = [Replacement]
list
    }

tFromStart :: Int -> Int -> String -> Int -> Replacement
tFromStart :: Int -> Int -> String -> Int -> Replacement
tFromStart Int
start Int
end String
repl Int
order =
    Replacement
newReplacement {
        repStartPos :: Position
repStartPos = Position
newPosition {
            posLine :: Integer
posLine = Integer
1,
            posColumn :: Integer
posColumn = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
start
        },
        repEndPos :: Position
repEndPos = Position
newPosition {
            posLine :: Integer
posLine = Integer
1,
            posColumn :: Integer
posColumn = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
end
        },
        repString :: String
repString = String
repl,
        repPrecedence :: Int
repPrecedence = Int
order,
        repInsertionPoint :: InsertionPoint
repInsertionPoint = InsertionPoint
InsertAfter
    }

tFromEnd :: Int -> Int -> String -> Int -> Replacement
tFromEnd Int
start Int
end String
repl Int
order =
    (Int -> Int -> String -> Int -> Replacement
tFromStart Int
start Int
end String
repl Int
order) {
        repInsertionPoint :: InsertionPoint
repInsertionPoint = InsertionPoint
InsertBefore
    }

prop_simpleFix1 :: Bool
prop_simpleFix1 = String -> String -> [Fix] -> Bool
testFixes String
"hello world" String
"hell world" [
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromEnd Int
5 Int
5 String
"o" Int
1
    ]]

prop_anchorsLeft :: Bool
prop_anchorsLeft = String -> String -> [Fix] -> Bool
testFixes String
"-->foobar<--" String
"--><--" [
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
4 Int
4 String
"foo" Int
1,
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
4 Int
4 String
"bar" Int
2
    ]]

prop_anchorsRight :: Bool
prop_anchorsRight = String -> String -> [Fix] -> Bool
testFixes String
"-->foobar<--" String
"--><--" [
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromEnd Int
4 Int
4 String
"bar" Int
1,
        Int -> Int -> String -> Int -> Replacement
tFromEnd Int
4 Int
4 String
"foo" Int
2
    ]]

prop_anchorsBoth1 :: Bool
prop_anchorsBoth1 = String -> String -> [Fix] -> Bool
testFixes String
"-->foobar<--" String
"--><--" [
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
4 Int
4 String
"bar" Int
2,
        Int -> Int -> String -> Int -> Replacement
tFromEnd Int
4 Int
4 String
"foo" Int
1
    ]]

prop_anchorsBoth2 :: Bool
prop_anchorsBoth2 = String -> String -> [Fix] -> Bool
testFixes String
"-->foobar<--" String
"--><--" [
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromEnd Int
4 Int
4 String
"foo" Int
2,
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
4 Int
4 String
"bar" Int
1
    ]]

prop_composeFixes1 :: Bool
prop_composeFixes1 = String -> String -> [Fix] -> Bool
testFixes String
"cd \"$1\" || exit" String
"cd $1" [
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
4 Int
4 String
"\"" Int
10,
        Int -> Int -> String -> Int -> Replacement
tFromEnd   Int
6 Int
6 String
"\"" Int
10
    ],
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromEnd Int
6 Int
6 String
" || exit" Int
5
    ]]

prop_composeFixes2 :: Bool
prop_composeFixes2 = String -> String -> [Fix] -> Bool
testFixes String
"$(\"$1\")" String
"`$1`" [
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
1 Int
2 String
"$(" Int
5,
        Int -> Int -> String -> Int -> Replacement
tFromEnd   Int
4 Int
5 String
")" Int
5
    ],
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
2 Int
2 String
"\"" Int
10,
        Int -> Int -> String -> Int -> Replacement
tFromEnd Int
4 Int
4 String
"\"" Int
10
    ]]

prop_composeFixes3 :: Bool
prop_composeFixes3 = String -> String -> [Fix] -> Bool
testFixes String
"(x)[x]" String
"xx" [
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
1 Int
1 String
"(" Int
4,
        Int -> Int -> String -> Int -> Replacement
tFromEnd   Int
2 Int
2 String
")" Int
3,
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
2 Int
2 String
"[" Int
2,
        Int -> Int -> String -> Int -> Replacement
tFromEnd   Int
3 Int
3 String
"]" Int
1
    ]]

prop_composeFixes4 :: Bool
prop_composeFixes4 = String -> String -> [Fix] -> Bool
testFixes String
"(x)[x]" String
"xx" [
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
1 Int
1 String
"(" Int
4,
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
2 Int
2 String
"[" Int
3,
        Int -> Int -> String -> Int -> Replacement
tFromEnd   Int
2 Int
2 String
")" Int
2,
        Int -> Int -> String -> Int -> Replacement
tFromEnd   Int
3 Int
3 String
"]" Int
1
    ]]

prop_composeFixes5 :: Bool
prop_composeFixes5 = String -> String -> [Fix] -> Bool
testFixes String
"\"$(x)\"" String
"`x`" [
    [Replacement] -> Fix
testFix [
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
1 Int
2 String
"$(" Int
2,
        Int -> Int -> String -> Int -> Replacement
tFromEnd   Int
3 Int
4 String
")"  Int
2,
        Int -> Int -> String -> Int -> Replacement
tFromStart Int
1 Int
1 String
"\"" Int
1,
        Int -> Int -> String -> Int -> Replacement
tFromEnd   Int
4 Int
4 String
"\"" Int
1
    ]]


return []
runTests :: IO Bool
runTests = Bool
String
[(String, Property)]
Bool -> Property
[(Int, Int)] -> [Int] -> Bool
[(String, Property)] -> (Property -> IO Result) -> IO Bool
Property -> IO Result
([(Int, Int)] -> [Int] -> Bool) -> Property
forall prop. Testable prop => prop -> IO Result
forall prop. Testable prop => prop -> Property
runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool
property :: forall prop. Testable prop => prop -> Property
quickCheckResult :: forall prop. Testable prop => prop -> IO Result
prop_composeFixes5 :: Bool
prop_composeFixes4 :: Bool
prop_composeFixes3 :: Bool
prop_composeFixes2 :: Bool
prop_composeFixes1 :: Bool
prop_anchorsBoth2 :: Bool
prop_anchorsBoth1 :: Bool
prop_anchorsRight :: Bool
prop_anchorsLeft :: Bool
prop_simpleFix1 :: Bool
prop_pstreeSumsCorrectly :: [(Int, Int)] -> [Int] -> Bool
prop_doReplace6 :: Bool
prop_doReplace5 :: Bool
prop_doReplace4 :: Bool
prop_doReplace3 :: Bool
prop_doReplace2 :: Bool
prop_doReplace1 :: Bool
prop_overlap_partial :: Bool
prop_overlap_enclosed :: Bool
prop_overlap_adjacent_zerowidth :: Bool
prop_overlap_contiguous :: Bool
$quickCheckAll