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)
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
initialBugsState :: BugsState
initialBugsState = BugsState
{ nextBugId = BugId 1
, bugs = empty
, nextMilestoneId = MilestoneId 1
, milestones = empty
}
genBugId :: Update BugsState BugId
genBugId =
do bs@BugsState{..} <- get
put $ bs { nextBugId = BugId $ succ $ unBugId $ nextBugId }
return nextBugId
getBugById :: BugId -> Query BugsState (Maybe Bug)
getBugById bid =
do BugsState{..} <- ask
return $ getOne (bugs @= bid)
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)
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
getMilestones :: Query BugsState [Milestone]
getMilestones =
do ms <- milestones <$> ask
return (toList ms)
getMilestoneIds :: Query BugsState [MilestoneId]
getMilestoneIds =
do ms <- milestones <$> ask
return (map milestoneId $ toList ms)
getMilestoneTitle :: MilestoneId -> Query BugsState (Maybe Text)
getMilestoneTitle mid =
do ms <- milestones <$> ask
return $ milestoneTitle <$> getOne (ms @= mid)
setMilestones :: [Milestone] -> Update BugsState ()
setMilestones ms =
modify $ \bs -> bs { milestones = fromList ms }
bugsForMilestones :: [MilestoneId] -> Query BugsState (IxSet Bug)
bugsForMilestones mids =
do bs <- bugs <$> ask
return $ (bs @+ mids)
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
]
)