{-# LANGUAGE QuasiQuotes #-}

module Data.Error.Tree where

import Data.List qualified as List
import Data.Sequence qualified as Seq
import Data.String (IsString (..))
import Data.Tree qualified as Tree
import PossehlAnalyticsPrelude

-- | A tree of 'Error's, with a single root 'Error' and 0..n nested 'ErrorTree's.
--
-- @
-- top error
-- |
-- |-- error 1
-- | |
-- |  -- error 1.1
-- |
-- |-- error 2
-- @
newtype ErrorTree = ErrorTree {ErrorTree -> Tree Error
unErrorTree :: (Tree.Tree Error)}
  deriving stock (Int -> ErrorTree -> ShowS
[ErrorTree] -> ShowS
ErrorTree -> String
(Int -> ErrorTree -> ShowS)
-> (ErrorTree -> String)
-> ([ErrorTree] -> ShowS)
-> Show ErrorTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorTree -> ShowS
showsPrec :: Int -> ErrorTree -> ShowS
$cshow :: ErrorTree -> String
show :: ErrorTree -> String
$cshowList :: [ErrorTree] -> ShowS
showList :: [ErrorTree] -> ShowS
Show)

instance IsString ErrorTree where
  fromString :: String -> ErrorTree
fromString = Error -> ErrorTree
singleError (Error -> ErrorTree) -> (String -> Error) -> String -> ErrorTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Error
forall a. IsString a => String -> a
fromString

-- deriving newtype (Ord) -- TODO: Add this instance with containers-0.6.5

-- | Turn a single 'Error' into an 'ErrorTree', a leaf.
singleError :: Error -> ErrorTree
singleError :: Error -> ErrorTree
singleError Error
e = Tree Error -> ErrorTree
ErrorTree (Tree Error -> ErrorTree) -> Tree Error -> ErrorTree
forall a b. (a -> b) -> a -> b
$ Error -> [Tree Error] -> Tree Error
forall a. a -> [Tree a] -> Tree a
Tree.Node Error
e []

-- | Take a list of errors & create a new 'ErrorTree' with the given 'Error' as the root.
errorTree :: Error -> NonEmpty Error -> ErrorTree
errorTree :: Error -> NonEmpty Error -> ErrorTree
errorTree Error
topLevelErr NonEmpty Error
nestedErrs =
  Tree Error -> ErrorTree
ErrorTree
    ( Error -> [Tree Error] -> Tree Error
forall a. a -> [Tree a] -> Tree a
Tree.Node
        Error
topLevelErr
        (NonEmpty Error
nestedErrs NonEmpty Error -> (Error -> Tree Error) -> NonEmpty (Tree Error)
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (\Error
e -> Error -> [Tree Error] -> Tree Error
forall a. a -> [Tree a] -> Tree a
Tree.Node Error
e []) NonEmpty (Tree Error)
-> (NonEmpty (Tree Error) -> [Tree Error]) -> [Tree Error]
forall a b. a -> (a -> b) -> b
& NonEmpty (Tree Error) -> [Tree Error]
forall a. NonEmpty a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList)
    )

-- | Attach more context to the root 'Error' of the 'ErrorTree', via 'errorContext'.
errorTreeContext :: Text -> ErrorTree -> ErrorTree
errorTreeContext :: Text -> ErrorTree -> ErrorTree
errorTreeContext Text
context (ErrorTree Tree Error
tree) =
  Tree Error -> ErrorTree
ErrorTree (Tree Error -> ErrorTree) -> Tree Error -> ErrorTree
forall a b. (a -> b) -> a -> b
$
    Tree Error
tree
      { Tree.rootLabel = tree.rootLabel & errorContext context
      }

-- | Nest the given 'Error' around the ErrorTree
--
-- @
-- top level error
-- |
-- -- nestedError
--   |
--   -- error 1
--   |
--   -- error 2
-- @
nestedError ::
  Error -> -- top level
  ErrorTree -> -- nested
  ErrorTree
nestedError :: Error -> ErrorTree -> ErrorTree
nestedError Error
topLevelErr ErrorTree
nestedErr =
  Tree Error -> ErrorTree
ErrorTree (Tree Error -> ErrorTree) -> Tree Error -> ErrorTree
forall a b. (a -> b) -> a -> b
$
    Tree.Node
      { rootLabel :: Error
Tree.rootLabel = Error
topLevelErr,
        subForest :: [Tree Error]
Tree.subForest = [ErrorTree
nestedErr.unErrorTree]
      }

-- | Nest the given 'Error' around the list of 'ErrorTree's.
--
-- @
-- top level error
-- |
-- |- nestedError1
-- | |
-- | -- error 1
-- | |
-- | -- error 2
-- |
-- |- nestedError 2
-- @
nestedMultiError ::
  Error -> -- top level
  NonEmpty ErrorTree -> -- nested
  ErrorTree
nestedMultiError :: Error -> NonEmpty ErrorTree -> ErrorTree
nestedMultiError Error
topLevelErr NonEmpty ErrorTree
nestedErrs =
  Tree Error -> ErrorTree
ErrorTree (Tree Error -> ErrorTree) -> Tree Error -> ErrorTree
forall a b. (a -> b) -> a -> b
$
    Tree.Node
      { rootLabel :: Error
Tree.rootLabel = Error
topLevelErr,
        subForest :: [Tree Error]
Tree.subForest = NonEmpty ErrorTree
nestedErrs NonEmpty ErrorTree
-> (NonEmpty ErrorTree -> [ErrorTree]) -> [ErrorTree]
forall a b. a -> (a -> b) -> b
& NonEmpty ErrorTree -> [ErrorTree]
forall a. NonEmpty a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList [ErrorTree] -> (ErrorTree -> Tree Error) -> [Tree Error]
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (.unErrorTree)
      }

prettyErrorTree :: ErrorTree -> Text
prettyErrorTree :: ErrorTree -> Text
prettyErrorTree (ErrorTree Tree Error
tree) =
  Tree Error
tree
    Tree Error -> (Error -> Text) -> Tree Text
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> Error -> Text
prettyError
    Tree Text -> (Text -> String) -> Tree String
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> String
textToString
    Tree String -> (Tree String -> String) -> String
forall a b. a -> (a -> b) -> b
& Tree String -> String
Tree.drawTree
    String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
stringToText

prettyErrorTrees :: NonEmpty ErrorTree -> Text
prettyErrorTrees :: NonEmpty ErrorTree -> Text
prettyErrorTrees NonEmpty ErrorTree
forest =
  NonEmpty ErrorTree
forest
    NonEmpty ErrorTree
-> (ErrorTree -> Tree Error) -> NonEmpty (Tree Error)
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (.unErrorTree)
    NonEmpty (Tree Error)
-> (Tree Error -> Tree Text) -> NonEmpty (Tree Text)
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (Error -> Text) -> Tree Error -> Tree Text
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Error -> Text
prettyError
    NonEmpty (Tree Text)
-> (Tree Text -> Tree String) -> NonEmpty (Tree String)
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (Text -> String) -> Tree Text -> Tree String
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
textToString
    NonEmpty (Tree String)
-> (NonEmpty (Tree String) -> [Tree String]) -> [Tree String]
forall a b. a -> (a -> b) -> b
& NonEmpty (Tree String) -> [Tree String]
forall a. NonEmpty a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList
    [Tree String] -> ([Tree String] -> String) -> String
forall a b. a -> (a -> b) -> b
& [Tree String] -> String
Tree.drawForest
    String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
stringToText

-- | Sometimes, ErrorTrees can get very large.
-- In that case, it’s recommended to first think about whether you can e.g. chunk the validation logic.
--
-- But even so, restricting the size of the `ErrorTree` before printing it is often a good idea.
--
-- This will make sure the given `maxlength` and `maxdepth` are not exceeded, and insert warnings if some subtree was elided.
restrictErrorTree ::
  ( HasField "maxlength" dat Natural,
    HasField "maxdepth" dat Natural
  ) =>
  dat ->
  ErrorTree ->
  ErrorTree
restrictErrorTree :: forall dat.
(HasField "maxlength" dat Natural,
 HasField "maxdepth" dat Natural) =>
dat -> ErrorTree -> ErrorTree
restrictErrorTree dat
dat (ErrorTree Tree Error
t) = Tree Error -> ErrorTree
ErrorTree (Tree Error -> ErrorTree) -> Tree Error -> ErrorTree
forall a b. (a -> b) -> a -> b
$ Natural -> Tree Error -> Tree Error
go Natural
0 Tree Error
t
  where
    go :: Natural -> Tree.Tree Error -> Tree.Tree Error
    go :: Natural -> Tree Error -> Tree Error
go Natural
curDepth (Tree.Node Error
a [Tree Error]
children) = do
      let maxlengthInt :: Int
maxlengthInt = dat
dat.maxlength Natural -> (Natural -> Int) -> Int
forall a b. a -> (a -> b) -> b
& forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Int
      let childplusone :: Seq (Tree Error)
childplusone = [Tree Error]
children [Tree Error] -> ([Tree Error] -> [Tree Error]) -> [Tree Error]
forall a b. a -> (a -> b) -> b
& Int -> [Tree Error] -> [Tree Error]
forall a. Int -> [a] -> [a]
List.take (Int
maxlengthInt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Tree Error]
-> ([Tree Error] -> Seq (Tree Error)) -> Seq (Tree Error)
forall a b. a -> (a -> b) -> b
& [Tree Error] -> Seq (Tree Error)
forall a. [a] -> Seq a
Seq.fromList
      if Natural
curDepth Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== dat
dat.maxdepth
        then Error -> [Tree Error] -> Tree Error
forall a. a -> [Tree a] -> Tree a
Tree.Node Error
a [Error -> [Tree Error] -> Tree Error
forall a. a -> [Tree a] -> Tree a
Tree.Node [fmt|<More errors, max depth reached ({dat.maxdepth})>|] []]
        else
          Error -> [Tree Error] -> Tree Error
forall a. a -> [Tree a] -> Tree a
Tree.Node Error
a ([Tree Error] -> Tree Error) -> [Tree Error] -> Tree Error
forall a b. (a -> b) -> a -> b
$
            (Tree Error -> Tree Error) -> [Tree Error] -> [Tree Error]
forall a b. (a -> b) -> [a] -> [b]
map (Natural -> Tree Error -> Tree Error
go (Natural
curDepth Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1)) ([Tree Error] -> [Tree Error]) -> [Tree Error] -> [Tree Error]
forall a b. (a -> b) -> a -> b
$
              Seq (Tree Error) -> [Tree Error]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (Seq (Tree Error) -> [Tree Error])
-> Seq (Tree Error) -> [Tree Error]
forall a b. (a -> b) -> a -> b
$
                if Seq (Tree Error) -> Int
forall a. Seq a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
List.length Seq (Tree Error)
childplusone Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxlengthInt
                  then
                    ( ( Int -> Seq (Tree Error) -> Seq (Tree Error)
forall a. Int -> Seq a -> Seq a
Seq.take Int
maxlengthInt Seq (Tree Error)
childplusone
                          Seq (Tree Error) -> Tree Error -> Seq (Tree Error)
forall a. Seq a -> a -> Seq a
Seq.:|> (Error -> [Tree Error] -> Tree Error
forall a. a -> [Tree a] -> Tree a
Tree.Node [fmt|<More errors, max length reached ({dat.maxlength})>|] [])
                      )
                    )
                  else Seq (Tree Error)
childplusone