Value.hs

{- |
Module                  : Toml.Parser.Value
Copyright               : (c) 2018-2022 Kowainik
SPDX-License-Identifier : MPL-2.0
Maintainer              : Kowainik <xrom.xkov@gmail.com>
Stability               : Stable
Portability             : Portable

Parser for 'UValue'.
-}

module Toml.Parser.Value
       ( arrayP
       , boolP
       , dateTimeP
       , doubleP
       , integerP
       , valueP
       , anyValueP
       ) where

import Control.Applicative (Alternative (..))
import Control.Applicative.Combinators (between, count, option, optional, sepBy1, sepEndBy,
                                        skipMany)
import Data.Fixed (Pico)
import Data.Time (Day, LocalTime (..), TimeOfDay, ZonedTime (..), fromGregorianValid,
                  makeTimeOfDayValid, minutesToTimeZone)
import Data.String (fromString)

import Text.Read (readMaybe)
import Text.Megaparsec (observing, parseMaybe)

import Toml.Parser.Core (Parser, char, digitChar, hexDigitChar, octDigitChar, binDigitChar, hexadecimal, octal, binary, lexeme, sc, signed,
                         string, text, try, (<?>))
import Toml.Parser.String (textP)
import Toml.Type (AnyValue, UValue (..), typeCheck)


-- | Parser for decimap 'Integer': included parsing of underscore.
decimalP :: Parser Integer
decimalP = do
        value <- observing $ try leadingZeroP
        case value of
          Left _ -> do
            try more
          Right _ -> 
            fail "Leading zero."

  where
    leadingZeroP :: Parser String
    leadingZeroP = do
               count 1 (char '0') >>= (\_ -> some digitChar)

    more :: Parser Integer
    more  = check =<< readMaybe . concat <$> sepBy1 (some digitChar) (char '_')

    check :: Maybe Integer -> Parser Integer
    check = maybe (fail "Not an integer") pure



-- | Parser for hexadecimal, octal and binary numbers : included parsing
numberP :: Parser Integer -> Parser Char -> String -> Parser Integer
numberP parseInteger parseDigit errorMessage = more
  where
    more :: Parser Integer
    more = check =<< intValueMaybe . concat <$> sepBy1 (some parseDigit) (char '_')

    intValueMaybe :: String -> Maybe Integer
    intValueMaybe = parseMaybe parseInteger . fromString

    check :: Maybe Integer -> Parser Integer
    check = maybe (fail errorMessage) pure



-- | Parser for 'Integer' value.
integerP :: Parser Integer
integerP = lexeme (bin <|> oct <|> hex <|> dec) <?> "integer"
  where
    bin, oct, hex, dec :: Parser Integer
    bin = try (char '0' *> char 'b') *> binaryP      <?> "bin"
    oct = try (char '0' *> char 'o') *> octalP       <?> "oct"
    hex = try (char '0' *> char 'x') *> hexadecimalP <?> "hex"
    dec = signed sc decimalP                        <?> "dec"
    binaryP = numberP binary binDigitChar "Invalid binary number"
    octalP  = numberP octal octDigitChar  "Invalid ocatl number"
    hexadecimalP = numberP hexadecimal hexDigitChar "Invalid hexadecimal number"

-- | Parser for 'Double' value.
doubleP :: Parser Double
doubleP = lexeme (signed sc (num <|> inf <|> nan)) <?> "double"
  where
    num, inf, nan :: Parser Double
    num = floatP
    inf = 1 / 0 <$ string "inf"
    nan = 0 / 0 <$ string "nan"

-- | Parser for 'Double' numbers. Used in 'doubleP'.
floatP :: Parser Double
floatP = check . readMaybe =<< mconcat [ digits, expo <|> dot ]
  where
    check :: Maybe Double -> Parser Double
    check = maybe (fail "Not a float") return

    digits, dot, expo :: Parser String
    digits = concat <$> sepBy1 (some digitChar) (char '_')
    dot = mconcat [pure <$> char '.', digits, option "" expo]
    expo = mconcat
        [ pure <$> (char 'e' <|> char 'E')
        , pure <$> option '+' (char '+' <|> char '-')
        , digits
        ]

-- | Parser for 'Bool' value.
boolP :: Parser Bool
boolP = False <$ text "false"
    <|> True  <$ text "true"
    <?> "bool"

