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

{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_HADDOCK hide #-}

module Data.Aeson.Extra where

import           Control.Exception    (throw)
import qualified Data.IntMap          as IntMap
import           Data.IntMap          (IntMap)
import qualified Data.Ix              as Ix
import qualified Data.Text            as T
import           Data.Text            (Text,pack,unpack)
import qualified Data.Text.Lazy       as LT
import qualified Data.Text.Lazy.Encoding as LT
import           Data.Text.Encoding.Error (UnicodeException(..))
import           Data.List            (intercalate)
import           Data.List.Extra      (groupOn)
import           Data.Tuple.Extra     (second, first)
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 qualified Data.Yaml            as Yaml
import           System.FilePath      ()

import qualified Clash.Util.Interpolate as I
import           Clash.Util           (ClashException(..))
#if MIN_VERSION_ghc(9,0,0)
import           GHC.Types.SrcLoc     (mkGeneralSrcSpan)
import           GHC.Data.FastString  (mkFastString)
#else
import           SrcLoc               (mkGeneralSrcSpan)
import           FastString           (mkFastString)
#endif
import           GHC.Stack            (HasCallStack)

-- | See 'toSpecNewlines'. A line map maps "virtual" lines to a range of
-- "real" lines. E.g., a map of {0: (0, 3), 1: (4, 5)} would mean that line
-- 0 in the virtual JSON (i.e., the one with newlines replaced) file map to
-- lines 0 up to and including 3 in the original user-supplied one.
type LineMap = IntMap (Int, Int)

-- | Aeson versions <1.5.0 accept unescaped newlines in JSON strings. This is in
-- violation of RFC 7159. Aeson 1.5.0 fixes this bug. Unfortunately, "Clash
-- JSON" files rely on the old behavior. This function replaces newlines (in
-- strings) with their escaped variants.
toSpecNewlines
  :: ByteString
  -> Either UnicodeException (LineMap, ByteString)
toSpecNewlines :: ByteString -> Either UnicodeException (LineMap, ByteString)
toSpecNewlines ByteString
bs = do
 String
s0 <- Text -> String
LT.unpack (Text -> String)
-> Either UnicodeException Text -> Either UnicodeException String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either UnicodeException Text
LT.decodeUtf8' ByteString
bs
 (LineMap, ByteString)
-> Either UnicodeException (LineMap, ByteString)
forall a b. b -> Either a b
Right ( [Int] -> LineMap
toLineMap (Int -> Bool -> String -> [Int]
go2 Int
0 Bool
False String
s0)
       , Text -> ByteString
LT.encodeUtf8 (String -> Text
LT.pack (Bool -> String -> String
go Bool
False String
s0)))
 where
  -- replace newlines with escaped ones
  go :: Bool -> String -> String
  go :: Bool -> String -> String
go Bool
_ [] = []
  go Bool
True (Char
'\n':String
rest) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'n' Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
True String
rest
  go Bool
True (Char
'\r':String
rest) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'r' Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
True String
rest
  go Bool
True (Char
'\t':String
rest) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
't' Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
True String
rest
  go Bool
inString (Char
'\\':Char
r:String
rest) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
r Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
inString String
rest
  go Bool
inString (Char
'"':String
rest) = Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
go (Bool -> Bool
not Bool
inString) String
rest
  go Bool
inString (Char
r:String
rest) = Char
r Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
go Bool
inString String
rest

  -- Calculate real:virtual mapping
  go2
    -- virtual line counter.
    :: Int
    -- Processing a JSON string?
    -> Bool
    -- String left to process
    -> String
    -- Virtual line numbers. [0, 1, 1, 2, 2, ..] would mean:
    --
    --  real | virtual
    --  --------------
    --     0 |       0
    --     1 |       1
    --     2 |       1
    --     3 |       2
    --     4 |       2
    --   ... |     ...
    --
    -> [Int]
  go2 :: Int -> Bool -> String -> [Int]
go2 Int
n Bool
_        [] = [Int
n]
  go2 Int
