We are no longer offering accounts on this server. Consider https://gitlab.freedesktop.org/ as a place to host projects.

Commit 58889ffa authored by wolftune's avatar wolftune

Merge github.com:strbean/snowdrift into newuserstuff

parents a1d75992 da4cae73
......@@ -126,10 +126,12 @@ createCommentTagForm = renderBootstrap3 $ areq textField "" Nothing
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
<$> aopt (tagCloudField $ tags project_tags) "Tags used elsewhere in this project:" Nothing
<*> aopt (tagCloudField $ tags other_tags) "Tags used in other projects:" Nothing
-- <*> areq hiddenField "" (Just "apply")
where tags = fmap (\(Entity tag_id tag) -> (tagName tag, tag_id))
tagCloudField = checkboxesFieldList' $ (\(PersistInt64 a) -> show a) . unKey
getOldNewCommentTagR :: Text -> Text -> CommentId -> Handler Html
getOldNewCommentTagR project_handle target comment_id = redirect $ NewCommentTagR project_handle target comment_id
......@@ -255,8 +257,16 @@ postNewCommentTagR create_tag project_handle target comment_id = do
FormMissing -> error "form missing"
FormFailure es -> formFailure es
else do
comment_tags <- fmap (map 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 commentTagTag comment_tags)
return tag
let filter_tags = filter (\(Entity t _) -> not $ M.member t tag_map)
(project_tags, other_tags) <- tagList project_id
((result_apply, _), _) <- runFormPost $ newCommentTagForm project_tags other_tags
((result_apply, _), _) <- runFormPost $ newCommentTagForm (filter_tags project_tags) (filter_tags other_tags)
case result_apply of
FormSuccess (mproject_tag_ids, mother_tag_ids) -> do
let project_tag_ids = fromMaybe [] mproject_tag_ids
......
......@@ -172,9 +172,22 @@ renderBootstrap3 aform fragment = do
|]
return (res, widget)
checkboxesFieldList' :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)]
optionsPairs' :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
=> (a -> String) -> [(msg, a)] -> m (OptionList a)
optionsPairs' mk_external opts = do
mr <- getMessageRender
let mkOption (display, internal) =
Option { optionDisplay = mr display
, optionInternalValue = internal
, optionExternalValue = pack' $ mk_external internal
}
return $ mkOptionList (map mkOption opts)
checkboxesFieldList' :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> (a -> String)
-> [(msg, a)]
-> Field (HandlerT site IO) [a]
checkboxesFieldList' = checkboxesField' . optionsPairs
checkboxesFieldList' mk_external = checkboxesField' . (optionsPairs' mk_external)
checkboxesField' :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment