<commit_before>module Handler.Tags where

import Import

import Model.User
import Model.AnnotatedTag


import Widgets.Tag

import Model.WikiPage

import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T

processCommentTags :: ([AnnotatedTag] -> Handler Html) -> Text -> Text -> CommentId -> Handler Html
processCommentTags go project_handle target comment_id = do
    (_, Entity page_id _) <- getPageInfo project_handle target

    comment_page_id <- runDB $ getCommentPageId comment_id

    when (comment_page_id /= page_id) $ error "wrong page for comment"

    tags <- fmap (map $ (commentTagTag &&& (commentTagUser &&& commentTagCount)) . entityVal) $ runDB $ select $ from $ \ comment_tag -> do
        where_ $ comment_tag ^. CommentTagComment ==. val comment_id
        return comment_tag

    tag_map <- fmap (M.fromList . entityPairs) $ runDB $ select $ from $ \ tag -> do
        where_ $ tag ^. TagId `in_` valList (S.toList $ S.fromList $ map fst tags)
        return tag

    go =<< buildAnnotatedTags tag_map (CommentTagR project_handle target comment_id) tags


processCommentTag :: (AnnotatedTag -> Handler Html) -> Text -> Text -> CommentId -> TagId -> Handler Html
processCommentTag go project_handle target comment_id tag_id = do
    (_, Entity page_id _) <- getPageInfo project_handle target

    comment_page <- runDB $ getCommentPageId comment_id

    when (comment_page /= page_id) $ error "wrong page for comment"

    tags <- fmap (map $ (commentTagTag &&& (commentTagUser &&& commentTagCount)) . entityVal) $ runDB $ select $ from $ \ comment_tag -> do
        where_ $ comment_tag ^. CommentTagComment ==. val comment_id &&. comment_tag ^. CommentTagTag ==. val tag_id
        return comment_tag

    tag_map <- fmap (M.fromList . entityPairs) $ runDB $ select $ from $ \ tag -> do
        where_ $ tag ^. TagId `in_` valList (S.toList $ S.fromList $ map fst tags)
        return tag

    annotated_tags <- buildAnnotatedTags tag_map (CommentTagR project_handle target comment_id) tags

    case annotated_tags of
        [] -> error "That tag has not been applied to this comment."
        [tag] -> go tag
        _ -> error "This should never happen."

renderTags :: [AnnotatedTag] -> Handler Html
renderTags tags = defaultLayout $(widgetFile "tags")


tagBumpForm :: Int -> Form Int
tagBumpForm = renderDivs . areq hiddenField "" . Just


getOldCommentTagR :: Text -> Text -> CommentId -> TagId -> Handler Html
getOldCommentTagR project_handle target comment_id tag_id = redirect $ OldCommentTagR project_handle target comment_id tag_id

getCommentTagR :: Text -> Text -> CommentId -> TagId -> Handler Html
getCommentTagR = processCommentTag $ \ (AnnotatedTag tag url color user_votes) -> do
    let tag_name = tagName $ entityVal tag

    (incForm, _) <- generateFormPost $ tagBumpForm 1
    (decForm, _) <- generateFormPost $ tagBumpForm (-1)

    defaultLayout $(widgetFile "tag")


postOldCommentTagR :: Text -> Text -> CommentId -> TagId -> Handler Html
postOldCommentTagR = postCommentTagR

postCommentTagR :: Text -> Text -> CommentId -> TagId -> Handler Html
postCommentTagR project_handle target comment_id tag_id = do
    user_id <- requireAuthId

    (_, Entity page_id _) <- getPageInfo project_handle target

    comment_page_id <- runDB $ getCommentPageId comment_id

    when (comment_page_id /= page_id) $ error "wrong page for comment"

    direction <- lookupPostParam "direction"

    let delta = case T.unpack <$> direction of
            Just "+" -> 1
            Just "-" -> -1
            Just "\215" -> -1
            Nothing -> error "direction unset"
            Just str -> error $ "unrecognized direction: " ++ str

    runDB $ do
        maybe_comment_tag_entity <- getBy $ UniqueCommentTag comment_id tag_id user_id
        case maybe_comment_tag_entity of
            Nothing -> void $ insert $ CommentTag comment_id tag_id user_id delta
            Just (Entity comment_tag_id comment_tag) -> case commentTagCount comment_tag + delta of
                0 -> delete $ from $ \ ct -> where_ $ ct ^. CommentTagId ==. val comment_tag_id
                x -> void $ update $ \ ct -> do
                    set ct [ CommentTagCount =. val x ]
                    where_ $ ct ^. CommentTagId ==. val comment_tag_id

    setUltDestReferer
    redirectUltDest $ CommentTagR project_handle target comment_id tag_id


