99 lines
2.5 KiB
Haskell
99 lines
2.5 KiB
Haskell
{-# 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 <> "'."
|
|
]
|
|
|