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

import           Prelude
                   ()
import           Prelude.Compat

import           Data.Map
                   (Map)
import           Test.StateMachine.TreeDiff.List

import qualified Data.Map                        as Map
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 (Map 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, 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 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 -> Map String Expr -> Expr
`Rec` Map String Expr
forall a. Monoid a => a
mempty) (String -> Expr) -> Gen String -> Gen Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
arbName
            ]
        arb t
n | 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 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 -> Map String Expr -> Expr
Rec (String -> Map String Expr -> Expr)
-> Gen String -> Gen (Map String Expr -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
arbName Gen (Map String Expr -> Expr) -> Gen (Map 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 (Map String Expr)
forall a. Gen a -> Gen (Map 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 Map String Expr
fs) = Map String Expr -> [Expr]
forall k a. Map k a -> [a]
Map.elems Map String Expr
fs
        [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [ String -> Map String Expr -> Expr
Rec String
n' Map 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 -> Map String Expr -> Expr
Rec String
n  Map String Expr
fs' | Map String Expr
fs' <- Map String Expr -> [Map String Expr]
forall a. Arbitrary a => a -> [a]
QC.shrink Map 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 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. [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)

    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. (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)
    impl ea :: Expr
ea@(Rec String
a Map String Expr
as) eb :: Expr
eb@(Rec String
b Map 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 -> Map String (Edit EditExpr) -> EditExpr
EditRec String
a (Map String (Edit EditExpr) -> EditExpr)
-> Map String (Edit EditExpr) -> EditExpr
forall a b. (a -> b) -> a -> b
$ [Map String (Edit EditExpr)] -> Map String (Edit EditExpr)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map String (Edit EditExpr)
inter, Map String (Edit EditExpr)
onlyA, Map String (Edit EditExpr)
onlyB]
        | Bool
otherwise = EditExpr -> EditExpr -> Edit EditExpr
forall a. a -> a -> Edit a
Swp (Expr -> EditExpr
EditExp Expr
ea) (Expr -> EditExpr
EditExp Expr
eb)
      where
        inter :: Map String (Edit EditExpr)
inter = (Expr -> Expr -> Edit EditExpr)
-> Map String Expr -> Map String Expr -> Map String (Edit EditExpr)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith Expr -> Expr -> Edit EditExpr
exprDiff Map String Expr
as Map String Expr
bs
        onlyA :: Map String (Edit EditExpr)
onlyA = (Expr -> Edit EditExpr)
-> Map String Expr -> Map String (Edit EditExpr)
forall a b. (a -> b) -> Map String a -> Map String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EditExpr -> Edit EditExpr
forall a. a -> Edit a
Del (EditExpr -> Edit EditExpr)
-> (Expr -> EditExpr) -> Expr -> Edit EditExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> EditExpr
EditExp) (Map String Expr -> Map String (Edit EditExpr) -> Map String Expr
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map String Expr
as Map String (Edit EditExpr)
inter)
        onlyB :: Map String (Edit EditExpr)
onlyB = (Expr -> Edit EditExpr)
-> Map String Expr -> Map String (Edit EditExpr)
forall a b. (a -> b) -> Map String a -> Map String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EditExpr -> Edit EditExpr
forall a. a -> Edit a
Ins (EditExpr -> Edit EditExpr)
-> (Expr -> EditExpr) -> Expr -> Edit EditExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> EditExpr
EditExp) (Map String Expr -> Map String (Edit EditExpr) -> Map String Expr
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map String Expr
bs Map String (Edit EditExpr)
inter)
    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. (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 (Map 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