{-# LANGUAGE RankNTypes, DeriveDataTypeable, TypeSynonymInstances #-}
{-# OPTIONS_GHC -F -pgmF htfpp #-}

module DPM.Core.Model (

  Model, emptyModel,

  Patch, PatchID, PatchState(..), Partial,

  addPatch, markAsReviewed, markAsDiscarded, markAsDiscarded',
  markAsUndecided, markAsApplied,
  closePatchGroup, openPatchGroup, getPatches, allConflicts,

  p_id, p_state, p_dependents, p_isReviewed,

  allHTFTests

) where

--
-- This module serves as the model for the operations of the DPM.
--

import qualified Data.Map as Map
import qualified Data.List as List
import qualified Data.Set as Set
import Data.List ( (\\) )
import Data.Maybe ( isJust )
import Control.Monad.Error
import Text.Regex.Posix
import Data.Maybe ( mapMaybe )

import Data.Generics ( everywhere, mkT, extT )
import Data.Data ( Data )
import Data.Typeable ( Typeable )

import Test.Framework hiding ( Filter )
import Test.Framework.Pretty

import DPM.Core.Utils hiding ( allHTFTests )
import DPM.Core.DataTypes ( PatchID(..), PatchGroupID(..),
                            PatchState(..), ReasonDiscarded(..),
                            PatchGroupState(..), PatchGroup(..),
                            Query(..),
                            queryTrue, queryFalse, isDiscarded )
import DPM.Core.Conflicts
--
-- The types defining the model
--

type Map = Map.Map
type Set = Set.Set

data Model = Model {
      m_closedGroups :: [ClosedPatchGroup]
    , m_openGroups :: Map PatchGroupID OpenPatchGroup
    , m_conflicts :: PatchConflicts
    }
    deriving (Eq,Show,Read,Data,Typeable)

emptyModel :: Model
emptyModel = Model [] Map.empty emptyConflicts

data ClosedPatchGroup = ClosedPatchGroup {
      cpg_name :: PatchGroupID
    , cpg_patches :: Either (PatchList APPLIED) (PatchList UNDECIDED)
    }
    deriving (Eq,Show,Read,Data,Typeable)

data OpenPatchGroup = OpenPatchGroup {
      opg_patches :: PatchList UNDECIDED
    }
    deriving (Eq,Show,Read,Data,Typeable)

data PatchList a = PatchList (Maybe (Patch a)) [Patch DISCARDED]
                   deriving (Eq,Show,Read,Data,Typeable)

type PatchName = PatchGroupID

data Patch a = Patch {
      p_id         :: PatchID
    , p_state      :: a
    , p_dependents :: [PatchID]
    , p_isReviewed :: Bool
    }
    deriving (Eq,Ord,Show,Read,Data,Typeable)

{- State transitions for patches. The diagram omits self-loops.

   APPLIED <------ UNDECIDED <------> DISCARDED
-}


data UNDECIDED = UNDECIDED deriving (Eq,Show,Read,Data,Typeable)
data APPLIED = APPLIED deriving (Eq,Show,Read,Data,Typeable)
data DISCARDED = DISCARDED ReasonDiscarded deriving (Eq,Show,Read,Data,Typeable)

class PATCH_STATE a where
    patchState :: a -> PatchState

instance PATCH_STATE UNDECIDED where
    patchState _ = PatchStateUNDECIDED

instance PATCH_STATE APPLIED where
    patchState _ = PatchStateAPPLIED

instance PATCH_STATE DISCARDED where
    patchState (DISCARDED r) = PatchStateDISCARDED r

--
-- The primitive operations
--

type Partial a = Either String a

-- | Adds a new patch to the model. The operation fails if any of the
--   IDs in the 3rd parameter does not exist in the model.
addPatch :: Model
         -> PatchID         -- ^ ID of the new patch
         -> PatchGroupID    -- ^ Name of the new patch
         -> [PatchID]       -- ^ IDs of the patches the new patch depends on
         -> [PatchID]       -- ^ IDs of the patches the new patch conflicts with
         -> Bool            -- ^ True iff the new patch conflicts with the repo
         -> Partial Model
addPatch model pid pname deps conflicts repoConflict =
    let eitherModel = addPatch' model (Patch pid UNDECIDED deps False) pname
    in case eitherModel of
         Left err -> Left err
         Right model' ->
           let c = m_conflicts model'
               c' = foldl addConflict c (zip (cycle [pid]) conflicts)
               c'' = if repoConflict then addConflictWithRepo c' pid else c'
           in Right $ model' { m_conflicts = c'' }

-- Only internally used.
addPatch' :: Model -> Patch UNDECIDED -> PatchName -> Partial Model
addPatch' model patch pname =
    assertModel model $
    let allPIDs = allPatchIDs model
    in case p_dependents patch \\ allPIDs of
         l@(_:_) -> Left ("The dependencies " ++ show l ++
                          " are not contained in the model")
         [] -> if p_id patch `elem` allPIDs
                  then Right model
                  else let openGroups = m_openGroups model
                           group = case Map.lookup pname
                                                   openGroups of
                                     Just (OpenPatchGroup patches) ->
                                       {- DPM already manges patches with the
                                          same name and none if
                                          these patches is in status APPLIED -}
                                       let patches' = patch `plCons` patches
                                       in OpenPatchGroup patches'
                                     Nothing ->
                                       {- DPM does not manage any patches with
                                          the same name or one of the patches
                                          with the same name is in status
                                          APPLIED -}
                                       OpenPatchGroup (plSingleton patch)
                        in Right $ model { m_openGroups =
                                           Map.insert pname
                                                      group openGroups }

-- | The operation fails if the patch with the ID given does not exist.
markAsReviewed :: Model -> PatchID -> Partial Model
markAsReviewed model pid =
    assertModelAndPID model pid $
    everywhere (mkT (markPatch UNDECIDED)
                `extT` markPatch APPLIED
                `extT` markPatch (DISCARDED ReasonRejected)
                `extT` markPatch (DISCARDED ReasonObsolete))
               model
    where
      markPatch :: a -> Patch a -> Patch a
      markPatch _ p | p_id p == pid = p { p_isReviewed = True }
                    | otherwise = p

-- | Marks the patch with the ID given as DISCARDED. The operation
--   fails if the patch with the ID given is in state APPLIED or does
--   not exist.
markAsDiscarded :: Model -> PatchID -> ReasonDiscarded -> Partial Model
markAsDiscarded = markAsDiscarded' True

-- | Marks the patch with the ID given as DISCARDED. The check parameter
--   specifies whether the operation fails if the patch with the ID
--   given is in state APPLIED. In any case, the operation fails if the
--   patch with the ID given does not exist.
markAsDiscarded' :: Bool -> Model -> PatchID -> ReasonDiscarded -> Partial Model
markAsDiscarded' check model pid reason =
    assertModel model $
    case findPatchInModel model pid of
      Left e -> Left e
      Right p ->
          if p_state p == PatchStateAPPLIED && check
             then Left ("Patch with ID " ++ show pid ++ " is in state APPLIED")
             else Right $ everywhere (mkT markInPatchList') $
                          everywhere (mkT markInPatchList) $
                          everywhere (mkT markPatch) model
    where
      markPatch :: Patch DISCARDED -> Patch DISCARDED
      markPatch p | p_id p == pid = p { p_state = DISCARDED reason }
                  | otherwise = p
      markInPatchList :: PatchList UNDECIDED -> PatchList UNDECIDED
      markInPatchList pl@(PatchList mp l) =
          case mp of
            Just p | p_id p == pid ->
                PatchList Nothing (p { p_state = DISCARDED reason } : l)
            _ -> pl
      markInPatchList' :: PatchList APPLIED -> PatchList APPLIED
      markInPatchList' pl@(PatchList mp l) =
          case mp of
            Just p | p_id p == pid ->
                PatchList Nothing (p { p_state = DISCARDED reason } : l)
            _ -> pl

-- | Marks the patch with the ID given as UNDECIDED. Suppose this patch is p.
--
--   * If the patch is contained in a patch group without a head patch
--     then p becomes the new head patch.
--
--   * If the patch is contained in a patch group whose head patch is
--     in state UNDECIDED then p becomes the new head patch and the old head
--     patch is marked as DISCARDED.
--   * If the patch is contained in a patch group whose head patch is
--     in state APPLIED then a new, open patch group is created consisting
--     of only p.
--
--   The operation fails if p is in state APPLIED or there exists no
--   patch with the ID given does not exists.
markAsUndecided :: Model -> PatchID -> Partial Model
markAsUndecided model pid =
    assertModel model $
    case findPatchInModel model pid of
      Left e -> Left e
      Right p ->
          if p_state p == PatchStateAPPLIED
             then Left ("Patch with ID " ++ show pid ++ " is in state APPLIED")
             else
                 let model' = everywhere (mkT markInPatchList
                                          `extT`
                                          deleteFromPatchList)
                                         model
                 in case findPatchGroupOf model pid of
                      Left e -> Left e
                      Right (Right _) -> Right model'
                      Right (Left cpg) ->
                          if isPatchGroupApplied cpg
                             then addPatch' model'
                                            (p { p_state = UNDECIDED })
                                            (cpg_name cpg)
                             else Right model'
    where
      deleteFromPatchList :: PatchList APPLIED -> PatchList APPLIED
      deleteFromPatchList (PatchList mp l) =
          PatchList mp (foldr (\ p acc -> if p_id p == pid then acc else p:acc)
                              [] l)
      markInPatchList :: PatchList UNDECIDED -> PatchList UNDECIDED
      markInPatchList pl@(PatchList mp l) =
          case foldr (\ p (x,acc) -> if p_id p == pid
                                        then (Just p, acc)
                                        else (x, p:acc))
                     (Nothing, []) l
          of
            (Nothing, _) -> pl
            (Just p, l') ->
                PatchList (Just (p { p_state = UNDECIDED }))
                          (l' ++ (case mp of
                                    Just p' -> [p' { p_state = DISCARDED
                                                                ReasonObsolete }]
                                    Nothing -> []))

-- | The operation fails if the patch with the ID given is in state
--   DISCARDED. Further, it fails if there exists a patch
--   on with the patch with the given ID depends but which is not in
--   state APPLIED.
markAsApplied :: Model -> PatchID -> Partial Model
markAsApplied model pid =
    assertModel model $
    case findPatchInModel model pid of
      Left e -> Left e
      Right p ->
          case () of
           _| isDiscarded (p_state p) ->
                Left ("Patch with ID " ++ show pid ++ " is in state " ++
                      show (p_state p))
            | any (not . isApplied) (p_dependents p) ->
                Left ("Patch with ID " ++ show pid ++
                      " depends at least on one unapplied patch")
            | p_state p == PatchStateAPPLIED ->
                Right model
            | otherwise -> -- patch is in state UNDECIDED
                  case findPatchGroupOf model pid of
                    Left e -> error ("markAsApplied: unexpected error: " ++ e)
                    Right (Left closed) ->
                        Right $ everywhere (mkT markInClosedPatchGroup) model
                    Right (Right (name, open)) ->
                        Right $ model {
                                  m_openGroups = Map.delete name
                                                            (m_openGroups model)
                                 ,m_closedGroups = m_closedGroups model
                                                   ++
                                                   [ClosedPatchGroup
                                                      name
                                                      (Left
                                                       (markInPatchList
                                                        (opg_patches open)))
                                                   ]
                              }
    where
      markInPatchList :: PatchList UNDECIDED -> PatchList APPLIED
      markInPatchList (PatchList (Just p) l) =
          PatchList (Just (p { p_state = APPLIED })) l
      markInPatchList pl = error ("markAsApplied.markInPatchList applied on " ++
                                  show pl)
      markInClosedPatchGroup :: ClosedPatchGroup -> ClosedPatchGroup
      markInClosedPatchGroup cpg =
          case cpg_patches cpg of
            Right pl@(PatchList (Just p) _) | p_id p == pid ->
                cpg { cpg_patches =
                        Left (markInPatchList pl)
                    }
            _ -> cpg
      isApplied :: PatchID -> Bool
      isApplied pid =
          case findPatchInModel model pid of
            Left e -> error ("markAsApplied.isApplied: unexpected error: " ++
                             e)
            Right p -> p_state p == PatchStateAPPLIED


-- | The operation fails if the patch group with the name given does
-- | not exist.
closePatchGroup :: Model -> PatchGroupID -> Partial Model
closePatchGroup model name =
    assertModel model $
    case Map.lookup name (m_openGroups model) of
      Just open -> Right $
          model {
            m_closedGroups = m_closedGroups model ++
                             [ClosedPatchGroup name (Right (opg_patches open))]
           ,m_openGroups = Map.delete name (m_openGroups model)
          }
      Nothing ->
          case List.find (\closed -> cpg_name closed == name)
                         (m_closedGroups model)
          of
            Just _ -> Right model
            Nothing -> Left ("Model does not contain a patch group of name "
                             ++ show name)

-- | Opens the patch group that contains the patch with the given
--   ID. The operation fails if there exists no patch with the ID
--   given or if the corresponding patch group contains a patch in
--   state APPLIED.
openPatchGroup :: Model -> PatchID -> Partial (Model, PatchGroupID)
openPatchGroup model pid =
    assertModelAndPID' model pid $
    case findPatchGroupOf model pid of
      Left err -> error err
      Right (Right (pgid, _)) -> Right (model, pgid)
      Right (Left cpg) ->
          case cpg_patches cpg of
            Left _ -> Left ("Cannot open patch group containing patch with " ++
                            show pid ++ " because patch group " ++ show cpg ++
                            " contains a patch in state APPLIED")
            Right patches ->
                let opg = OpenPatchGroup $
                        case Map.lookup (cpg_name cpg) (m_openGroups model) of
                          Just (OpenPatchGroup patches') ->
                              patches `plConcat` patches'
                          Nothing ->
                              patches
                in Right (
                     model {
                       m_closedGroups = List.delete cpg (m_closedGroups model)
                      ,m_openGroups = Map.insert (cpg_name cpg) opg
                                                 (m_openGroups model)
                     },
                     cpg_name cpg
                   )

getPatches :: Model -> [PatchGroup (Patch PatchState)]
getPatches model =
    assertModel model $
    modelToPatchGroups model

allConflicts :: Model -> PatchConflicts
allConflicts = m_conflicts

--
-- Auxiliaries
--

pgID :: String -> PatchGroupID
pgID = PatchGroupID

assertModel' :: Model -> Set PatchID
assertModel' model =
    let l = allPatchIDs model
    in case foldr (\pid eset -> do set <- eset
                                   if Set.member pid set
                                      then Left ("Model contains " ++ show pid
                                                 ++ " more than once")
                                      else Right $ Set.insert pid set)
                  (Right Set.empty) l
       of Left e -> error e
          Right set -> set

assertModel :: Model -> a -> a
assertModel model x = assertModel' model `seq` x

assertModelAndPID :: Model -> PatchID -> a -> Partial a
assertModelAndPID model pid x =
    let set = assertModel' model
    in if Set.member pid set
          then Right x
          else Left ("Unknown patch ID: " ++ show pid)

assertModelAndPID' :: Model -> PatchID -> Partial a -> Partial a
assertModelAndPID' model pid px =
    case assertModelAndPID model pid px of
      Right x -> x
      Left e -> Left e

plCons :: Patch UNDECIDED -> PatchList UNDECIDED -> PatchList UNDECIDED
plCons p (PatchList Nothing l) =
    PatchList (Just p) l
plCons p (PatchList (Just p') l) =
    PatchList (Just p) (p' { p_state = DISCARDED ReasonObsolete } : l)

plSingleton :: Patch UNDECIDED -> PatchList UNDECIDED
plSingleton p = PatchList (Just p) []

plConcat :: PatchList a -> PatchList a -> PatchList a
plConcat (PatchList (Just x) xs) pl =
    PatchList (Just x) (xs ++ (case pl of
                                 PatchList (Just y) ys ->
                                    y { p_state = DISCARDED ReasonObsolete } : ys
                                 PatchList Nothing ys -> ys))
plConcat (PatchList Nothing xs) (PatchList (Just y) ys) =
    PatchList (Just y) (xs ++ ys)
plConcat (PatchList Nothing xs) (PatchList Nothing ys) =
    PatchList Nothing (xs ++ ys)

allPatchIDs :: Model -> [PatchID]
allPatchIDs model = map p_id (flattenModel model)

findPatchInModel :: Model -> PatchID -> Partial (Patch PatchState)
findPatchInModel model pid =
    let allPatches = flattenModel model
    in case findPatchInList pid allPatches of
         Nothing -> Left ("Patch with ID " ++ show pid ++ " not found")
         Just p -> Right p

modelToPatchGroups :: Model -> [PatchGroup (Patch PatchState)]
modelToPatchGroups model =
    map (\cpg -> PatchGroup (cpg_name cpg)
                            PatchGroupClosed
                            (case cpg_patches cpg of
                               Right l -> flattenPatchList l
                               Left l -> flattenPatchList l)
                            True)
       (m_closedGroups model)
    ++
    map (\ (name, opg) -> PatchGroup name
                                     PatchGroupOpen
                                     (flattenPatchList (opg_patches opg))
                                     True)
        (Map.toList (m_openGroups model))

flattenModel :: Model -> [Patch PatchState]
flattenModel model =
    concatMap flattenClosedPatchGroup (m_closedGroups model) ++
    concatMap flattenOpenPatchGroup (mapRange (m_openGroups model))

flattenClosedPatchGroup :: ClosedPatchGroup -> [Patch PatchState]
flattenClosedPatchGroup pg =
    case cpg_patches pg of
      Left pl -> flattenPatchList pl
      Right pl -> flattenPatchList pl

flattenOpenPatchGroup :: OpenPatchGroup -> [Patch PatchState]
flattenOpenPatchGroup pg =
    flattenPatchList (opg_patches pg)

flattenPatchList :: PATCH_STATE a => PatchList a -> [Patch PatchState]
flattenPatchList (PatchList head l) =
    let l' = map convertPatch l
    in case head of
         Nothing -> l'
         Just p -> convertPatch p : l'

convertPatch :: PATCH_STATE a => Patch a -> Patch PatchState
convertPatch p = p { p_state = patchState (p_state p) }

findPatchGroupOf :: Model -> PatchID -> Partial (Either ClosedPatchGroup
                                                        (PatchGroupID,
                                                         OpenPatchGroup))
findPatchGroupOf model pid =
    case msum (map (checkPatchGroup flattenClosedPatchGroup)
                   (m_closedGroups model)) of
      Just cpg -> Right (Left cpg)
      Nothing ->
          case msum (map (checkPatchGroup' flattenOpenPatchGroup)
                         (Map.assocs (m_openGroups model))) of
               Just x -> Right (Right x)
               Nothing -> Left ("No patch group found that contains a patch "
                                ++ "with ID " ++ show pid)
    where
      checkPatchGroup :: (pg -> [Patch a]) -> pg -> Maybe pg
      checkPatchGroup flattenFun pg =
          if isJust (findPatchInList pid (flattenFun pg))
             then Just pg
             else Nothing
      checkPatchGroup' :: (pg -> [Patch a]) -> (PatchGroupID, pg)
                       -> Maybe (PatchGroupID, pg)
      checkPatchGroup' f (name, pg) =
          case checkPatchGroup f pg of
            Just pg -> Just (name, pg)
            Nothing -> Nothing

findPatchInList :: PatchID -> [Patch a] -> Maybe (Patch a)
findPatchInList pid l = List.find (\p -> p_id p == pid) l

mapRange :: Map k v -> [v]
mapRange m = map snd (Map.toList m)

mapPL :: (forall b . Patch b -> Patch b) -> PatchList a -> PatchList a
mapPL f (PatchList (Just head) l) = PatchList (Just (f head)) (map f l)
mapPL f (PatchList Nothing l) = PatchList Nothing (map f l)

isPatchGroupApplied :: ClosedPatchGroup -> Bool
isPatchGroupApplied cpg = case cpg_patches cpg of
                            Left _ -> True
                            _ -> False

--
-- Tests
--

-- FIXME: test conflict handling

p1 = Patch (PatchID "p1") APPLIED [] True
p2 = Patch (PatchID "p2") (DISCARDED ReasonObsolete) [] False
p3 = Patch (PatchID "p3") (DISCARDED ReasonObsolete) [] True
p4 = Patch (PatchID "p4") APPLIED [p_id p1] True
p5 = Patch (PatchID "p5") (DISCARDED ReasonObsolete) [p_id p1] True
p6 = Patch (PatchID "p6") UNDECIDED [p_id p1, p_id p5] True
p7 = Patch (PatchID "p7") (DISCARDED ReasonObsolete) [p_id p1] False
p8 = Patch (PatchID "p8") (DISCARDED ReasonObsolete) [p_id p1] False
p9 = Patch (PatchID "p9") (DISCARDED ReasonObsolete) [p_id p2] False
p10 = Patch (PatchID "p10") (DISCARDED ReasonObsolete) [p_id p2, p_id p5] False
p11 = Patch (PatchID "p11") UNDECIDED [p_id p1, p_id p4] False
p12 = Patch (PatchID "p12") (DISCARDED ReasonObsolete) [p_id p1, p_id p4] True
p13 = Patch (PatchID "p13") (DISCARDED ReasonObsolete) [p_id p1, p_id p4] False
p14 = Patch (PatchID "p14") (DISCARDED ReasonRejected) [p_id p1, p_id p11] False
p15 = Patch (PatchID "p15") (DISCARDED ReasonObsolete) [p_id p1, p_id p11] True
p17 = Patch (PatchID "p17") (DISCARDED ReasonObsolete) [] True
p18 = Patch (PatchID "p18") UNDECIDED [] True
p19 = Patch (PatchID "p19") (DISCARDED ReasonObsolete) [] True

p16 = Patch (PatchID "p16") UNDECIDED [] False

invalidModel = Model
                [ClosedPatchGroup (pgID "pg1") (Right $ PatchList (Just p6) [])]
                (Map.fromList [(pgID "pg2",
                                OpenPatchGroup (PatchList (Just p6) []))])
                emptyConflicts
sampleModel =
    Model
      [ClosedPatchGroup (pgID "pg1") (Left $ PatchList (Just p1) [p2,p3]),
       ClosedPatchGroup (pgID "pg2") (Left $ PatchList (Just p4) [p5]),
       ClosedPatchGroup (pgID "pg2") (Right $ PatchList (Just p6) [p7,p8]),
       ClosedPatchGroup (pgID "pg3") (Right $ PatchList Nothing [p9,p10]),
       ClosedPatchGroup (pgID "pg4") (Right $ PatchList Nothing [p17]),
       ClosedPatchGroup (pgID "pg4") (Right $ PatchList (Just p18) [p19])]
      (Map.fromList
              [(pgID "pg4", OpenPatchGroup (PatchList (Just p11) [p12,p13])),
               (pgID "pg5", OpenPatchGroup (PatchList Nothing [p14,p15]))])
      emptyConflicts

test_markAsReviewed =
    do assertLeft $ markAsReviewed sampleModel (PatchID "foo")
       assertThrowsSome $ markAsReviewed invalidModel (PatchID "p14")
       m1 <- assertRight $ markAsReviewed sampleModel (PatchID "p14")
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg5")
                            (OpenPatchGroup (PatchList Nothing
                                              [p14 { p_isReviewed = True },
                                               p15]))
                            (m_openGroups sampleModel)
                    })
                    m1
       m2 <- assertRight $ markAsReviewed sampleModel (PatchID "p2")
       assertEqual (sampleModel {
                      m_closedGroups =
                          ClosedPatchGroup (pgID "pg1")
                                           (Left $ PatchList (Just p1)
                                                   [p2 { p_isReviewed = True },
                                                    p3])
                          : tail (m_closedGroups sampleModel)
                    })
                    m2
       m3 <- assertRight $ markAsReviewed sampleModel (PatchID "p1")
       assertEqual sampleModel m3
       m4 <- assertRight $ markAsReviewed sampleModel (PatchID "p12")
       assertEqual sampleModel m4

-- FIXME: add tests for conflicts

test_addPatch =
    do m0 <- assertRight $ addPatch sampleModel (PatchID "p1") (pgID "pg3")
                             [] [] False
       assertEqual sampleModel m0
       m1 <- assertRight $ addPatch sampleModel (PatchID "p16") (pgID "pg5")
                             [] [] False
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg5")
                            (OpenPatchGroup (PatchList (Just p16) [p14,p15]))
                            (m_openGroups sampleModel)
                    })
                    m1
       m2 <- assertRight $ addPatch sampleModel (PatchID "p16") (pgID "pg4")
                             [] [] False
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg4")
                            (OpenPatchGroup (PatchList (Just p16)
                                                [p11 {p_state=(DISCARDED
                                                               ReasonObsolete)},
                                                 p12,
                                                 p13]))
                            (m_openGroups sampleModel)
                    })
                   m2
       m3 <- assertRight $ addPatch sampleModel (PatchID "p16") (pgID "pg1")
                             [] [] False
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg1")
                            (OpenPatchGroup (PatchList (Just p16) []))
                            (m_openGroups sampleModel)
                    })
                   m3
       m4 <- assertRight $ addPatch sampleModel (PatchID "p16") (pgID "pg6")
                             [] [] False
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg6")
                            (OpenPatchGroup (PatchList (Just p16) []))
                            (m_openGroups sampleModel)
                    })
                   m4
       assertLeft $ addPatch sampleModel (PatchID "p16") (pgID "pg6")
                       [PatchID "foo"] [] False
       assertThrowsSome $ (addPatch invalidModel (PatchID "p16")
                                        (pgID "pg6") [] [] False)

