{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}

module Json.Errors
  ( -- * Types
    Errors

    -- * Encoding
  , encode
  , builderUtf8
  , hPut

    -- * Create
  , singleton

    -- * Conversion
  , toSmallArray
  ) where

import Control.Monad.ST (runST)
import Data.ByteString.Short.Internal (ShortByteString (SBS))
import Data.Bytes.Builder (Builder)
import Data.Primitive (SmallArray)
import Data.Text.Short (ShortText)
import Json.Error (Error)
import System.IO (Handle)

import qualified Data.Bytes.Builder as Builder
import qualified Data.Bytes.Chunks as ByteChunks
import qualified Data.Primitive as PM
import qualified Data.Primitive.Contiguous as Arr
import qualified Data.Text.Short.Unsafe as TS
import qualified GHC.Exts as Exts
import qualified Json.Error as Error

-- | A builder for errors that support efficient concatenation.
data Errors
  = ErrorsOne !Error
  | ErrorsPlus !Errors !Errors

instance Semigroup Errors where
  <> :: Errors -> Errors -> Errors
(<>) = Errors -> Errors -> Errors
ErrorsPlus

instance Show Errors where
  showsPrec :: Int -> Errors -> ShowS
showsPrec Int
d Errors
x = Int -> [Error] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (SmallArray Error -> [Item (SmallArray Error)]
forall l. IsList l => l -> [Item l]
Exts.toList (Errors -> SmallArray Error
toSmallArray Errors
x))

instance Eq Errors where
  Errors
x == :: Errors -> Errors -> Bool
== Errors
y = Errors -> SmallArray Error
toSmallArray Errors
x SmallArray Error -> SmallArray Error -> Bool
forall a. Eq a => a -> a -> Bool
== Errors -> SmallArray Error
toSmallArray Errors
y

singleton :: Error -> Errors
singleton :: Error -> Errors
singleton = Error -> Errors
ErrorsOne

{- | Convert errors to builder. The errors are separated by
a pair of characters: comma and space.
-}
builderUtf8 :: Errors -> Builder
builderUtf8 :: Errors -> Builder
builderUtf8 Errors
errs =
  let len :: Int
len = Errors -> Int
countErrors Errors
errs
      errArr :: SmallArray Error
errArr = Int -> Errors -> SmallArray Error
makeErrorArray Int
len Errors
errs
   in Error -> Builder
