{-# LANGUAGE DeriveDataTypeable, RecordWildCards, TemplateHaskell, TypeFamilies #-}
module Clckwrks.Bugs.Acid where
import Control.Applicative ((<$>))
import Control.Monad.Reader (ask)
import Control.Monad.State (get, modify, put)
import Data.Acid (Query, Update, makeAcidic)
import Data.IxSet (IxSet, Proxy(..), (@=), (@+), getOne, empty, toAscList, toList, fromList, updateIx)
import qualified Data.IxSet as IxSet
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Ratio ((%))
import Data.SafeCopy (base, deriveSafeCopy, extension, Migrate(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Clckwrks.Bugs.Types (Bug(..), BugStatus(..), BugId(..), Milestone(..), MilestoneId(..), TargetDate(..))
data BugsState_0 = BugsState_0
{ nextBugId_0 :: BugId
, bugs_0 :: IxSet Bug
}
$(deriveSafeCopy 0 'base ''BugsState_0)
-- | 'BugsState' stores all the bugs
data BugsState = BugsState
{ nextBugId :: BugId
, bugs :: IxSet Bug
, nextMilestoneId :: MilestoneId
, milestones :: IxSet Milestone
}
$(deriveSafeCopy 1 'extension ''BugsState)
instance Migrate BugsState where
type MigrateFrom BugsState = BugsState_0
migrate (BugsState_0 n b) = BugsState n b (MilestoneId 1) empty
-- | initial 'BugsState'
initialBugsState :: BugsState
initialBugsState = BugsState
{ nextBugId = BugId 1
, bugs = empty
, nextMilestoneId = MilestoneId 1
, milestones = empty
}
-- | get the next unused 'BugsId'
genBugId :: Update BugsState BugId
genBugId =
do bs@BugsState{..} <- get
put $ bs { nextBugId = BugId $ succ $ unBugId $ nextBugId }
return nextBugId
-- | get 'Bugs' by 'BugId'
getBugById :: BugId -> Query BugsState (Maybe Bug)
getBugById bid =
do BugsState{..} <- ask
return $ getOne (bugs @= bid)
-- | store 'Bugs' in the state. Will overwrite an existing entry with the same 'BugId'
putBug :: Bug -> Update BugsState ()
putBug bug =
do bs@BugsState{..} <- get
put $ bs { bugs = updateIx (bugId bug) bug bugs }
allBugIds :: Query BugsState [BugId]
allBugIds =
do BugsState{..} <- ask
return $ map bugId (toList bugs)
------------------------------------------------------------------------------
-- Milestones
------------------------------------------------------------------------------
-- | add a new, empty 'Milestone' to the database and return the 'MilestoneId'
newMilestone :: Update BugsState MilestoneId
newMilestone =
do bs@BugsState{..} <- get
let milestone = Milestone { milestoneId = nextMilestoneId
, milestoneTitle = Text.empty
, milestoneTarget = Nothing
, milestoneReached = Nothing
}
put $ bs { nextMilestoneId = succ nextMilestoneId
, milestones = IxSet.insert milestone milestones
}
return nextMilestoneId
-- | get the milestones
getMilestones :: Query BugsState [Milestone]
getMilestones =
do ms <- milestones <$> ask
return (toList ms)
-- | get all the 'MilestoneId's
getMilestoneIds :: Query BugsState [MilestoneId]
getMilestoneIds =
do ms <- milestones <$> ask
return (map milestoneId $ toList ms)
-- | get the 'milestoneTitle' for a 'MilestoneId'
getMilestoneTitle :: MilestoneId -> Query BugsState (Maybe Text)
getMilestoneTitle mid =
do ms <- milestones <$> ask
return $ milestoneTitle <$> getOne (ms @= mid)
-- | get the milestones sorted by target date
setMilestones :: [Milestone] -> Update BugsState ()
setMilestones ms =
modify $ \bs -> bs { milestones = fromList ms }
-- | get all the 'Bug's with one of the target 'MilestoneId's
bugsForMilestones :: [MilestoneId] -> Query BugsState (IxSet Bug)
bugsForMilestones mids =
do bs <- bugs <$> ask
return $ (bs @+ mids)
-- | return the percentage completion of a 'MilestoneId'
--
-- Will return 'Nothing' if no bugs were found for the 'MilestoneId'
milestoneCompletion :: MilestoneId
-> Query BugsState (Maybe Rational)
milestoneCompletion mid =
do bs <- IxSet.getEQ mid . bugs <$> ask
case IxSet.size bs of
0 -> return Nothing
total -> let closed = IxSet.size (bs @+ [Closed, Invalid, WontFix])
in return $ Just (toRational (closed % total))
$(makeAcidic ''BugsState
[ 'genBugId
, 'getBugById
, 'putBug
, 'allBugIds
, 'newMilestone
, 'getMilestones
, 'getMilestoneTitle
, 'setMilestones
, 'bugsForMilestones
, 'milestoneCompletion
]
)