test_markAsDiscarded =
    do assertLeft $ markAsDiscarded sampleModel (PatchID "foo") ReasonObsolete
       assertThrowsSome $ markAsDiscarded invalidModel (PatchID "p14")
                            ReasonObsolete
       assertLeft $ markAsDiscarded sampleModel (PatchID "p4") ReasonObsolete
       m0 <- assertRight $ markAsDiscarded sampleModel (PatchID "p2")
                             ReasonObsolete
       assertEqual sampleModel m0
       m1 <- assertRight $ markAsDiscarded sampleModel (PatchID "p12")
                             ReasonObsolete
       assertEqual sampleModel m1
       m2 <- assertRight $ markAsDiscarded sampleModel (PatchID "p6")
                             ReasonRejected
       assertEqual (sampleModel {
                      m_closedGroups =
                          listReplaceAt 2
                             (ClosedPatchGroup (pgID "pg2")
                               (Right $ PatchList Nothing
                                          [p6 { p_state = (DISCARDED
                                                            ReasonRejected) },
                                           p7, p8]))
                             (m_closedGroups sampleModel)
                    })
                   m2
       m3 <- assertRight $ markAsDiscarded sampleModel (PatchID "p11")
                             ReasonObsolete
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg4")
                             (OpenPatchGroup (PatchList Nothing
                                               [p11 { p_state =
                                                          (DISCARDED
                                                           ReasonObsolete) },
                                                p12,
                                                p13]))
                             (m_openGroups sampleModel)
                    })
                    m3
       m4 <- assertRight $ markAsDiscarded sampleModel (PatchID "p15")
                             ReasonRejected
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg5")
                             (OpenPatchGroup (PatchList Nothing
                                               [p14,
                                                p15 { p_state = DISCARDED
                                                                 ReasonRejected
                                                    }]))
                             (m_openGroups sampleModel)
                    })
                   m4
       m5 <- assertRight $ markAsDiscarded sampleModel (PatchID "p14")
                             ReasonObsolete
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg5")
                             (OpenPatchGroup (PatchList Nothing
                                               [p14 { p_state = DISCARDED
                                                                 ReasonObsolete
                                                    },
                                                p15]))
                             (m_openGroups sampleModel)
                    })
                   m5

