{-# LANGUAGE UndecidableInstances #-}

module Dino.AST.Diff where

import Prelude

import Control.Monad (guard, zipWithM)
import Data.Coerce (coerce)
import Data.Foldable (asum)
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HM
import Data.List (sortOn)
import Data.Text (Text)
import qualified Data.Text as Text
import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty (..), (<+>))
import qualified Text.PrettyPrint.ANSI.Leijen as PP

import Dino.Pretty
import Dino.AST

-- | Drop elements at the end of a list
dropEnd :: Int -> [a] -> [a]
dropEnd :: Int -> [a] -> [a]
dropEnd Int
n [a]
as = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) [a]
as



--------------------------------------------------------------------------------
-- * Types
--------------------------------------------------------------------------------

data Replace a = Replace
  { Replace a -> a
original :: a
  , Replace a -> a
new :: a
  } deriving (Replace a -> Replace a -> Bool
(Replace a -> Replace a -> Bool)
-> (Replace a -> Replace a -> Bool) -> Eq (Replace a)
forall a. Eq a => Replace a -> Replace a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Replace a -> Replace a -> Bool
$c/= :: forall a. Eq a => Replace a -> Replace a -> Bool
== :: Replace a -> Replace a -> Bool
$c== :: forall a. Eq a => Replace a -> Replace a -> Bool
Eq, Int -> Replace a -> ShowS
[Replace a] -> ShowS
Replace a -> String
(Int -> Replace a -> ShowS)
-> (Replace a -> String)
-> ([Replace a] -> ShowS)
-> Show (Replace a)
forall a. Show a => Int -> Replace a -> ShowS
forall a. Show a => [Replace a] -> ShowS
forall a. Show a => Replace a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Replace a] -> ShowS
$cshowList :: forall a. Show a => [Replace a] -> ShowS
show :: Replace a -> String
$cshow :: forall a. Show a => Replace a -> String
showsPrec :: Int -> Replace a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Replace a -> ShowS
Show, a -> Replace b -> Replace a
(a -> b) -> Replace a -> Replace b
(forall a b. (a -> b) -> Replace a -> Replace b)
-> (forall a b. a -> Replace b -> Replace a) -> Functor Replace
forall a b. a -> Replace b -> Replace a
forall a b. (a -> b) -> Replace a -> Replace b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Replace b -> Replace a
$c<$ :: forall a b. a -> Replace b -> Replace a
fmap :: (a -> b) -> Replace a -> Replace b
$cfmap :: forall a b. (a -> b) -> Replace a -> Replace b
Functor)

-- | Edit operations on an optional element
data ElemOp a
  = AddElem a
  | RemoveElem a
  | EditElem (Diff a)

deriving instance (Eq a, Eq (Diff a))     => Eq (ElemOp a)
deriving instance (Show a, Show (Diff a)) => Show (ElemOp a)

-- | Edit operations at the end of a list
data EndOp a
  = Append [a]
  | DropEnd [a]
  deriving (EndOp a -> EndOp a -> Bool
(EndOp a -> EndOp a -> Bool)
-> (EndOp a -> EndOp a -> Bool) -> Eq (EndOp a)
forall a. Eq a => EndOp a -> EndOp a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EndOp a -> EndOp a -> Bool
$c/= :: forall a. Eq a => EndOp a -> EndOp a -> Bool
== :: EndOp a -> EndOp a -> Bool
$c== :: forall a. Eq a => EndOp a -> EndOp a -> Bool
Eq, Int -> EndOp a -> ShowS
[EndOp a] -> ShowS
EndOp a -> String
(Int -> EndOp a -> ShowS)
-> (EndOp a -> String) -> ([EndOp a] -> ShowS) -> Show (EndOp a)
forall a. Show a => Int -> EndOp a -> ShowS
forall a. Show a => [EndOp a] -> ShowS
forall a. Show a => EndOp a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EndOp a] -> ShowS
$cshowList :: forall a. Show a => [EndOp a] -> ShowS
show :: EndOp a -> String
$cshow :: forall a. Show a => EndOp a -> String
showsPrec :: Int -> EndOp a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> EndOp a -> ShowS
Show, a -> EndOp b -> EndOp a
(a -> b) -> EndOp a -> EndOp b
(forall a b. (a -> b) -> EndOp a -> EndOp b)
-> (forall a b. a -> EndOp b -> EndOp a) -> Functor EndOp
forall a b. a -> EndOp b -> EndOp a
forall a b. (a -> b) -> EndOp a -> EndOp b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EndOp b -> EndOp a
$c<$ :: forall a b. a -> EndOp b -> EndOp a
fmap :: (a -> b) -> EndOp a -> EndOp b
$cfmap :: forall a b. (a -> b) -> EndOp a -> EndOp b
Functor)

-- | Edit operations on lists
data ListOp a =
  ListOp
    [Maybe (Diff a)]
      -- Edits for elements that are common in both lists (drawn from start)
    (Maybe (EndOp a))
      -- Elements that are added or removed at the end

deriving instance (Eq a, Eq (Diff a))     => Eq (ListOp a)
deriving instance (Show a, Show (Diff a)) => Show (ListOp a)

