{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE Safe              #-}

-- |
-- Copyright: © Herbert Valerio Riedel 2015-2018
-- SPDX-License-Identifier: GPL-2.0-or-later
--
module Data.YAML.Pos
    ( Pos(..)
    , prettyPosWithSource
    ) where

import qualified Data.ByteString.Lazy     as BL
import qualified Data.YAML.Token.Encoding as Enc
import           Util

-- | Position in parsed YAML source
--
-- See also 'prettyPosWithSource'.
--
-- __NOTE__: if 'posCharOffset' is negative the 'Pos' value doesn't refer to a proper location; this may be emitted in corner cases when no proper location can be inferred.
data Pos = Pos
    { Pos -> Int
posByteOffset :: !Int -- ^ 0-based byte offset
    , Pos -> Int
posCharOffset :: !Int -- ^ 0-based character (Unicode code-point) offset
    , Pos -> Int
posLine       :: !Int -- ^ 1-based line number
    , Pos -> Int
posColumn     :: !Int -- ^ 0-based character (Unicode code-point) column number
    } deriving (Pos -> Pos -> Bool
(Pos -> Pos -> Bool) -> (Pos -> Pos -> Bool) -> Eq Pos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pos -> Pos -> Bool
$c/= :: Pos -> Pos -> Bool
== :: Pos -> Pos -> Bool
$c== :: Pos -> Pos -> Bool
Eq, Int -> Pos -> ShowS
[Pos] -> ShowS
Pos -> String
(Int -> Pos -> ShowS)
-> (Pos -> String) -> ([Pos] -> ShowS) -> Show Pos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pos] -> ShowS
$cshowList :: [Pos] -> ShowS
show :: Pos -> String
$cshow :: Pos -> String
showsPrec :: Int -> Pos -> ShowS
$cshowsPrec :: Int -> Pos -> ShowS
Show, (forall x. Pos -> Rep Pos x)
-> (forall x. Rep Pos x -> Pos) -> Generic Pos
forall x. Rep Pos x -> Pos
forall x. Pos -> Rep Pos x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Pos x -> Pos
$cfrom :: forall x. Pos -> Rep Pos x
Generic)

-- | @since 0.2.0
instance NFData Pos where rnf :: Pos -> ()
rnf !Pos
_ = ()

-- | Pretty prints a 'Pos' together with the line the 'Pos' refers and the column position.
--
-- The input 'BL.ByteString' must be the same that was passed to the
-- YAML decoding function that produced the 'Pos' value. The 'String'
-- argument is inserted right after the @<line>:<column>:@ in the
-- first line. The pretty-printed position result 'String' will be
-- terminated by a trailing newline.
--
-- For instance,
--
-- @
-- 'prettyPosWithSource' somePos someInput " error" ++ "unexpected character\\n"
-- @ results in
--
-- > 11:7: error
-- >     |
-- >  11 | foo: | bar
-- >     |        ^
-- > unexpected character
--
-- @since 0.2.1
prettyPosWithSource :: Pos -> BL.ByteString -> String -> String
prettyPosWithSource :: Pos -> ByteString -> ShowS
prettyPosWithSource Pos{..} source :: ByteString
source msg :: String
msg
  | Int
posCharOffset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 Bool -> Bool -> Bool
|| Int
posByteOffset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = "0:0:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" -- unproper location
  | Bool
otherwise = [String] -> String
unlines
    [ Int -> String
forall a. Show a => a -> String
show Int
posLine String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
posColumn String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
    , String
lpfx
    , String
lnostr String -> ShowS
forall a. [a] -> [a] -> [a]
++ "| " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
line
    , String
lpfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
posColumn ' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ "^"
    ]

  where
    lnostr :: String
lnostr = " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
posLine String -> ShowS
forall a. [a] -> [a] -> [a]
++ " "
    lpfx :: String
lpfx   = (' ' Char -> ShowS
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String
lnostr) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "| "

    (_,lstart :: [(Int, Char)]
lstart) = Int -> ByteString -> (Int, [(Int, Char)])
findLineStartByByteOffset Int
posByteOffset ByteString
source
    line :: String
line = ((Int, Char) -> Char) -> [(Int, Char)] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int, Char) -> Char
forall a b. (a, b) -> b
snd ([(Int, Char)] -> String) -> [(Int, Char)] -> String
forall a b. (a -> b) -> a -> b
$ ((Int, Char) -> Bool) -> [(Int, Char)] -> [(Int, Char)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> ((Int, Char) -> Bool) -> (Int, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isNL (Char -> Bool) -> ((Int, Char) -> Char) -> (Int, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Char) -> Char
forall a b. (a, b) -> b
snd) [(Int, Char)]
lstart

    isNL :: Char -> Bool
isNL c :: Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\r' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n'

findLineStartByByteOffset :: Int -> BL.ByteString -> (Int,[(Int,Char)])
findLineStartByByteOffset :: Int -> ByteString -> (Int, [(Int, Char)])
findLineStartByByteOffset bofs0 :: Int
bofs0 input :: ByteString
input = Int -> [(Int, Char)] -> [(Int, Char)] -> (Int, [(Int, Char)])
go 0 [(Int, Char)]
inputChars [(Int, Char)]
inputChars
  where
    (_,inputChars :: [(Int, Char)]
inputChars) = ByteString -> (Encoding, [(Int, Char)])
Enc.decode ByteString
input

    go :: Int -> [(Int, Char)] -> [(Int, Char)] -> (Int, [(Int, Char)])
go lsOfs :: Int
lsOfs lsChars :: [(Int, Char)]
lsChars [] = (Int
lsOfs,[(Int, Char)]
lsChars)
    go lsOfs :: Int
lsOfs lsChars :: [(Int, Char)]
lsChars ((ofs' :: Int
ofs',_):_)
      | Int
bofs0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ofs' = (Int
lsOfs,[(Int, Char)]
lsChars)

    go _ _ ((_,'\r'):(ofs' :: Int
ofs','\n'):rest :: [(Int, Char)]
rest) = Int -> [(Int, Char)] -> [(Int, Char)] -> (Int, [(Int, Char)])
go Int
ofs' [(Int, Char)]
rest [(Int, Char)]
rest
    go _ _ ((ofs' :: Int
ofs','\r'):rest :: [(Int, Char)]
rest) = Int -> [(Int, Char)] -> [(Int, Char)] -> (Int, [(Int, Char)])
go Int
ofs' [(Int, Char)]
rest [(Int, Char)]
rest
    go _ _ ((ofs' :: Int
ofs','\n'):rest :: [(Int, Char)]
rest) = Int -> [(Int, Char)] -> [(Int, Char)] -> (Int, [(Int, Char)])
go Int
ofs' [(Int, Char)]
rest [(Int, Char)]
rest
    go lsOfs :: Int
lsOfs lsChars :: [(Int, Char)]
lsChars (_:rest :: [(Int, Char)]
rest) = Int -> [(Int, Char)] -> [(Int, Char)] -> (Int, [(Int, Char)])
go Int
lsOfs [(Int, Char)]
lsChars [(Int, Char)]
rest