clash-lib-1.4.0: src/Data/Aeson/Extra.hs
{-|
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 #-}
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 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
-- stings) with their escaped variants.
toSpecNewlines
:: ByteString
-> Either UnicodeException (LineMap, ByteString)
toSpecNewlines bs = do
s0 <- LT.unpack <$> LT.decodeUtf8' bs
Right ( toLineMap (go2 0 False s0)
, LT.encodeUtf8 (LT.pack (go False s0)))
where
-- replace newlines with escaped ones
go :: Bool -> String -> String
go _ [] = []
go True ('\n':rest) = '\\' : 'n' : go True rest
go True ('\r':rest) = '\\' : 'r' : go True rest
go True ('\t':rest) = '\\' : 't' : go True rest
go inString ('\\':r:rest) = '\\' : r : go inString rest
go inString ('"':rest) = '"' : go (not inString) rest
go inString (r:rest) = r : go inString 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 n _ [] = [n]
go2 n True ('\n':rest) = n : go2 n True rest
go2 n False ('\n':rest) = n : go2 (succ n) False rest
go2 n inString ('\\':_:rest) = go2 n inString rest
go2 n inString ('"':rest) = go2 n (not inString) rest
go2 n inString (_:rest) = go2 n inString rest
toLineMap :: [Int] -> LineMap
toLineMap virtuals =
IntMap.fromList
$ map (second (\reals -> (minimum reals, maximum reals)))
$ map (first head . unzip)
$ groupOn fst
$ zip virtuals [(0::Int)..]
genLineErr' :: [Text] -> (Int, Int) -> [Int] -> Text
genLineErr' allLines range errorLines =
T.unlines [ T.concat [ if elem i errorLines then pack ">> " else pack " "
, pack $ show (i + 1)
, pack ". "
, allLines !! i
] | i <- Ix.range range]
-- | Pretty print part of json file related to error
genLineErr :: LineMap -> ByteString -> ByteString -> ByteString -> Text
genLineErr lineMap fullOrig full part =
genLineErr' allLinesOrig interval [errorLineMin..errorLineMax]
where
-- Determine error line in "virtual" json file
nLastLines = 1 + (length $ LT.lines $ LT.decodeUtf8 part)
errorLineN = min (length allLines - 1) (length allLines - nLastLines + 1)
allLines = T.lines $ LT.toStrict $ LT.decodeUtf8 full
-- Convert to error lines in actual json file, and calculate interval
-- to display to user.
allLinesOrig = T.lines $ LT.toStrict $ LT.decodeUtf8 fullOrig
(errorLineMin, errorLineMax) = lineMap IntMap.! errorLineN
interval = ( max 0 (errorLineMin - 5)
, min (max 0 $ length allLinesOrig - 1) (errorLineMax + 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 path contents0 =
case toSpecNewlines contents0 of
Left (DecodeError err _) -> clashError [I.i|
Failed to decode JSON file as UTF8:
#{path}
Decoder reported:
#{err}
|]
Left _ -> error "unreachable"
Right (!lineMap, !contents1) ->
case parse json contents1 of
Done leftover v ->
case fromJSON v of
Success _ | BS.any notWhitespace leftover ->
clashError ("After parsing " ++ show path
++ ", found unparsed trailing garbage:\n"
++ BSChar.unpack leftover)
Success a ->
a
Error msg ->
clashError
( "Could not deduce valid scheme for json in "
++ show path ++ ". Error was: \n\n" ++ msg )
-- JSON parse error:
Fail bytes cntxs msg ->
clashError
( "Could not read or parse json in " ++ show path ++ ". "
++ (if null cntxs then "" else "Context was:\n " ++ intercalate "\n " cntxs)
++ "\n\nError reported by Attoparsec was:\n "
++ msg
++ "\n\nApproximate location of error:\n\n"
-- HACK: Replace with proper parser/fail logic in future. Or don't. It's not important.
++ (unpack $ genLineErr lineMap contents0 contents1 bytes) )
where
loc = mkGeneralSrcSpan $ mkFastString path
clashError msg = throw $ ClashException loc msg Nothing
notWhitespace c = BS.notElem c whitespace
where whitespace = BSChar.pack " \t\n\r"