{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}

-- | a monad that collects warnings, outputs, etc,
module LintWriter where

import           Control.Monad.Trans.Maybe ()
import           Control.Monad.Writer      (MonadTrans (lift),
                                            MonadWriter (tell), WriterT)
import           Data.Aeson                (ToJSON (toJSON))
import           Data.Text                 (Text)
import           GHC.Generics              (Generic)

import Util (PrettyPrint(..), showText)

-- | Levels of errors and warnings, collectively called
-- "Hints" until I can think of some better name
data Level = Warning | Suggestion | Info | Forbidden | Error | Fatal
  deriving (Show, Generic, ToJSON)

-- | a hint comes with an explanation (and a level)
data Hint = Hint
  { hintLevel :: Level
  , hintMsg   :: Text }
  deriving (Generic, ToJSON)

instance PrettyPrint Hint where
  prettyprint Hint { hintMsg, hintLevel } =
    showText hintLevel <> ": " <> hintMsg

-- shorter constructor
hint :: Level -> Text -> Hint
hint level msg = Hint { hintLevel = level, hintMsg = msg }

-- | a monad to collect hints. If it yields Left, then the
-- map is flawed in some fundamental way which prevented us
-- from getting any hints at all except whatever broke it
type LintWriter a = WriterT [Hint] (Either Hint) a

-- this is wrapped in a newtype because Aeson is silly and wants
-- to serialise Either as { "Right" : … } or { "Left" : … } ...
type LintResult' a = Either Hint (a, [Hint])
newtype LintResult a = LintResult (LintResult' a)

-- better, less confusing serialisation of an Either Hint (a, [Hint]).
-- Note that Left hint is also serialised as a list to make the resulting
-- json schema more regular.
instance ToJSON a => ToJSON (LintResult a) where
  toJSON (LintResult r) = toJson' r
    where toJson' (Left hint)        = toJSON [hint]
          toJson' (Right (_, hints)) = toJSON hints



-- | write a hint into the LintWriter monad
lint :: Level -> Text -> LintWriter ()
lint level = tell . (: []) . hint level

warn = lint Warning
info = lint Info
forbid = lint Forbidden
suggest = lint Suggestion
complain = lint Error


-- TODO: all these functions should probably also just operate on LintWriter

-- | converts a Maybe to an Either, with a default value for Left
unwrap :: b -> Maybe a  -> Either b a
unwrap hint maybe = case maybe of
  Just a  -> Right a
  Nothing -> Left hint

-- | unwrap and produce a warning if the value was Nothing
unwrapWarn :: Text -> Maybe a -> Either Hint a
unwrapWarn msg = unwrap $ hint Warning msg

-- | same as unwrapWarn, but for booleans
assertWarn :: Text -> Bool -> LintWriter ()
assertWarn msg cond = lift $ if cond then Right () else Left $ hint Warning msg