{-# LANGUAGE RankNTypes #-}

module Ondim.Extra.Exceptions
  ( tryExp,
    exceptionExp,
    prettyException,
  ) where

import Data.Text qualified as T
import Ondim
import Ondim.Debug
import Ondim.Extra.Expansions (listExp)

tryExp :: PolyExpansion s
tryExp :: forall s a. OndimNode a => Expansion s a
tryExp a
node = Expansion s a
forall t s. OndimNode t => Expansion s t
expandChildren a
node Ondim s [a]
-> (OndimFailure
    -> Text -> SomeTypeRep -> TraceData -> Ondim s [a])
-> Ondim s [a]
forall s a.
Ondim s a
-> (OndimFailure -> Text -> SomeTypeRep -> TraceData -> Ondim s a)
-> Ondim s a
`catchFailure` \OndimFailure
_ Text
_ SomeTypeRep
_ TraceData
_ -> [a] -> Ondim s [a]
forall a. a -> Ondim s a
forall (m :: * -> *) a. Monad m => a -> m a
return []

exceptionExp :: OndimException -> NamespaceMap s
exceptionExp :: forall s. OndimException -> NamespaceMap s
exceptionExp exc :: OndimException
exc@(OndimException ExceptionType
e TraceData
t) = do
  Text
"pretty" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ OndimException -> Text
prettyException OndimException
exc
  Text
"stack" Text -> NamespaceMap s -> NamespaceMap s
forall m. Text -> NamespaceMap m -> NamespaceMap m
#. ((Text, DefinitionSite) -> NamespaceItem s)
-> [(Text, DefinitionSite)] -> NamespaceMap s
forall a s. (a -> NamespaceItem s) -> [a] -> NamespaceMap s
listExp (Text, DefinitionSite) -> NamespaceItem s
forall {m}. (Text, DefinitionSite) -> NamespaceItem m
stackExp (TraceData -> [(Text, DefinitionSite)]
expansionTrace TraceData
t)
  Text
"depth" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ TraceData -> Int
depth TraceData
t
  Text
"site" Text -> NamespaceMap s -> NamespaceMap s
forall m. Text -> NamespaceMap m -> NamespaceMap m
#. DefinitionSite -> NamespaceMap s
forall {m}. DefinitionSite -> NamespaceMap m
locExp (DefinitionSite -> NamespaceMap s)
-> DefinitionSite -> NamespaceMap s
forall a b. (a -> b) -> a -> b
$ TraceData -> DefinitionSite
currentSite TraceData
t
  case ExceptionType
e of
    ExceptionType
MaxExpansionDepthExceeded -> Text
"type" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
"max-depth"
    TemplateError CallStack
cs Text
msg -> do
      Text
"type" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
"template-error"
      Text
"stacktrace" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ CallStack -> String
prettyCallStack CallStack
cs
      Text
"message" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
msg
    Failure SomeTypeRep
trep Text
name OndimFailure
f -> do
      Text
"type" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
"failure"
      Text
"caller" Text -> NamespaceMap s -> NamespaceMap s
forall m. Text -> NamespaceMap m -> NamespaceMap m
#. do
        Text
"type" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ SomeTypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeTypeRep
trep
        Text
"name" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
name
      Text
"failure" Text -> NamespaceMap s -> NamespaceMap s
forall m. Text -> NamespaceMap m -> NamespaceMap m
#. case OndimFailure
f of
        OndimFailure
NotBound -> Text
"type" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
"not-bound"
        ExpansionWrongType SomeTypeRep
trep2 -> do
          Text
"type" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
"expansion-wrong-type"
          Text
"bound-type" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ SomeTypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeTypeRep
trep2
        TemplateWrongType SomeTypeRep
trep2 -> do
          Text
"type" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
"template-wrong-type"
          Text
"bound-type" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ SomeTypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeTypeRep
trep2
        FailureOther Text
msg -> do
          Text
"type" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
"other"
          Text
"message" Text -> Text -> NamespaceMap s
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
msg
  where
    locExp :: DefinitionSite -> NamespaceMap m
locExp = \case
      DefinitionSite
NoDefinition -> Text
"type" Text -> Text -> NamespaceMap m
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
"none"
      FileDefinition String
f Text
_ -> do
        Text
"type" Text -> Text -> NamespaceMap m
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
"file"
        Text
"filepath" Text -> Text -> NamespaceMap m
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ String -> Text
forall a. ToText a => a -> Text
toText String
f
      CodeDefinition SrcLoc
c -> do
        Text
"type" Text -> Text -> NamespaceMap m
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
"code"
        Text
"location" Text -> Text -> NamespaceMap m
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String
prettySrcLoc SrcLoc
c
    stackExp :: (Text, DefinitionSite) -> NamespaceItem m
stackExp (Text
name, DefinitionSite
loc) = NamespaceMap m -> NamespaceItem m
forall m. NamespaceMap m -> NamespaceItem m
namespace do
      Text
"name" Text -> Text -> NamespaceMap m
forall m. HasCallStack => Text -> Text -> NamespaceMap m
#@ Text
name
      Text
"site" Text -> NamespaceMap m -> NamespaceMap m
forall m. Text -> NamespaceMap m -> NamespaceMap m
#. DefinitionSite -> NamespaceMap m
forall {m}. DefinitionSite -> NamespaceMap m
locExp DefinitionSite
loc

prettyException :: OndimException -> Text
prettyException :: OndimException -> Text
prettyException (OndimException ExceptionType
e TraceData
t) =
  Text
eMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"While expanding " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
loc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Expansion stack:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eStack
  where
    loc :: Text
loc = DefinitionSite -> Text
loc' (TraceData -> DefinitionSite
currentSite TraceData
t)
    loc' :: DefinitionSite -> Text
loc' = \case
      DefinitionSite
NoDefinition -> Text
"undefined location"
      FileDefinition String
fp Text
_ -> Text
"file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall b a. (Show a, IsString b) => a -> b
show String
fp
      CodeDefinition SrcLoc
c -> Text
"code location " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (SrcLoc -> String
prettySrcLoc SrcLoc
c)
    eStack :: Text
eStack =
      [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        TraceData -> [(Text, DefinitionSite)]
expansionTrace TraceData
t [(Text, DefinitionSite)]
-> ((Text, DefinitionSite) -> Text) -> [Text]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Text
name, DefinitionSite
l) ->
          Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DefinitionSite -> Text
loc' DefinitionSite
l
    eMsg :: Text
eMsg = case ExceptionType
e of
      ExceptionType
MaxExpansionDepthExceeded ->
        Text
"Maximum expansion depth exceeded. Did you write something recursive?\n"
      TemplateError CallStack
cs Text
msg -> do
        Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Template error! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (CallStack -> String
prettyCallStack CallStack
cs)
      Failure SomeTypeRep
trep Text
name OndimFailure
f ->
        case OndimFailure
f of
          OndimFailure
NotBound ->
            Text
"Identifier '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' (of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeTypeRep
trep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") is not bound!"
          ExpansionWrongType SomeTypeRep
trep2 ->
            Text
"Identifier '"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is bound to an expansion of type "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeTypeRep
trep2
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" instead of "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeTypeRep
trep
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
          TemplateWrongType SomeTypeRep
trep2 ->
            Text
"Identifier '"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is bound to an expansion of type "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeTypeRep
trep2
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" instead of "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeTypeRep
trep
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", and no conversion is declared."
          FailureOther Text
msg ->
            Text
msg
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n(While calling identifier '"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' from type "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeTypeRep
trep
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"