74 lines
2.0 KiB
Haskell
74 lines
2.0 KiB
Haskell
module Gyehoek.Jalmot
|
|
( Jalmot
|
|
, Exception(..)
|
|
, AJalmot(..)
|
|
, AJalmotCS(..)
|
|
, module Effectful.Error.Static
|
|
, runJalmot
|
|
, runJalmotIO
|
|
, runJalmotIOE
|
|
, runJalmotUnsafe
|
|
, runJalmotCS
|
|
)
|
|
where
|
|
|
|
import Gyehoek.Prelude
|
|
import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
|
|
import Data.Void (Void)
|
|
import Effectful.Exception
|
|
import Effectful.Error.Static
|
|
import qualified Data.InvertibleGrammar as Grammar
|
|
import Gyehoek.Sexp.Syntax (Ann)
|
|
import Prettyprinter (defaultLayoutOptions, layoutPretty, pretty)
|
|
import Prettyprinter.Render.String (renderString)
|
|
import Control.Exception.Base (throw)
|
|
|
|
|
|
deriving instance Show p => Show (Grammar.ErrorMessage p)
|
|
deriving instance Data p => Data (Grammar.ErrorMessage p)
|
|
|
|
data AJalmot
|
|
= ReaderError (ParseErrorBundle Text Void)
|
|
| GrammarError (Grammar.ErrorMessage Ann)
|
|
| VMError Text
|
|
deriving (Show, Generic, Data)
|
|
|
|
data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
|
|
deriving (Show)
|
|
|
|
type Jalmot = Error AJalmot
|
|
|
|
runJalmot :: Eff (Jalmot : es) a -> Eff es (Either (CallStack, AJalmot) a)
|
|
runJalmot = runError
|
|
|
|
runJalmotCS :: Eff (Jalmot : es) a -> Eff es (Either AJalmotCS a)
|
|
runJalmotCS = (mapped . _Left %~ uncurry MkAJalmotCS) . runError
|
|
|
|
runJalmotIOE :: IOE :> es => Eff (Jalmot : es) a -> Eff es a
|
|
runJalmotIOE eff =
|
|
runJalmot eff >>= \case
|
|
Right a -> pure a
|
|
Left (cs,jm) -> throwIO $ MkAJalmotCS cs jm
|
|
|
|
runJalmotIO :: Eff '[Jalmot, IOE] a -> IO a
|
|
runJalmotIO = runEff . runJalmotIOE
|
|
|
|
runJalmotUnsafe :: Eff '[Jalmot] a -> a
|
|
runJalmotUnsafe m = case runPureEff . runJalmot $ m of
|
|
Left (cs,e) -> throw $ MkAJalmotCS cs e
|
|
Right x -> x
|
|
|
|
instance Exception AJalmot where
|
|
displayException = \case
|
|
ReaderError eb -> errorBundlePretty eb
|
|
GrammarError err ->
|
|
pretty err
|
|
& layoutPretty defaultLayoutOptions
|
|
& renderString
|
|
VMError err -> [i|#{err}|]
|
|
|
|
instance Exception AJalmotCS where
|
|
backtraceDesired = const False
|
|
displayException (MkAJalmotCS cs jm) =
|
|
"\n" <> displayException jm <> "\n\n" <> prettyCallStack cs <> "\n"
|