yogsototh/espial
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

add related tags

Browse source
This commit is contained in:
Jon Schoning 2020-02-02 01:55:44 -06:00
parent 8c448e257b
commit 5b1033f63a
10 changed files with 94 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

79
purs/src/Component/TagCloud.purs
View file

@ -20,8 +20,8 @@ import Halogen.HTML (HTML, a, attr, button, div, text)
import Halogen.HTML.Events (onClick)
import Halogen.HTML.Properties (ButtonType(..), href, title, type_)
import Math (log)
import Model (TagCloud, TagCloudModeF(..), isExpanded, setExpanded, tagCloudModeFromF)
import Util (class_, fromNullableStr, whenH)
import Model (TagCloud, TagCloudModeF(..), isExpanded, isRelated, setExpanded, tagCloudModeFromF)
import Util (class_, fromNullableStr, whenH, ifElseA)
data TAction
= TInitialize
@ -57,39 +57,48 @@ tagcloudcomponent m' =
div [class_ "tag_cloud" ] []
render s@{ mode, tagcloud } =
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")
, title "show a cloud of your most-used tags"
, onClick \_ -> Just (TChangeMode modetop)
] [text "Top Tags"]
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue ml2 " <> guard (mode == modelb1) " b")
, title "show all tags"
, onClick \_ -> Just (TChangeMode modelb1)
] [text "all"]
, text "‧"
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb2) " b")
, title "show tags with at least 2 bookmarks"
, onClick \_ -> Just (TChangeMode modelb2)
] [text "2"]
, text "‧"
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb5) " b")
, title "show tags with at least 5 bookmarks"
, onClick \_ -> Just (TChangeMode modelb5)
] [text "5"]
, text "‧"
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb10) " b")
, title "show tags with at least 10 bookmarks"
, 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") ]
]
[
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")
, title "show a cloud of your most-used tags"
, onClick \_ -> Just (TChangeMode modetop)
] [text "Top Tags"]
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue ml2 " <> guard (mode == modelb1) " b")
, title "show all tags"
, onClick \_ -> Just (TChangeMode modelb1)
] [text "all"]
, text "‧"
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb2) " b")
, title "show tags with at least 2 bookmarks"
, onClick \_ -> Just (TChangeMode modelb2)
] [text "2"]
, text "‧"
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb5) " b")
, title "show tags with at least 5 bookmarks"
, onClick \_ -> Just (TChangeMode modelb5)
] [text "5"]
, text "‧"
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb10) " b")
, title "show tags with at least 10 bookmarks"
, 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
let n = fromMaybe 1 (minimum (F.values tagcloud))
m = fromMaybe 1 (maximum (F.values tagcloud))

9
purs/src/Model.purs
View file

@ -5,6 +5,7 @@ import Data.Array (intercalate, singleton)
import Data.Either (hush)
import Data.Maybe (fromMaybe)
import Data.Nullable (Nullable)
import Data.String (Pattern(..), split)
import Foreign (Foreign, readInt, readString, unsafeToForeign)
import Foreign.Object (Object)
import Prelude (class Eq, pure, ($), (<$>))
@ -85,7 +86,7 @@ tagCloudModeToF tagCloudMode =
case tagCloudMode.mode of
"top" -> TagCloudModeTop 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
tagCloudModeFromF :: TagCloudModeF -> TagCloudMode
@ -96,7 +97,7 @@ tagCloudModeFromF (TagCloudModeLowerBound e i) =
tagCloudModeFromF (TagCloudModeRelated e tags) =
{ mode: "related" , value: unsafeToForeign (intercalate " " tags), expanded: e }
tagCloudModeFromF TagCloudModeNone =
{ mode: "related" , value: unsafeToForeign "", expanded: false }
{ mode: "none" , value: unsafeToForeign "", expanded: false }
isExpanded :: TagCloudModeF -> Boolean
isExpanded (TagCloudModeTop e _) = e
@ -104,6 +105,10 @@ isExpanded (TagCloudModeLowerBound e _) = e
isExpanded (TagCloudModeRelated e _) = e
isExpanded TagCloudModeNone = false
isRelated :: TagCloudModeF -> Boolean
isRelated (TagCloudModeRelated _ _) = true
isRelated _ = false
setExpanded :: TagCloudModeF -> Boolean -> TagCloudModeF
setExpanded (TagCloudModeTop e i) e' = TagCloudModeTop e' i
setExpanded (TagCloudModeLowerBound e i) e' = TagCloudModeLowerBound e' i

3
purs/src/Util.purs
View file

@ -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 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 m k = maybe (HH.text "") k m

15
src/Handler/Common.hs
View file

@ -57,8 +57,15 @@ setTagCloudMode = setSessionBS "tagCloudMode" . toStrict . A.encode
getTagCloudMode :: MonadHandler m => Bool -> [Tag] -> m TagCloudMode
getTagCloudMode isowner tags = do
ms <- lookupTagCloudMode
let expanded = maybe False isExpanded ms
pure $
if not isowner then TagCloudModeNone else
if not (null tags)
then fromMaybe (TagCloudModeTop False 200) ms --TagCloudModeRelated False tags
else fromMaybe (TagCloudModeTop False 200) ms
if not isowner
then TagCloudModeNone
else if not (null tags)
then TagCloudModeRelated expanded tags
else case ms of
Nothing -> TagCloudModeTop expanded 200
Just (TagCloudModeRelated e _) -> TagCloudModeTop e 200
Just m -> m

4
src/Handler/User.hs
View file

@ -81,7 +81,7 @@ postUserTagCloudR = do
tc <- runDB $ case mode of
TagCloudModeTop _ n -> tagCountTop userId n
TagCloudModeLowerBound _ n -> tagCountLowerBound userId n
TagCloudModeRelated _ _ -> notFound
TagCloudModeRelated _ tags -> tagCountRelated userId tags
TagCloudModeNone -> notFound
sendStatusJSON ok200 (Map.fromList tc :: Map.Map Text Int)
@ -96,7 +96,7 @@ _updateTagCloudMode mode =
case mode of
TagCloudModeTop _ _ -> setTagCloudMode mode
TagCloudModeLowerBound _ _ -> setTagCloudMode mode
TagCloudModeRelated _ _ -> notFound
TagCloudModeRelated _ _ -> setTagCloudMode mode
TagCloudModeNone -> notFound
bookmarkToRssEntry :: (Entity Bookmark,[Text]) -> FeedEntry Text

25
src/Model.hs
View file

@ -413,6 +413,12 @@ data TagCloudMode
| TagCloudModeNone
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
parseJSON (Object o) =
case lookup "mode" o of
@ -475,6 +481,25 @@ tagCountLowerBound user lowerBound =
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
fileNoteToNote :: UserId -> FileNote -> IO Note

2
static/js/app.min.js vendored
View file

File diff suppressed because one or more lines are too long

BIN
static/js/app.min.js.gz
View file

Binary file not shown.

2
static/js/app.min.js.map
View file

File diff suppressed because one or more lines are too long

BIN
static/js/app.min.js.map.gz
View file

Binary file not shown.