github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-28 10:15:55 +03:00
Code Issues Projects Releases Wiki Activity

Parameterize interpret by a comparable function.

Browse Source
This commit is contained in:
Rob Rix 2015-11-18 11:09:11 -08:00
parent 6e64ada5ad
commit 0ad19372fd
1 changed files with 16 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
src/Interpreter.hs
View File

@ -10,38 +10,40 @@ import Data.Map
import Patch
import SES
constructAndRun :: Eq a => Term a Info -> Term a Info -> Maybe (Diff a)
constructAndRun a b =
run $ algorithm a b where
constructAndRun :: Eq a => Comparable a -> Term a Info -> Term a Info -> Maybe (Diff a)
constructAndRun comparable a b =
run comparable $ algorithm a b where
algorithm (_ :< Indexed a) (_ :< Indexed b) = Free $ ByIndex a b (Pure . Free . Indexed)
algorithm (_ :< Keyed a) (_ :< Keyed b) = Free $ ByKey a b (Pure . Free . Keyed)
algorithm (_ :< Leaf a) (_ :< Leaf b) | a == b = Pure . Free $ Leaf b
algorithm a b = Free $ Recursive a b Pure
run :: Eq a => Algorithm a (Diff a) -> Maybe (Diff a)
run (Pure diff) = Just diff
run :: Eq a => Comparable a -> Algorithm a (Diff a) -> Maybe (Diff a)
run _ (Pure diff) = Just diff
run (Free (Recursive a b f)) = run . f $ recur a b where
run comparable (Free (Recursive a b f)) = run comparable . f $ recur a b where
recur (_ :< Indexed a') (_ :< Indexed b') | length a' == length b' =
Free . Indexed $ zipWith interpret a' b'
Free . Indexed $ zipWith (interpret comparable) a' b'
recur (_ :< Fixed a') (_ :< Fixed b') | length a' == length b' =
Free . Fixed $ zipWith interpret a' b'
Free . Fixed $ zipWith (interpret comparable) a' b'
recur (_ :< Keyed a') (_ :< Keyed b') | keys a' == keys b' =
Free . Keyed . fromList . fmap repack $ keys b' where
repack key = (key, interpretInBoth key a' b')
interpretInBoth key a' b' = maybeInterpret (Data.Map.lookup key a') (Data.Map.lookup key b')
maybeInterpret (Just a) (Just b) = interpret a b
maybeInterpret (Just a) (Just b) = interpret comparable a b
recur _ _ = Pure $ Replace a b
run (Free (ByKey a b f)) = run $ f byKey where
run comparable (Free (ByKey a b f)) = run comparable $ f byKey where
byKey = unions [ deleted, inserted, patched ]
deleted = (Pure . Delete) <$> difference a b
inserted = (Pure . Insert) <$> difference b a
patched = intersectionWith interpret a b
patched = intersectionWith (interpret comparable) a b
run (Free (ByIndex a b f)) = run . f $ ses constructAndRun cost a b
run comparable (Free (ByIndex a b f)) = run comparable . f $ ses (constructAndRun comparable) cost a b
interpret :: Eq a => Term a Info -> Term a Info -> Diff a
interpret a b = maybeReplace $ constructAndRun a b where
type Comparable a = a -> a -> Bool
interpret :: Eq a => Comparable a -> Term a Info -> Term a Info -> Diff a
interpret comparable a b = maybeReplace $ constructAndRun comparable a b where
maybeReplace (Just a) = a
maybeReplace Nothing = Pure $ Replace a b