{- DisTract ------------------------------------------------------\
 |                                                                 |
 | Copyright (c) 2007, Matthew Sackman (matthew@wellquite.org)     |
 |                                                                 |
 | DisTract is freely distributable under the terms of a 3-Clause  |
 | BSD-style license. For details, see the DisTract web site:      |
 |   http://distract.wellquite.org/                                |
 |                                                                 |
 \-----------------------------------------------------------------}

{-# LANGUAGE TemplateHaskell #-}

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')