n Bool
True     (Char
'\n':String
rest) = Int
n Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> Bool -> String -> [Int]
go2 Int
n Bool
True String
rest
  go2 Int
n Bool
False    (Char
'\n':String
rest) = Int
n Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> Bool -> String -> [Int]
go2 (Int -> Int
forall a. Enum a => a -> a
succ Int
n) Bool
False String
rest
  go2 Int
n Bool
inString (Char
'\\':Char
_:String
rest) = Int -> Bool -> String -> [Int]
go2 Int
n Bool
inString String
rest
  go2 Int
n Bool
inString (Char
'"':String
rest) = Int -> Bool -> String -> [Int]
go2 Int
n (Bool -> Bool
not Bool
inString) String
rest
  go2 Int
n Bool
inString (Char
_:String
rest) = Int -> Bool -> String -> [Int]
go2 Int
n Bool
inString String
rest

  toLineMap :: [Int] -> LineMap
  toLineMap :: [Int] -> LineMap
toLineMap [Int]
virtuals =
      [(Int, (Int, Int))] -> LineMap
forall a. [(Int, a)] -> IntMap a
IntMap.fromList
    ([(Int, (Int, Int))] -> LineMap) -> [(Int, (Int, Int))] -> LineMap
forall a b. (a -> b) -> a -> b
$ ((Int, [Int]) -> (Int, (Int, Int)))
-> [(Int, [Int])] -> [(Int, (Int, Int))]
forall a b. (a -> b) -> [a] -> [b]
map (([Int] -> (Int, Int)) -> (Int, [Int]) -> (Int, (Int, Int))
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (\[Int]
reals -> ([Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
reals, [Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
reals)))
    ([(Int, [Int])] -> [(Int, (Int, Int))])
-> [(Int, [Int])] -> [(Int, (Int, Int))]
forall a b. (a -> b) -> a -> b
$ ([(Int, Int)] -> (Int, [Int])) -> [[(Int, Int)]] -> [(Int, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map (([Int] -> Int) -> ([Int], [Int]) -> (Int, [Int])
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first [Int] -> Int
forall a. [a] -> a
head (([Int], [Int]) -> (Int, [Int]))
-> ([(Int, Int)] -> ([Int], [Int])) -> [(Int, Int)] -> (Int, [Int])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Int)] -> ([Int], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip)
    ([[(Int, Int)]] -> [(Int, [Int])])
-> [[(Int, Int)]] -> [(Int, [Int])]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Int) -> [(Int, Int)] -> [[(Int, Int)]]
forall k a. Eq k => (a -> k) -> [a] -> [[a]]
groupOn (Int, Int) -> Int
forall a b. (a, b) -> a
fst
    ([(Int, Int)] -> [[(Int, Int)]]) -> [(Int, Int)] -> [[(Int, Int)]]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
virtuals [(Int
0::Int)..]

genLineErr' :: [Text] -> (Int, Int) -> [Int] -> Text
genLineErr' :: [Text] -> (Int, Int) -> [Int] -> Text
genLineErr' [Text]
allLines (Int, Int)
range [Int]
errorLines =
  [Text] -> Text
T.unlines [ [Text] -> Text
T.concat [ if Int -> [Int] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
elem Int
i [Int]
errorLines then String -> Text
pack String
">> " else  String -> Text
pack String
"   "
            , 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            , String -> Text
pack String
". "
            , [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 :: LineMap -> ByteString -> ByteString -> ByteString -> Text
genLineErr :: LineMap -> ByteString -> ByteString -> ByteString -> Text
genLineErr LineMap
lineMap ByteString
fullOrig ByteString
full ByteString
part =
    [Text] -> (Int, Int) -> [Int] -> Text
genLineErr' [Text]
allLinesOrig (Int, Int)
interval [Int
errorLineMin..Int
errorLineMax]
  where
    -- Determine error line in "virtual" json file
    nLastLines :: Int
nLastLines = Int
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]
LT.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
LT.decodeUtf8 ByteString
part)
    errorLineN :: Int
errorLineN = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([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
1) ([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
+ Int
1)
    allLines :: [Text]
allLines   = Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
LT.decodeUtf8 ByteString
full

    -- Convert to error lines in actual json file, and calculate interval
    -- to display to user.
    allLinesOrig :: [Text]
allLinesOrig = Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
LT.decodeUtf8 ByteString
fullOrig
    (Int
errorLineMin, Int
errorLineMax) = LineMap
lineMap LineMap -> Int -> (Int, Int)
forall a. IntMap a -> Int -> a
IntMap.! Int
errorLineN
    interval :: (Int, Int)
interval = ( Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
errorLineMin Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
5)
               , Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
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]
allLinesOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
errorLineMax Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5) )

-- | Parse a ByteString according to the given JSON template. Throws exception
-- if it fails.
decodeOrErrYaml
  :: (HasCallStack, FromJSON a)
  => FilePath
  -- ^ Path read from (for error message)
  -> ByteString
  -- ^ Bytestring to parse
  -> a
decodeOrErrYaml :: String -> ByteString -> a
decodeOrErrYaml String
path ByteString
contents =
  case ByteString -> Either ParseException a
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' (ByteString -> ByteString
BS.toStrict ByteString
contents) of
    Left (ParseException -> String
Yaml.prettyPrintParseException -> String
err) -> String -> a
forall a. String -> a
clashError [I.i|
      Failed to decode YAML:

        #{path}

      Decoder reported:

        #{err}
    |]
    Right a
a -> a
a
 where
  clashError :: String -> a
clashError String
msg = ClashException -> a
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
loc String
msg Maybe String
forall a. Maybe a
Nothing)
  loc :: SrcSpan
