{-|
  Copyright   :  (C) 2015-2016, University of Twente
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}

module Data.Aeson.Extra where

import           Control.Exception    (throw)
import qualified Data.Ix              as Ix
import qualified Data.Text            as T
import           Data.Text            (Text,pack,unpack)
import           Data.List            (intercalate)
import           Data.Aeson           (FromJSON, Result (..), fromJSON, json)
import           Data.Attoparsec.Lazy (Result (..), parse)
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BSChar
import           System.FilePath      ()

import           Clash.Util           (ClashException(..))
import           SrcLoc               (mkGeneralSrcSpan)
import           FastString           (mkFastString)
import           GHC.Stack            (HasCallStack)

-- Quick and dirty way of replacing fake escapes in naively converted bytestring
replaceCommonEscapes :: Text -> Text
replaceCommonEscapes :: Text -> Text
replaceCommonEscapes = ( Text -> Text -> Text -> Text
T.replace (String -> Text
pack "\\n") (String -> Text
pack "\n") ) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       ( Text -> Text -> Text -> Text
T.replace (String -> Text
pack "\\\\") (String -> Text
pack "\\") ) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       ( Text -> Text -> Text -> Text
T.replace (String -> Text
pack "\\\"") (String -> Text
pack "\"") )

genLineErr' :: [Text] -> (Int, Int) -> Int -> Text
genLineErr' :: [Text] -> (Int, Int) -> Int -> Text
genLineErr' allLines :: [Text]
allLines range :: (Int, Int)
range errorLineN :: Int
errorLineN = [Text] -> Text
T.unlines [ [Text] -> Text
T.concat [ if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
errorLineN then String -> Text
pack ">> " else  String -> Text
pack "   "
                                                             , String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i
                                                             , String -> Text
pack ". "
                                                             , [Text]
allLines [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
i
                                                             ] | Int
i <- (Int, Int) -> [Int]
forall a. Ix a => (a, a) -> [a]
Ix.range (Int, Int)
range]

-- | Pretty print part of json file related to error
genLineErr :: ByteString -> ByteString -> Text
genLineErr :: ByteString -> ByteString -> Text
genLineErr full :: ByteString
full part :: ByteString
part = [Text] -> (Int, Int) -> Int -> Text
genLineErr' [Text]
allLines (Int, Int)
interval Int
errorLineN
  where
    -- Determine interval, and pass to helper function
    nLastLines :: Int
nLastLines = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([Text] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length ([Text] -> Int) -> [Text] -> Int
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
replaceCommonEscapes (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
part)
    errorLineN :: Int
errorLineN = [Text] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Text]
allLines Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nLastLines Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
    allLines :: [Text]
allLines   = Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
replaceCommonEscapes (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
full
    interval :: (Int, Int)
interval   = (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int
errorLineN Int -> Int -> Int
forall a. Num a => a -> a -> a
- 5), Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Text] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Text]
allLines Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int
errorLineN Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 5))

-- | Parse a ByteString according to the given JSON template. Throws exception
-- if it fails.
decodeOrErr
  :: (HasCallStack, FromJSON a)
  => FilePath
  -- ^ Path read from (for error message)
  -> ByteString
  -- ^ Bytestring to parse
  -> a
decodeOrErr :: String -> ByteString -> a
decodeOrErr path :: String
path contents :: ByteString
contents =
  case Parser Value -> ByteString -> Result Value
forall a. Parser a -> ByteString -> Result a
parse Parser Value
json ByteString
contents of
    Done leftover :: ByteString
leftover v :: Value
v ->
      case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
        Success _ | (Word8 -> Bool) -> ByteString -> Bool
BS.any Word8 -> Bool
notWhitespace ByteString
leftover ->
          String -> a
forall a. String -> a
clashError ("After parsing " String -> String -> String
forall a. [a] -> [a] -> [a]
++  String -> String
forall a. Show a => a -> String
show String
path
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", found unparsed trailing garbage:\n"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BSChar.unpack ByteString
leftover)
        Success a :: a
a ->
          a
a
        Error msg :: String
msg ->
          String -> a
forall a. String -> a
clashError
            ( "Could not deduce valid scheme for json in "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ ". Error was: \n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg )

    -- JSON parse error:
    Fail bytes :: ByteString
bytes cntxs :: [String]
cntxs msg :: String
msg ->
      String -> a
forall a. String -> a
clashError
        ( "Could not read or parse json in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ ". "
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if [String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
cntxs then "" else "Context was:\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n  " [String]
cntxs)
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\nError reported by Attoparsec was:\n  "
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\nApproximate location of error:\n\n"
       -- HACK: Replace with proper parser/fail logic in future. Or don't. It's not important.
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Text
genLineErr ByteString
contents ByteString
bytes) )
  where
    loc :: SrcSpan
loc = FastString -> SrcSpan
mkGeneralSrcSpan (FastString -> SrcSpan) -> FastString -> SrcSpan
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString String
path
    clashError :: String -> a
clashError msg :: String
msg = ClashException -> a
forall a e. Exception e => e -> a
throw (ClashException -> a) -> ClashException -> a
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
loc String
msg Maybe String
forall a. Maybe a
Nothing
    notWhitespace :: Word8 -> Bool
notWhitespace c :: Word8
c = Word8 -> ByteString -> Bool
BS.notElem Word8
c ByteString
whitespace
      where whitespace :: ByteString
whitespace = String -> ByteString
BSChar.pack " \t\n\r"