test_markAsUndecided =
    do assertLeft $ markAsUndecided sampleModel (PatchID "foo")
       assertThrowsSome $ markAsUndecided invalidModel (PatchID "p14")
       assertLeft $ markAsUndecided sampleModel (PatchID "p4")
       m0 <- assertRight $ markAsUndecided sampleModel (PatchID "p11")
       assertEqual sampleModel m0
       m1 <- assertRight $ markAsUndecided sampleModel (PatchID "p2")
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg1")
                                     (OpenPatchGroup
                                            (PatchList
                                             (Just (p2 { p_state = UNDECIDED }))
                                             []))
                                     (m_openGroups sampleModel)
                    , m_closedGroups =
                        ClosedPatchGroup (pgID "pg1")
                                         (Left $ PatchList (Just p1) [p3])
                        : tail (m_closedGroups sampleModel)
                    })
                    m1
       m2 <- assertRight $ markAsUndecided sampleModel (PatchID "p7")
       assertEqual (sampleModel {
                      m_closedGroups =
                          listReplaceAt 2
                                (ClosedPatchGroup (pgID "pg2")
                                                  (Right $ PatchList
                                                   (Just (p7 { p_state =
                                                               UNDECIDED }))
                                                   [p8, p6 { p_state =
                                                             (DISCARDED
                                                              ReasonObsolete)}]))
                                (m_closedGroups sampleModel)
                    })
                    m2
       m3 <- assertRight $ markAsUndecided sampleModel (PatchID "p9")
       assertEqual (sampleModel {
                      m_closedGroups =
                          listReplaceAt 3
                               (ClosedPatchGroup (pgID "pg3")
                                                 (Right $ PatchList
                                                          (Just (p9{p_state =
                                                                    UNDECIDED}))
                                                          [p10]))
                               (m_closedGroups sampleModel)
                    })
                    m3
       m4 <- assertRight $ markAsUndecided sampleModel (PatchID "p12")
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg4")
                             (OpenPatchGroup (PatchList (Just (p12 {p_state =
                                                                    UNDECIDED}))
                                                [p13,
                                                 p11 {p_state=(DISCARDED
                                                               ReasonObsolete)}
                                                ]))
                             (m_openGroups sampleModel)
                    })
                   m4
       m5 <- assertRight $ markAsUndecided sampleModel (PatchID "p14")
       assertEqual (sampleModel {
                      m_openGroups =
                          Map.insert (pgID "pg5")
                             (OpenPatchGroup (PatchList (Just (p14{p_state =
                                                                   UNDECIDED}))
                                                [p15]))
                             (m_openGroups sampleModel)
                    })
                   m5
       return ()