-- | Edit operation on a 'AST'
data Edit a
  = Replacement (Replace (AST a))
  | EditApp Constr [Maybe (Edit a)]
  | EditList (Diff [AST a])
  | EditLet (Diff (Text, AST a, AST a))
  | EditRecord (Diff (Mapping Field (AST a)))
  deriving (Edit a -> Edit a -> Bool
(Edit a -> Edit a -> Bool)
-> (Edit a -> Edit a -> Bool) -> Eq (Edit a)
forall a. Eq a => Edit a -> Edit a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Edit a -> Edit a -> Bool
$c/= :: forall a. Eq a => Edit a -> Edit a -> Bool
== :: Edit a -> Edit a -> Bool
$c== :: forall a. Eq a => Edit a -> Edit a -> Bool
Eq, Int -> Edit a -> ShowS
[Edit a] -> ShowS
Edit a -> String
(Int -> Edit a -> ShowS)
-> (Edit a -> String) -> ([Edit a] -> ShowS) -> Show (Edit a)
forall a. Show a => Int -> Edit a -> ShowS
forall a. Show a => [Edit a] -> ShowS
forall a. Show a => Edit a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Edit a] -> ShowS
$cshowList :: forall a. Show a => [Edit a] -> ShowS
show :: Edit a -> String
$cshow :: forall a. Show a => Edit a -> String
showsPrec :: Int -> Edit a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Edit a -> ShowS
Show)

-- | Wrapper for values that should be regarded as monolithic when diffing
newtype Monolithic a = Monolithic {Monolithic a -> a
unMonolithic :: a}



--------------------------------------------------------------------------------
-- * Diffing
--------------------------------------------------------------------------------

class Diffable a where
  -- | Representation of the difference between two values
  type Diff a
  type instance Diff a = Replace a

  -- | Calculate the difference between two values
  --
  -- The result is 'Nothing' iff. the two values are equal.
  --
  -- The following property holds:
  --
  -- @
  -- If   Just d = diff a b
  -- Then Just b = `applyDiff` d a
  -- @
  diff ::
       a -- ^ Original
    -> a -- ^ New
    -> Maybe (Diff a)

  default diff :: (Eq a, Diff a ~ Replace a) => a -> a -> Maybe (Diff a)
  diff a
original a
new = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
original a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
new)
    Replace a -> Maybe (Replace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Replace a -> Maybe (Replace a)) -> Replace a -> Maybe (Replace a)
forall a b. (a -> b) -> a -> b
$ Replace :: forall a. a -> a -> Replace a
Replace {a
original :: a
original :: a
original, a
new :: a
new :: a
new}

  -- | Apply an 'Edit' to a 'Value'
  --
  -- This function is mostly intended for testing. It succeeds iff. the edit
  -- makes sense.
  applyDiff :: Diff a -> a -> Maybe a

  default applyDiff :: (Eq a, Diff a ~ Replace a) => Diff a -> a -> Maybe a
  applyDiff (Replace {original, new}) a
a
    | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
original = a -> Maybe a
forall a. a -> Maybe a
Just a
new
    | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing

applyDiffWhen :: Diffable a => Maybe (Diff a) -> a -> Maybe a
applyDiffWhen :: Maybe (Diff a) -> a -> Maybe a
applyDiffWhen Maybe (Diff a)
Nothing a
a  = a -> Maybe a
forall a. a -> Maybe a
Just a
a
applyDiffWhen (Just Diff a
d) a
a = Diff a -> a -> Maybe a
forall a. Diffable a => Diff a -> a -> Maybe a
applyDiff Diff a
d a
a

instance Diffable ()
instance Diffable Bool
instance Diffable Text
instance Diffable Int
instance Diffable Integer
instance Diffable Float
instance Diffable Double
instance Diffable Rational

instance Eq a => Diffable (Monolithic a) where
  type Diff (Monolithic a) = Replace a
  diff :: Monolithic a -> Monolithic a -> Maybe (Diff (Monolithic a))
diff (Monolithic a
original) (Monolithic a
new) = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
original a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
new)
    Replace a -> Maybe (Replace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Replace a -> Maybe (Replace a)) -> Replace a -> Maybe (Replace a)
forall a b. (a -> b) -> a -> b
$ Replace :: forall a. a -> a -> Replace a
Replace {a
original :: a
original :: a
original, a
new :: a
new :: a
new}

  applyDiff :: Diff (Monolithic a) -> Monolithic a -> Maybe (Monolithic a)
applyDiff (Replace {original, new}) Monolithic a
a
    | Monolithic a -> a
forall a. Monolithic a -> a
unMonolithic Monolithic a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
original = Monolithic a -> Maybe (Monolithic a)
forall a. a -> Maybe a
Just (Monolithic a -> Maybe (Monolithic a))
-> Monolithic a -> Maybe (Monolithic a)
forall a b. (a -> b) -> a -> b
$ a -> Monolithic a
forall a. a -> Monolithic a
Monolithic a
new
    | Bool
otherwise = Maybe (Monolithic a)
forall a. Maybe a
Nothing

instance Diffable a => Diffable (Maybe a) where
  type Diff (Maybe a) = ElemOp a
  diff :: Maybe a -> Maybe a -> Maybe (Diff (Maybe a))
