module DisTract.HTML.BugList
(formatBugList
)
where
import Text.HTML.Chunks
import DisTract.Types
import DisTract.IOUtils
import DisTract.Utils
import DisTract.Layout
import Data.List
import Data.Maybe
import Data.Time
import qualified Data.Map as M
import qualified JSON as J
import System.FilePath
$(chunksFromFile "./html/templates/bugList.html")
formatBugList :: Config -> IO ()
formatBugList config
= do { time <- (getZonedTime >>= formatTimeHuman)
; bugsList <- makeBugsList config
; let htmlStr = format $ Chunk_page { page_base = baseDir config,
page_bugsList = bugsList,
page_generation_time = time,
page_version = version
}
; writeFile path htmlStr
; return ()
}
where
version = (packageName config) ++ " version " ++ (packageVersion config)
path = combine (htmlDir (baseDir config)) fileName
fileName = addExtension "list" "html"
makeBugsList :: Config -> IO String
makeBugsList config
= do { bugsM <- loadAll config
; let bugsListTxt = buildBugsListTxt config (catMaybes bugsM)
; let fieldsListTxt = buildFieldsListTxt config
; return (fieldsListTxt ++ bugsListTxt)
}
buildFieldsListTxt :: Config -> String
buildFieldsListTxt Config { fieldDfns = fields }
= "fieldsList = " ++ J.stringify (J.Array fieldsJSON) ++ ";\n\n"
where
fieldsJSON = (J.String "BugId"):
(map fieldNameToJSON . sort . M.elems $ fields)
fieldNameToJSON :: Field -> J.Value
fieldNameToJSON = J.String . fieldName
buildBugsListTxt :: Config -> [Bug] -> String
buildBugsListTxt config bugs
= "bugsList = " ++ J.stringify (J.Array orderingsJSON) ++ ";\n\n"
where
orderingsMap = createOrderingsMap bugs
orderings = addOrderings (M.elems . fieldDfns $ config) bugs orderingsMap
orderingsJSON = map convertOrderingsToJSON . M.elems $ orderings
convertOrderingsToJSON :: M.Map String (String, Int)
-> J.Value
convertOrderingsToJSON obj = J.Object obj'
where
obj' = M.foldWithKey toJSON M.empty obj
toJSON :: String -> (String, Int) -> M.Map String J.Value ->
M.Map String J.Value
toJSON name (val, num) acc = acc''
where
acc' = M.insert name (J.String val) acc
acc'' = M.insert (name ++ "_order") (J.Int num) acc'
addOrderings :: [Field] -> [Bug] -> M.Map BugId (M.Map String (String, Int)) ->
M.Map BugId (M.Map String (String, Int))
addOrderings [] bugs acc = acc'
where
name = "BugId"
acc' = foldr (updateBugIdMap name) acc sortedTxt
sorted = sortBugsByBugId bugs
sortedTxt = zipWith takeValueStringBugId sorted [1..]
takeValueStringBugId :: Bug -> Int -> (BugId, String, Int)
takeValueStringBugId Bug { bugId = bugId } num
= (bugId, (show bugId), num)
addOrderings (field:fields) bugs acc = addOrderings fields bugs acc'
where
name = fieldName field
acc' = foldr (updateBugIdMap name) acc sortedTxt
sorted = sortBugsByField field bugs
sortedTxt = zipWith takeValueString sorted [1..]
takeValueString :: Bug -> Int -> (BugId, String, Int)
takeValueString bug num = ((bugId bug), value, num)
where
(FieldValue value _) = selectField field bug
updateBugIdMap :: String -> (BugId, String, Int) ->
M.Map BugId (M.Map String (String, Int)) ->
M.Map BugId (M.Map String (String, Int))
updateBugIdMap name (bugId, value, num) obj
= M.adjust (M.insert name (value,num)) bugId obj
createOrderingsMap :: [Bug] -> M.Map BugId (M.Map String (String, Int))
createOrderingsMap = foldr insertBugIdMap M.empty
where
insertBugIdMap :: Bug -> M.Map BugId (M.Map String (String, Int)) ->
M.Map BugId (M.Map String (String, Int))
insertBugIdMap bug obj = M.insert (bugId bug) M.empty obj
sortBugsByBugId :: [Bug] -> [Bug]
sortBugsByBugId = sortBy bugIdSorter
where
bugIdSorter :: Bug -> Bug -> Ordering
bugIdSorter b1 b2 = compare (bugId b1) (bugId b2)
sortBugsByField :: Field -> [Bug] -> [Bug]
sortBugsByField field bugs
= sortBy (sorter fieldSelector) bugs
where
fieldSelector = selectField field
sorter :: (Ord a) => (Bug -> a) -> Bug -> Bug -> Ordering
sorter selector b1 b2 = compare (selector b1) (selector b2)
selectField :: Field -> Bug -> FieldValue
selectField field bug = fieldValue
where
name = fieldName field
fields = bugFields bug
(Just fv@(FieldValue _ field')) = M.lookup name fields
fieldValue = case field == field' of
True -> fv
False -> error $ "Expecting field " ++ (show field) ++
" in bug " ++ (show bug) ++
" bug found field " ++ (show field')