```{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Precis.Properties
-- Copyright   :  (c) Stephen Tetley 2010
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  to be determined.
--
--
--
--------------------------------------------------------------------------------

module Precis.Properties
(
-- * Property type
Property(..)

-- * Edit type
, Edit(..)

-- * Edit operations
, difference
, diffProperty
, summarizeConflictRemoved

) 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   -- already found
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])
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])
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 =
`nextLine` vsep (map (addedLine sf)   as)
`nextLine` vsep (map (removedLine sf) rs)
where
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)

-> 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
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)
```