-- | This module uses 'Expr' for richer diffs than based on 'Tree'.
module Data.TreeDiff.Expr (
    -- * Types
    Expr (..),
    ConstructorName,
    FieldName,
    EditExpr (..),
    Edit (..),
    exprDiff,
    ) where

import Control.DeepSeq (NFData (..))
import Data.Semialign  (alignWith)
import Data.These      (These (..))

import Data.TreeDiff.List
import Data.TreeDiff.OMap (OMap)

import qualified Data.TreeDiff.OMap as OMap
import qualified Test.QuickCheck    as QC

-- | Constructor name is a string
type ConstructorName = String
--
-- | Record field name is a string too.
type FieldName       = String

-- | A untyped Haskell-like expression.
--
-- Having richer structure than just 'Tree' allows to have richer diffs.
data Expr
    = App ConstructorName [Expr]                 -- ^ application
    | Rec ConstructorName (OMap FieldName Expr)  -- ^ record constructor
    | Lst [Expr]                                 -- ^ list constructor
  deriving (Expr -> Expr -> Bool
(Expr -> Expr -> Bool) -> (Expr -> Expr -> Bool) -> Eq Expr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
/= :: Expr -> Expr -> Bool
Eq, Eq Expr
Eq Expr =>
(Expr -> Expr -> Ordering)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Expr)
-> (Expr -> Expr -> Expr)
-> Ord Expr
Expr -> Expr -> Bool
Expr -> Expr -> Ordering
Expr -> Expr -> Expr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Expr -> Expr -> Ordering
compare :: Expr -> Expr -> Ordering
$c< :: Expr -> Expr -> Bool
< :: Expr -> Expr -> Bool
$c<= :: Expr -> Expr -> Bool
<= :: Expr -> Expr -> Bool
$c> :: Expr -> Expr -> Bool
> :: Expr -> Expr -> Bool
$c>= :: Expr -> Expr -> Bool
>= :: Expr -> Expr -> Bool
$cmax :: Expr -> Expr -> Expr
max :: Expr -> Expr -> Expr
$cmin :: Expr -> Expr -> Expr
min :: Expr -> Expr -> Expr
Ord, Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
(Int -> Expr -> ShowS)
-> (Expr -> String) -> ([Expr] -> ShowS) -> Show Expr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Expr -> ShowS
showsPrec :: Int -> Expr -> ShowS
$cshow :: Expr -> String
show :: Expr -> String
$cshowList :: [Expr] -> ShowS
showList :: [Expr] -> ShowS
Show)

instance NFData Expr where
    rnf :: Expr -> ()
rnf (App String
n [Expr]
es) = String -> ()
forall a. NFData a => a -> ()
rnf String
n () -> () -> ()
forall a b. a -> b -> b
`seq` [Expr] -> ()
forall a. NFData a => a -> ()
rnf [Expr]
es
    rnf (Rec String
n OMap String Expr
fs) = String -> ()
forall a. NFData a => a -> ()
rnf String
n () -> () -> ()
forall a b. a -> b -> b
`seq` OMap String Expr -> ()
forall a. NFData a => a -> ()
rnf OMap String Expr
fs
    rnf (Lst [Expr]
es)   = [Expr] -> ()
forall a. NFData a => a -> ()
rnf [Expr]
es

instance QC.Arbitrary Expr where
    arbitrary :: Gen Expr
arbitrary = (Int -> Int) -> Gen Expr -> Gen Expr
forall a. (Int -> Int) -> Gen a -> Gen a
QC.scale (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
25) (Gen Expr -> Gen Expr) -> Gen Expr -> Gen Expr
forall a b. (a -> b) -> a -> b
$ (Int -> Gen Expr) -> Gen Expr
forall a. (Int -> Gen a) -> Gen a
QC.sized Int -> Gen Expr
forall {t}. (Random t, Integral t) => t -> Gen Expr
arb where
        arb :: t -> Gen Expr
