module DisTract.Bug.PseudoField
(pseudoFieldDfn,
loadPseudoFields
)
where
import DisTract.Types
import DisTract.Utils
import System.Locale
import Control.Monad
import Control.Monad.Fix
import qualified Data.Map as M
import Data.Time
data PseudoField = Reporter
| Created
deriving (Show, Eq, Ord, Enum)
instance Read PseudoField where
readsPrec _ txt
| reporterTxt == take reporterTxtLen txt
= [(Reporter, drop reporterTxtLen txt)]
| createdTxt == take createdTxtLen txt
= [(Created, drop createdTxtLen txt)]
| otherwise = error $ "Unknown PseudoField name '" ++ txt ++
"'. Known PseudoFields are: " ++ (show [Reporter ..])
where
reporterTxt = "Reporter"
createdTxt = "Created"
reporterTxtLen = length reporterTxt
createdTxtLen = length createdTxt
pseudoFieldDfn :: PseudoField -> Field
pseudoFieldDfn Reporter = pf
where
pf = PseudoField { fieldName = (show Reporter),
fieldValueExtractor = extractReporter
}
extractReporter :: Bug -> IO FieldValue
extractReporter bug = return $ FieldValue reporter pf
where
(BugId _ reporter) = bugId bug
pseudoFieldDfn Created = pf
where
pf = PseudoField { fieldName = (show Created),
fieldValueExtractor = extractCreated
}
extractCreated :: Bug -> IO FieldValue
extractCreated bug = do { calendarTime <- utcToLocalZonedTime createdClock
; return $ FieldValue (created calendarTime) pf
}
where
(BugId createdClock _) = bugId bug
created = formatTime defaultTimeLocale
humanTimeFormat
loadPseudoFields :: Config -> Bug -> IO Bug
loadPseudoFields config = fix (loadPseudoFields' config)
loadPseudoFields' :: Config -> (Bug -> IO Bug) -> (Bug -> IO Bug)
loadPseudoFields' (Config{ fieldDfns = dfns }) recFunc bug
= do { values <- fieldValues
; let bug' = bug { bugFields = values }
; case bug == bug' of
True -> return bug
False -> recFunc bug'
}
where
fieldValues = M.fold runPseudoField (return $ bugFields bug) dfns
runPseudoField :: Field -> IO (M.Map String FieldValue) ->
IO (M.Map String FieldValue)
runPseudoField (Field {}) accM = accM
runPseudoField (PseudoField { fieldName = name,
fieldValueExtractor = extractor
}) accM
= do { acc <- accM
; value <- extractor bug
; return $ M.insert name value acc
}