test_markAsApplied =
    do assertLeft $ markAsApplied sampleModel (PatchID "foo")
       assertThrowsSome $ markAsApplied invalidModel (PatchID "p11")
       assertLeft $ markAsApplied sampleModel (PatchID "p3")
       assertLeft $ markAsApplied sampleModel (PatchID "p8")
       assertLeft $ markAsApplied sampleModel (PatchID "p6")
       assertLeft $ markAsApplied sampleModel (PatchID "p15")
       m0 <- assertRight $ markAsApplied sampleModel (PatchID "p1")
       assertEqual sampleModel m0
       m1 <- assertRight $ markAsApplied sampleModel (PatchID "p4")
       assertEqual sampleModel m1
       -- p6
       m2 <- assertRight $ markAsApplied sampleModel (PatchID "p11")
       assertEqual (sampleModel {
                      m_closedGroups =
                          m_closedGroups sampleModel ++
                          [ClosedPatchGroup (pgID "pg4")
                             (Left $ PatchList
                                       (Just (p11 { p_state = APPLIED }))
                                       [p12, p13])]
                     ,m_openGroups = Map.delete (pgID "pg4")
                                                (m_openGroups sampleModel)
                    })
                   m2

test_closePatchGroup =
    do assertLeft $ closePatchGroup sampleModel (pgID "foo")
       assertThrowsSome $ closePatchGroup invalidModel (pgID "pg1")
       m0 <- assertRight $ closePatchGroup sampleModel (pgID "pg1")
       assertEqual sampleModel m0
       m1 <- assertRight $ closePatchGroup sampleModel (pgID "pg4")
       assertEqual (sampleModel {
                      m_closedGroups =
                          m_closedGroups sampleModel ++
                          [ClosedPatchGroup (pgID "pg4")
                           (Right (PatchList (Just p11) [p12,p13]))]
                     ,m_openGroups =
                         Map.delete (pgID "pg4") (m_openGroups sampleModel)
                   })
                   m1

