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
  | EvalError 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}|]
    EvalError err -> [i|#{err}|]

instance Exception AJalmotCS where
  backtraceDesired = const False
  displayException (MkAJalmotCS cs jm) =
    "\n" <> displayException jm <> "\n\n" <> prettyCallStack cs <> "\n"