-- | Parser for datetime values.
dateTimeP :: Parser UValue
dateTimeP = lexeme (try (UHours <$> hoursP) <|> dayLocalZoned) <?> "datetime"

-- dayLocalZoned can parse: only a local date, a local date with time, or
-- a local date with a time and an offset
dayLocalZoned :: Parser UValue
dayLocalZoned = do
    day        <- try dayP
    maybeHours <- optional (try $ (char 'T' <|> char ' ') *> hoursP)
    case maybeHours of
        Nothing    -> pure $ UDay day
        Just hours -> do
            maybeOffset <- optional (try timeOffsetP)
            let localTime = LocalTime day hours
            pure $ case maybeOffset of
                Nothing     -> ULocal localTime
                Just offset -> UZoned $ ZonedTime localTime (minutesToTimeZone offset)

-- | Parser for time-zone offset
timeOffsetP :: Parser Int
timeOffsetP = z <|> numOffset
  where
    z :: Parser Int
    z = 0 <$ char 'Z'

    numOffset :: Parser Int
    numOffset = do
        sign    <- char '+' <|> char '-'
        hours   <- int2DigitsP
        _       <- char ':'
        minutes <- int2DigitsP
        let totalMinutes = hours * 60 + minutes
        pure $ if sign == '+'
            then totalMinutes
            else negate totalMinutes

-- | Parser for offset in day.
hoursP :: Parser TimeOfDay
hoursP = do
    hours   <- int2DigitsP
    _ <- char ':'
    minutes <- int2DigitsP
    _ <- char ':'
    seconds <- picoTruncated
    case makeTimeOfDayValid hours minutes seconds of
        Just time -> pure time
        Nothing   -> fail $
           "Invalid time of day: " <> show hours <> ":" <> show minutes <> ":" <> show seconds

-- | Parser for 'Day'.
dayP :: Parser Day
dayP = do
    year  <- yearP
    _     <- char '-'
    month <- int2DigitsP
    _     <- char '-'
    day   <- int2DigitsP
    case fromGregorianValid year month day of
        Just date -> pure date
        Nothing   -> fail $
            "Invalid date: " <> show year <> "-" <> show month <> "-" <> show day

-- | Parser for exactly 4 integer digits.
yearP :: Parser Integer
yearP = read <$> count 4 digitChar

-- | Parser for exactly two digits. Used to parse months or hours.
int2DigitsP :: Parser Int
int2DigitsP = read <$> count 2 digitChar

-- | Parser for pico-chu.
picoTruncated :: Parser Pico
picoTruncated = do
    int <- count 2 digitChar
    frc <- optional $ char '.' *> (take 12 <$> some digitChar)
    pure $ read $ case frc of
        Nothing   -> int
        Just frc' -> int ++ "." ++ frc'

{- | Parser for array of values. This parser tries to parse first element of
array, pattern-matches on this element and uses parser according to this first
element. This allows to prevent parsing of heterogeneous arrays.
-}
arrayP :: Parser [UValue]
arrayP = lexeme (between (char '[' *> sc) (char ']') elements) <?> "array"
  where
    elements :: Parser [UValue]
    elements = option [] $ do -- Zero or more elements
        v   <- valueP -- Parse the first value to determine the type
        sep <- optional spComma
        vs  <- case sep of
            Nothing -> pure []
            Just _  -> (element v `sepEndBy` spComma) <* skipMany spComma
        pure (v:vs)

    element :: UValue -> Parser UValue
    element = \case
        UBool    _ -> UBool    <$> boolP
        UZoned   _ -> dayLocalZoned
        ULocal   _ -> dayLocalZoned
        UDay     _ -> UDay     <$> dayP
        UHours   _ -> UHours   <$> hoursP
        UDouble  _ -> UDouble  <$> try doubleP
        UInteger _ -> UInteger <$> integerP
        UText    _ -> UText    <$> textP
        UArray   _ -> UArray   <$> arrayP

    spComma :: Parser ()
    spComma = char ',' *> sc

-- | Parser for 'UValue'.
valueP :: Parser UValue
valueP = UText    <$> textP
     <|> UBool    <$> boolP
     <|> UArray   <$> arrayP
     <|> dateTimeP
     <|> UDouble  <$> try doubleP
     <|> UInteger <$> integerP

-- | Uses 'valueP' and typechecks it.
anyValueP :: Parser AnyValue
anyValueP = typeCheck <$> valueP >>= \case
    Left err -> fail $ show err
    Right v  -> pure v