1
1
mirror of https://github.com/github/semantic.git synced 2024-12-22 22:31:36 +03:00
semantic/src/Diff.hs

72 lines
3.3 KiB
Haskell
Raw Normal View History

2017-05-08 18:52:36 +03:00
{-# LANGUAGE TypeSynonymInstances, UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
2015-11-18 00:25:36 +03:00
module Diff where
import Prologue
import Data.Functor.Both as Both
2016-07-23 00:38:10 +03:00
import Data.Mergeable
import Data.Record
2017-05-08 18:46:12 +03:00
import Data.These
2015-11-18 05:23:53 +03:00
import Patch
import Syntax
2016-02-29 18:04:59 +03:00
import Term
2015-11-18 00:25:36 +03:00
2016-01-14 20:30:21 +03:00
-- | An annotated series of patches of terms.
type DiffF f annotation = FreeF (TermF f (Both annotation)) (Patch (Term f annotation))
type Diff f annotation = Free (TermF f (Both annotation)) (Patch (Term f annotation))
2016-05-03 22:50:38 +03:00
type SyntaxDiff leaf fields = Diff (Syntax leaf) (Record fields)
diffSum :: (Foldable f, Functor f) => (Patch (Term f annotation) -> Int) -> Diff f annotation -> Int
2015-12-01 18:13:05 +03:00
diffSum patchCost diff = sum $ fmap patchCost diff
2015-12-01 03:06:48 +03:00
2016-04-11 22:06:59 +03:00
-- | The sum of the node count of the diffs patches.
diffCost :: (Foldable f, Functor f) => Diff f annotation -> Int
2015-12-01 03:16:22 +03:00
diffCost = diffSum $ patchSum termSize
-- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch.
2017-05-08 18:52:36 +03:00
mergeMaybe :: Mergeable f => (Patch (Term f annotation) -> Maybe (Term f annotation)) -> (Both annotation -> annotation) -> Diff f annotation -> Maybe (Term f annotation)
mergeMaybe transform extractAnnotation = iter algebra . fmap transform
2017-05-08 18:52:36 +03:00
where algebra (annotations :< syntax) = cofree . (extractAnnotation annotations :<) <$> sequenceAlt syntax
-- | Recover the before state of a diff.
2016-09-15 00:13:10 +03:00
beforeTerm :: Mergeable f => Diff f annotation -> Maybe (Term f annotation)
beforeTerm = mergeMaybe before Both.fst
-- | Recover the after state of a diff.
afterTerm :: Mergeable f => Diff f annotation -> Maybe (Term f annotation)
afterTerm = mergeMaybe after Both.snd
2017-02-07 22:58:11 +03:00
-- | Map a function over the annotations in a diff, whether in diff or term nodes.
2017-02-07 23:03:59 +03:00
--
2017-02-08 20:03:50 +03:00
-- Typed using Free so as to accommodate Free structures derived from diffs that dont fit into the Diff type synonym.
mapAnnotations :: (Functor f, Functor g)
=> (annotation -> annotation')
-> Free (TermF f (g annotation)) (Patch (Term f annotation))
-> Free (TermF f (g annotation')) (Patch (Term f annotation'))
mapAnnotations f = iter (wrap . first (fmap f)) . fmap (pure . fmap (fmap f))
2017-05-08 18:46:12 +03:00
2017-05-08 19:48:49 +03:00
-- | Fold a diff with a combining rule for replacement patches and an algebra on the annotated syntax functor.
2017-05-08 19:44:36 +03:00
foldDiffWith :: Functor f
2017-05-08 19:48:49 +03:00
=> (b -> b -> b) -- ^ A function to merge the results of the algebra when applied to replacement patches.
-> (TermF f (These a a) b -> b) -- ^ An algebra on the annotated syntax functor.
-> Diff f a -- ^ The diff to fold.
-> b -- ^ The final resulting value.
foldDiffWith merge algebra = iter (algebra . first (runBothWith These)) . fmap (mergeTheseWith (cata algebra . fmap This) (cata algebra . fmap That) merge . unPatch)
2017-05-08 18:46:12 +03:00
2017-05-08 19:48:49 +03:00
-- | Fold a diff with an algebra on the annotated syntax functor.
--
-- This is just like 'foldDiffWith' except that it uses the overloaded '(<>)' method from 'Semigroup'.
2017-05-08 19:44:36 +03:00
foldDiff :: (Semigroup b, Functor f)
2017-05-08 19:48:49 +03:00
=> (TermF f (These a a) b -> b) -- ^ An algebra on the annotated syntax functor.
-> Diff f a -- ^ The diff to fold.
-> b -- ^ The final resulting value.
foldDiff = foldDiffWith (<>)
2017-05-08 18:46:12 +03:00
instance (NFData (f (Diff f a)), NFData (Cofree f a), NFData a, Functor f) => NFData (Diff f a) where
rnf fa = case runFree fa of
Free f -> rnf f `seq` ()
Pure a -> rnf a `seq` ()