{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
module Compiler.RlpcError
    ( IsRlpcError(..)
    , MsgEnvelope(..)
    , Severity(..)
    , RlpcError(..)
    , msgSpan
    , msgDiagnostic
    , msgSeverity
    , liftRlpcErrors
    , errorMsg
    , debugMsg
    -- * Located Comonad
    , Located(..)
    , SrcSpan(..)

    -- * Common error messages
    , undefinedVariableErr
    )
    where
----------------------------------------------------------------------------------
import Control.Monad.Errorful
import Data.Text                (Text)
import Data.Text                qualified as T
import GHC.Exts                 (IsString(..))
import GHC.Generics
import Control.Lens             hiding ((.=))
import Compiler.Types

import Data.Aeson
----------------------------------------------------------------------------------

data MsgEnvelope e = MsgEnvelope
   { _msgSpan        :: SrcSpan
   , _msgDiagnostic  :: e
   , _msgSeverity    :: Severity
   }
   deriving (Functor, Show)

instance (ToJSON e) => ToJSON (MsgEnvelope e) where
    toJSON msg = object
        [ "span" .= _msgSpan msg
        , "severity" .= _msgSeverity msg
        , "diagnostic" .= _msgDiagnostic msg
        ]

newtype RlpcError = Text [Text]
    deriving (Show, Generic)
    deriving (ToJSON)
        via Generically [Text]

instance IsString RlpcError where
    fromString = Text . pure . T.pack

class IsRlpcError e where
    liftRlpcError :: e -> RlpcError

instance IsRlpcError RlpcError where
    liftRlpcError = id

data Severity = SevWarning
              | SevError
              | SevDebug Text -- ^ Tag
              deriving (Show, Generic)
              deriving (ToJSON)
                via Generically Severity

makeLenses ''MsgEnvelope

liftRlpcErrors :: (Functor m, IsRlpcError e)
               => ErrorfulT e m a
               -> ErrorfulT RlpcError m a
liftRlpcErrors = mapErrorful liftRlpcError

instance (IsRlpcError e) => IsRlpcError (MsgEnvelope e) where
    liftRlpcError msg = msg ^. msgDiagnostic & liftRlpcError

errorMsg :: SrcSpan -> e -> MsgEnvelope e
errorMsg s e = MsgEnvelope
    { _msgSpan = s
    , _msgDiagnostic = e
    , _msgSeverity = SevError
    }

debugMsg :: Text -> e -> MsgEnvelope e
debugMsg tag e = MsgEnvelope
    -- TODO: not pretty, but it is a debug message after all
    { _msgSpan = SrcSpan 0 0 0 0
    , _msgDiagnostic = e
    , _msgSeverity = SevDebug tag
    }

undefinedVariableErr :: Text -> RlpcError
undefinedVariableErr n = Text
    [ "Variable not in scope: `" <> n <> "'."
    ]