module Precis.Properties
(
Property(..)
, Edit(..)
, difference
, diffProperty
, addedRemoved
, summarizeAddedRemoved
, summarizeConflictRemoved
, summarizeAddedConflictRemoved
) where
import Precis.PPShowS
import Precis.Utils
import Data.List ( find )
data Property n = Property
{ property_name :: String
, property_description :: String
, property_value :: n
}
deriving (Eq,Ord,Show)
data Edit a = Added a | Conflict a a | Same a | Removed a
deriving (Eq,Show)
difference :: (a -> a -> Bool) -> (a -> a -> Bool) -> [a] -> [a] -> [Edit a]
difference matches conflict as bs = toListH $ checkShort bs (checkLong as id)
where
checkLong [] f = f
checkLong (x:xs) f = case find (matches x) bs of
Just b | conflict x b -> checkLong xs (f `snocH` Conflict x b)
| otherwise -> checkLong xs (f `snocH` Same x)
Nothing -> checkLong xs (f `snocH` Added x)
checkShort [] f = f
checkShort (y:ys) f = case find (matches y) as of
Just _ -> checkShort ys f
Nothing -> checkShort ys (f `snocH` Removed y)
diffProperty :: (n -> n -> b) -> Property n -> Property n -> b
diffProperty cmp (Property _ _ a) (Property _ _ b) = cmp a b
addedRemoved :: [Edit a] -> ([a],[a])
addedRemoved = foldr fn ([],[])
where
fn (Added a) (as,rs) = (a:as,rs)
fn (Removed r) (as,rs) = (as,r:rs)
fn _ acc = acc
addedConflictRemoved :: [Edit a] -> ([a],[(a,a)],[a])
addedConflictRemoved = foldr fn ([],[],[])
where
fn (Added a) (as,cs,rs) = (a:as,cs,rs)
fn (Conflict a b) (as,cs,rs) = (as,(a,b):cs,rs)
fn (Removed r) (as,cs,rs) = (as,cs,r:rs)
fn _ acc = acc
conflictRemoved :: [Edit a] -> ([(a,a)],[a])
conflictRemoved = foldr fn ([],[])
where
fn (Conflict a b) (cs,rs) = ((a,b):cs,rs)
fn (Removed r) (cs,rs) = (cs,r:rs)
fn _ acc = acc
summarizeAddedRemoved :: String -> String -> (a -> String) -> [Edit a] -> ShowS
summarizeAddedRemoved single plural sf xs =
added_msg <> comma <+> removed_msg
`nextLine` vsep (map (addedLine sf) as)
`nextLine` vsep (map (removedLine sf) rs)
where
(as,rs) = addedRemoved xs
added_msg = addedMsg single plural (length as)
removed_msg = removedMsg single plural (length rs)
summarizeConflictRemoved :: String -> String -> (a -> String) -> [Edit a] -> ShowS
summarizeConflictRemoved single plural sf xs =
conflict_msg <> comma <+> removed_msg
`nextLine` vsep (map (conflictLine sf) cs)
`nextLine` vsep (map (removedLine sf) rs)
where
(cs,rs) = conflictRemoved xs
conflict_msg = conflictMsg single plural (length cs)
removed_msg = removedMsg single plural (length rs)
summarizeAddedConflictRemoved :: String
-> String
-> (a -> String) -> [Edit a] -> ShowS
summarizeAddedConflictRemoved single plural sf xs =
added_msg <> comma <+> conflict_msg <> comma <+> removed_msg
`nextLine` vsep (map (addedLine sf) as)
`nextLine` vsep (map (conflictLine sf) cs)
`nextLine` vsep (map (removedLine sf) rs)
where
(as,cs,rs) = addedConflictRemoved xs
added_msg = addedMsg single plural (length as)
conflict_msg = conflictMsg single plural (length cs)
removed_msg = removedMsg single plural (length rs)
msgCount :: String -> String -> Int -> ShowS
msgCount single _ 1 = int 1 <+> text single
msgCount _ plural n = int n <+> text plural
addedMsg :: String -> String -> Int -> ShowS
addedMsg single plural i = msgCount single plural i <+> text "added (+)"
conflictMsg :: String -> String -> Int -> ShowS
conflictMsg single plural i = msgCount single plural i <+> text "conflict (*)"
removedMsg :: String -> String -> Int -> ShowS
removedMsg single plural i = msgCount single plural i <+> text "removed (-)"
addedLine :: (a -> String) -> a -> ShowS
addedLine f a = char '+' <+> (text $ f a)
conflictLine :: (a -> String) -> (a,a) -> ShowS
conflictLine f (a,b) = prefixLines (text "< ") (f a) `line`
prefixLines (text "> ") (f b) <> newline
removedLine :: (a -> String) -> a -> ShowS
removedLine f a = char '-' <+> (text $ f a)