Initial commit

src/MyLib.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+module MyLib (defaultMain, test) where
+
+import AI
+import Control.Lens (over, re, strict, view, (&), (.~), (^.))
+import Data.Aeson (decode, encode)
+import Data.Either (fromRight)
+import Data.Maybe (fromMaybe)
+import Data.Set qualified as S
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Strict.Lens (utf8)
+import Katip qualified as K
+import M
+import Options.Generic (Generic, ParseRecord (..), getRecord, unHelpful, type (<?>))
+import Text.Pandoc (PandocError, def, readHtml, runPure, writeMarkdown)
+import Wallabag
+import qualified Streamly.Data.Fold.Prelude as Fold
+import qualified Streamly.Data.Stream.Prelude as Stream
+
+data Options = Options
+  { full :: Bool <?> "Go through all the entries",
+    verbose :: Bool
+  }
+  deriving (Generic, Show)
+
+instance ParseRecord Options
+
+tooShort :: Entry -> Bool
+tooShort e = length (T.lines (view content e)) < 5
+
+missingTags :: Entry -> Bool
+missingTags Entry {_entryTags = []} = True
+missingTags Entry {} = False
+
+htmlToMarkdown :: Text -> Either PandocError Text
+htmlToMarkdown input = runPure $ do
+  doc <- readHtml def input
+  writeMarkdown def doc
+
+processableEntries :: (Monad m) => Stream.Stream m Entry -> Stream.Stream m Entry
+processableEntries = Stream.filter (not . tooShort) . Stream.filter missingTags
+
+markdownEntry :: (Monad m) => Stream.Stream m Entry -> Stream.Stream m Entry
+markdownEntry = fmap (over content (\x -> fromRight x $ htmlToMarkdown x))
+
+run :: K.Severity -> Scan -> IO ()
+run sev scan = initialS sev $ \s -> do
+  runM s $ do
+    Stream.fold Fold.drain $
+      sourceEntries scan & markdownEntry & processableEntries &
+      Stream.parMapM (Stream.maxThreads 5) doWork
+
+test :: IO ()
+test = run K.DebugS Quick
+
+suggestTags :: Text -> M [Text]
+suggestTags txt = do
+  c <- view creds
+  let prompt =
+        T.unlines
+          [ "Assign tags for the given article from this set of tags: " <> encode hardLabels ^. strict . utf8,
+            "Respond in JSON. Respond only in JSON, nothing more",
+            "Example response: [\"Politics\"]",
+            "",
+            "The article contents:",
+            txt
+          ]
+  unparsed <- completions c prompt
+  pure $ maybe [] parseTags unparsed
+  where
+    parseTags :: Text -> [Text]
+    parseTags = fromMaybe [] . decode . view (re utf8 . re strict) . T.dropWhileEnd (/= ']') . T.dropWhile (/= '[')
+
+suggestTagsForEntry :: Entry -> M Entry
+suggestTagsForEntry e = do
+  newTags <- suggestTags (e ^. content)
+  pure $ e & tags .~ newTags
+
+doWork :: Entry -> M ()
+doWork e = do
+  entryWithTags <- suggestTagsForEntry e
+  applyTags entryWithTags
+
+hardLabels :: S.Set Text
+hardLabels =
+  S.fromList
+    [ "Politics",
+      "Writing",
+      "Nature",
+      "Camping",
+      "Hiking",
+      "Economics",
+      "Climate",
+      "Software",
+      "Programming",
+      "Maths",
+      "Animals",
+      "Health",
+      "Sexuality",
+      "Relationships",
+      "Media and television",
+      "Social media",
+      "Gaming",
+      "Plants",
+      "Gadgets",
+      "AI"
+    ]
+
+defaultMain :: IO ()
+defaultMain = do
+  opts <- getRecord "Wallabag tagger"
+  let sev = severity opts
+  if unHelpful $ full opts
+    then run sev Full
+    else run sev Quick
+  where
+    severity Options {verbose = True} = K.DebugS
+    severity _ = K.InfoS