Improved gDiff for Expr

cleantest.icl

@@ -29,7 +29,47 @@ import Text.GenJSON
 import Text.GenParse
 import Text.Language
 
-derive gDiff GenConsAssoc, Maybe, Expr
+derive gDiff GenConsAssoc, Maybe
+
+gDiff{|Expr|} x y = case (x,y) of
+	(ExprInt a,    ExprInt b)    -> gDiff{|*|} a b
+	(ExprChar a,   ExprChar b)   -> gDiff{|*|} a b
+	(ExprBool a,   ExprBool b)   -> gDiff{|*|} a b
+	(ExprReal a,   ExprReal b)   -> gDiff{|*|} a b
+	(ExprString a, ExprString b) -> gDiff{|*|} a b
+	(ExprTuple a,  ExprTuple b)  -> gDiff{|*|} a b
+	(ExprList a,   ExprList b)   -> gDiff{|*|} a b
+	(ExprArray a,  ExprArray b)  -> gDiff{|*|} a b
+	(ExprRecord r1 xs, ExprRecord r2 ys) | r1 == r2 -> [
+			{ status   = parentStatus field_diffs
+			, value    = fromMaybe "<unnamed record>" r1
+			, children = field_diffs
+			}]
+		with
+			field_diffs =
+				[ let ds = gDiff{|*|} (find k xs) (find k ys) in
+					{status=parentStatus ds, value=k +++ "=", children=ds} \\ k <- both] ++
+				[{status=OnlyLeft,  value=k +++ "=", children=[{status=OnlyLeft,  value=toString (find k xs), children=[]}]} \\ k <- xonly] ++
+				[{status=OnlyRight, value=k +++ "=", children=[{status=OnlyRight, value=toString (find k ys), children=[]}]} \\ k <- yonly]
+
+			xkeys = [k \\ ExprField k _ <-: xs]
+			ykeys = [k \\ ExprField k _ <-: ys]
+			both = intersect xkeys ykeys
+			xonly = difference xkeys ykeys
+			yonly = difference ykeys xkeys
+			find k vs = case [e \\ ExprField f e <-: vs | f == k] of
+				[e:_] -> e
+				_     -> abort "gDiff_Expr: internal error\n"
+
+			parentStatus :: [Diff] -> DiffStatus
+			parentStatus diffs = if (all (\d -> d.status == Common) field_diffs) Common Changed
+	_ -> simple x y
+where
+	simple :: Expr Expr -> [Diff]
+	simple left right =
+		[ {status=OnlyLeft,  value=toString left,  children=[]}
+		, {status=OnlyRight, value=toString right, children=[]}
+		]
 
 :: *ProcessOutput =
 	{ lines :: ![String]