Diffs are Church-encoded.

src/Diff.hs

@@ -2,7 +2,7 @@ module Diff where
 
 import Syntax
 import Data.Set
-import Control.Monad.Free
+import Control.Monad.Free.Church
 import Patch
 import Term
 import Range
@@ -18,7 +18,7 @@ data Info = Info { characterRange :: !Range, categories :: !(Set Category) }
 instance Categorizable Info where
   categories = Diff.categories
 
-type Diff a annotation = Free (Annotated a (annotation, annotation)) (Patch (Term a annotation))
+type Diff a annotation = F (Annotated a (annotation, annotation)) (Patch (Term a annotation))
 
 diffSum :: (Patch (Term a annotation) -> Integer) -> Diff a annotation -> Integer
 diffSum patchCost diff = sum $ fmap patchCost diff

src/Interpreter.hs

@@ -21,7 +21,7 @@ import Data.Maybe
 type Comparable a annotation = Term a annotation -> Term a annotation -> Bool
 
 interpret :: (Eq a, Eq annotation) => Comparable a annotation -> Term a annotation -> Term a annotation -> Diff a annotation
-interpret comparable a b = fromMaybe (Pure $ Replace a b) $ constructAndRun comparable a b
+interpret comparable a b = fromMaybe (pure $ Replace a b) $ constructAndRun comparable a b
 
 hylo :: Functor f => (t -> f b -> b) -> (a -> (t, f a)) -> a -> b
 hylo down up a = down annotation $ hylo down up <$> syntax where
@@ -33,15 +33,15 @@ constructAndRun _ a b | a == b = hylo introduce eliminate <$> zipTerms a b where
   eliminate :: Cofree f a -> (a, f (Cofree f a))
   eliminate (extract :< unwrap) = (extract, unwrap)
   introduce :: (annotation, annotation) -> Syntax a (Diff a annotation) -> Diff a annotation
-  introduce ann syntax = Free $ Annotated ann syntax
+  introduce ann syntax = wrap $ Annotated ann syntax
 constructAndRun comparable a b | not $ comparable a b = Nothing
 constructAndRun comparable (annotation1 :< a) (annotation2 :< b) =
   run comparable $ algorithm a b where
     algorithm (Indexed a') (Indexed b') = Free $ ByIndex a' b' (annotate . Indexed)
     algorithm (Keyed a') (Keyed b') = Free $ ByKey a' b' (annotate . Keyed)
     algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b'
-    algorithm a' b' = Free $ Recursive (annotation1 :< a') (annotation2 :< b') Pure
+    algorithm a' b' = wrap $ Recursive (annotation1 :< a') (annotation2 :< b') pure
-    annotate = Pure . Free . Annotated (annotation1, annotation2)
+    annotate = pure . wrap . Annotated (annotation1, annotation2)
 
 -- | Runs the diff algorithm
 run :: (Eq a, Eq annotation) => Comparable a annotation -> Algorithm a annotation (Diff a annotation) -> Maybe (Diff a annotation)
@@ -55,14 +55,14 @@ run comparable (Free (Recursive (annotation1 :< a) (annotation2 :< b) f)) = run
       bKeys = Map.keys b'
       repack key = (key, interpretInBoth key a' b')
       interpretInBoth key x y = interpret comparable (x ! key) (y ! key)
-  recur _ _ = Pure $ Replace (annotation1 :< a) (annotation2 :< b)
+  recur _ _ = pure $ Replace (annotation1 :< a) (annotation2 :< b)
 
-  annotate = Free . Annotated (annotation1, annotation2)
+  annotate = wrap . Annotated (annotation1, annotation2)
 
 run comparable (Free (ByKey a b f)) = run comparable $ f byKey where
   byKey = Map.fromList $ toKeyValue <$> List.union aKeys bKeys
-  toKeyValue key | List.elem key deleted = (key, Pure . Delete $ a ! key)
+  toKeyValue key | List.elem key deleted = (key, pure . Delete $ a ! key)
-  toKeyValue key | List.elem key inserted = (key, Pure . Insert $ b ! key)
+  toKeyValue key | List.elem key inserted = (key, pure . Insert $ b ! key)
   toKeyValue key = (key, interpret comparable (a ! key) (b ! key))
   aKeys = Map.keys a
   bKeys = Map.keys b

src/SES.hs

