126 lines
3.3 KiB
Haskell
126 lines
3.3 KiB
Haskell
{-# 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 Streamly.Data.Fold.Prelude qualified as Fold
|
|
import Streamly.Data.Stream.Prelude qualified as Stream
|
|
import Text.Pandoc (PandocError, def, readHtml, runPure, writeMarkdown)
|
|
import Wallabag
|
|
|
|
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
|