A Metric for Daily Schedules

$ runghc -package --ghc-arg=diagrams-lib \
-package --ghc-arg=diagrams-svg \
-- ScheduleMetric.hs -w 200 -o /home/pi/schedule/report/report.svg

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

module ScheduleMetric where

import Control.Monad
import Data.Function
import Data.Functor
import Data.List
import Data.Maybe
import qualified Data.Set as Set
import Diagrams.Prelude
import Diagrams.Backend.SVG.CmdLine
import System.Directory
import System.FilePath

main :: IO ()
main =
    -- for each month, prepare the set of days for which a schedule is present
    scheduled <&>
    
    -- construct a Haskell representation of the diagram
    scorecard >>=
    
    -- render the diagram
    mainWith

-- given a list of (month number, set of days in month) pairs construct a
-- Haskell representation of the diagram to be rendered
scorecard :: [(Int, Set.Set Int)] -> Diagram B
scorecard monthSets =
    monthSets            &

    -- prepare a separate "scorecard" for each month
    map monthlyScorecard &


    -- arrange the monthly scorecards vertically, starting from January at the
    -- top to December at the bottom 
    vcat

-- given a tuple whose first element is the number of a month (a number between
-- 1 and 12, inclusive) and second element is a set of numbers representing
-- dates within that month for which a schedule is present, create the Haskell
-- representation of horizontal line of squares where the leftmost square is
-- just the number of the month and the subsequent squares represent the days of
-- that month. Each day where a schedule is present is colored green otherwise
-- it is colored red.
monthlyScorecard :: (Int, Set.Set Int) -> Diagram B
monthlyScorecard (month, days) = monthName ||| monthScorecard
  where
    -- the leftmost square, a white box containing the number of the month.
    monthName = month # show # text # fontSizeL 2 # fc black <>
        square 2 # fc white

    -- the subsequent squares, there is one for each day of the month.
    monthScorecard = [1..month & size]      &
        map (\i -> square 2 # fc (color i)) &
        hcat

    -- the count of days in the month given its number. 1 represents January
    -- which has 31 days, 2 represents February with 28 days, and so on.
    size month
        | month == 2              = 28
        | month `elem` [4,6,9,11] = 30
        | otherwise               = 31

    -- if a day is present in the input set then its corresponding box is
    -- colored green and otherwise colored red.
    color day
        | day `Set.member` days = green
        | otherwise             = red

-- this function evaluates to a list of tuples where the first element of each
-- tuple is a number representing a month (1 stands for January and 12 stands
-- for December) and the second element is a set of numbers representing the
-- days in the month for which schedules are present
--
-- suppose the contents of the target directory are:
-- 1/1.ses
-- 1/4.ses
-- 1/9.ses
-- 2/3.ses
-- 2/4.ses
--
-- then the function below will evaluate to
-- [ (1, {1,4,9})
-- , (2, {3,4})
-- ]
scheduled :: IO [(Int, Set.Set Int)]
scheduled =
    listDirectory target        <&>
    sort                        <&>
    -- make the paths of the month folders absolute
    map (target </>)            >>=
    filterM doesDirectoryExist  <&>
    -- turn each folder path into a Just (folder path, month number) or Nothing
    map dirMonthFromDirectory   <&>
    -- remove all the Nothing values
    catMaybes                   >>= \directories ->
    forM directories             $  \(directory, month) ->
    listDirectory directory     <&>
    -- make the paths of the day files absolute
    map (directory </>)         >>=
    filterM doesFileExist       <&>
    -- throw away any file that doesn't end in a .md or a .ses
    filter mdOrSes              <&>
    -- turn each file path into a (Just day) or Nothing
    map dayFromFile             <&>
    catMaybes                   <&>
    Set.fromList                <&> \set ->
    (month, set)

-- given the path to a file, relative or absolute, evaluate to True if the
-- file's extension indicates that it is a markdown file or a simple Emacs
-- spreadsheet file, this is relevant because my daily schedule files are
-- confined to these two formats.
mdOrSes :: FilePath -> Bool
mdOrSes filename = ".md" `isSuffixOf` filename || ".ses" `isSuffixOf` filename

-- given the relative or absolute path to a directory, kill the part containing
-- its parent directory and if the remaining part - the "dir2" in "/dir1/dir2/"
-- - is a String that can be read as a number, do so and return a tuple, the
-- first element of which is the directory path as-is and the second part is the
-- numbe and if that remaining part cannot be read as a number then return
-- Nothing.
dirMonthFromDirectory :: FilePath -> Maybe (FilePath, Int)
dirMonthFromDirectory dir
    | baseName & isNumber = (dir, baseName & read) & Just
    | otherwise           = Nothing
  where
    baseName = dir & takeBaseName

-- given the path to a file, relative or absolute, kill its extension and
-- directory portion, and if the remaining part - the "base" in
-- "/dir1/dir2/base.ses" - is a string that can be read as a number, do so and
-- return the number. Otherwise return None.
dayFromFile :: FilePath -> Maybe Int
dayFromFile file
    | baseName & isNumber = baseName & read & Just
    | otherwise           = Nothing
  where
    baseName = file & takeBaseName

-- evaluates to True if the argument is a String containing only digits, False
-- otherwise
isNumber :: String -> Bool
isNumber s = s & map (`elem` "0123456789") & and

-- the directory containing numbered folders representing months
target = "/home/pi/schedule/2020"