module Test.StateMachine.TreeDiff.Expr (
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
type ConstructorName = String
type FieldName = String
data Expr
= App ConstructorName [Expr]
| Rec ConstructorName (Map FieldName Expr)
| Lst [Expr]
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
"_×_×_×_"])
]
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))
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
data EditExpr
= EditApp ConstructorName [Edit EditExpr]
| EditRec ConstructorName (Map FieldName (Edit EditExpr))
| EditLst [Edit EditExpr]
| EditExp Expr
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