{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Helpers for the other modules.
--
-- This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Yamlet.Internal.Utils
  ( textStripPrefix
  , textIsPrefixOf
  , maxImplicitKeyLength
  , maxVersion
  , minExpansion
  , coreTagPrefix
  , picoDecimals
  , decimalPlaces
  , isHighSurrogate
  , isLowSurrogate
  , fromSurrogates
  , isScalarValue
  , xEscapeDigits
  , uEscapeDigits
  , bigUEscapeDigits
  , percentDigits
  , showText
  , strictPair
  , strictMap
  , firstOfResult
  ) where

import Data.Char
import Data.Fixed
import Data.Proxy
import Data.Text qualified as T
import Math.NumberTheory.Logarithms
import Numeric

#if !MIN_VERSION_text(2,1,4)
import Data.Text.Internal qualified as T
#endif

-- | 'Data.Text.stripPrefix'. Before text 2.1.4, 'Data.Text.stripPrefix'
-- compares the texts as streams of characters and allocates for each
-- character. For these versions this is the code of text 2.1.4, which
-- compares the UTF-8 bytes.
textStripPrefix :: T.Text -> T.Text -> Maybe T.Text
#if MIN_VERSION_text(2,1,4)
textStripPrefix :: Text -> Text -> Maybe Text
textStripPrefix = Text -> Text -> Maybe Text
T.stripPrefix
#else
textStripPrefix p@(T.Text _arr _off plen) t@(T.Text arr off len)
  | textIsPrefixOf p t = Just $! T.text arr (off + plen) (len - plen)
  | otherwise = Nothing
#endif

-- | 'Data.Text.isPrefixOf', with the code of text 2.1.4 as in
-- 'textStripPrefix'.
textIsPrefixOf :: T.Text -> T.Text -> Bool
#if MIN_VERSION_text(2,1,4)
textIsPrefixOf :: Text -> Text -> Bool
textIsPrefixOf = Text -> Text -> Bool
T.isPrefixOf
#else
textIsPrefixOf a@(T.Text _aArr _aOff aLen) b@(T.Text bArr bOff bLen) =
  d >= 0 && a == b'
  where
    d :: Int
    d = bLen - aLen

    b' :: T.Text
    b'
      | d == 0 = b
      | otherwise = T.Text bArr bOff aLen
#endif

-- | The largest number of characters of an implicit key, from the YAML 1.2.2
-- specification.
maxImplicitKeyLength :: Int
maxImplicitKeyLength :: Int
maxImplicitKeyLength = Int
1024

-- | The largest number in a version of a @%YAML@ directive.
--
-- Without a limit, the largest number depends on the size of Int, which
-- differs between architectures. The limit is far above any version of YAML,
-- and a number below it times 10 fits in 32 bits.
maxVersion :: Int
maxVersion :: Int
maxVersion = Int
1000000

-- | The size that an expansion of a small input can always add: the visits
-- that aliases add to a traversal, or the bytes that the prefixes of @%TAG@
-- directives add to the tags. A larger input can add as much as it has.
--
-- A traversal of 100000 nodes takes about 5 ms and 6 MB, measured with a
-- copy of the nodes. go-yaml allows about 400000 nodes from aliases in a
-- small document.
minExpansion :: Int
minExpansion :: Int
minExpansion = Int
100000

-- | The prefix of the tags of the core schema, and of the @!!@ handle.
coreTagPrefix :: T.Text
coreTagPrefix :: Text
coreTagPrefix = Text
"tag:yaml.org,2002:"

-- | The number of decimal places of 'Pico', the resolution of the durations of
-- the time library.
picoDecimals :: Int
picoDecimals :: Int
picoDecimals = Integer -> Int
integerLog10 (Proxy E12 -> Integer
forall k (a :: k) (p :: k -> *). HasResolution a => p a -> Integer
forall (p :: * -> *). p E12 -> Integer
resolution (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @E12))

-- | The number of decimal places of 1/n, or 'Nothing' if 1/n has no finite
-- decimal form. It has one if n is 2^a * 5^b, and then it needs max a b
-- places.
decimalPlaces :: Integer -> Maybe Int
decimalPlaces :: Integer -> Maybe Int
decimalPlaces Integer
n = if Integer
rest Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
twos Int
fives) else Maybe Int
forall a. Maybe a
Nothing
  where
    twos, fives :: Int
    afterTwos, rest :: Integer
    (Int
twos, Integer
afterTwos) = Integer -> Integer -> (Int, Integer)
factors Integer
2 Integer
n
    (Int
fives, Integer
rest) = Integer -> Integer -> (Int, Integer)
factors Integer
5 Integer
afterTwos

    -- The number of factors p of x, and x without them.
    factors :: Integer -> Integer -> (Int, Integer)
    factors :: Integer -> Integer -> (Int, Integer)
