{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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 = forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (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 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 (forall a. SmallArray a -> Int -> a
PM.indexSmallArray SmallArray Error
errArr Int
0)
      forall a. Semigroup a => a -> a -> a
<>
      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
' ' forall a. Semigroup a => a -> a -> a
<> Error -> Builder
Error.builderUtf8 Error
e)
        (forall (arr :: * -> *) a.
(Contiguous arr, Element arr a) =>
arr a -> Int -> Int -> Sliced arr a
Arr.slice SmallArray Error
errArr Int
1 (Int
len 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 = 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 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 =
  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 a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
  SmallMutableArray (PrimState (ST s)) Error
dst <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
len forall a. a
makeErrorArrayErrorThunk
  let go :: Int -> Errors -> ST s Int
go !Int
ix Errors
errs = case Errors
errs of
        ErrorsOne Error
e -> do
          forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray (PrimState (ST s)) Error
dst Int
ix Error
e
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix 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 forall a. Eq a => a -> a -> Bool
== Int
len
    then forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray (PrimState (ST s)) Error
dst
    else 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 = 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 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)))