finance scripts in a robust shake file

1-example

~/notes$ ./do.hs
Linking do ...
~/notes$ ./do 
Usage:
./do.hs         install deps & (re)compile this script
./do [help]     show this help
./do time       show time status
./do money      show money status
./do lassets    show liquid assets
./do incexp     show monthly income & expenses
./do budget     show monthly expense budget performance
./do tbudget    show time budget performance
./do timelog    show timelog status

2-do.hs

#!/usr/bin/env stack
{- stack exec
   --verbosity=info
   --package base-prelude
   --package directory
   --package extra
   --package filepath
   --package regex
   --package shake
   --package time
   ghc
-} -- sync this package list to: imports below, DO_PACKAGES in Makefile

{-
General personal management scripts - finance, time etc.
Some useful make rules when working on this:
make do, make ghci-do, make ghcid-do, make ghcid-do-CMD.
-}

-- {-# LANGUAGE MultiWayIf #-}
-- {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PackageImports #-}
-- {-# LANGUAGE ScopedTypeVariables #-}

import                Prelude ()
import "base-prelude" BasePrelude
import "base"         Control.Exception as C
import "directory"    System.Directory
import "extra"        Data.List.Extra
import "filepath"     System.FilePath
-- import "process"      System.Process
import "regex"        Text.RE.TDFA.String
import "regex"        Text.RE.Replace
-- import "safe"         Safe
import "shake"        Development.Shake
-- import "shake"        Development.Shake.FilePath
import "time"         Data.Time

dir = "/Users/simon/notes"
timelogFile = dir </> "time-2019.timedot"

cmds = [
  -- command,   help,                                      shake action
   ("time"    ,"show time status"                        , time)
  ,("money"   ,"show money status"                       , money)
  ,("lassets" ,"show liquid assets"                      , liquidAssets True)
  ,("incexp"  ,"show monthly income & expenses"          , incomeExpenses True)
  ,("budget"  ,"show monthly expense budget performance" , budget)
  ,("tbudget" ,"show time budget performance"            , timeBudget)
  ,("timelog" ,"show timelog status"                     , timelog)
  --          ,"-----------------------------------------------------------79-^
  ]

main :: IO ()
main = shakeArgs shakeOptions { shakeVerbosity=Quiet } $ do
  want ["help"]
  phony "help" $ io $ putStr $ unlines $
    ["Usage:"
    ,"./do.hs         install deps & (re)compile this script"
    ,"./do [help]     show this help"
    ] ++ 
    [printf "./do %-10s %s" c h | (c,h,_) <- cmds]
  forM_ cmds $ \(c,_,action) -> phony c action

time :: Action ()
time = do
  t <- io getCurrentLocalTime
  io $ printf "TIME (updated %s)\n\n" (showTime t)
  timelog    >> blankline
  timeBudget >> blankline
  sleepWake  >> blankline

money :: Action ()
money = do
  t <- io getCurrentLocalTime
  io $ printf "MONEY (updated %s)\n\n" (showTime t)
  liquidAssets True >> blankline
  incomeExpenses False >> blankline
  budget >> blankline

liquidAssets :: Bool -> Action ()
liquidAssets cleared = do
  io $ printf "Liquid assets (%scleared):\n" (if cleared then "" else "un")
  cmd_ Shell "hledger bal wf cash:wallet cash:emperors assets.*paypal" (if cleared then "-C" else "")
    "| grep -vE '^$'"

incomeExpenses :: Bool -> Action ()
incomeExpenses cleared = do
  -- io $ printf "Income & Expenses (%scleared):\n" (if cleared then "" else "un")
  -- cmd_ Shell "hledger bal -M -V sm:'(rev|exp)' -2" (if cleared then "-C" else "") >> blankline
  cmd_ Shell "hledger is -M -V sm:'(rev|exp)' -3" (if cleared then "-C" else "")
    "| grep -vE '^$'"

budget :: Action ()
budget = do
  ls <- filter (not . null) . lines . fromStdout <$> (cmd Shell "hledger bal --budget -V -E -M -blastmonth sm:exp -3 --flat --drop 2")
  io $ putStr $ unlines $ take 3 ls ++ drop 5 ls

timeBudget :: Action ()
timeBudget = do
  ls <- drop 1 . lines . fromStdout <$> (cmd "hledger -f time.journal -f time-daily.budget bal --budget -D -1 date:yesterday-tomorrow")
  io $ printf "Daily time budget:%s" (unlines ls)
  io $ putStrLn ""
  ls <- drop 1 . lines . fromStdout <$> (cmd "hledger -f time.journal -f time-weekly.budget bal --budget -W -1 date:lastweek-nextweek")
  io $ printf "Weekly time budget:%s" (unlines ls)
  io $ putStrLn ""
  ls <- drop 1 . lines . fromStdout <$> (cmd "hledger -f time.journal -f time-weekly.budget bal --budget -M -1 date:lastmonth-nextmonth")
  io $ printf "Monthly time budget:%s" (unlines ls)

timelog :: Action ()
timelog = do
  tz <- io $ getCurrentTimeZone
  tmod <- (utcToLocalTime tz <$>) $ io $ getModificationTime timelogFile
  tacc <- (utcToLocalTime tz <$>) $ io $ getAccessTime timelogFile
  log <- io $ readFile timelogFile
  let todaylog = last $ splitOn "\n\n" log
  io $ printf "Today's timelog: (saved %s, accessed %s)\n%s"
    (showTime tmod) (showTime tacc) (alphabetiseTimedotDay $ formatTimedot todaylog)

sleepWake :: Action ()
sleepWake = do
  io $ printf "Recent sleep/wakes:\n"
  cmd_ Shell
    "( pmset -g log | grep -E '((Sleep|Wake) +\\t|Display is)' )"
    "| tail"
    "| cut -c 1-78"
    "| sed -E"
    "-e 's/(Notification|Sleep|Wake) *\t//'"
    "-e 's/is turned //'"
    "-e 's/Entering Sleep state/Sleep/'"

---------------

-- Utilities

type Timedot = String

-- Format one day's worth of timedot-format text: sort all but the first line
-- alphabetically. (Will sort blank and comment lines too.)
alphabetiseTimedotDay :: Timedot -> Timedot
alphabetiseTimedotDay s = unlines $ take 1 ls ++ sort (drop 1 ls)
  where ls = lines s

-- Format some timedot-format text: align the dots based on widest account name.
formatTimedot :: Timedot -> Timedot
formatTimedot s = unlines $ map formatline $ lines s
  where
    ls = lines s
    accts = concat [take 1 $ splitOn "  " l | l <- ls, not $ isDate l]
    acctwidth = maximum $ map length accts
    isDate = isJust . parsedateM
    isComment = (`elem` [";","#"]) . take 1 . strip
    isBlank = null . strip
    formatline l
      | isDate l || isComment l || isBlank l = l
      | otherwise = printf ("%-"++show acctwidth++"s  %s") acct (intercalate "  " rest)
      where
        acct:rest = splitOn "  " l

showMD :: FormatTime t => t -> String
showMD = formatTime defaultTimeLocale "%b %-e"

showHM :: FormatTime t => t -> String
showHM = formatTime defaultTimeLocale "%H:%M" :: FormatTime t => t -> String

showTime :: FormatTime t => t -> String
showTime t = printf "%s %s" (showMD t) (showHM t)

blankline = io $ putStrLn ""

-- General utilities

io = liftIO

getCurrentDay :: IO Day
getCurrentDay = do
  t <- getZonedTime
  return $ localDay (zonedTimeToLocalTime t)

getCurrentLocalTime :: IO LocalTime
getCurrentLocalTime = do
  t <- getCurrentTime
  tz <- getCurrentTimeZone
  return $ utcToLocalTime tz t

readFileStrictly :: FilePath -> IO String
readFileStrictly f = readFile f >>= \s -> C.evaluate (length s) >> return s

-- | Parse a couple of date string formats to a time type.
parsedateM :: String -> Maybe Day
parsedateM s = firstJust id [
     parseTimeM True defaultTimeLocale "%Y/%m/%d" s,
     parseTimeM True defaultTimeLocale "%Y-%m-%d" s
     ]

-- | Remove leading and trailing whitespace.
strip :: String -> String
strip = lstrip . rstrip

-- | Remove leading whitespace.
lstrip :: String -> String
lstrip = dropWhile isSpace

-- | Remove trailing whitespace.
rstrip :: String -> String
rstrip = reverse . lstrip . reverse

-- | Remove trailing newlines/carriage returns.
chomp :: String -> String
chomp = reverse . dropWhile (`elem` "\r\n") . reverse