arb t
n | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = [Gen Expr] -> Gen Expr
forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof
            [ (String -> [Expr] -> Expr
`App` []) (String -> Expr) -> Gen String -> Gen Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
arbName
            ,  (String -> OMap String Expr -> Expr
`Rec` OMap String Expr
forall k v. OMap k v
OMap.empty) (String -> Expr) -> Gen String -> Gen Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
arbName
            ]
              | Bool
otherwise = do
            t
n' <- (t, t) -> Gen t
forall a. Random a => (a, a) -> Gen a
QC.choose (t
0, t
n t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
3)
            [Gen Expr] -> Gen Expr
forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof
                [ String -> [Expr] -> Expr
App (String -> [Expr] -> Expr) -> Gen String -> Gen ([Expr] -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
arbName Gen ([Expr] -> Expr) -> Gen [Expr] -> Gen Expr
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Expr -> Gen [Expr]
forall a. Gen a -> Gen [a]
forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a)
QC.liftArbitrary (t -> Gen Expr
arb t
n')
                , String -> OMap String Expr -> Expr
Rec (String -> OMap String Expr -> Expr)
-> Gen String -> Gen (OMap String Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
arbName Gen (OMap String Expr -> Expr)
-> Gen (OMap String Expr) -> Gen Expr
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Expr -> Gen (OMap String Expr)
forall a. Gen a -> Gen (OMap String a)
forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a)
QC.liftArbitrary (t -> Gen Expr
arb t
n')
                , [Expr] -> Expr
Lst ([Expr] -> Expr) -> Gen [Expr] -> Gen Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Expr -> Gen [Expr]
forall a. Gen a -> Gen [a]
forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a)
QC.liftArbitrary (t -> Gen Expr
arb t
n')
                ]

    shrink :: Expr -> [Expr]
shrink (Lst [Expr]
es)   = [Expr]
es
        [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [ [Expr] -> Expr
Lst [Expr]
es'    | [Expr]
es' <- [Expr] -> [[Expr]]
forall a. Arbitrary a => a -> [a]
QC.shrink [Expr]
es ]
    shrink (Rec String
n OMap String Expr
fs) = OMap String Expr -> [Expr]
forall k v. OMap k v -> [v]
OMap.elems OMap String Expr
fs
        [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [ String -> OMap String Expr -> Expr
Rec String
n' OMap String Expr
fs  | String
n'  <- String -> [String]
forall a. Arbitrary a => a -> [a]
QC.shrink String
n  ]
        [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [ String -> OMap String Expr -> Expr
Rec String
n  OMap String Expr
fs' | OMap String Expr
fs' <- OMap String Expr -> [OMap String Expr]
forall a. Arbitrary a => a -> [a]
QC.shrink OMap String Expr
fs ]
    shrink (App String
n [Expr]
es) = [Expr]
es
        [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [ String -> [Expr] -> Expr
App String
n' [Expr]
es  | String
n'  <- String -> [String]
forall a. Arbitrary a => a -> [a]
QC.shrink String
n  ]
        [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [ String -> [Expr] -> Expr
App String
n  [Expr]
es' | [Expr]
es' <- [Expr] -> [[Expr]]
forall a. Arbitrary a => a -> [a]
QC.shrink [Expr]
es ]

arbName :: QC.Gen String
arbName :: Gen String
arbName = [(Int, Gen String)] -> Gen String
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
    [ (Int
10, Gen Char -> Gen String
forall a. Gen a -> Gen [a]
forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a)
QC.liftArbitrary (Gen Char -> Gen String) -> Gen Char -> Gen String
forall a b. (a -> b) -> a -> b
$ String -> Gen Char
forall a. HasCallStack => [a] -> Gen a
QC.elements (String -> Gen Char) -> String -> Gen Char
forall a b. (a -> b) -> a -> b
$ [Char
'a'..Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0' .. Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"+-_:")
    , (Int
1, ShowS
forall a. Show a => a -> String
show ShowS -> Gen String -> Gen String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen String
forall a. Arbitrary a => Gen a
QC.arbitrary :: QC.Gen String))
    , (Int
1, Gen String
forall a. Arbitrary a => Gen a
QC.arbitrary)
    , (Int
1, [String] -> Gen String
forall a. HasCallStack => [a] -> Gen a
QC.elements [String
"_×_", String
"_×_×_", String
"_×_×_×_"])
    ]

-- | Diff two 'Expr'.
--
-- For examples see 'ediff' in "Data.TreeDiff.Class".
exprDiff :: Expr -> Expr -> Edit EditExpr
exprDiff :: Expr -> Expr -> Edit EditExpr
exprDiff = Expr -> Expr -> Edit EditExpr
impl
  where
    impl :: Expr -> Expr -> Edit EditExpr
impl Expr
ea Expr
eb | Expr
ea Expr -> Expr -> Bool
forall a. Eq a => a -> a -> Bool
== Expr
eb = EditExpr -> Edit EditExpr
forall a. a -> Edit a
Cpy (Expr -> EditExpr
EditExp Expr
ea)

    -- application
    impl ea :: Expr
ea@(App String
a [Expr]
as) eb :: Expr
eb@(App String
b [Expr]
bs)
        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
b    = EditExpr -> Edit EditExpr
forall a. a -> Edit a
Cpy (EditExpr -> Edit EditExpr) -> EditExpr -> Edit EditExpr
forall a b. (a -> b) -> a -> b
$ String -> [Edit EditExpr] -> EditExpr
EditApp String
a ((Edit Expr -> Edit EditExpr) -> [Edit Expr] -> [Edit EditExpr]
forall a b. (a -> b) -> [a] -> [b]
map Edit Expr -> Edit EditExpr
recurse ((Expr -> Expr -> Bool) -> [Expr] -> [Expr] -> [Edit Expr]
forall a. Show a => (a -> a -> Bool) -> [a] -> [a] -> [Edit a]
diffBy Expr -> Expr -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Expr]
as [Expr]
bs))
        | Bool
otherwise = EditExpr -> EditExpr -> Edit EditExpr
forall a. a -> a -> Edit a
Swp (Expr -> EditExpr
EditExp Expr
ea) (Expr -> EditExpr
EditExp Expr
eb)

    -- records
    impl ea :: Expr
ea@(Rec String
a OMap String Expr
as) eb :: Expr
eb@(Rec String
b OMap String Expr
bs)
        | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
b    = EditExpr -> Edit EditExpr
forall a. a -> Edit a
Cpy (EditExpr -> Edit EditExpr) -> EditExpr -> Edit EditExpr
forall a b. (a -> b) -> a -> b
$ String -> OMap String (Edit EditExpr) -> EditExpr
EditRec String
a (OMap String (Edit EditExpr) -> EditExpr)
-> OMap String (Edit EditExpr) -> EditExpr
forall a b. (a -> b) -> a -> b
$ (These Expr Expr -> Edit EditExpr)
-> OMap String Expr
-> OMap String Expr
-> OMap String (Edit EditExpr)
forall a b c.
(These a b -> c) -> OMap String a -> OMap String b -> OMap String c
forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
alignWith These Expr Expr -> Edit EditExpr
cls OMap String Expr
as OMap String Expr
bs
        | Bool
otherwise = EditExpr -> EditExpr -> Edit EditExpr
forall a. a -> a -> Edit a
Swp (Expr -> EditExpr
EditExp Expr
ea) (Expr -> EditExpr
EditExp Expr
eb)
      where
        cls :: These Expr Expr -> Edit EditExpr
        cls :: These Expr Expr -> Edit EditExpr
cls (This Expr
x) = EditExpr -> Edit EditExpr
forall a. a -> Edit a
Del (Expr -> EditExpr
EditExp Expr
x)
        cls (That Expr
y) = EditExpr -> Edit EditExpr
forall a. a -> Edit a
Ins (Expr -> EditExpr
EditExp Expr
y)
        cls (These Expr
x Expr
y) = Expr -> Expr -> Edit EditExpr
exprDiff Expr
x Expr
y

    -- lists
    impl (Lst [Expr]
as) (Lst [Expr]
bs) =
        EditExpr -> Edit EditExpr
forall a. a -> Edit a
Cpy (EditExpr -> Edit EditExpr) -> EditExpr -> Edit EditExpr
forall a b. (a -> b) -> a -> b
$ [Edit EditExpr] -> EditExpr
EditLst ((Edit Expr -> Edit EditExpr) -> [Edit Expr] -> [Edit EditExpr]
forall a b. (a -> b) -> [a] -> [b]
map Edit Expr -> Edit EditExpr
recurse ((Expr -> Expr -> Bool) -> [Expr] -> [Expr] -> [Edit Expr]
forall a. Show a => (a -> a -> Bool) -> [a] -> [a] -> [Edit a]
diffBy Expr -> Expr -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Expr]
as [Expr]
bs))

    -- If higher level doesn't match, just swap.
    impl Expr
a Expr
b = EditExpr -> EditExpr -> Edit EditExpr
forall a. a -> a -> Edit a
Swp (Expr -> EditExpr
EditExp Expr
a) (Expr -> EditExpr
EditExp Expr
b)

    recurse :: Edit Expr -> Edit EditExpr
recurse (Ins Expr
x)   = EditExpr -> Edit EditExpr
forall a. a -> Edit a
Ins (Expr -> EditExpr
EditExp Expr
x)
    recurse (Del Expr
y)   = EditExpr -> Edit EditExpr
forall a. a -> Edit a
Del (Expr -> EditExpr
EditExp Expr
y)
    recurse (Cpy Expr
z)   = EditExpr -> Edit EditExpr
forall a. a -> Edit a
Cpy (Expr -> EditExpr
EditExp Expr
z)
    recurse (Swp Expr
x Expr
y) = Expr -> Expr -> Edit EditExpr
impl Expr
x Expr
y

-- | Type used in the result of 'ediff'.
data EditExpr
    = EditApp ConstructorName [Edit EditExpr]
    | EditRec ConstructorName (OMap FieldName (Edit EditExpr))
    | EditLst [Edit EditExpr]
    | EditExp Expr  -- ^ unchanged tree
  deriving Int -> EditExpr -> ShowS
[EditExpr] -> ShowS
EditExpr -> String
(Int -> EditExpr -> ShowS)
-> (EditExpr -> String) -> ([EditExpr] -> ShowS) -> Show EditExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EditExpr -> ShowS
showsPrec :: Int -> EditExpr -> ShowS
$cshow :: EditExpr -> String
show :: EditExpr -> String
$cshowList :: [EditExpr] -> ShowS
showList :: [EditExpr] -> ShowS
Show

instance NFData EditExpr where
    rnf :: EditExpr -> ()
rnf (EditApp String
n [Edit EditExpr]
es) = String -> ()
forall a. NFData a => a -> ()
rnf String
n () -> () -> ()
forall a b. a -> b -> b
`seq` [Edit EditExpr] -> ()
forall a. NFData a => a -> ()
rnf [Edit EditExpr]
es
    rnf (EditRec String
n OMap String (Edit EditExpr)
fs) = String -> ()
forall a. NFData a => a -> ()
rnf String
n () -> () -> ()
forall a b. a -> b -> b
`seq` OMap String (Edit EditExpr) -> ()
forall a. NFData a => a -> ()
rnf OMap String (Edit EditExpr)
fs
    rnf (EditLst [Edit EditExpr]
es)   = [Edit EditExpr] -> ()
forall a. NFData a => a -> ()
rnf [Edit EditExpr]
es
    rnf (EditExp Expr
e)    = Expr -> ()
forall a. NFData a => a -> ()
rnf Expr
e