getOldCommentTagsR :: Text -> Text -> CommentId -> Handler Html
getOldCommentTagsR project_handle target comment_id = redirect $ CommentTagsR project_handle target comment_id

getCommentTagsR :: Text -> Text -> CommentId -> Handler Html
getCommentTagsR = processCommentTags renderTags

createCommentTagForm :: Form Text
createCommentTagForm = renderBootstrap3 $ areq textField "" Nothing
--    <*> areq hiddenField "" (Just "create")

newCommentTagForm :: [Entity Tag] -> [Entity Tag] -> Form (Maybe [TagId], Maybe [TagId])
newCommentTagForm project_tags other_tags = renderBootstrap3 $ (,)
    -- <$> fmap (\(Entity tag_id tag) -> aopt checkBoxField (tag_id) (tagName tag)) (project_tags <> other_tags)
    <$> aopt (checkboxesFieldList' $ tags project_tags) "Tags already used in this project:" Nothing
    <*> aopt (checkboxesFieldList' $ tags other_tags) "Tags used in other projects:" Nothing
--    <*> areq hiddenField "" (Just "apply")
    where tags = fmap (\(Entity tag_id tag) -> (tagName tag, tag_id))

getOldNewCommentTagR :: Text -> Text -> CommentId -> Handler Html
getOldNewCommentTagR project_handle target comment_id = redirect $ NewCommentTagR project_handle target comment_id

tagList :: ProjectId -> Handler ([Entity Tag], [Entity Tag])
tagList project_id = do
    project_tags :: [Entity Tag] <- runDB $ selectDistinct $ from $ \(tag `InnerJoin` rel `InnerJoin` comment `InnerJoin` page) -> do<commit_msg>adjusted header wording again<commit_after>module Handler.Tags where

import Import

import Model.User
import Model.AnnotatedTag


import Widgets.Tag

import Model.WikiPage

import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T

processCommentTags :: ([AnnotatedTag] -> Handler Html) -> Text -> Text -> CommentId -> Handler Html
processCommentTags go project_handle target comment_id = do
    (_, Entity page_id _) <- getPageInfo project_handle target

    comment_page_id <- runDB $ getCommentPageId comment_id

    when (comment_page_id /= page_id) $ error "wrong page for comment"

    tags <- fmap (map $ (commentTagTag &&& (commentTagUser &&& commentTagCount)) . entityVal) $ runDB $ select $ from $ \ comment_tag -> do
        where_ $ comment_tag ^. CommentTagComment ==. val comment_id
        return comment_tag

    tag_map <- fmap (M.fromList . entityPairs) $ runDB $ select $ from $ \ tag -> do
        where_ $ tag ^. TagId `in_` valList (S.toList $ S.fromList $ map fst tags)
        return tag

    go =<< buildAnnotatedTags tag_map (CommentTagR project_handle target comment_id) tags


processCommentTag :: (AnnotatedTag -> Handler Html) -> Text -> Text -> CommentId -> TagId -> Handler Html
processCommentTag go project_handle target comment_id tag_id = do
    (_, Entity page_id _) <- getPageInfo project_handle target

    comment_page <- runDB $ getCommentPageId comment_id

    when (comment_page /= page_id) $ error "wrong page for comment"

    tags <- fmap (map $ (commentTagTag &&& (commentTagUser &&& commentTagCount)) . entityVal) $ runDB $ select $ from $ \ comment_tag -> do
        where_ $ comment_tag ^. CommentTagComment ==. val comment_id &&. comment_tag ^. CommentTagTag ==. val tag_id
        return comment_tag

    tag_map <- fmap (M.fromList . entityPairs) $ runDB $ select $ from $ \ tag -> do
        where_ $ tag ^. TagId `in_` valList (S.toList $ S.fromList $ map fst tags)
        return tag

    annotated_tags <- buildAnnotatedTags tag_map (CommentTagR project_handle target comment_id) tags

    case annotated_tags of
        [] -> error "That tag has not been applied to this comment."
        [tag] -> go tag
        _ -> error "This should never happen."

renderTags :: [AnnotatedTag] -> Handler Html
renderTags tags = defaultLayout $(widgetFile "tags")


tagBumpForm :: Int -> Form Int
tagBumpForm = renderDivs . areq hiddenField "" . Just


getOldCommentTagR :: Text -> Text -> CommentId -> TagId -> Handler Html
getOldCommentTagR project_handle target comment_id tag_id = redirect $ OldCommentTagR project_handle target comment_id tag_id

getCommentTagR :: Text -> Text -> CommentId -> TagId -> Handler Html
getCommentTagR = processCommentTag $ \ (AnnotatedTag tag url color user_votes) -> do
    let tag_name = tagName $ entityVal tag

    (incForm, _) <- generateFormPost $ tagBumpForm 1
    (decForm, _) <- generateFormPost $ tagBumpForm (-1)

    defaultLayout $(widgetFile "tag")


postOldCommentTagR :: Text -> Text -> CommentId -> TagId -> Handler Html
postOldCommentTagR = postCommentTagR

postCommentTagR :: Text -> Text -> CommentId -> TagId -> Handler Html
postCommentTagR project_handle target comment_id tag_id = do
    user_id <- requireAuthId

    (_, Entity page_id _) <- getPageInfo project_handle target

    comment_page_id <- runDB $ getCommentPageId comment_id

    when (comment_page_id /= page_id) $ error "wrong page for comment"

    direction <- lookupPostParam "direction"

    let delta = case T.unpack <$> direction of
            Just "+" -> 1
            Just "-" -> -1
            Just "\215" -> -1
            Nothing -> error "direction unset"
            Just str -> error $ "unrecognized direction: " ++ str

    runDB $ do
        maybe_comment_tag_entity <- getBy $ UniqueCommentTag comment_id tag_id user_id
        case maybe_comment_tag_entity of
            Nothing -> void $ insert $ CommentTag comment_id tag_id user_id delta
            Just (Entity comment_tag_id comment_tag) -> case commentTagCount comment_tag + delta of
                0 -> delete $ from $ \ ct -> where_ $ ct ^. CommentTagId ==. val comment_tag_id
                x -> void $ update $ \ ct -> do
                    set ct [ CommentTagCount =. val x ]
                    where_ $ ct ^. CommentTagId ==. val comment_tag_id

    setUltDestReferer
    redirectUltDest $ CommentTagR project_handle target comment_id tag_id


getOldCommentTagsR :: Text -> Text -> CommentId -> Handler Html
getOldCommentTagsR project_handle target comment_id = redirect $ CommentTagsR project_handle target comment_id

getCommentTagsR :: Text -> Text -> CommentId -> Handler Html
getCommentTagsR = processCommentTags renderTags

createCommentTagForm :: Form Text
createCommentTagForm = renderBootstrap3 $ areq textField "" Nothing
--    <*> areq hiddenField "" (Just "create")

newCommentTagForm :: [Entity Tag] -> [Entity Tag] -> Form (Maybe [TagId], Maybe [TagId])
newCommentTagForm project_tags other_tags = renderBootstrap3 $ (,)
    -- <$> fmap (\(Entity tag_id tag) -> aopt checkBoxField (tag_id) (tagName tag)) (project_tags <> other_tags)
    <$> aopt (checkboxesFieldList' $ tags project_tags) "Tags used elsewhere in this project:" Nothing
    <*> aopt (checkboxesFieldList' $ tags other_tags) "Tags used in other projects:" Nothing
--    <*> areq hiddenField "" (Just "apply")
    where tags = fmap (\(Entity tag_id tag) -> (tagName tag, tag_id))

getOldNewCommentTagR :: Text -> Text -> CommentId -> Handler Html
getOldNewCommentTagR project_handle target comment_id = redirect $ NewCommentTagR project_handle target comment_id

tagList :: ProjectId -> Handler ([Entity Tag], [Entity Tag])
tagList project_id = do
    project_tags :: [Entity Tag] <- runDB $ selectDistinct $ from $ \(tag `InnerJoin` rel `InnerJoin` comment `InnerJoin` page) -> do
{'fraction_non_alphanumeric': 0.09741482622838556, 'fraction_numerical': 0.0018832391713747645, 'mean_word_length': 3.3078908554572273, 'pattern_counts': {'":': 0, '<': 55, '<?xml version=': 0, '>': 143, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2829293', 'n_tokens_mistral': 3522, 'n_tokens_neox': 3357, 'n_words': 1086}