mirror of
https://github.com/github/semantic.git
synced 2024-12-21 05:41:54 +03:00
75 lines
3.1 KiB
Haskell
75 lines
3.1 KiB
Haskell
{-# LANGUAGE TypeSynonymInstances, UndecidableInstances #-}
|
||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||
module Diff where
|
||
|
||
import qualified Control.Comonad.Trans.Cofree as CofreeF
|
||
import Control.DeepSeq
|
||
import qualified Control.Monad.Free as Free
|
||
import qualified Control.Monad.Trans.Free as FreeF
|
||
import Data.Bifunctor
|
||
import Data.Functor.Both as Both
|
||
import Data.Functor.Classes.Pretty.Generic
|
||
import Data.Mergeable
|
||
import Data.Record
|
||
import Patch
|
||
import Syntax
|
||
import Term
|
||
|
||
-- | An annotated series of patches of terms.
|
||
type DiffF f annotation = FreeF.FreeF (TermF f (Both annotation)) (Patch (Term f annotation))
|
||
type Diff f annotation = Free.Free (TermF f (Both annotation)) (Patch (Term f annotation))
|
||
|
||
type SyntaxDiff fields = Diff Syntax (Record fields)
|
||
|
||
diffSum :: (Foldable f, Functor f) => (Patch (Term f annotation) -> Int) -> Diff f annotation -> Int
|
||
diffSum patchCost diff = sum $ fmap patchCost diff
|
||
|
||
-- | The sum of the node count of the diff’s patches.
|
||
diffCost :: (Foldable f, Functor f) => Diff f annotation -> Int
|
||
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.
|
||
mergeMaybe :: Mergeable f => (Patch (Term f annotation) -> Maybe (Term f annotation)) -> (Both annotation -> annotation) -> Diff f annotation -> Maybe (Term f annotation)
|
||
mergeMaybe transform extractAnnotation = Free.iter algebra . fmap transform
|
||
where algebra (annotations CofreeF.:< syntax) = cofree . (extractAnnotation annotations CofreeF.:<) <$> sequenceAlt syntax
|
||
|
||
-- | Recover the before state of a diff.
|
||
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
|
||
|
||
-- | Map a function over the annotations in a diff, whether in diff or term nodes.
|
||
--
|
||
-- Typed using Free so as to accommodate Free structures derived from diffs that don’t fit into the Diff type synonym.
|
||
mapAnnotations :: (Functor f, Functor g)
|
||
=> (annotation -> annotation')
|
||
-> Free.Free (TermF f (g annotation)) (Patch (Term f annotation))
|
||
-> Free.Free (TermF f (g annotation')) (Patch (Term f annotation'))
|
||
mapAnnotations f = Free.hoistFree (first (fmap f)) . fmap (fmap (fmap f))
|
||
|
||
|
||
instance (NFData (f (Diff f a)), NFData (f (Term f a)), NFData a, Functor f) => NFData (Diff f a) where
|
||
rnf fa = case runFree fa of
|
||
FreeF.Free f -> rnf f `seq` ()
|
||
FreeF.Pure a -> rnf a `seq` ()
|
||
|
||
|
||
free :: FreeF.FreeF f a (Free.Free f a) -> Free.Free f a
|
||
free (FreeF.Free f) = Free.Free f
|
||
free (FreeF.Pure a) = Free.Pure a
|
||
|
||
runFree :: Free.Free f a -> FreeF.FreeF f a (Free.Free f a)
|
||
runFree (Free.Free f) = FreeF.Free f
|
||
runFree (Free.Pure a) = FreeF.Pure a
|
||
|
||
|
||
instance Pretty1 f => Pretty1 (Free.Free f) where
|
||
liftPretty p pl = go where go (Free.Pure a) = p a
|
||
go (Free.Free f) = liftPretty go (list . map (liftPretty p pl)) f
|
||
|
||
instance (Pretty1 f, Pretty a) => Pretty (Free.Free f a) where
|
||
pretty = liftPretty pretty prettyList
|