feat: monthly digest

Signed-off-by: Tsung-Ju Lii <usefulalgorithm@gmail.com>

Author: usefulalgorithm

scripts/monthly_rewind/app/Main.hs

@@ -0,0 +1,108 @@
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import           Data.List                  (sortBy)
+import           Data.List.Split            (splitOn)
+import           Data.Maybe                 (catMaybes)
+import           Data.Ord                   (Down (Down), comparing)
+import qualified Data.Text                  as T
+import           Data.Time                  (fromGregorian)
+import           Data.Time.Calendar         (Day, addGregorianMonthsClip,
+                                             toGregorian)
+import           Data.Time.Clock            (getCurrentTime, utctDay)
+import           System.Directory           (listDirectory)
+import           Text.Pandoc                (Inline (Space, Str),
+                                             Pandoc (Pandoc), readMarkdown,
+                                             runIO)
+import           Text.Pandoc.Options
+import           Text.Pandoc.Writers.Shared (lookupMetaInlines)
+
+parseDateFromString :: String -> Day
+parseDateFromString filePath =
+    let [year, month, day] = map read . take 3 . splitOn "-" $ filePath
+    in fromGregorian (toInteger year) month day
+
+data AlbumPostSummary = AlbumPostSummary {
+    score    :: Float,
+    released :: Day,
+    title    :: String
+} deriving (Eq, Ord)
+
+instance Show AlbumPostSummary where
+    show summary =
+        title summary ++ " (score: " ++ show (score summary) ++ ", release date: " ++ show (released summary) ++ ")"
+
+getAlbumPostSummary :: String -> IO (Maybe AlbumPostSummary)
+getAlbumPostSummary filePath = do
+    md <- T.pack <$> readFile ("posts/" ++ filePath)
+    pandoc <- runIO $
+        readMarkdown
+        (def {
+            readerStandalone = True,
+            readerExtensions =
+            enableExtension Ext_yaml_metadata_block (readerExtensions def) } )
+        md
+    case pandoc of
+        Left _ -> return Nothing
+        Right (Pandoc meta _) -> do
+            if not . hasMusicTag $ lookupMetaInlines "tags" meta
+            then do
+                return Nothing
+            else return $ Just AlbumPostSummary {
+                released = parseDateFromString (getValue "released"),
+                score = read (getValue "score") :: Float,
+                title = getValue "title"
+            }
+            where
+                hasMusicTag inlines = any (`elem` inlines) [Str "music", Str "music,"]
+                getValue key = T.unpack . T.concat . map stringify . lookupMetaInlines key $ meta
+                stringify (Str value) = value
+                stringify Space       = " "
+                stringify _           = ""
+
+data What = Good | Wack | Ok deriving (Eq)
+instance Show What where
+    show Good = "====== good ======"
+    show Wack = "====== wack ======"
+    show Ok   = "======= ok ======="
+
+data Bucket = Bucket {
+    summaries :: [AlbumPostSummary],
+    what      :: What
+}
+
+
+summariesToBuckets :: [AlbumPostSummary] -> ([AlbumPostSummary], [AlbumPostSummary], [AlbumPostSummary])
+summariesToBuckets = foldr f ([], [], [])
+    where
+        f s (hi, mid, lo)  | score s >= 8.0 = (s:hi, mid, lo)
+        f s (hi, mid, lo)  | score s < 6.0 = (hi, mid, s:lo)
+        f s (hi, mid, lo)   = (hi, s:mid, lo)
+
+printBucket :: Bucket -> IO ()
+printBucket bucket =
+    if null (summaries bucket)
+    then return ()
+    else do
+        putStrLn ""
+        print (what bucket)
+        mapM_ print $ summaries bucket
+        putStrLn ""
+
+main :: IO ()
+main = do
+    files <- listDirectory "posts/"
+    (year, month, _) <- toGregorian . utctDay <$> getCurrentTime
+    let endDate = fromGregorian year month 1
+        startDate = addGregorianMonthsClip (-1) endDate
+        filteredFiles = filter ((\fileDate -> fileDate >= startDate && fileDate < endDate) . parseDateFromString) files
+    allSummaries <- sortBy (comparing Down) . catMaybes <$> mapM getAlbumPostSummary filteredFiles
+    let (hiScores, midScores, lowScores) = summariesToBuckets allSummaries
+    mapM_ printBucket
+        [ Bucket hiScores Good
+        , Bucket midScores Ok
+        , Bucket lowScores Wack
+        ]
+    -- TODO: send this as an email? save it as a new post? just run it every month and then collect it somehow?

scripts/monthly_rewind/hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+  cabal:

scripts/monthly_rewind/monthly-rewind.cabal

@@ -0,0 +1,81 @@
+cabal-version:   3.8
+
+-- The cabal-version field refers to the version of the .cabal specification,
+-- and can be different from the cabal-install (the tool) version and the
+-- Cabal (the library) version you are using. As such, the Cabal (the library)
+-- version used must be equal or greater than the version stated in this field.
+-- Starting from the specification version 2.2, the cabal-version field must be
+-- the first thing in the cabal file.
+
+-- Initial package description 'monthly-rewind' generated by
+-- 'cabal init'. For further documentation, see:
+--   http://haskell.org/cabal/users-guide/
+--
+-- The name of the package.
+name:            monthly-rewind
+
+-- The package version.
+-- See the Haskell package versioning policy (PVP) for standards
+-- guiding when and how versions should be incremented.
+-- https://pvp.haskell.org
+-- PVP summary:     +-+------- breaking API changes
+--                  | | +----- non-breaking API additions
+--                  | | | +--- code changes with no API change
+version:         0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- The license under which the package is released.
+license:
+
+-- The package author(s).
+author:          Tsung-Ju Lii
+
+-- An email address to which users can send suggestions, bug reports, and patches.
+maintainer:      usefulalgorithm@gmail.com
+
+-- A copyright notice.
+-- copyright:
+build-type:      Simple
+
+-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.
+extra-doc-files: CHANGELOG.md
+
+-- Extra source files to be distributed with the package, such as examples, or a tutorial module.
+-- extra-source-files:
+
+common warnings
+  ghc-options: -Wall
+
+executable monthly-rewind
+  -- Import common warning flags.
+  import:           warnings
+
+  -- .hs or .lhs file containing the Main module.
+  main-is:          Main.hs
+
+  -- Modules included in this executable, other than Main.
+  -- other-modules:
+
+  -- LANGUAGE extensions used by modules in this package.
+  -- other-extensions:
+
+  -- Other library packages from which modules are imported.
+  build-depends:
+    , base        ^>=4.17.2.1
+    , containers  ==0.6.7
+    , directory
+    , pandoc      ==3.0.1
+    , text
+    , time        ==1.12.2
+    , split
+
+  -- Directories containing source files.
+  hs-source-dirs:   app
+
+  -- Base language which the package is written in.
+  default-language: Haskell2010

stack.yaml

@@ -35,6 +35,7 @@ resolver: lts-21.25
 packages:
   - .
   - scripts/pull_album_info
+  - scripts/monthly_rewind
 
 # Dependency packages to be pulled from upstream that are not in the resolver
 # using the same syntax as the packages field.