Printing.hs

module Caliper.Cli.Printing where

import Data.Function ((&))
import Data.List ((!?))
import Data.List.NonEmpty qualified as NE
import Data.Maybe
import Data.Text qualified as T
import Data.Time.LocalTime

import Caliper.Syntax

{- | Precondition: entries must be all of the same day
Each + symbol is a quarter of an hour, a dot is anything less than a quarter.
-}
histogramLine :: NE.NonEmpty ResolvedEntry -> String
histogramLine es =
  let spnSeconds :: Rational
      spnSeconds = realToFrac (sumDuration $ NE.toList es)
      spnQuarterOfHour :: Rational
      spnQuarterOfHour = (/ 15) $ (/ 60) spnSeconds

      go :: Rational -> String
      go 0 = ""
      go n
        | n < 1 = "."
        | n <= 1 = "+"
        | n <= 2 = "++"
        | n <= 3 = "+++"
        | n <= 4 = "+++$"
        | otherwise = go 4 <> go (n - 4)
  in  show (localDay $ zonedTimeToLocalTime d)
        <> " "
        <> show (zonedTimeZone d)
        <> " | "
        <> go spnQuarterOfHour
  where
    d = entryStart $ NE.head es

-- TODO: parameterize to show more context on demand
withFencedHelp :: T.Text -> SrcSpan -> T.Text -> T.Text
withFencedHelp src (SrcSpan fname startPos endPos) message =
  let SrcPosition startLine startCol = startPos
      SrcPosition _ endCol = endPos

      srcLines :: [T.Text]
      srcLines = T.lines src

      header :: T.Text
      header = fname <> ":" <> lineNumber <> ":"

      lineNumber :: T.Text
      lineNumber = T.show startLine
      emptyLineNumber :: T.Text
      emptyLineNumber = T.replicate (T.length lineNumber) " "

      mkLine :: Int -> T.Text
      mkLine n =
        let numberingOrEmpty :: T.Text
            numberingOrEmpty = if n == startLine then lineNumber else emptyLineNumber
            maybeContent :: T.Text
            maybeContent = fromMaybe "" $ srcLines !? (n - 1)
        in  numberingOrEmpty <> " | " <> maybeContent

      undercurl :: T.Text
      undercurl = emptyLineNumber <> " | " <> T.replicate (startCol - 1) " " <> T.replicate (endCol - startCol) "^"
  in  message
        <> "\n"
        <> T.unlines
          [ header
          , mkLine $ startLine - 1
          , mkLine startLine
          , undercurl
          , mkLine $ startLine + 1
          ]

resolutionErrorPretty :: T.Text -> ResolutionError -> T.Text
resolutionErrorPretty src (ResolutionError kind spn) = case kind of
  NegativeTimeSpan duration ->
    "user error: Timespan has negative or null duration of " <> T.show duration
      & withFencedHelp src spn
  InvalidTime t ->
    "user error: time " <> quote t <> " is a not valid date time"
      & withFencedHelp src spn
  UndeclaredType ty ->
    "user error: event has undeclared type " <> quote ty
      & withFencedHelp src spn
  DuplicatedType ty ty2 ->
    "user error: event has duplicate types "
      <> quote ty2
      <> " while it already bears the type "
      <> quote ty
      & withFencedHelp src spn
  where
    quote s = "\"" <> s <> "\""