UserNote.hs

{- |
Module      : Henforcer.Rules.UserNote
Description : Generic field for user defined notes
Copyright   : (c) Flipstone Technology Partners, 2024-2026
License     : MIT
Maintainer  : maintainers@flipstone.com
-}
module Henforcer.Rules.UserNote
  ( UserNote
  , userNoteField
  , FailureWithUserNote (userNotes, underlyingFailure)
  , failureWithUserNotes
  , failureWithUserNote
  , failureWithNoNote
  , noUserNote
  ) where

import qualified Data.Maybe as Maybe
import qualified Toml

import qualified CompatGHC
import qualified TomlHelper

newtype UserNote = UserNote (Maybe String)
  deriving (Eq, Show)

userNoteMbStr :: UserNote -> Maybe String
userNoteMbStr (UserNote mbStr) = mbStr

userNoteCodec :: Toml.Key -> Toml.TomlCodec UserNote
userNoteCodec =
  Toml.diwrap . Toml.dioptional . Toml.string

userNoteField :: (object -> UserNote) -> Toml.Codec object UserNote
{-# INLINEABLE userNoteField #-}
userNoteField accessor =
  TomlHelper.addField "note" accessor userNoteCodec

noUserNote :: UserNote
noUserNote = UserNote Nothing

data FailureWithUserNote a = FailureWithUserNote
  { userNotes :: ![UserNote]
  , underlyingFailure :: !a
  }

instance (CompatGHC.Outputable a) => CompatGHC.Outputable (FailureWithUserNote a) where
  ppr withUserNote =
    let
      underlyingDoc = CompatGHC.ppr (underlyingFailure withUserNote)
     in
      case Maybe.mapMaybe userNoteMbStr $ userNotes withUserNote of
        [] -> underlyingDoc
        noteStrs ->
          CompatGHC.vcat $ pure underlyingDoc <> fmap (CompatGHC.text . ("Note: " <>)) noteStrs

failureWithUserNotes :: [UserNote] -> a -> FailureWithUserNote a
failureWithUserNotes = FailureWithUserNote

failureWithUserNote :: UserNote -> a -> FailureWithUserNote a
failureWithUserNote note = failureWithUserNotes (pure note)

failureWithNoNote :: a -> FailureWithUserNote a
failureWithNoNote = failureWithUserNote noUserNote