test_openPatchGroup =
    do assertLeft $ openPatchGroup sampleModel (PatchID "foo")
       assertThrowsSome $ openPatchGroup invalidModel (PatchID "p11")
       assertLeft $ openPatchGroup sampleModel (PatchID "p1")
       (m0,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p11")
       assertEqual sampleModel m0
       (m0',_) <- assertRight $ openPatchGroup sampleModel (PatchID "p12")
       assertEqual sampleModel m0'
       (m1,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p6")
       assertEqual (sampleModel {
                      m_closedGroups =
                         listDeleteAt 2 (m_closedGroups sampleModel)
                     ,m_openGroups =
                         Map.insert (pgID "pg2")
                                    (OpenPatchGroup
                                      (PatchList (Just p6) [p7,p8]))
                                    (m_openGroups sampleModel)
                   })
                   m1
       (m2,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p7")
       assertEqual m1 m2
       (m3,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p8")
       assertEqual m1 m3
       (m4,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p9")
       assertEqual (sampleModel {
                      m_closedGroups =
                         listDeleteAt 3 (m_closedGroups sampleModel)
                     ,m_openGroups =
                         Map.insert (pgID "pg3")
                                    (OpenPatchGroup
                                      (PatchList Nothing [p9,p10]))
                                    (m_openGroups sampleModel)
                   })
                   m4
       (m5,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p10")
       assertEqual m4 m5
       (m6,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p17")
       assertEqual (sampleModel {
                      m_closedGroups =
                         listDeleteAt 4 (m_closedGroups sampleModel)
                     ,m_openGroups =
                         Map.insert
                            (pgID "pg4")
                            (OpenPatchGroup (PatchList (Just p11) [p17,
                                                                   p12,
                                                                   p13]))
                            (m_openGroups sampleModel)
                   })
                   m6
       (m7,_) <- assertRight $ openPatchGroup sampleModel (PatchID "p18")
       assertEqual (sampleModel {
                      m_closedGroups =
                         listDeleteAt 5 (m_closedGroups sampleModel)
                     ,m_openGroups =
                         Map.insert
                            (pgID "pg4")
                            (OpenPatchGroup (PatchList (Just p18)
                                                       [p19,
                                                        p11 { p_state =
                                                              (DISCARDED
                                                               ReasonObsolete) },
                                                        p12,
                                                        p13]))
                            (m_openGroups sampleModel)
                   })
                   m7

test_getPatches =
    do assertThrowsSome $ getPatches invalidModel
       let allPGs = [PatchGroup (pgID "pg1")
                                PatchGroupClosed
                                [convertPatch p1, convertPatch p2,
                                 convertPatch p3]
                                True
                    ,PatchGroup (pgID "pg2")
                                PatchGroupClosed
                                [convertPatch p4, convertPatch p5]
                                True
                    ,PatchGroup (pgID "pg2")
                                PatchGroupClosed
                                [convertPatch p6, convertPatch p7,
                                 convertPatch p8]
                                True
                    ,PatchGroup (pgID "pg3")
                                PatchGroupClosed
                                [convertPatch p9, convertPatch p10]
                                True
                    ,PatchGroup (pgID "pg4")
                                PatchGroupClosed
                                [convertPatch p17]
                                True
                    ,PatchGroup (pgID "pg4")
                                PatchGroupClosed
                                [convertPatch p18, convertPatch p19]
                                True
                    ,PatchGroup (pgID "pg4")
                                PatchGroupOpen
                                [convertPatch p11, convertPatch p12,
                                 convertPatch p13]
                                True
                    ,PatchGroup (pgID "pg5")
                                PatchGroupOpen
                                [convertPatch p14, convertPatch p15]
                                True]
       assertEqual allPGs (getPatches sampleModel)

--
-- Pretty instances
--

instance Pretty PatchGroupState where
    pretty PatchGroupClosed = text "closed"
    pretty PatchGroupOpen = text "open"

instance Pretty a => Pretty (PatchGroup a) where
    pretty pg =
        text "PatchGroup" <+> char '{' <>
        nest 0 (text "pg_id" <+> equals <+> pretty (pg_id pg) <> comma $$
                text "pg_state" <+> equals <+> pretty (pg_state pg) <> comma $$
                text "pg_complete" <+> equals <+>
                     pretty (pg_complete pg) <> comma $$
                text "pg_patches" <+> equals <+> pretty (pg_patches pg)) <>
        char '}'

instance Pretty a => Pretty (Patch a) where
    pretty p =
        text "Patch" <+> char '{' <>
        nest 0 (text "p_id" <=> pretty (p_id p) <> comma $$
                text "p_state" <=>
                pretty (p_state p) <> comma $$
                text "p_dependents" <=> pretty (p_dependents p) <> comma $$
                text "p_isReviewed" <=> pretty (p_isReviewed p)) <>
        char '}'

instance Pretty PatchState where
    pretty PatchStateUNDECIDED = text "UNDECIDED"
    pretty PatchStateAPPLIED = text "APPLIED"
    pretty (PatchStateDISCARDED reason) = text "DISCARDED" <>
                                          braces (pretty reason)

instance Pretty ReasonDiscarded where
    pretty ReasonRejected = text "rejected"
    pretty ReasonObsolete = text "obsolete"

instance Pretty PatchGroupID where
    pretty pgid = text (unPatchGroupID pgid)

instance Pretty PatchID where
    pretty pid = text (unPatchID pid)