    {-|
      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.NonEmpty   (NonEmpty (..))
    import qualified Data.List.NonEmpty   as NE
    import           Data.Tuple.Extra     (second, first)
    import           Data.Aeson           (FromJSON, Result (..), fromJSON)
    import           Data.Aeson.Parser    (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 [] = LineMap
    forall a. IntMap a
    IntMap.empty
      toLineMap (Int
    v:[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, NonEmpty Int) -> (Int, (Int, Int)))
    -> [(Int, NonEmpty Int)] -> [(Int, (Int, Int))]
    forall a b. (a -> b) -> [a] -> [b]
    map ((NonEmpty Int -> (Int, Int))
    -> (Int, NonEmpty Int) -> (Int, (Int, Int))
    forall b b' a. (b -> b') -> (a, b) -> (a, b')
    second (\NonEmpty Int
    reals -> (NonEmpty Int -> Int
    forall a. Ord a => NonEmpty a -> a
    forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
    minimum NonEmpty Int
    reals, NonEmpty Int -> Int
    forall a. Ord a => NonEmpty a -> a
    forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
    maximum NonEmpty Int
    reals)))
        ([(Int, NonEmpty Int)] -> [(Int, (Int, Int))])
    -> [(Int, NonEmpty Int)] -> [(Int, (Int, Int))]
    forall a b. (a -> b) -> a -> b
    $ (NonEmpty (Int, Int) -> (Int, NonEmpty Int))
    -> [NonEmpty (Int, Int)] -> [(Int, NonEmpty Int)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((NonEmpty Int -> Int)
    -> (NonEmpty Int, NonEmpty Int) -> (Int, NonEmpty Int)
    forall a a' b. (a -> a') -> (a, b) -> (a', b)
    first NonEmpty Int -> Int
    forall a. NonEmpty a -> a
    NE.head ((NonEmpty Int, NonEmpty Int) -> (Int, NonEmpty Int))
    -> (NonEmpty (Int, Int) -> (NonEmpty Int, NonEmpty Int))
    -> NonEmpty (Int, Int)
    -> (Int, NonEmpty Int)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . NonEmpty (Int, Int) -> (NonEmpty Int, NonEmpty Int)
    forall (f :: Type -> Type) a b. Functor f => f (a, b) -> (f a, f b)
    NE.unzip)
        ([NonEmpty (Int, Int)] -> [(Int, NonEmpty Int)])
    -> [NonEmpty (Int, Int)] -> [(Int, NonEmpty Int)]
    forall a b. (a -> b) -> a -> b
    $ ((Int, Int) -> (Int, Int) -> Bool)
    -> NonEmpty (Int, Int) -> [NonEmpty (Int, Int)]
    forall (f :: Type -> Type) a.
    Foldable f =>
    (a -> a -> Bool) -> f a -> [NonEmpty a]
    NE.groupBy (\(Int
    a,Int
    _) (Int
    b,Int
    _) -> Int
    a Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    b)
        (NonEmpty (Int, Int) -> [NonEmpty (Int, Int)])
    -> NonEmpty (Int, Int) -> [NonEmpty (Int, Int)]
    forall a b. (a -> b) -> a -> b
    $ NonEmpty Int -> NonEmpty Int -> NonEmpty (Int, Int)
    forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
    NE.zip (Int
    v Int -> [Int] -> NonEmpty Int
    forall a. a -> [a] -> NonEmpty a
    :| [Int]
    virtuals) ((Int -> Int) -> Int -> NonEmpty Int
    forall a. (a -> a) -> a -> NonEmpty a
    NE.iterate (Int -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) (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 a. Eq a => a -> [a] -> 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. HasCallStack => [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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 :: forall a. (HasCallStack, FromJSON a) => 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 :: forall a. (HasCallStack, FromJSON a) => 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 a. [a] -> 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"