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,7 +57,16 @@ 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"]
|
[
|
||||||
|
div [class_ "tag_cloud_header mb2"] $
|
||||||
|
ifElseA (isRelated mode)
|
||||||
|
(\_ -> do --RELATED
|
||||||
|
[ button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue mr1 b")
|
||||||
|
, onClick \_ -> Just (TExpanded (not (isExpanded mode)))
|
||||||
|
] [text "Related Tags"]
|
||||||
|
]
|
||||||
|
)
|
||||||
|
(\_ -> do -- NOT RELATED
|
||||||
[ button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue mr1" <> guard (mode == modetop) " b")
|
[ button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue mr1" <> guard (mode == modetop) " b")
|
||||||
, title "show a cloud of your most-used tags"
|
, title "show a cloud of your most-used tags"
|
||||||
, onClick \_ -> Just (TChangeMode modetop)
|
, onClick \_ -> Just (TChangeMode modetop)
|
||||||
|
@ -86,10 +95,10 @@ tagcloudcomponent m' =
|
||||||
, title "show tags with at least 20 bookmarks"
|
, title "show tags with at least 20 bookmarks"
|
||||||
, onClick \_ -> Just (TChangeMode modelb20)
|
, onClick \_ -> Just (TChangeMode modelb20)
|
||||||
] [text "20"]
|
] [text "20"]
|
||||||
, button [ type_ ButtonButton, class_ "pa1 ml2 f7 link silver hover-blue "
|
])
|
||||||
|
<> [button [ type_ ButtonButton, class_ "pa1 ml2 f7 link silver hover-blue "
|
||||||
, onClick \_ -> Just (TExpanded (not (isExpanded mode)))]
|
, onClick \_ -> Just (TExpanded (not (isExpanded mode)))]
|
||||||
[ text (if isExpanded mode then "hide" else "show") ]
|
[ 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