factors Integer
p = Int -> Integer -> (Int, Integer)
go Int
0
      where
        go :: Int -> Integer -> (Int, Integer)
        go :: Int -> Integer -> (Int, Integer)
go Int
i Integer
x = case Integer
x Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Integer
p of
          (Integer
q, Integer
0) | Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> Int -> Integer -> (Int, Integer)
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Integer
q
          (Integer, Integer)
_ -> (Int
i, Integer
x)

-- | The first code unit of a surrogate pair of UTF-16.
isHighSurrogate :: Int -> Bool
isHighSurrogate :: Int -> Bool
isHighSurrogate Int
u = Int
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xD800 Bool -> Bool -> Bool
&& Int
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xDBFF

-- | The second code unit of a surrogate pair of UTF-16.
isLowSurrogate :: Int -> Bool
isLowSurrogate :: Int -> Bool
isLowSurrogate Int
u = Int
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xDC00 Bool -> Bool -> Bool
&& Int
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xDFFF

-- | The code point of a surrogate pair, by the formula of UTF-16.
fromSurrogates :: Int -> Int -> Int
fromSurrogates :: Int -> Int -> Int
fromSurrogates Int
hi Int
lo = Int
0x10000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0xD800) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
0x400 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0xDC00)

-- | A code point that a character can have: in the range of Unicode, and not a
-- surrogate.
isScalarValue :: Int -> Bool
isScalarValue :: Int -> Bool
isScalarValue Int
c =
  Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
ord Char
forall a. Bounded a => a
maxBound Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
isHighSurrogate Int
c Bool -> Bool -> Bool
|| Int -> Bool
isLowSurrogate Int
c)

-- | The number of hex digits of the @\\x@, @\\u@ and @\\U@ escapes of a
-- double-quoted scalar.
xEscapeDigits, uEscapeDigits, bigUEscapeDigits :: Int
xEscapeDigits :: Int
xEscapeDigits = Int
2
uEscapeDigits :: Int
uEscapeDigits = Int
4
bigUEscapeDigits :: Int
bigUEscapeDigits = Int
8

-- | The number of hex digits of a @%XX@ escape in a tag.
percentDigits :: Int
percentDigits :: Int
percentDigits = Int
2

-- | The text in double quotes for a message, with the escapes of a
-- double-quoted scalar for a quote, a backslash and a character that does
-- not print, so that the message stays on one line. Unlike 'show', it keeps
-- the other characters that are not ASCII, e.g. @"zażółć"@.
showText :: T.Text -> String
showText :: Text -> [Char]
showText Text
t = Char
'"' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: (Char -> [Char]) -> [Char] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
escape (Text -> [Char]
T.unpack Text
t) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\""
  where
    escape :: Char -> String
    escape :: Char -> [Char]
escape Char
c
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' = [Char
'\\', Char
c]
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = [Char]
"\\n"
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' = [Char]
"\\r"
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t' = [Char]
"\\t"
      | Char -> Bool
isPrint Char
c = [Char
c]
      | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
xEscapeDigits = Char -> Int -> [Char]
hex Char
'x' Int
xEscapeDigits
      | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
uEscapeDigits = Char -> Int -> [Char]
hex Char
'u' Int
uEscapeDigits
      | Bool
otherwise = Char -> Int -> [Char]
hex Char
'U' Int
bigUEscapeDigits
      where
        hex :: Char -> Int -> String
        hex :: Char -> Int -> [Char]
hex Char
p Int
width =
          let h :: [Char]
h = Int -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showHex (Char -> Int
ord Char
c) [Char]
""
          in Char
'\\' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Char
p Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
h) Char
'0' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
h

-- | A pair with both components evaluated.
strictPair :: a -> b -> (a, b)
strictPair :: forall a b. a -> b -> (a, b)
strictPair !a
a !b
b = (a
a, b
b)

-- | 'map' with the spine and the elements of the result evaluated. The
-- results are in reverse until the end, so that the stack does not grow with
-- the length of the list.
strictMap :: forall a b. (a -> b) -> [a] -> [b]
strictMap :: forall a b. (a -> b) -> [a] -> [b]
strictMap a -> b
f = [b] -> [a] -> [b]
go []
  where
    go :: [b] -> [a] -> [b]
    go :: [b] -> [a] -> [b]
go [b]
acc = \case
      [] -> [b] -> [b]
forall a. [a] -> [a]
reverse [b]
acc
      a
x : [a]
xs -> let !y :: b
y = a -> b
f a
x in [b] -> [a] -> [b]
go (b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
acc) [a]
xs

-- | The first component of a pair in a result. Unlike @'fmap' 'fst'@, it
-- gives no selector thunk inside the result.
firstOfResult :: Either e (a, b) -> Either e a
firstOfResult :: forall e a b. Either e (a, b) -> Either e a
firstOfResult = \case
  Left e
e -> e -> Either e a
forall a b. a -> Either a b
Left e
e
  Right (a
a, b
_) -> a -> Either e a
forall a b. b -> Either a b
Right a
a