module DDC.Core.Salt.Convert.Base
( ConvertM
, Error(..))
where
import DDC.Core.Salt.Name
import DDC.Core.Pretty
import DDC.Core.Module
import DDC.Core.Exp
import qualified DDC.Control.Monad.Check as G
type ConvertM a x = G.CheckM (Error a) x
data Error a
= ErrorUndefined
{ errorVar :: Bound Name }
| ErrorBindNone
| ErrorNoTopLevelLetrec
{ errorModule :: Module a Name }
| ErrorTypeInvalid
{ errorType :: Type Name }
| ErrorFunctionInvalid
{ errorExp :: Exp a Name }
| ErrorParameterInvalid
{ errorBind :: Bind Name }
| ErrorBodyInvalid
{ errorExp :: Exp a Name }
| ErrorBodyMustPassControl
{ errorExp :: Exp a Name }
| ErrorStmtInvalid
{ errorExp :: Exp a Name }
| ErrorAltInvalid
{ errorAlt :: Alt a Name }
| ErrorRValueInvalid
{ errorExp :: Exp a Name }
| ErrorArgInvalid
{ errorExp :: Exp a Name }
| ErrorPrimCallInvalid
{ errorPrimOp :: PrimOp
, errorArgs :: [Exp a Name]}
deriving Show
instance (Show a, Pretty a) => Pretty (Error a) where
ppr err
= case err of
ErrorUndefined var
-> vcat [ text "Undefined variable" <+> ppr var ]
ErrorBindNone
-> vcat [ text "Found a _ binder"]
ErrorNoTopLevelLetrec _mm
-> vcat [ text "Module does not have a top-level letrec." ]
ErrorTypeInvalid tt
-> vcat [ text "Invalid type for local variable."
, empty
, text "with:" <+> align (ppr tt) ]
ErrorFunctionInvalid xx
-> vcat [ text "Invalid function definition."
, empty
, text "with:" <+> align (ppr xx) ]
ErrorParameterInvalid b
-> vcat [ text "Invalid function parameter."
, empty
, text "with:" <+> align (ppr b) ]
ErrorBodyInvalid xx
-> vcat [ text "Invalid function body."
, empty
, text "with:" <+> align (ppr xx) ]
ErrorBodyMustPassControl xx
-> vcat [ text "The final statement in a function must pass control"
, text " You need an explicit return# or fail#."
, empty
, text "this isn't one: " <+> align (ppr xx) ]
ErrorStmtInvalid xx
-> vcat [ text "Invalid statement."
, empty
, text "with:" <+> align (ppr xx) ]
ErrorAltInvalid xx
-> vcat [ text "Invalid case-alternative."
, empty
, text "with:" <+> align (ppr xx) ]
ErrorRValueInvalid xx
-> vcat [ text "Invalid R-value."
, empty
, text "with:" <+> align (ppr xx) ]
ErrorArgInvalid xx
-> vcat [ text "Invalid argument."
, empty
, text "with:" <+> align (ppr xx) ]
ErrorPrimCallInvalid p xs
-> vcat [ text "Invalid primCall."
, text " primitive: " <+> align (ppr p)
, text " args: " <+> align (ppr xs) ]