Error.builderUtf8 (SmallArray Error -> Int -> Error
forall a. SmallArray a -> Int -> a
PM.indexSmallArray SmallArray Error
errArr Int
0)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Error -> Builder) -> Slice SmallArray Error -> Builder
forall (arr :: * -> *) a m.
(Contiguous arr, Element arr a, Monoid m) =>
(a -> m) -> arr a -> m
Arr.foldMap
          (\Error
e -> Char -> Char -> Builder
Builder.ascii2 Char
',' Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Error -> Builder
Error.builderUtf8 Error
e)
          (SmallArray Error -> Int -> Int -> Sliced SmallArray Error
forall a.
Element SmallArray a =>
SmallArray a -> Int -> Int -> Sliced SmallArray a
forall (arr :: * -> *) a.
(Contiguous arr, Element arr a) =>
arr a -> Int -> Int -> Sliced arr a
Arr.slice SmallArray Error
errArr Int
1 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

{- | Print errors to the provided handle. Typically, @System.IO.stderr@
is provided as the handle. Each encoded error is suffixed with a newline.

This is a convenience function for the common case where, after a
failed parse, an application prints out all parse errors and then exits.
-}
hPut :: Handle -> Errors -> IO ()
hPut :: Handle -> Errors -> IO ()
hPut Handle
h Errors
errs = do
  let len :: Int
len = Errors -> Int
countErrors Errors
errs
      errArr :: SmallArray Error
errArr = Int -> Errors -> SmallArray Error
makeErrorArray Int
len Errors
errs
      bldr :: Builder
bldr =
        (Error -> Builder) -> SmallArray Error -> Builder
forall (arr :: * -> *) a m.
(Contiguous arr, Element arr a, Monoid m) =>
(a -> m) -> arr a -> m
Arr.foldMap
          (\Error
e -> Error -> Builder
Error.builderUtf8 Error
e Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.ascii Char
'\n')
          SmallArray Error
errArr
   in Handle -> Chunks -> IO ()
ByteChunks.hPut Handle
h (Int -> Builder -> Chunks
Builder.run Int
128 Builder
bldr)

-- | Convert errors to array.
toSmallArray :: Errors -> SmallArray Error
toSmallArray :: Errors -> SmallArray Error
toSmallArray Errors
e = Int -> Errors -> SmallArray Error
makeErrorArray (Errors -> Int
countErrors Errors
e) Errors
e

makeErrorArrayErrorThunk :: a
{-# NOINLINE makeErrorArrayErrorThunk #-}
makeErrorArrayErrorThunk :: forall a. a
makeErrorArrayErrorThunk =
  String -> a
forall a. String -> a
errorWithoutStackTrace String
"Json.Arrow.makeErrorArray: implementation mistake"

makeErrorArray :: Int -> Errors -> SmallArray Error
makeErrorArray :: Int -> Errors -> SmallArray Error
makeErrorArray !Int
len Errors
errs0 = (forall s. ST s (SmallArray Error)) -> SmallArray Error
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (SmallArray Error)) -> SmallArray Error)
-> (forall s. ST s (SmallArray Error)) -> SmallArray Error
forall a b. (a -> b) -> a -> b
$ do
  SmallMutableArray (PrimState (ST s)) Error
dst <- Int -> Error -> ST s (SmallMutableArray (PrimState (ST s)) Error)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
len Error
forall a. a
makeErrorArrayErrorThunk
  let go :: Int -> Errors -> ST s Int
go !Int
ix Errors
errs = case Errors
errs of
        ErrorsOne Error
e -> do
          SmallMutableArray (PrimState (ST s)) Error
-> Int -> Error -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray (PrimState (ST s)) Error
dst Int
ix Error
e
          Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        ErrorsPlus Errors
a Errors
b -> do
          Int
ix' <- Int -> Errors -> ST s Int
go Int
ix Errors
a
          Int -> Errors -> ST s Int
go Int
ix' Errors
b
  !Int
finalIx <- Int -> Errors -> ST s Int
go Int
0 Errors
errs0
  if Int
finalIx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len
    then SmallMutableArray (PrimState (ST s)) Error
-> ST s (SmallArray Error)
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray (PrimState (ST s)) Error
dst
    else String -> ST s (SmallArray Error)
forall a. String -> a
errorWithoutStackTrace String
"Json.Arrow.makeErrorArray: other impl mistake"

-- postcondition: results is greater than 0.
countErrors :: Errors -> Int
countErrors :: Errors -> Int
countErrors = Errors -> Int
forall {a}. Num a => Errors -> a
go
 where
  go :: Errors -> a
go ErrorsOne {} = a
1
  go (ErrorsPlus Errors
a Errors
b) = Errors -> a
go Errors
a a -> a -> a
forall a. Num a => a -> a -> a
+ Errors -> a
go Errors
b

ba2st :: PM.ByteArray -> ShortText
{-# INLINE ba2st #-}
ba2st :: ByteArray -> ShortText
ba2st (PM.ByteArray ByteArray#
x) = ShortByteString -> ShortText
TS.fromShortByteStringUnsafe (ByteArray# -> ShortByteString
SBS ByteArray#
x)

encode :: Errors -> ShortText
encode :: Errors -> ShortText
encode Errors
p = ByteArray -> ShortText
ba2st (Chunks -> ByteArray
ByteChunks.concatU (Int -> Builder -> Chunks
Builder.run Int
128 (Errors -> Builder
builderUtf8 Errors
p)))