Skip to content

Commit 8e601f8

Browse files
phadejphadej
authored
Merge pull request #55 from haskellari/small-memory
Small memory
2 parents e79f2ad + 7bd0ac7 commit 8e601f8

File tree

6 files changed

+180
-37
lines changed

6 files changed

+180
-37
lines changed

‎ChangeLog.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
`Pretty` datastructure is changed.
55
- Change `Expr` to use `OMap`; pretty-printing preserves field order.
66
- Add `strict` and `these` instances
7+
- Add `Eq` and `NFData (Edit a)` instances.
78
- Bump lower bounds
89

910
## 0.1

‎src-diff/RefDiffBy.hs‎

Lines changed: 60 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,60 @@
1+
{-# LANGUAGE ScopedTypeVariables #-}
2+
module RefDiffBy (diffBy) where
3+
4+
import Data.TreeDiff.List (Edit (..))
5+
6+
import qualified Data.Primitive as P
7+
8+
diffBy :: forall a. (a -> a -> Bool) -> [a] -> [a] -> [Edit a]
9+
diffBy eq xs' ys' = reverse (getCell (lcs xn yn))
10+
where
11+
xn = length xs'
12+
yn = length ys'
13+
14+
xs = P.arrayFromListN xn xs'
15+
ys = P.arrayFromListN yn ys'
16+
17+
memo :: P.Array (Cell [Edit a])
18+
memo = P.arrayFromListN ((xn + 1) * (yn + 1))
19+
[ impl xi yi
20+
| xi <- [0 .. xn]
21+
, yi <- [0 .. yn]
22+
]
23+
24+
lcs :: Int -> Int -> Cell [Edit a]
25+
lcs xi yi = P.indexArray memo (yi + xi * (yn + 1))
26+
27+
impl :: Int -> Int -> Cell [Edit a]
28+
impl 0 0 = Cell 0 []
29+
impl 0 m = case lcs 0 (m - 1) of
30+
Cell w edit -> Cell (w + 1) (Ins (P.indexArray ys (m - 1)) : edit)
31+
impl n 0 = case lcs (n - 1) 0 of
32+
Cell w edit -> Cell (w + 1) (Del (P.indexArray xs (n - 1)) : edit)
33+
34+
impl n m = bestOfThree
35+
edit
36+
(bimap (+1) (Ins y :) (lcs n (m - 1)))
37+
(bimap (+1) (Del x :) (lcs (n - 1) m))
38+
where
39+
x = P.indexArray xs (n - 1)
40+
y = P.indexArray ys (m - 1)
41+
42+
edit
43+
| eq x y = bimap id (Cpy x :) (lcs (n - 1) (m - 1))
44+
| otherwise = bimap (+1) (Swp x y :) (lcs (n - 1) (m - 1))
45+
46+
data Cell a = Cell !Int !a
47+
48+
getCell :: Cell a -> a
49+
getCell (Cell _ x) = x
50+
51+
bestOfThree :: Cell a -> Cell a -> Cell a -> Cell a
52+
bestOfThree a@(Cell i _x) b@(Cell j _y) c@(Cell k _z)
53+
| i <= j
54+
= if i <= k then a else c
55+
56+
| otherwise
57+
= if j <= k then b else c
58+
59+
bimap :: (Int -> Int) -> (a -> b) -> Cell a -> Cell b
60+
bimap f g (Cell i x) = Cell (f i) (g x)

‎src/Data/TreeDiff/List.hs‎

Lines changed: 101 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,18 @@
1+
{-# LANGUAGE BangPatterns #-}
12
{-# LANGUAGE ScopedTypeVariables #-}
23
-- | A list diff.
3-
module Data.TreeDiff.List (diffBy, Edit (..)) where
4+
module Data.TreeDiff.List (
5+
diffBy,
6+
Edit (..),
7+
) where
48

59
import Control.DeepSeq (NFData (..))
10+
import Control.Monad.ST (ST, runST)
611

712
import qualified Data.Primitive as P
813

14+
-- import Debug.Trace
15+
916
-- | List edit operations
1017
--
1118
-- The 'Swp' constructor is redundant, but it let us spot
@@ -15,7 +22,7 @@ data Edit a
1522
| Del a -- ^ delete
1623
| Cpy a -- ^ copy unchanged
1724
| Swp a a -- ^ swap, i.e. delete + insert
18-
deriving Show
25+
deriving (Eq, Show)
1926

2027
instance NFData a => NFData (Edit a) where
2128
rnf (Ins x) = rnf x
@@ -37,45 +44,105 @@ instance NFData a => NFData (Edit a) where
3744
-- /Note:/ currently this has O(n*m) memory requirements, for the sake
3845
-- of more obviously correct implementation.
3946
--
40-
diffBy :: forall a. (a -> a -> Bool) -> [a] -> [a] -> [Edit a]
41-
diffBy eq xs' ys' = reverse (getCell (lcs xn yn))
47+
diffBy :: forall a. Show a => (a -> a -> Bool) -> [a] -> [a] -> [Edit a]
48+
diffBy _ [] [] = []
49+
diffBy _ [] ys' = map Ins ys'
50+
diffBy _ xs' [] = map Del xs'
51+
diffBy eq xs' ys'
52+
| otherwise = reverse (getCell lcs)
4253
where
4354
xn = length xs'
4455
yn = length ys'
4556

4657
xs = P.arrayFromListN xn xs'
4758
ys = P.arrayFromListN yn ys'
4859

49-
memo :: P.Array (Cell [Edit a])
50-
memo = P.arrayFromListN ((xn + 1) * (yn + 1))
51-
[ impl xi yi
52-
| xi <- [0 .. xn]
53-
, yi <- [0 .. yn]
54-
]
55-
56-
lcs :: Int -> Int -> Cell [Edit a]
57-
lcs xi yi = P.indexArray memo (yi + xi * (yn + 1))
58-
59-
impl :: Int -> Int -> Cell [Edit a]
60-
impl 0 0 = Cell 0 []
61-
impl 0 m = case lcs 0 (m - 1) of
62-
Cell w edit -> Cell (w + 1) (Ins (P.indexArray ys (m - 1)) : edit)
63-
impl n 0 = case lcs (n - 1) 0 of
64-
Cell w edit -> Cell (w + 1) (Del (P.indexArray xs (n - 1)) : edit)
65-
66-
impl n m = bestOfThree
67-
edit
68-
(bimap (+1) (Ins y :) (lcs n (m - 1)))
69-
(bimap (+1) (Del x :) (lcs (n - 1) m))
70-
where
71-
x = P.indexArray xs (n - 1)
72-
y = P.indexArray ys (m - 1)
73-
74-
edit
75-
| eq x y = bimap id (Cpy x :) (lcs (n - 1) (m - 1))
76-
| otherwise = bimap (+1) (Swp x y :) (lcs (n - 1) (m - 1))
77-
78-
data Cell a = Cell !Int !a
60+
lcs :: Cell [Edit a]
61+
lcs = runST $ do
62+
-- traceShowM ("sizes", xn, yn)
63+
64+
-- create two buffers.
65+
buf1 <- P.newArray yn (Cell 0 [])
66+
buf2 <- P.newArray yn (Cell 0 [])
67+
68+
-- fill the first row
69+
-- 0,0 case is filled already
70+
yLoop (Cell 0 []) $ \m (Cell w edit) -> do
71+
let cell = Cell (w + 1) (Ins (P.indexArray ys m) : edit)
72+
P.writeArray buf1 m cell
73+
P.writeArray buf2 m cell
74+
-- traceShowM ("init", m, cell)
75+
return cell
76+
77+
-- following rows
78+
--
79+
-- cellC cellT
80+
-- cellL cellX
81+
(buf1final, _, _) <- xLoop (buf1, buf2, Cell 0 []) $ \n (prev, curr, cellC) -> do
82+
-- prevZ <- P.unsafeFreezeArray prev
83+
-- currZ <- P.unsafeFreezeArray prev
84+
-- traceShowM ("prev", n, prevZ)
85+
-- traceShowM ("curr", n, currZ)
86+
87+
let cellL :: Cell [Edit a]
88+
cellL = case cellC of (Cell w edit) -> Cell (w + 1) (Del (P.indexArray xs n) : edit)
89+
90+
-- traceShowM ("cellC, cellL", n, cellC, cellL)
91+
92+
yLoop (cellC, cellL) $ \m (cellC', cellL') -> do
93+
-- traceShowM ("inner loop", n, m)
94+
cellT <- P.readArray prev m
95+
96+
-- traceShowM ("cellT", n, m, cellT)
97+
98+
let x, y :: a
99+
x = P.indexArray xs n
100+
y = P.indexArray ys m
101+
102+
-- from diagonal
103+
let cellX1 :: Cell [Edit a]
104+
cellX1
105+
| eq x y = bimap id (Cpy x :) cellC'
106+
| otherwise = bimap (+1) (Swp x y :) cellC'
107+
108+
-- from top
109+
let cellX2 :: Cell [Edit a]
110+
cellX2 = bimap (+1) (Del x :) cellT
111+
112+
-- from left
113+
let cellX3 :: Cell [Edit a]
114+
cellX3 = bimap (+1) (Ins y :) cellL'
115+
116+
-- the actual cell is best of three
117+
let cellX :: Cell [Edit a]
118+
cellX = bestOfThree cellX1 cellX2 cellX3
119+
120+
-- traceShowM ("cellX", n, m, cellX)
121+
122+
-- memoize
123+
P.writeArray curr m cellX
124+
125+
return (cellT, cellX)
126+
127+
return (curr, prev, cellL)
128+
129+
P.readArray buf1final (yn - 1)
130+
131+
xLoop :: acc -> (Int -> acc -> ST s acc) -> ST s acc
132+
xLoop !acc0 f = go acc0 0 where
133+
go !acc !n | n < xn = do
134+
acc' <- f n acc
135+
go acc' (n + 1)
136+
go !acc _ = return acc
137+
138+
yLoop :: acc -> (Int -> acc -> ST s acc) -> ST s ()
139+
yLoop !acc0 f = go acc0 0 where
140+
go !acc !m | m < yn = do
141+
acc' <- f m acc
142+
go acc' (m + 1)
143+
go _ _ = return ()
144+
145+
data Cell a = Cell !Int !a deriving Show
79146

80147
getCell :: Cell a -> a
81148
getCell (Cell _ x) = x

‎src/Data/TreeDiff/Tree.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -72,7 +72,7 @@ import Data.TreeDiff.List
7272
-- >>> ppEditTree PP.char (treeDiff x w)
7373
-- (a b (c d +x e) f)
7474
--
75-
treeDiff :: Eq a => Tree a -> Tree a -> Edit (EditTree a)
75+
treeDiff :: (Show a, Eq a) => Tree a -> Tree a -> Edit (EditTree a)
7676
treeDiff ta@(Node a as) tb@(Node b bs)
7777
| a == b = Cpy $ EditNode a (map rec (diffBy (==) as bs))
7878
| otherwise = Swp (treeToEdit ta) (treeToEdit tb)

‎tests/Tests.hs‎

Lines changed: 14 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,10 +2,11 @@
22
module Main (main) where
33

44
import Data.Proxy (Proxy (..))
5+
import Data.Word (Word8)
56
import GHC.Generics (Generic)
67
import Prelude ()
78
import Prelude.Compat
8-
import Test.QuickCheck (Property, counterexample)
9+
import Test.QuickCheck (Property, counterexample, (===))
910
import Test.Tasty (TestTree, defaultMain, testGroup)
1011
import Test.Tasty.Golden.Advanced (goldenTest)
1112
import Test.Tasty.QuickCheck (testProperty)
@@ -17,15 +18,27 @@ import qualified Text.Trifecta.Result as T (ErrInfo (..), Result (..))
1718

1819
import Data.TreeDiff
1920
import Data.TreeDiff.Golden
21+
import Data.TreeDiff.List
2022
import Data.TreeDiff.QuickCheck
2123

24+
import qualified RefDiffBy
25+
2226
main :: IO ()
2327
main = defaultMain $ testGroup "tests"
2428
[ testProperty "trifecta-pretty roundtrip" roundtripTrifectaPretty
2529
, testProperty "parsec-ansi-wl-pprint roundtrip" roundtripParsecAnsiWl
30+
, testProperty "diffBy model" diffByModel
2631
, goldenTests
2732
]
2833

34+
-------------------------------------------------------------------------------
35+
-- diffBy
36+
-------------------------------------------------------------------------------
37+
38+
diffByModel :: [Word8] -> [Word8] -> Property
39+
diffByModel xs ys =
40+
diffBy (==) xs ys === RefDiffBy.diffBy (==) xs ys
41+
2942
-------------------------------------------------------------------------------
3043
-- Roundtrip
3144
-------------------------------------------------------------------------------

‎tree-diff.cabal‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -143,8 +143,9 @@ test-suite tree-diff-test
143143
default-language: Haskell2010
144144
type: exitcode-stdio-1.0
145145
main-is: Tests.hs
146-
hs-source-dirs: tests
146+
hs-source-dirs: tests src-diff
147147
ghc-options: -Wall -threaded
148+
other-modules: RefDiffBy
148149

149150
-- dependencies from library
150151
build-depends:
@@ -153,6 +154,7 @@ test-suite tree-diff-test
153154
, base
154155
, base-compat
155156
, parsec
157+
, primitive
156158
, QuickCheck
157159
, tagged
158160
, tree-diff

0 commit comments

Comments
 (0)