add related tags

purs/src/Component/TagCloud.purs

@@ -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 Model (TagCloud, TagCloudModeF(..), isExpanded, isRelated, setExpanded, tagCloudModeFromF)
-import Util (class_, fromNullableStr, whenH)
+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")
+      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
         let n = fromMaybe 1 (minimum (F.values tagcloud))
             m = fromMaybe 1 (maximum (F.values tagcloud))

purs/src/Model.purs

@@ -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

purs/src/Util.purs

@@ -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
 

src/Handler/Common.hs

@@ -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 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
+
+  

src/Handler/User.hs

@@ -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

src/Model.hs

@@ -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