-- | 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
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
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 QC.Arbitrary Expr where
    arbitrary :: Gen Expr
arbitrary = forall a. (Int -> Int) -> Gen a -> Gen a
QC.scale (forall a. Ord a => a -> a -> a
min Int
25) forall a b. (a -> b) -> a -> b
$ forall a. (Int -> Gen a) -> Gen a
QC.sized forall {t}. (Random t, Integral t) => t -> Gen Expr
arb where
        arb :: t -> Gen Expr
arb t
n | t
n forall a. Ord a => a -> a -> Bool
<= t
0 = forall a. [Gen a] -> Gen a
QC.oneof
            [ (String -> [Expr] -> Expr
`App` []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
arbName
            ,  (String -> Map String Expr -> Expr
`Rec` forall a. Monoid a => a
mempty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
arbName
            ]
        arb t
n | Bool
otherwise = do
            t
n' <- forall a. Random a => (a, a) -> Gen a
QC.choose (t
0, t
n forall a. Integral a => a -> a -> a
`div` t
3)
            forall a. [Gen a] -> Gen a
QC.oneof
                [ String -> [Expr] -> Expr
App forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
arbName forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a)
QC.liftArbitrary (t -> Gen Expr
arb t
n')
                , String -> Map String Expr -> Expr
Rec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String
arbName forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a)
QC.liftArbitrary (t -> Gen Expr
arb t
n')
                , [Expr] -> Expr
Lst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
        forall a. [a] -> [a] -> [a]
++ [ [Expr] -> Expr
Lst [Expr]
es'    | [Expr]
es' <- forall a. Arbitrary a => a -> [a]
QC.shrink [Expr]
es ]
    shrink (Rec String
n Map String Expr
fs) = forall k a. Map k a -> [a]
Map.elems Map String Expr
fs
        forall a. [a] -> [a] -> [a]
++ [ String -> Map String Expr -> Expr
Rec String
n' Map String Expr
fs  | String
n'  <- forall a. Arbitrary a => a -> [a]
QC.shrink String
n  ]
        forall a. [a] -> [a] -> [a]
++ [ String -> Map String Expr -> Expr
Rec String
n  Map String Expr
fs' | Map String Expr
fs' <- forall a. Arbitrary a => a -> [a]
QC.shrink Map String Expr
fs ]
    shrink (App String
n [Expr]
es) = [Expr]
es
        forall a. [a] -> [a] -> [a]
++ [ String -> [Expr] -> Expr
App String
n' [Expr]
es  | String
n'  <- forall a. Arbitrary a => a -> [a]
QC.shrink String
n  ]
        forall a. [a] -> [a] -> [a]
++ [ String -> [Expr] -> Expr
App String
n  [Expr]
es' | [Expr]
es' <- forall a. Arbitrary a => a -> [a]
QC.shrink [Expr]
es ]

arbName :: QC.Gen String
arbName :: Gen String
arbName = forall a. [(Int, Gen a)] -> Gen a
QC.frequency
    [ (Int
10, forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a)
QC.liftArbitrary forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Gen a
QC.elements forall a b. (a -> b) -> a -> b
$ [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ [Char
'0' .. Char
'9'] forall a. [a] -> [a] -> [a]
++ String
"+-_:")
    , (Int
1, forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Arbitrary a => Gen a
QC.arbitrary :: QC.Gen String))
    , (Int
1, forall a. Arbitrary a => Gen a
QC.arbitrary)
    , (Int
1, 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 forall a. Eq a => a -> a -> Bool
== Expr
eb = 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 forall a. Eq a => a -> a -> Bool
== String
b = forall a. a -> Edit a
Cpy forall a b. (a -> b) -> a -> b
$ String -> [Edit EditExpr] -> EditExpr
EditApp String
a (forall a b. (a -> b) -> [a] -> [b]
map Edit Expr -> Edit EditExpr
recurse (forall a. (a -> a -> Bool) -> [a] -> [a] -> [Edit a]
diffBy forall a. Eq a => a -> a -> Bool
(==) [Expr]
as [Expr]
bs))
        | Bool
otherwise = 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 forall a. Eq a => a -> a -> Bool
== String
b = forall a. a -> Edit a
Cpy forall a b. (a -> b) -> a -> b
$ String -> Map String (Edit EditExpr) -> EditExpr
EditRec String
a forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> a -> Edit a
Swp (Expr -> EditExpr
EditExp Expr
ea) (Expr -> EditExpr
EditExp Expr
eb)
      where
        inter :: Map String (Edit EditExpr)
inter = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Edit a
Del forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> EditExpr
EditExp) (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Edit a
Ins forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> EditExpr
EditExp) (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) =
        forall a. a -> Edit a
Cpy forall a b. (a -> b) -> a -> b
$ [Edit EditExpr] -> EditExpr
EditLst (forall a b. (a -> b) -> [a] -> [b]
map Edit Expr -> Edit EditExpr
recurse (forall a. (a -> a -> Bool) -> [a] -> [a] -> [Edit a]
diffBy forall a. Eq a => a -> a -> Bool
(==) [Expr]
as [Expr]
bs))

    -- If higher level doesn't match, just swap.
    impl Expr
a Expr
b = 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)   = forall a. a -> Edit a
Ins (Expr -> EditExpr
EditExp Expr
x)
    recurse (Del Expr
y)   = forall a. a -> Edit a
Del (Expr -> EditExpr
EditExp Expr
y)
    recurse (Cpy Expr
z)   = 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
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