@@ -3,7 +3,6 @@ module SES where
 import Patch
 import Diff
 import Term
-import Control.Monad.Free
 import Control.Monad.State
 import Data.Foldable (minimumBy)
 import Data.List (uncons)
@@ -20,9 +19,9 @@ ses diffTerms cost as bs = fst <$> evalState diffState Map.empty where
 diffAt :: Compare a annotation -> Cost a annotation -> (Integer, Integer) -> [Term a annotation] -> [Term a annotation] -> State (Map.Map (Integer, Integer) [(Diff a annotation, Integer)]) [(Diff a annotation, Integer)]
 diffAt _ _ _ [] [] = return []
 diffAt _ cost _ [] bs = return $ foldr toInsertions [] bs where
-  toInsertions each = consWithCost cost (Pure . Insert $ each)
+  toInsertions each = consWithCost cost (pure . Insert $ each)
 diffAt _ cost _ as [] = return $ foldr toDeletions [] as where
-  toDeletions each = consWithCost cost (Pure . Delete $ each)
+  toDeletions each = consWithCost cost (pure . Delete $ each)
 diffAt diffTerms cost (i, j) (a : as) (b : bs) = do
   cachedDiffs <- get
   case Map.lookup (i, j) cachedDiffs of
@@ -39,8 +38,8 @@ diffAt diffTerms cost (i, j) (a : as) (b : bs) = do
       put $ Map.insert (i, j) nomination cachedDiffs'
       return nomination
   where
-    delete = consWithCost cost (Pure . Delete $ a)
+    delete = consWithCost cost (pure . Delete $ a)
-    insert = consWithCost cost (Pure . Insert $ b)
+    insert = consWithCost cost (pure . Insert $ b)
     costOf [] = 0
     costOf ((_, c) : _) = c
     best = minimumBy (comparing costOf)

src/Split.hs

@@ -10,6 +10,7 @@ import Syntax
 import Control.Comonad.Cofree
 import Range
 import Control.Monad.Free
+import Control.Monad.Free.Church
 import Data.ByteString.Lazy.Internal
 import Text.Blaze.Html
 import Text.Blaze.Html5 hiding (map)
@@ -88,8 +89,8 @@ instance ToMarkup (Renderable (SplitDiff a Info)) where
           toMarkupAndRange term@(Info range _ :< _) = ((div ! A.class_ (stringValue "patch")) . toMarkup $ Renderable (source, term), range)
 
 splitDiffByLines :: Diff a Info -> (Int, Int) -> (Source Char, Source Char) -> ([Row (SplitDiff a Info)], (Range, Range))
-splitDiffByLines diff (prevLeft, prevRight) sources = case diff of
+splitDiffByLines diff (prevLeft, prevRight) sources = case fromF diff of
-  Free (Annotated annotation syntax) -> (splitAnnotatedByLines sources (ranges annotation) (categories annotation) syntax, ranges annotation)
+  Free (Annotated annotation syntax) -> (splitAnnotatedByLines sources (ranges annotation) (categories annotation) (toF <$> syntax), ranges annotation)
   Pure (Insert term) -> let (lines, range) = splitTermByLines term (snd sources) in
     (Row EmptyLine . fmap Pure <$> lines, (Range prevLeft prevLeft, range))
   Pure (Delete term) -> let (lines, range) = splitTermByLines term (fst sources) in

src/Unified.hs

@@ -7,7 +7,7 @@ import Term
 import Range
 import Source hiding ((++))
 import Control.Arrow
-import Control.Monad.Free
+import Control.Monad.Free.Church
 import Control.Comonad.Cofree
 import Data.List hiding (foldl)
 import qualified OrderedMap as Map
@@ -24,6 +24,9 @@ unified diff before after = do
     annotationAndSyntaxToChunks source (Info range _) (Fixed f) = (unifiedRange range f source, Just range)
     annotationAndSyntaxToChunks source (Info range _) (Keyed k) = (unifiedRange range (sort $ snd <$> Map.toList k) source, Just range)
 
+    iter :: Functor f => (f a -> a) -> F f a -> a
+    iter phi xs = runF xs id phi
+
     unifiedPatch :: Patch (Term a Info) -> [Chunk String]
     unifiedPatch patch = (fore red . bold <$> beforeChunk) <> (fore green . bold <$> afterChunk) where
       beforeChunk = maybe [] (change "-" . unifiedTerm before) $ Patch.before patch