add related tags
This commit is contained in:
parent
8c448e257b
commit
5b1033f63a
|
@ -20,8 +20,8 @@ import Halogen.HTML (HTML, a, attr, button, div, text)
|
||||||
import Halogen.HTML.Events (onClick)
|
import Halogen.HTML.Events (onClick)
|
||||||
import Halogen.HTML.Properties (ButtonType(..), href, title, type_)
|
import Halogen.HTML.Properties (ButtonType(..), href, title, type_)
|
||||||
import Math (log)
|
import Math (log)
|
||||||
import Model (TagCloud, TagCloudModeF(..), isExpanded, setExpanded, tagCloudModeFromF)
|
import Model (TagCloud, TagCloudModeF(..), isExpanded, isRelated, setExpanded, tagCloudModeFromF)
|
||||||
import Util (class_, fromNullableStr, whenH)
|
import Util (class_, fromNullableStr, whenH, ifElseA)
|
||||||
|
|
||||||
data TAction
|
data TAction
|
||||||
= TInitialize
|
= TInitialize
|
||||||
|
@ -57,39 +57,48 @@ tagcloudcomponent m' =
|
||||||
div [class_ "tag_cloud" ] []
|
div [class_ "tag_cloud" ] []
|
||||||
render s@{ mode, tagcloud } =
|
render s@{ mode, tagcloud } =
|
||||||
div [class_ "tag_cloud mv3" ]
|
div [class_ "tag_cloud mv3" ]
|
||||||
[ div [class_ "tag_cloud_header mb2"]
|
[
|
||||||
[ button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue mr1" <> guard (mode == modetop) " b")
|
div [class_ "tag_cloud_header mb2"] $
|
||||||
, title "show a cloud of your most-used tags"
|
ifElseA (isRelated mode)
|
||||||
, onClick \_ -> Just (TChangeMode modetop)
|
(\_ -> do --RELATED
|
||||||
] [text "Top Tags"]
|
[ button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue mr1 b")
|
||||||
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue ml2 " <> guard (mode == modelb1) " b")
|
, onClick \_ -> Just (TExpanded (not (isExpanded mode)))
|
||||||
, title "show all tags"
|
] [text "Related Tags"]
|
||||||
, onClick \_ -> Just (TChangeMode modelb1)
|
]
|
||||||
] [text "all"]
|
)
|
||||||
, text "‧"
|
(\_ -> do -- NOT RELATED
|
||||||
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb2) " b")
|
[ button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue mr1" <> guard (mode == modetop) " b")
|
||||||
, title "show tags with at least 2 bookmarks"
|
, title "show a cloud of your most-used tags"
|
||||||
, onClick \_ -> Just (TChangeMode modelb2)
|
, onClick \_ -> Just (TChangeMode modetop)
|
||||||
] [text "2"]
|
] [text "Top Tags"]
|
||||||
, text "‧"
|
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue ml2 " <> guard (mode == modelb1) " b")
|
||||||
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb5) " b")
|
, title "show all tags"
|
||||||
, title "show tags with at least 5 bookmarks"
|
, onClick \_ -> Just (TChangeMode modelb1)
|
||||||
, onClick \_ -> Just (TChangeMode modelb5)
|
] [text "all"]
|
||||||
] [text "5"]
|
, text "‧"
|
||||||
, text "‧"
|
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb2) " b")
|
||||||
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb10) " b")
|
, title "show tags with at least 2 bookmarks"
|
||||||
, title "show tags with at least 10 bookmarks"
|
, onClick \_ -> Just (TChangeMode modelb2)
|
||||||
, onClick \_ -> Just (TChangeMode modelb10)
|
] [text "2"]
|
||||||
] [text "10"]
|
, text "‧"
|
||||||
, text "‧"
|
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb5) " b")
|
||||||
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb20) " b")
|
, title "show tags with at least 5 bookmarks"
|
||||||
, title "show tags with at least 20 bookmarks"
|
, onClick \_ -> Just (TChangeMode modelb5)
|
||||||
, onClick \_ -> Just (TChangeMode modelb20)
|
] [text "5"]
|
||||||
] [text "20"]
|
, text "‧"
|
||||||
, button [ type_ ButtonButton, class_ "pa1 ml2 f7 link silver hover-blue "
|
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb10) " b")
|
||||||
, onClick \_ -> Just (TExpanded (not (isExpanded mode)))]
|
, title "show tags with at least 10 bookmarks"
|
||||||
[ text (if isExpanded mode then "hide" else "show") ]
|
, onClick \_ -> Just (TChangeMode modelb10)
|
||||||
]
|
] [text "10"]
|
||||||
|
, text "‧"
|
||||||
|
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb20) " b")
|
||||||
|
, title "show tags with at least 20 bookmarks"
|
||||||
|
, onClick \_ -> Just (TChangeMode modelb20)
|
||||||
|
] [text "20"]
|
||||||
|
])
|
||||||
|
<> [button [ type_ ButtonButton, class_ "pa1 ml2 f7 link silver hover-blue "
|
||||||
|
, onClick \_ -> Just (TExpanded (not (isExpanded mode)))]
|
||||||
|
[ text (if isExpanded mode then "hide" else "show") ]]
|
||||||
, whenH (isExpanded mode) $ \_ -> do
|
, whenH (isExpanded mode) $ \_ -> do
|
||||||
let n = fromMaybe 1 (minimum (F.values tagcloud))
|
let n = fromMaybe 1 (minimum (F.values tagcloud))
|
||||||
m = fromMaybe 1 (maximum (F.values tagcloud))
|
m = fromMaybe 1 (maximum (F.values tagcloud))
|
||||||
|
|
|
@ -5,6 +5,7 @@ import Data.Array (intercalate, singleton)
|
||||||
import Data.Either (hush)
|
import Data.Either (hush)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Nullable (Nullable)
|
import Data.Nullable (Nullable)
|
||||||
|
import Data.String (Pattern(..), split)
|
||||||
import Foreign (Foreign, readInt, readString, unsafeToForeign)
|
import Foreign (Foreign, readInt, readString, unsafeToForeign)
|
||||||
import Foreign.Object (Object)
|
import Foreign.Object (Object)
|
||||||
import Prelude (class Eq, pure, ($), (<$>))
|
import Prelude (class Eq, pure, ($), (<$>))
|
||||||
|
@ -85,7 +86,7 @@ tagCloudModeToF tagCloudMode =
|
||||||
case tagCloudMode.mode of
|
case tagCloudMode.mode of
|
||||||
"top" -> TagCloudModeTop tagCloudMode.expanded <$> readInt tagCloudMode.value
|
"top" -> TagCloudModeTop tagCloudMode.expanded <$> readInt tagCloudMode.value
|
||||||
"lowerBound" -> TagCloudModeLowerBound tagCloudMode.expanded <$> readInt tagCloudMode.value
|
"lowerBound" -> TagCloudModeLowerBound tagCloudMode.expanded <$> readInt tagCloudMode.value
|
||||||
"related" -> (\s -> TagCloudModeRelated tagCloudMode.expanded (singleton s)) <$> readString tagCloudMode.value
|
"related" -> (\s -> TagCloudModeRelated tagCloudMode.expanded (split (Pattern " ") s)) <$> readString tagCloudMode.value
|
||||||
_ -> pure TagCloudModeNone
|
_ -> pure TagCloudModeNone
|
||||||
|
|
||||||
tagCloudModeFromF :: TagCloudModeF -> TagCloudMode
|
tagCloudModeFromF :: TagCloudModeF -> TagCloudMode
|
||||||
|
@ -96,7 +97,7 @@ tagCloudModeFromF (TagCloudModeLowerBound e i) =
|
||||||
tagCloudModeFromF (TagCloudModeRelated e tags) =
|
tagCloudModeFromF (TagCloudModeRelated e tags) =
|
||||||
{ mode: "related" , value: unsafeToForeign (intercalate " " tags), expanded: e }
|
{ mode: "related" , value: unsafeToForeign (intercalate " " tags), expanded: e }
|
||||||
tagCloudModeFromF TagCloudModeNone =
|
tagCloudModeFromF TagCloudModeNone =
|
||||||
{ mode: "related" , value: unsafeToForeign "", expanded: false }
|
{ mode: "none" , value: unsafeToForeign "", expanded: false }
|
||||||
|
|
||||||
isExpanded :: TagCloudModeF -> Boolean
|
isExpanded :: TagCloudModeF -> Boolean
|
||||||
isExpanded (TagCloudModeTop e _) = e
|
isExpanded (TagCloudModeTop e _) = e
|
||||||
|
@ -104,6 +105,10 @@ isExpanded (TagCloudModeLowerBound e _) = e
|
||||||
isExpanded (TagCloudModeRelated e _) = e
|
isExpanded (TagCloudModeRelated e _) = e
|
||||||
isExpanded TagCloudModeNone = false
|
isExpanded TagCloudModeNone = false
|
||||||
|
|
||||||
|
isRelated :: TagCloudModeF -> Boolean
|
||||||
|
isRelated (TagCloudModeRelated _ _) = true
|
||||||
|
isRelated _ = false
|
||||||
|
|
||||||
setExpanded :: TagCloudModeF -> Boolean -> TagCloudModeF
|
setExpanded :: TagCloudModeF -> Boolean -> TagCloudModeF
|
||||||
setExpanded (TagCloudModeTop e i) e' = TagCloudModeTop e' i
|
setExpanded (TagCloudModeTop e i) e' = TagCloudModeTop e' i
|
||||||
setExpanded (TagCloudModeLowerBound e i) e' = TagCloudModeLowerBound e' i
|
setExpanded (TagCloudModeLowerBound e i) e' = TagCloudModeLowerBound e' i
|
||||||
|
|
|
@ -135,6 +135,9 @@ whenA b k = if b then k unit else []
|
||||||
ifElseH :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> (Unit -> HH.HTML p i) -> HH.HTML p i
|
ifElseH :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> (Unit -> HH.HTML p i) -> HH.HTML p i
|
||||||
ifElseH b f k = if b then f unit else k unit
|
ifElseH b f k = if b then f unit else k unit
|
||||||
|
|
||||||
|
ifElseA :: forall t. Boolean -> (Unit -> Array t) -> (Unit -> Array t) -> Array t
|
||||||
|
ifElseA b f k = if b then f unit else k unit
|
||||||
|
|
||||||
maybeH :: forall a p i. Maybe a -> (a -> HH.HTML p i) -> HH.HTML p i
|
maybeH :: forall a p i. Maybe a -> (a -> HH.HTML p i) -> HH.HTML p i
|
||||||
maybeH m k = maybe (HH.text "") k m
|
maybeH m k = maybe (HH.text "") k m
|
||||||
|
|
||||||
|
|
|
@ -57,8 +57,15 @@ setTagCloudMode = setSessionBS "tagCloudMode" . toStrict . A.encode
|
||||||
getTagCloudMode :: MonadHandler m => Bool -> [Tag] -> m TagCloudMode
|
getTagCloudMode :: MonadHandler m => Bool -> [Tag] -> m TagCloudMode
|
||||||
getTagCloudMode isowner tags = do
|
getTagCloudMode isowner tags = do
|
||||||
ms <- lookupTagCloudMode
|
ms <- lookupTagCloudMode
|
||||||
|
let expanded = maybe False isExpanded ms
|
||||||
pure $
|
pure $
|
||||||
if not isowner then TagCloudModeNone else
|
if not isowner
|
||||||
if not (null tags)
|
then TagCloudModeNone
|
||||||
then fromMaybe (TagCloudModeTop False 200) ms --TagCloudModeRelated False tags
|
else if not (null tags)
|
||||||
else fromMaybe (TagCloudModeTop False 200) ms
|
then TagCloudModeRelated expanded tags
|
||||||
|
else case ms of
|
||||||
|
Nothing -> TagCloudModeTop expanded 200
|
||||||
|
Just (TagCloudModeRelated e _) -> TagCloudModeTop e 200
|
||||||
|
Just m -> m
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -81,7 +81,7 @@ postUserTagCloudR = do
|
||||||
tc <- runDB $ case mode of
|
tc <- runDB $ case mode of
|
||||||
TagCloudModeTop _ n -> tagCountTop userId n
|
TagCloudModeTop _ n -> tagCountTop userId n
|
||||||
TagCloudModeLowerBound _ n -> tagCountLowerBound userId n
|
TagCloudModeLowerBound _ n -> tagCountLowerBound userId n
|
||||||
TagCloudModeRelated _ _ -> notFound
|
TagCloudModeRelated _ tags -> tagCountRelated userId tags
|
||||||
TagCloudModeNone -> notFound
|
TagCloudModeNone -> notFound
|
||||||
sendStatusJSON ok200 (Map.fromList tc :: Map.Map Text Int)
|
sendStatusJSON ok200 (Map.fromList tc :: Map.Map Text Int)
|
||||||
|
|
||||||
|
@ -96,7 +96,7 @@ _updateTagCloudMode mode =
|
||||||
case mode of
|
case mode of
|
||||||
TagCloudModeTop _ _ -> setTagCloudMode mode
|
TagCloudModeTop _ _ -> setTagCloudMode mode
|
||||||
TagCloudModeLowerBound _ _ -> setTagCloudMode mode
|
TagCloudModeLowerBound _ _ -> setTagCloudMode mode
|
||||||
TagCloudModeRelated _ _ -> notFound
|
TagCloudModeRelated _ _ -> setTagCloudMode mode
|
||||||
TagCloudModeNone -> notFound
|
TagCloudModeNone -> notFound
|
||||||
|
|
||||||
bookmarkToRssEntry :: (Entity Bookmark,[Text]) -> FeedEntry Text
|
bookmarkToRssEntry :: (Entity Bookmark,[Text]) -> FeedEntry Text
|
||||||
|
|
25
src/Model.hs
25
src/Model.hs
|
@ -413,6 +413,12 @@ data TagCloudMode
|
||||||
| TagCloudModeNone
|
| TagCloudModeNone
|
||||||
deriving (Show, Eq, Read, Generic)
|
deriving (Show, Eq, Read, Generic)
|
||||||
|
|
||||||
|
isExpanded :: TagCloudMode -> Bool
|
||||||
|
isExpanded (TagCloudModeTop e _) = e
|
||||||
|
isExpanded (TagCloudModeLowerBound e _) = e
|
||||||
|
isExpanded (TagCloudModeRelated e _) = e
|
||||||
|
isExpanded TagCloudModeNone = False
|
||||||
|
|
||||||
instance FromJSON TagCloudMode where
|
instance FromJSON TagCloudMode where
|
||||||
parseJSON (Object o) =
|
parseJSON (Object o) =
|
||||||
case lookup "mode" o of
|
case lookup "mode" o of
|
||||||
|
@ -475,6 +481,25 @@ tagCountLowerBound user lowerBound =
|
||||||
pure $ (t ^. BookmarkTagTag, countRows')
|
pure $ (t ^. BookmarkTagTag, countRows')
|
||||||
)
|
)
|
||||||
|
|
||||||
|
tagCountRelated :: Key User -> [Tag] -> DB [(Text, Int)]
|
||||||
|
tagCountRelated user tags =
|
||||||
|
fmap (\(tname, tcount) -> (E.unValue tname, E.unValue tcount)) <$>
|
||||||
|
( select $
|
||||||
|
from $ \t -> do
|
||||||
|
where_ $
|
||||||
|
foldl (\expr tag ->
|
||||||
|
expr &&. (exists $
|
||||||
|
from $ \u ->
|
||||||
|
where_ (u ^. BookmarkTagBookmarkId E.==. t ^. BookmarkTagBookmarkId &&.
|
||||||
|
(u ^. BookmarkTagTag `E.like` val tag))))
|
||||||
|
(t ^. BookmarkTagUserId E.==. val user)
|
||||||
|
tags
|
||||||
|
E.groupBy (E.lower_ $ t ^. BookmarkTagTag)
|
||||||
|
let countRows' = E.countRows
|
||||||
|
E.orderBy [E.asc $ E.lower_ $ (t ^. BookmarkTagTag)]
|
||||||
|
pure $ (t ^. BookmarkTagTag, countRows')
|
||||||
|
)
|
||||||
|
|
||||||
-- Notes
|
-- Notes
|
||||||
|
|
||||||
fileNoteToNote :: UserId -> FileNote -> IO Note
|
fileNoteToNote :: UserId -> FileNote -> IO Note
|
||||||
|
|
2
static/js/app.min.js
vendored
2
static/js/app.min.js
vendored
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
Loading…
Reference in a new issue