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

import Prelude ()
import Prelude.Compat

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
/= :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c== :: Expr -> Expr -> Bool
Eq, 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
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> String
$cshow :: Expr -> String
showsPrec :: Int -> Expr -> ShowS
$cshowsPrec :: Int -> Expr -> ShowS
Show)

instance NFData Expr where
    rnf :: Expr -> ()
rnf (App String
n [Expr]
es) = String -> ()
forall a. NFData a => a -> ()
rnf String
n () -> () -> ()
`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 () -> () -> ()
`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. [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. [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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Expr -> Gen [Expr]
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Expr -> Gen (OMap String Expr)
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 (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. [(Int, Gen a)] -> Gen a
QC.frequency
    [ (Int
10, Gen Char -> Gen String
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. [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. [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 (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
showList :: [EditExpr] -> ShowS
$cshowList :: [EditExpr] -> ShowS
show :: EditExpr -> String
$cshow :: EditExpr -> String
showsPrec :: Int -> EditExpr -> ShowS
$cshowsPrec :: Int -> 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 () -> () -> ()
`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 () -> () -> ()
`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