loc = FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
mkFastString String
path)

-- | Parse a ByteString according to the given JSON template. Throws exception
-- if it fails.
decodeOrErrJson
  :: (HasCallStack, FromJSON a)
  => FilePath
  -- ^ Path read from (for error message)
  -> ByteString
  -- ^ Bytestring to parse
  -> a
decodeOrErrJson :: String -> ByteString -> a
decodeOrErrJson String
path ByteString
contents0 =
  case ByteString -> Either UnicodeException (LineMap, ByteString)
toSpecNewlines ByteString
contents0 of
    Left (DecodeError String
err Maybe Word8
_) -> String -> a
forall a. String -> a
clashError [I.i|
      Failed to decode JSON file as UTF8:

        #{path}

      Decoder reported:

        #{err}
    |]
    Left UnicodeException
_ -> String -> a
forall a. HasCallStack => String -> a
error String
"unreachable"
    Right (!LineMap
lineMap, !ByteString
contents1) ->
      case Parser Value -> ByteString -> Result Value
forall a. Parser a -> ByteString -> Result a
parse Parser Value
json ByteString
contents1 of
        Done ByteString
leftover Value
v ->
          case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
            Success a
_ | (Word8 -> Bool) -> ByteString -> Bool
BS.any Word8 -> Bool
notWhitespace ByteString
leftover ->
              String -> a
forall a. String -> a
clashError (String
"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]
++ String
", found unparsed trailing garbage:\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BSChar.unpack ByteString
leftover)
            Success a
a ->
              a
a
            Error String
msg ->
              String -> a
forall a. String -> a
clashError
                ( String
"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]
++ String
". Error was: \n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg )

        -- JSON parse error:
        Fail ByteString
bytes [String]
cntxs String
msg ->
          String -> a
forall a. String -> a
clashError
            ( String
"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 -> String
forall a. [a] -> [a] -> [a]
++ (if [String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [String]
cntxs then String
"" else String
"Context was:\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n  " [String]
cntxs)
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\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]
++ String
"\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
$ LineMap -> ByteString -> ByteString -> ByteString -> Text
genLineErr LineMap
lineMap ByteString
contents0 ByteString
contents1 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 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 Word8
c = Word8 -> ByteString -> Bool
BS.notElem Word8
c ByteString
whitespace
      where whitespace :: ByteString
whitespace = String -> ByteString
BSChar.pack String
" \t\n\r"