diff Maybe a
Nothing   Maybe a
Nothing   = Maybe (Diff (Maybe a))
forall a. Maybe a
Nothing
  diff (Just a
a') Maybe a
Nothing   = ElemOp a -> Maybe (ElemOp a)
forall a. a -> Maybe a
Just (ElemOp a -> Maybe (ElemOp a)) -> ElemOp a -> Maybe (ElemOp a)
forall a b. (a -> b) -> a -> b
$ a -> ElemOp a
forall a. a -> ElemOp a
RemoveElem a
a'
  diff Maybe a
Nothing   (Just a
b') = ElemOp a -> Maybe (ElemOp a)
forall a. a -> Maybe a
Just (ElemOp a -> Maybe (ElemOp a)) -> ElemOp a -> Maybe (ElemOp a)
forall a b. (a -> b) -> a -> b
$ a -> ElemOp a
forall a. a -> ElemOp a
AddElem a
b'
  diff (Just a
a') (Just a
b') = Diff a -> ElemOp a
forall a. Diff a -> ElemOp a
EditElem (Diff a -> ElemOp a) -> Maybe (Diff a) -> Maybe (ElemOp a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a -> Maybe (Diff a)
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff a
a' a
b'

  applyDiff :: Diff (Maybe a) -> Maybe a -> Maybe (Maybe a)
applyDiff (RemoveElem _) Maybe a
Nothing  = Maybe (Maybe a)
forall a. Maybe a
Nothing
  applyDiff (RemoveElem _) (Just a
_) = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing
  applyDiff (AddElem a) Maybe a
Nothing     = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
  applyDiff (AddElem _) (Just a
_)    = Maybe (Maybe a)
forall a. Maybe a
Nothing
  applyDiff (EditElem d) (Just a
a)   = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Maybe a -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Diff a -> a -> Maybe a
forall a. Diffable a => Diff a -> a -> Maybe a
applyDiff Diff a
d a
a
  applyDiff (EditElem _) Maybe a
Nothing    = Maybe (Maybe a)
forall a. Maybe a
Nothing

-- | Matches element-wise from the start of the lists, and detects
-- additions/removals at the end.
instance Diffable a => Diffable [a] where
  type Diff [a] = ListOp a
  diff :: [a] -> [a] -> Maybe (Diff [a])
diff [a]
o [a]
n
    | Maybe (Diff a)
Nothing <- [Maybe (Diff a)] -> Maybe (Diff a)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [Maybe (Diff a)]
es, Maybe (EndOp a)
Nothing <- Maybe (EndOp a)
endOp = Maybe (Diff [a])
forall a. Maybe a
Nothing
    | Bool
otherwise = ListOp a -> Maybe (ListOp a)
forall a. a -> Maybe a
Just (ListOp a -> Maybe (ListOp a)) -> ListOp a -> Maybe (ListOp a)
forall a b. (a -> b) -> a -> b
$ [Maybe (Diff a)] -> Maybe (EndOp a) -> ListOp a
forall a. [Maybe (Diff a)] -> Maybe (EndOp a) -> ListOp a
ListOp [Maybe (Diff a)]
es Maybe (EndOp a)
endOp
    where
      es :: [Maybe (Diff a)]
es = (a -> a -> Maybe (Diff a)) -> [a] -> [a] -> [Maybe (Diff a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> Maybe (Diff a)
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff [a]
o [a]
n
      lo :: Int
lo = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
o
      ln :: Int
ln = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
n
      endOp :: Maybe (EndOp a)
endOp
        | Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ln = EndOp a -> Maybe (EndOp a)
forall a. a -> Maybe a
Just (EndOp a -> Maybe (EndOp a)) -> EndOp a -> Maybe (EndOp a)
forall a b. (a -> b) -> a -> b
$ [a] -> EndOp a
forall a. [a] -> EndOp a
Append (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
lo [a]
n)
        | Int
ln Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lo = EndOp a -> Maybe (EndOp a)
forall a. a -> Maybe a
Just (EndOp a -> Maybe (EndOp a)) -> EndOp a -> Maybe (EndOp a)
forall a b. (a -> b) -> a -> b
$ [a] -> EndOp a
forall a. [a] -> EndOp a
DropEnd (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
dropEnd Int
ln [a]
o)
        | Bool
otherwise = Maybe (EndOp a)
forall a. Maybe a
Nothing

  applyDiff :: Diff [a] -> [a] -> Maybe [a]
applyDiff (ListOp es endOp) [a]
as
    | Int
le Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
la, Bool -> (EndOp a -> Bool) -> Maybe (EndOp a) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False EndOp a -> Bool
forall a. EndOp a -> Bool
isAppend Maybe (EndOp a)
endOp = Maybe [a]
forall a. Maybe a
Nothing
    | Int
le Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
la = [a] -> [a]
applyEndOp ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (Diff a) -> a -> Maybe a)
-> [Maybe (Diff a)] -> [a] -> Maybe [a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe (Diff a) -> a -> Maybe a
forall a. Diffable a => Maybe (Diff a) -> a -> Maybe a
applyDiffWhen [Maybe (Diff a)]
es [a]
as
    | Bool
otherwise = Maybe [a]
forall a. Maybe a
Nothing
    where
      le :: Int
le = [Maybe (Diff a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe (Diff a)]
es
      la :: Int
la = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as
      isAppend :: EndOp a -> Bool
isAppend (Append [a]
_) = Bool
True
      isAppend EndOp a
_ = Bool
False
      applyEndOp :: [a] -> [a]
applyEndOp = case Maybe (EndOp a)
endOp of
        Just (Append [a]
bs) -> ([a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
bs)
        Maybe (EndOp a)
_ -> [a] -> [a]
forall a. a -> a
id -- Dropping is handled by `zipWithM` above

instance (Diffable a, Diffable b) => Diffable (a, b) where
  type Diff (a, b) = (Maybe (Diff a), Maybe (Diff b))
  diff :: (a, b) -> (a, b) -> Maybe (Diff (a, b))
diff (a
oa, b
ob) (a
na, b
nb)
    | Maybe (Diff a)
Nothing <- Maybe (Diff a)
da, Maybe (Diff b)
Nothing <- Maybe (Diff b)
db = Maybe (Diff (a, b))
forall a. Maybe a
Nothing
    | Bool
otherwise = (Maybe (Diff a), Maybe (Diff b))
-> Maybe (Maybe (Diff a), Maybe (Diff b))
forall a. a -> Maybe a
Just (Maybe (Diff a)
da, Maybe (Diff b)
db)
    where
      da :: Maybe (Diff a)
da = a -> a -> Maybe (Diff a)
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff a
oa a
na
      db :: Maybe (Diff b)
db = b -> b -> Maybe (Diff b)
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff b
ob b
nb

  applyDiff :: Diff (a, b) -> (a, b) -> Maybe (a, b)
applyDiff (da, db) (a
a, b
b) = (,) (a -> b -> (a, b)) -> Maybe a -> Maybe (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Diff a) -> a -> Maybe a
forall a. Diffable a => Maybe (Diff a) -> a -> Maybe a
applyDiffWhen Maybe (Diff a)
da a
a Maybe (b -> (a, b)) -> Maybe b -> Maybe (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Diff b) -> b -> Maybe b
forall a. Diffable a => Maybe (Diff a) -> a -> Maybe a
applyDiffWhen Maybe (Diff b)
db b
b

instance (Diffable a, Diffable b, Diffable c) => Diffable (a, b, c) where
  type Diff (a, b, c) = (Maybe (Diff a), Maybe (Diff b), Maybe (Diff c))
  diff :: (a, b, c) -> (a, b, c) -> Maybe (Diff (a, b, c))
diff (a
oa, b
ob, c
oc) (a
na, b
nb, c
nc)
    | Maybe (Diff a)
Nothing <- Maybe (Diff a)
da, Maybe (Diff b)
Nothing <- Maybe (Diff b)
db, Maybe (Diff c)
Nothing <- Maybe (Diff c)
dc = Maybe (Diff (a, b, c))
forall a. Maybe a
Nothing
    | Bool
otherwise = (Maybe (Diff a), Maybe (Diff b), Maybe (Diff c))
-> Maybe (Maybe (Diff a), Maybe (Diff b), Maybe (Diff c))
forall a. a -> Maybe a
Just (Maybe (Diff a)
da, Maybe (Diff b)
db, Maybe (Diff c)
dc)
    where
      da :: Maybe (Diff a)
da = a -> a -> Maybe (Diff a)
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff a
oa a
na
      db :: Maybe (Diff b)
db = b -> b -> Maybe (Diff b)
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff b
ob b
nb
      dc :: Maybe (Diff c)
dc = c -> c -> Maybe (Diff c)
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff c
oc c
nc

  applyDiff :: Diff (a, b, c) -> (a, b, c) -> Maybe (a, b, c)
applyDiff (da, db, dc) (a
a, b
b, c
c) =
    (,,) (a -> b -> c -> (a, b, c))
-> Maybe a -> Maybe (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Diff a) -> a -> Maybe a
forall a. Diffable a => Maybe (Diff a) -> a -> Maybe a
applyDiffWhen Maybe (Diff a)
da a
a Maybe (b -> c -> (a, b, c)) -> Maybe b -> Maybe (c -> (a, b, c))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Diff b) -> b -> Maybe b
forall a. Diffable a => Maybe (Diff a) -> a -> Maybe a
applyDiffWhen Maybe (Diff b)
db b
b Maybe (c -> (a, b, c)) -> Maybe c -> Maybe (a, b, c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Diff c) -> c -> Maybe c
forall a. Diffable a => Maybe (Diff a) -> a -> Maybe a
applyDiffWhen Maybe (Diff c)
dc c
c

instance (Eq k, Hashable k, Diffable a) => Diffable (Mapping k a) where
  type Diff (Mapping k a) = Mapping k (ElemOp a)

  diff :: Mapping k a -> Mapping k a -> Maybe (Diff (Mapping k a))
diff (Mapping Importance
oi HashMap k a
o) (Mapping Importance
ni HashMap k a
n)
    | HashMap k (ElemOp a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null HashMap k (ElemOp a)
e = Maybe (Diff (Mapping k a))
forall a. Maybe a
Nothing
    | Bool
otherwise = Mapping k (ElemOp a) -> Maybe (Mapping k (ElemOp a))
forall a. a -> Maybe a
Just (Mapping k (ElemOp a) -> Maybe (Mapping k (ElemOp a)))
-> Mapping k (ElemOp a) -> Maybe (Mapping k (ElemOp a))
forall a b. (a -> b) -> a -> b
$ Importance -> HashMap k (ElemOp a) -> Mapping k (ElemOp a)
forall k v. Importance -> HashMap k v -> Mapping k v
Mapping (Importance
oi Importance -> Importance -> Importance
forall a. Semigroup a => a -> a -> a
<> Importance
ni) HashMap k (ElemOp a)
e
    where
      e :: HashMap k (ElemOp a)
e = ((k -> a -> Maybe (ElemOp a))
 -> HashMap k a -> HashMap k (ElemOp a))
-> HashMap k a
-> (k -> a -> Maybe (ElemOp a))
-> HashMap k (ElemOp a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (k -> a -> Maybe (ElemOp a)) -> HashMap k a -> HashMap k (ElemOp a)
forall k v1 v2.
(k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
HM.mapMaybeWithKey (HashMap k a -> HashMap k a -> HashMap k a
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union HashMap k a
o HashMap k a
n) ((k -> a -> Maybe (ElemOp a)) -> HashMap k (ElemOp a))
-> (k -> a -> Maybe (ElemOp a)) -> HashMap k (ElemOp a)
forall a b. (a -> b) -> a -> b
$ \k
k a
_ ->
        Maybe a -> Maybe a -> Maybe (Diff (Maybe a))
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff (k -> HashMap k a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup k
k HashMap k a
o) (k -> HashMap k a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup k
k HashMap k a
n)

  applyDiff :: Diff (Mapping k a) -> Mapping k a -> Maybe (Mapping k a)
applyDiff (Mapping imp e) (Mapping Importance
_ HashMap k a
m) =
    (HashMap k (Maybe a) -> Mapping k a)
-> Maybe (HashMap k (Maybe a)) -> Maybe (Mapping k a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Importance -> HashMap k a -> Mapping k a
forall k v. Importance -> HashMap k v -> Mapping k v
Mapping Importance
imp (HashMap k a -> Mapping k a)
-> (HashMap k (Maybe a) -> HashMap k a)
-> HashMap k (Maybe a)
-> Mapping k a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap k a -> HashMap k a -> HashMap k a
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union HashMap k a
additions (HashMap k a -> HashMap k a)
-> (HashMap k (Maybe a) -> HashMap k a)
-> HashMap k (Maybe a)
-> HashMap k a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Maybe a) -> HashMap k (Maybe a) -> HashMap k a
forall v1 v2 k. (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
HM.mapMaybe Maybe a -> Maybe a
forall a. a -> a
id) (Maybe (HashMap k (Maybe a)) -> Maybe (Mapping k a))
-> Maybe (HashMap k (Maybe a)) -> Maybe (Mapping k a)
forall a b. (a -> b) -> a -> b
$
    (k -> a -> Maybe (Maybe a))
-> HashMap k a -> Maybe (HashMap k (Maybe a))
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HM.traverseWithKey k -> a -> Maybe (Maybe a)
applyElem HashMap k a
m
    where
      applyElem :: k -> a -> Maybe (Maybe a)
applyElem k
k a
v =
        case k -> HashMap k (ElemOp a) -> Maybe (ElemOp a)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup k
k HashMap k (ElemOp a)
e of
          Maybe (ElemOp a)
Nothing -> Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (Maybe a -> Maybe (Maybe a)) -> Maybe a -> Maybe (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
v
          Just (AddElem a
_) -> Maybe (Maybe a)
forall a. Maybe a
Nothing -- Cannot add an existing element
          Just (RemoveElem a
_) -> Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing
          Just (EditElem Diff a
d) -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Maybe a -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Diff a -> a -> Maybe a
forall a. Diffable a => Diff a -> a -> Maybe a
applyDiff Diff a
d a
v
      additions :: HashMap k a
additions =
        ((ElemOp a -> Maybe a) -> HashMap k (ElemOp a) -> HashMap k a)
-> HashMap k (ElemOp a) -> (ElemOp a -> Maybe a) -> HashMap k a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ElemOp a -> Maybe a) -> HashMap k (ElemOp a) -> HashMap k a
forall v1 v2 k. (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
HM.mapMaybe HashMap k (ElemOp a)
e ((ElemOp a -> Maybe a) -> HashMap k a)
-> (ElemOp a -> Maybe a) -> HashMap k a
forall a b. (a -> b) -> a -> b
$ \ElemOp a
d ->
          case ElemOp a
d of
            AddElem a
v -> a -> Maybe a
forall a. a -> Maybe a
Just a
v
            ElemOp a
_ -> Maybe a
forall a. Maybe a
Nothing

instance Eq a => Diffable (AST a) where
  type Diff (AST a) = Edit a

  diff :: AST a -> AST a -> Maybe (Diff (AST a))
diff (App Constr
List [AST a]
o) (App Constr
List [AST a]
n) = ListOp (AST a) -> Edit a
forall a. Diff [AST a] -> Edit a
EditList (ListOp (AST a) -> Edit a)
-> Maybe (ListOp (AST a)) -> Maybe (Edit a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AST a] -> [AST a] -> Maybe (Diff [AST a])
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff [AST a]
o [AST a]
n
  diff (App Constr
co [AST a]
os) (App Constr
cn [AST a]
ns)
    | Constr
co Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== Constr
cn Bool -> Bool -> Bool
&& [AST a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AST a]
os Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [AST a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AST a]
ns =
      (\(ListOp [Maybe (Diff (AST a))]
es Maybe (EndOp (AST a))
_) -> Constr -> [Maybe (Edit a)] -> Edit a
forall a. Constr -> [Maybe (Edit a)] -> Edit a
EditApp Constr
co [Maybe (Diff (AST a))]
[Maybe (Edit a)]
es) (ListOp (AST a) -> Edit a)
-> Maybe (ListOp (AST a)) -> Maybe (Edit a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AST a] -> [AST a] -> Maybe (Diff [AST a])
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff [AST a]
os [AST a]
ns
        -- We know that `os` and `ns` have the same length, so if `diffList`
        -- returns `Just`, it must mean that at least one element in `es` is
        -- `Just`.
  diff (Let Text
vo AST a
o AST a
bo) (Let Text
vn AST a
n AST a
bn) = (Maybe (Replace Text), Maybe (Edit a), Maybe (Edit a)) -> Edit a
forall a. Diff (Text, AST a, AST a) -> Edit a
EditLet ((Maybe (Replace Text), Maybe (Edit a), Maybe (Edit a)) -> Edit a)
-> Maybe (Maybe (Replace Text), Maybe (Edit a), Maybe (Edit a))
-> Maybe (Edit a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text, AST a, AST a)
-> (Text, AST a, AST a) -> Maybe (Diff (Text, AST a, AST a))
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff (Text
vo, AST a
o, AST a
bo) (Text
vn, AST a
n, AST a
bn)
  diff (Record Mapping Field (AST a)
o) (Record Mapping Field (AST a)
n) = Mapping Field (ElemOp (AST a)) -> Edit a
forall a. Diff (Mapping Field (AST a)) -> Edit a
EditRecord (Mapping Field (ElemOp (AST a)) -> Edit a)
-> Maybe (Mapping Field (ElemOp (AST a))) -> Maybe (Edit a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mapping Field (AST a)
-> Mapping Field (AST a) -> Maybe (Diff (Mapping Field (AST a)))
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff Mapping Field (AST a)
o Mapping Field (AST a)
n
  diff AST a
o AST a
n = Replace (AST a) -> Edit a
forall a. Replace (AST a) -> Edit a
Replacement (Replace (AST a) -> Edit a)
-> Maybe (Replace (AST a)) -> Maybe (Edit a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Monolithic (AST a)
-> Monolithic (AST a) -> Maybe (Diff (Monolithic (AST a)))
forall a. Diffable a => a -> a -> Maybe (Diff a)
diff (AST a -> Monolithic (AST a)
forall a. a -> Monolithic a
Monolithic AST a
o) (AST a -> Monolithic (AST a)
forall a. a -> Monolithic a
Monolithic AST a
n)

  applyDiff :: Diff (AST a) -> AST a -> Maybe (AST a)
applyDiff (Replacement d) AST a
a = Maybe (Monolithic (AST a)) -> Maybe (AST a)
coerce (Maybe (Monolithic (AST a)) -> Maybe (AST a))
-> Maybe (Monolithic (AST a)) -> Maybe (AST a)
forall a b. (a -> b) -> a -> b
$ Diff (Monolithic (AST a))
-> Monolithic (AST a) -> Maybe (Monolithic (AST a))
forall a. Diffable a => Diff a -> a -> Maybe a
applyDiff Diff (Monolithic (AST a))
Replace (AST a)
d (AST a -> Monolithic (AST a)
forall a. a -> Monolithic a
Monolithic AST a
a)
  applyDiff (EditList e) (App Constr
List [AST a]
as) = Constr -> [AST a] -> AST a
forall n. Constr -> [AST n] -> AST n
App Constr
List ([AST a] -> AST a) -> Maybe [AST a] -> Maybe (AST a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Diff [AST a] -> [AST a] -> Maybe [AST a]
forall a. Diffable a => Diff a -> a -> Maybe a
applyDiff Diff [AST a]
e [AST a]
as
  applyDiff (EditApp c es) (App Constr
c' [AST a]
as)
    | Constr
c Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== Constr
c' = Constr -> [AST a] -> AST a
forall n. Constr -> [AST n] -> AST n
App Constr
c ([AST a] -> AST a) -> Maybe [AST a] -> Maybe (AST a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Diff [AST a] -> [AST a] -> Maybe [AST a]
forall a. Diffable a => Diff a -> a -> Maybe a
applyDiff ([Maybe (Diff (AST a))] -> Maybe (EndOp (AST a)) -> ListOp (AST a)
forall a. [Maybe (Diff a)] -> Maybe (EndOp a) -> ListOp a
ListOp [Maybe (Diff (AST a))]
[Maybe (Edit a)]
es Maybe (EndOp (AST a))
forall a. Maybe a
Nothing) [AST a]
as
  applyDiff (EditLet e) (Let Text
v AST a
a AST a
b) =
    (\(Text
v', AST a
a', AST a
b') -> Text -> AST a -> AST a -> AST a
forall n. Text -> AST n -> AST n -> AST n
Let Text
v' AST a
a' AST a
b') ((Text, AST a, AST a) -> AST a)
-> Maybe (Text, AST a, AST a) -> Maybe (AST a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Diff (Text, AST a, AST a)
-> (Text, AST a, AST a) -> Maybe (Text, AST a, AST a)
forall a. Diffable a => Diff a -> a -> Maybe a
applyDiff Diff (Text, AST a, AST a)
e (Text
v, AST a
a, AST a
b)
  applyDiff (EditRecord e) (Record Mapping Field (AST a)
rec) = Mapping Field (AST a) -> AST a
forall n. Mapping Field (AST n) -> AST n
Record (Mapping Field (AST a) -> AST a)
-> Maybe (Mapping Field (AST a)) -> Maybe (AST a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Diff (Mapping Field (AST a))
-> Mapping Field (AST a) -> Maybe (Mapping Field (AST a))
forall a. Diffable a => Diff a -> a -> Maybe a
applyDiff Diff (Mapping Field (AST a))
e Mapping Field (AST a)
rec
  applyDiff Diff (AST a)
_ AST a
_ = Maybe (AST a)
forall a. Maybe a
Nothing



--------------------------------------------------------------------------------
-- * Rendering
--------------------------------------------------------------------------------

-- | If @k@ is a 'String'-like type, it will be shown with quotes. Use 'Field'
-- to prevent this.
instance {-# OVERLAPPING #-}
         (Pretty a, Pretty (Diff a), Show k, Ord k) =>
         Pretty (Mapping k (ElemOp a)) where
  pretty :: Mapping k (ElemOp a) -> Doc
pretty (Mapping Importance
imp HashMap k (ElemOp a)
m) =
    Doc -> Doc -> Doc -> [Doc] -> Doc
verticalList Doc
PP.lbrace Doc
PP.comma Doc
PP.rbrace ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    ((k, ElemOp a) -> Doc) -> [(k, ElemOp a)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (k, ElemOp a) -> Doc
prettyField ([(k, ElemOp a)] -> [Doc]) -> [(k, ElemOp a)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((k, ElemOp a) -> k) -> [(k, ElemOp a)] -> [(k, ElemOp a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (k, ElemOp a) -> k
forall a b. (a, b) -> a
fst ([(k, ElemOp a)] -> [(k, ElemOp a)])
-> [(k, ElemOp a)] -> [(k, ElemOp a)]
forall a b. (a -> b) -> a -> b
$ HashMap k (ElemOp a) -> [(k, ElemOp a)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap k (ElemOp a)
m
    where
      prettyField :: (k, ElemOp a) -> Doc
prettyField (k
f, AddElem a
v) =
        Doc -> Doc
PP.green (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        (String -> Doc
PP.text String
"+" Doc -> Doc -> Doc
<+>
         Importance -> Doc -> Doc
emphasize Importance
imp (String -> Doc
PP.string (k -> String
forall a. Show a => a -> String
show k
f)) Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
"=") Doc -> Doc -> Doc
PP.<$>
        String -> Doc
PP.text String
"    " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
        Doc -> Doc
PP.align (a -> Doc
forall a. Pretty a => a -> Doc
pretty a
v)
      prettyField (k
f, RemoveElem a
v) =
        Doc -> Doc
PP.red (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        (String -> Doc
PP.text String
"-" Doc -> Doc -> Doc
<+>
         Importance -> Doc -> Doc
emphasize Importance
imp (String -> Doc
PP.string (k -> String
forall a. Show a => a -> String
show k
f)) Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
"=") Doc -> Doc -> Doc
PP.<$>
        String -> Doc
PP.text String
"    " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
        Doc -> Doc
PP.align (a -> Doc
forall a. Pretty a => a -> Doc
pretty a
v)
      prettyField (k
f, EditElem Diff a
e) =
        Doc -> Doc -> Doc
underHeader (Importance -> Doc -> Doc
emphasize Importance
imp (String -> Doc
PP.string (k -> String
forall a. Show a => a -> String
show k
f)) Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
"=") (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        Diff a -> Doc
forall a. Pretty a => a -> Doc
pretty Diff a
e

instance Pretty a => Pretty (Replace a) where
  pretty :: Replace a -> Doc
pretty Replace {a
original :: a
original :: forall a. Replace a -> a
original, a
new :: a
new :: forall a. Replace a -> a
new} =
    Doc -> Doc
PP.red (Char -> Doc
PP.char Char
'-' Doc -> Doc -> Doc
<+> Doc -> Doc
PP.align (a -> Doc
forall a. Pretty a => a -> Doc
pretty a
original)) Doc -> Doc -> Doc
PP.<$>
    Doc -> Doc
PP.green (Char -> Doc
PP.char Char
'+' Doc -> Doc -> Doc
<+> Doc -> Doc
PP.align (a -> Doc
forall a. Pretty a => a -> Doc
pretty a
new))

-- | Pretty print for edits on tuple-like collections (where elements are
-- identified by position)
prettyEditTuple :: Pretty a => Doc -> Doc -> Doc -> [Maybe a] -> Doc
prettyEditTuple :: Doc -> Doc -> Doc -> [Maybe a] -> Doc
prettyEditTuple Doc
l Doc
sep Doc
r = Doc -> Doc -> Doc -> [Doc] -> Doc
verticalList Doc
l Doc
sep Doc
r ([Doc] -> Doc) -> ([Maybe a] -> [Doc]) -> [Maybe a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Doc) -> [Maybe a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> (a -> Doc) -> Maybe a -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
unchanged a -> Doc
forall a. Pretty a => a -> Doc
pretty)

-- | Pretty print 'EditApp' for \"named\" constructors
prettyEditApp :: Pretty a => NameType -> Text -> [Maybe a] -> Doc
prettyEditApp :: NameType -> Text -> [Maybe a] -> Doc
prettyEditApp NameType
t Text
c [] = NameType -> Text -> Doc
prettyNamed NameType
t Text
c
prettyEditApp NameType
t Text
c [Maybe a]
as =
  Doc -> Doc -> Doc
underHeader (NameType -> Text -> Doc
prettyNamed NameType
t Text
c) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Maybe a -> Doc) -> [Maybe a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> (a -> Doc) -> Maybe a -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
unchanged a -> Doc
forall a. Pretty a => a -> Doc
pretty) [Maybe a]
as

instance (Pretty a, Pretty (Diff a)) => Pretty (ListOp a) where
  pretty :: ListOp a -> Doc
pretty (ListOp [Maybe (Diff a)]
es Maybe (EndOp a)
endOp) =
    Doc -> Doc -> Doc -> [Doc] -> Doc
verticalList Doc
PP.lbracket Doc
PP.comma Doc
PP.rbracket ([Doc]
es' [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc]
os)
    where
      es' :: [Doc]
es' =
        [ Doc -> Doc -> Doc
underHeader (Doc -> Doc
PP.magenta (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text (String
"edit @" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)) (Diff a -> Doc
forall a. Pretty a => a -> Doc
pretty Diff a
e)
        | (Int
i :: Int, Just Diff a
e) <- [Int] -> [Maybe (Diff a)] -> [(Int, Maybe (Diff a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Maybe (Diff a)]
es
        ]
      os :: [Doc]
os = case Maybe (EndOp a)
endOp of
        Maybe (EndOp a)
Nothing -> []
        Just (Append [a]
vs) ->
          [ Doc -> Doc -> Doc
underHeader (Doc -> Doc
PP.magenta (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"append") (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
          Doc -> Doc
PP.green (Char -> Doc
PP.char Char
'+' Doc -> Doc -> Doc
<+> Doc -> Doc
PP.align (a -> Doc
forall a. Pretty a => a -> Doc
pretty a
v))
          | a
v <- [a]
vs
          ]
        Just (DropEnd [a]
vs) ->
          [ Doc -> Doc -> Doc
underHeader (Doc -> Doc
PP.magenta (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
"drop from end") (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
          Doc -> Doc
PP.red (Char -> Doc
PP.char Char
'-' Doc -> Doc -> Doc
<+> Doc -> Doc
PP.align (a -> Doc
forall a. Pretty a => a -> Doc
pretty a
v))
          | a
v <- [a]
vs
          ]

instance Show a => Pretty (Edit a) where
  pretty :: Edit a -> Doc
pretty (EditApp Constr
Tuple [Maybe (Edit a)]
es) =
    Doc -> Doc -> Doc -> [Doc] -> Doc
verticalList Doc
PP.lparen Doc
PP.comma Doc
PP.rparen ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Maybe (Edit a) -> Doc) -> [Maybe (Edit a)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> (Edit a -> Doc) -> Maybe (Edit a) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
unchanged Edit a -> Doc
forall a. Pretty a => a -> Doc
pretty) [Maybe (Edit a)]
es
  pretty (Replacement Replace (AST a)
e)          = Replace (AST a) -> Doc
forall a. Pretty a => a -> Doc
pretty Replace (AST a)
e
  pretty (EditApp Constr
List [Maybe (Edit a)]
es)        = Edit a -> Doc
forall a. Pretty a => a -> Doc
pretty (Edit a -> Doc) -> Edit a -> Doc
forall a b. (a -> b) -> a -> b
$ Diff [AST a] -> Edit a
forall a. Diff [AST a] -> Edit a
EditList ([Maybe (Diff (AST a))] -> Maybe (EndOp (AST a)) -> ListOp (AST a)
forall a. [Maybe (Diff a)] -> Maybe (EndOp a) -> ListOp a
ListOp [Maybe (Diff (AST a))]
[Maybe (Edit a)]
es Maybe (EndOp (AST a))
forall a. Maybe a
Nothing)
  pretty (EditApp (Named NameType
t Text
c) [Maybe (Edit a)]
es) = NameType -> Text -> [Maybe (Edit a)] -> Doc
forall a. Pretty a => NameType -> Text -> [Maybe a] -> Doc
prettyEditApp NameType
t Text
c [Maybe (Edit a)]
es
  pretty (EditList Diff [AST a]
e)             = ListOp (AST a) -> Doc
forall a. Pretty a => a -> Doc
pretty Diff [AST a]
ListOp (AST a)
e
  pretty (EditLet (v, a, b)) =
    Doc -> Doc -> Doc
underHeader (String -> Doc
PP.string String
"let" Doc -> Doc -> Doc
PP.<+> Doc -> Doc
PP.align Doc
var Doc -> Doc -> Doc
PP.<+> Doc
"=") (Doc -> (Edit a -> Doc) -> Maybe (Edit a) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
unchanged Edit a -> Doc
forall a. Pretty a => a -> Doc
pretty Maybe (Edit a)
a)
      Doc -> Doc -> Doc
PP.<$>
    Doc -> Doc -> Doc
underHeader (String -> Doc
PP.string String
" in") (Doc -> (Edit a -> Doc) -> Maybe (Edit a) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
unchanged Edit a -> Doc
forall a. Pretty a => a -> Doc
pretty Maybe (Edit a)
b)
    where
      var :: Doc
var = Doc -> (Replace Text -> Doc) -> Maybe (Replace Text) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
unchanged (Replace Doc -> Doc
forall a. Pretty a => a -> Doc
pretty (Replace Doc -> Doc)
-> (Replace Text -> Replace Doc) -> Replace Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc) -> Replace Text -> Replace Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Doc
PP.string (String -> Doc) -> (Text -> String) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)) Maybe (Replace Text)
v
        -- TODO Would maybe be good to show the variable name even if it hasn't
        -- changed...
  pretty (EditRecord (Mapping imp erec)) =
    Doc -> Doc -> Doc -> [Doc] -> Doc
verticalList Doc
PP.lbrace Doc
PP.comma Doc
PP.rbrace ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    ((Field, ElemOp (AST a)) -> Doc)
-> [(Field, ElemOp (AST a))] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Field, ElemOp (AST a)) -> Doc
prettyField ([(Field, ElemOp (AST a))] -> [Doc])
-> [(Field, ElemOp (AST a))] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((Field, ElemOp (AST a)) -> Field)
-> [(Field, ElemOp (AST a))] -> [(Field, ElemOp (AST a))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Field, ElemOp (AST a)) -> Field
forall a b. (a, b) -> a
fst ([(Field, ElemOp (AST a))] -> [(Field, ElemOp (AST a))])
-> [(Field, ElemOp (AST a))] -> [(Field, ElemOp (AST a))]
forall a b. (a -> b) -> a -> b
$ HashMap Field (ElemOp (AST a)) -> [(Field, ElemOp (AST a))]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Field (ElemOp (AST a))
erec
    where
      prettyField :: (Field, ElemOp (AST a)) -> Doc
prettyField (Field
f, AddElem AST a
v) =
        Doc -> Doc
PP.green (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        (String -> Doc
PP.text String
"+" Doc -> Doc -> Doc
<+>
         Importance -> Doc -> Doc
emphasize Importance
imp (String -> Doc
PP.string (Field -> String
unField Field
f)) Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
"=") Doc -> Doc -> Doc
PP.<$>
        String -> Doc
PP.text String
"    " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
        Doc -> Doc
PP.align (AST a -> Doc
forall a. Pretty a => a -> Doc
pretty AST a
v)
      prettyField (Field
f, RemoveElem AST a
v) =
        Doc -> Doc
PP.red (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        (String -> Doc
PP.text String
"-" Doc -> Doc -> Doc
<+>
         Importance -> Doc -> Doc
emphasize Importance
imp (String -> Doc
PP.string (Field -> String
unField Field
f)) Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
"=") Doc -> Doc -> Doc
PP.<$>
        String -> Doc
PP.text String
"    " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
        Doc -> Doc
PP.align (AST a -> Doc
forall a. Pretty a => a -> Doc
pretty AST a
v)
      prettyField (Field
f, EditElem Diff (AST a)
e) =
        Doc -> Doc -> Doc
underHeader (Importance -> Doc -> Doc
emphasize Importance
imp (String -> Doc
PP.string (Field -> String
unField Field
f)) Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
"=") (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        Edit a -> Doc
forall a. Pretty a => a -> Doc
pretty Diff (AST a)
Edit a
e

-- | Print an 'Edit' value to the terminal using ANSI colors
printEdit :: Show a => Edit a -> IO ()
printEdit :: Edit a -> IO ()
printEdit Edit a
e = Doc -> IO ()
PP.putDoc (Edit a -> Doc
forall a. Pretty a => a -> Doc
pretty Edit a
e) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
""

-- | Print a diff as a test result
--
-- 'Nothing' is shown as a green \"OK\".
--
-- @`Just` d@ is shown as a red \"Fail\", followed by a rendering of the diff.
diffAsTestResult :: Show a => Maybe (Edit a) -> Doc
diffAsTestResult :: Maybe (Edit a) -> Doc
diffAsTestResult Maybe (Edit a)
Nothing  = Doc -> Doc
PP.green (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.string String
"OK"
diffAsTestResult (Just Edit a
e) = Doc -> Doc -> Doc
underHeader (Doc -> Doc
PP.red (String -> Doc
PP.string String
"Fail")) (Edit a -> Doc
forall a. Pretty a => a -> Doc
PP.pretty Edit a
e)