{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

{-|
Parse a TOML document.

References:

* https://toml.io/en/v1.0.0
* https://github.com/toml-lang/toml/blob/1.0.0/toml.abnf
-}
module TOML.Parser (
  parseTOML,
) where

import Control.Monad (guard, unless, void, when)
import Control.Monad.Combinators.NonEmpty (sepBy1)
import Data.Bifunctor (bimap)
import Data.Char (chr, isDigit, isSpace, ord)
import Data.Fixed (Fixed (..))
import Data.Foldable (foldlM)
#if !MIN_VERSION_base(4,20,0)
import Data.Foldable (foldl')
#endif
import Data.Functor (($>))
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time (Day, LocalTime, TimeOfDay, TimeZone)
import Data.Time qualified as Time
import Data.Void (Void)
import Numeric qualified
import Text.Megaparsec hiding (sepBy1)
import Text.Megaparsec.Char hiding (space, space1)
import Text.Megaparsec.Char.Lexer qualified as L

import TOML.Error (NormalizeError (..), TOMLError (..))
import TOML.Utils.Map (getPathLens)
import TOML.Value (Table, Value (..))

parseTOML ::
  String
  -- ^ Name of file (for error messages)
  -> Text
  -- ^ Input
  -> Either TOMLError Value
parseTOML :: String -> Text -> Either TOMLError Value
parseTOML String
filename Text
input =
  case Parsec Void Text TOMLDoc
-> String -> Text -> Either (ParseErrorBundle Text Void) TOMLDoc
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parsec Void Text TOMLDoc
parseTOMLDocument String
filename Text
input of
    Left ParseErrorBundle Text Void
e -> TOMLError -> Either TOMLError Value
forall a b. a -> Either a b
Left (TOMLError -> Either TOMLError Value)
-> TOMLError -> Either TOMLError Value
forall a b. (a -> b) -> a -> b
$ Text -> TOMLError
ParseError (Text -> TOMLError) -> Text -> TOMLError
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
e
    Right TOMLDoc
result -> Table -> Value
Table (Table -> Value)
-> Either TOMLError Table -> Either TOMLError Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TOMLDoc -> Either TOMLError Table
normalize TOMLDoc
result

-- 'Value' generalized to allow for unnormalized + annotated Values.
data GenericValue map key tableMeta arrayMeta
  = GenericTable tableMeta (map key (GenericValue map key tableMeta arrayMeta))
  | GenericArray arrayMeta [GenericValue map key tableMeta arrayMeta]
  | GenericString Text
  | GenericInteger Integer
  | GenericFloat Double
  | GenericBoolean Bool
  | GenericOffsetDateTime (LocalTime, TimeZone)
  | GenericLocalDateTime LocalTime
  | GenericLocalDate Day
  | GenericLocalTime TimeOfDay

fromGenericValue ::
  (map key (GenericValue map key tableMeta arrayMeta) -> Table)
  -> GenericValue map key tableMeta arrayMeta
  -> Value
fromGenericValue :: forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
(map key (GenericValue map key tableMeta arrayMeta) -> Table)
-> GenericValue map key tableMeta arrayMeta -> Value
fromGenericValue map key (GenericValue map key tableMeta arrayMeta) -> Table
fromGenericTable = \case
  GenericTable tableMeta
_ map key (GenericValue map key tableMeta arrayMeta)
t -> Table -> Value
Table (Table -> Value) -> Table -> Value
forall a b. (a -> b) -> a -> b
$ map key (GenericValue map key tableMeta arrayMeta) -> Table
fromGenericTable map key (GenericValue map key tableMeta arrayMeta)
t
  GenericArray arrayMeta
_ [GenericValue map key tableMeta arrayMeta]
vs -> [Value] -> Value
Array ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (GenericValue map key tableMeta arrayMeta -> Value)
-> [GenericValue map key tableMeta arrayMeta] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ((map key (GenericValue map key tableMeta arrayMeta) -> Table)
-> GenericValue map key tableMeta arrayMeta -> Value
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
(map key (GenericValue map key tableMeta arrayMeta) -> Table)
-> GenericValue map key tableMeta arrayMeta -> Value
fromGenericValue map key (GenericValue map key tableMeta arrayMeta) -> Table
fromGenericTable) [GenericValue map key tableMeta arrayMeta]
vs
  GenericString Text
x -> Text -> Value
String Text
x
  GenericInteger Integer
x -> Integer -> Value
Integer Integer
x
  GenericFloat Double
x -> Double -> Value
Float Double
x
  GenericBoolean Bool
x -> Bool -> Value
Boolean Bool
x
  GenericOffsetDateTime (LocalTime, TimeZone)
x -> (LocalTime, TimeZone) -> Value
OffsetDateTime (LocalTime, TimeZone)
x
  GenericLocalDateTime LocalTime
x -> LocalTime -> Value
LocalDateTime LocalTime
x
  GenericLocalDate Day
x -> Day -> Value
LocalDate Day
x
  GenericLocalTime TimeOfDay
x -> TimeOfDay -> Value
LocalTime TimeOfDay
x

{--- Parse raw document ---}

type Parser = Parsec Void Text

-- | An unannotated, unnormalized value.
type RawValue = GenericValue LookupMap Key () ()

type Key = NonEmpty Text
type RawTable = LookupMap Key RawValue
newtype LookupMap k v = LookupMap {forall k v. LookupMap k v -> [(k, v)]
unLookupMap :: [(k, v)]}

data TOMLDoc = TOMLDoc
  { TOMLDoc -> RawTable
rootTable :: RawTable
  , TOMLDoc -> [TableSection]
subTables :: [TableSection]
  }

data TableSection = TableSection
  { TableSection -> TableSectionHeader
tableSectionHeader :: TableSectionHeader
  , TableSection -> RawTable
tableSectionTable :: RawTable
  }

data TableSectionHeader = SectionTable Key | SectionTableArray Key

parseTOMLDocument :: Parser TOMLDoc
parseTOMLDocument :: Parsec Void Text TOMLDoc
parseTOMLDocument = do
  Parser ()
emptyLines
  rootTable <- Parser RawTable
parseRawTable
  emptyLines
  subTables <- many parseTableSection
  emptyLines
  eof
  return TOMLDoc{..}

parseRawTable :: Parser RawTable
parseRawTable :: Parser RawTable
parseRawTable = ([(Key, RawValue)] -> RawTable)
-> ParsecT Void Text Identity [(Key, RawValue)] -> Parser RawTable
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Key, RawValue)] -> RawTable
forall k v. [(k, v)] -> LookupMap k v
LookupMap (ParsecT Void Text Identity [(Key, RawValue)] -> Parser RawTable)
-> ParsecT Void Text Identity [(Key, RawValue)] -> Parser RawTable
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity (Key, RawValue)
-> ParsecT Void Text Identity [(Key, RawValue)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void Text Identity (Key, RawValue)
 -> ParsecT Void Text Identity [(Key, RawValue)])
-> ParsecT Void Text Identity (Key, RawValue)
-> ParsecT Void Text Identity [(Key, RawValue)]
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity (Key, RawValue)
parseKeyValue ParsecT Void Text Identity (Key, RawValue)
-> Parser () -> ParsecT Void Text Identity (Key, RawValue)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
endOfLine ParsecT Void Text Identity (Key, RawValue)
-> Parser () -> ParsecT Void Text Identity (Key, RawValue)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
emptyLines

parseTableSection :: Parser TableSection
parseTableSection :: ParsecT Void Text Identity TableSection
parseTableSection = do
  tableSectionHeader <-
    [ParsecT Void Text Identity TableSectionHeader]
-> ParsecT Void Text Identity TableSectionHeader
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
      [ Key -> TableSectionHeader
SectionTableArray (Key -> TableSectionHeader)
-> ParsecT Void Text Identity Key
-> ParsecT Void Text Identity TableSectionHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> ParsecT Void Text Identity Key
parseHeader Text
"[[" Text
"]]"
      , Key -> TableSectionHeader
SectionTable (Key -> TableSectionHeader)
-> ParsecT Void Text Identity Key
-> ParsecT Void Text Identity TableSectionHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> ParsecT Void Text Identity Key
parseHeader Text
"[" Text
"]"
      ]
  endOfLine
  emptyLines
  tableSectionTable <- parseRawTable
  emptyLines
  return TableSection{..}
  where
    parseHeader :: Text -> Text -> ParsecT Void Text Identity Key
parseHeader Text
brackStart Text
brackEnd = Text -> Parser ()
hsymbol Text
brackStart Parser ()
-> ParsecT Void Text Identity Key -> ParsecT Void Text Identity Key
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Key
parseKey ParsecT Void Text Identity Key
-> Parser () -> ParsecT Void Text Identity Key
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser ()
hsymbol Text
brackEnd

parseKeyValue :: Parser (Key, RawValue)
parseKeyValue :: ParsecT Void Text Identity (Key, RawValue)
parseKeyValue = do
  key <- ParsecT Void Text Identity Key
parseKey
  hsymbol "="
  value <- parseValue
  pure (key, value)

parseKey :: Parser Key
parseKey :: ParsecT Void Text Identity Key
parseKey =
  (ParsecT Void Text Identity Text
-> Parser () -> ParsecT Void Text Identity Key
forall (m :: * -> *) a sep.
MonadPlus m =>
m a -> m sep -> m (NonEmpty a)
`sepBy1` Parser () -> Parser ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Text -> Parser ()
hsymbol Text
".")) (ParsecT Void Text Identity Text -> ParsecT Void Text Identity Key)
-> ([ParsecT Void Text Identity Text]
    -> ParsecT Void Text Identity Text)
-> [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParsecT Void Text Identity Text]
 -> ParsecT Void Text Identity Key)
-> [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Key
forall a b. (a -> b) -> a -> b
$
    [ ParsecT Void Text Identity Text
parseBasicString
    , ParsecT Void Text Identity Text
parseLiteralString
    , ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
parseUnquotedKey
    ]
  where
    parseUnquotedKey :: ParsecT Void Text Identity (Tokens Text)
parseUnquotedKey =
      Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P
        (String -> Maybe String
forall a. a -> Maybe a
Just String
"[A-Za-z0-9_-]")
        (Token Text -> [Token Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A' .. Char
'Z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'a' .. Char
'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'0' .. Char
'9'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-_")

parseValue :: Parser RawValue
parseValue :: Parser RawValue
parseValue =
  [Parser RawValue] -> Parser RawValue
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser RawValue -> Parser RawValue
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser RawValue -> Parser RawValue)
-> Parser RawValue -> Parser RawValue
forall a b. (a -> b) -> a -> b
$ () -> RawTable -> RawValue
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
tableMeta
-> map key (GenericValue map key tableMeta arrayMeta)
-> GenericValue map key tableMeta arrayMeta
GenericTable () (RawTable -> RawValue) -> Parser RawTable -> Parser RawValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser RawTable -> Parser RawTable
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"table" Parser RawTable
parseInlineTable
    , Parser RawValue -> Parser RawValue
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser RawValue -> Parser RawValue)
-> Parser RawValue -> Parser RawValue
forall a b. (a -> b) -> a -> b
$ () -> [RawValue] -> RawValue
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
arrayMeta
-> [GenericValue map key tableMeta arrayMeta]
-> GenericValue map key tableMeta arrayMeta
GenericArray () ([RawValue] -> RawValue)
-> ParsecT Void Text Identity [RawValue] -> Parser RawValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void Text Identity [RawValue]
-> ParsecT Void Text Identity [RawValue]
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"array" ParsecT Void Text Identity [RawValue]
parseInlineArray
    , Parser RawValue -> Parser RawValue
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser RawValue -> Parser RawValue)
-> Parser RawValue -> Parser RawValue
forall a b. (a -> b) -> a -> b
$ Text -> RawValue
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
Text -> GenericValue map key tableMeta arrayMeta
GenericString (Text -> RawValue)
-> ParsecT Void Text Identity Text -> Parser RawValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"string" ParsecT Void Text Identity Text
parseString
    , Parser RawValue -> Parser RawValue
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser RawValue -> Parser RawValue)
-> Parser RawValue -> Parser RawValue
forall a b. (a -> b) -> a -> b
$ (LocalTime, TimeZone) -> RawValue
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
(LocalTime, TimeZone) -> GenericValue map key tableMeta arrayMeta
GenericOffsetDateTime ((LocalTime, TimeZone) -> RawValue)
-> ParsecT Void Text Identity (LocalTime, TimeZone)
-> Parser RawValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void Text Identity (LocalTime, TimeZone)
-> ParsecT Void Text Identity (LocalTime, TimeZone)
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"offset-datetime" ParsecT Void Text Identity (LocalTime, TimeZone)
parseOffsetDateTime
    , Parser RawValue -> Parser RawValue
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser RawValue -> Parser RawValue)
-> Parser RawValue -> Parser RawValue
forall a b. (a -> b) -> a -> b
$ LocalTime -> RawValue
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
LocalTime -> GenericValue map key tableMeta arrayMeta
GenericLocalDateTime (LocalTime -> RawValue)
-> ParsecT Void Text Identity LocalTime -> Parser RawValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void Text Identity LocalTime
-> ParsecT Void Text Identity LocalTime
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"local-datetime" ParsecT Void Text Identity LocalTime
parseLocalDateTime
    , Parser RawValue -> Parser RawValue
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser RawValue -> Parser RawValue)
-> Parser RawValue -> Parser RawValue
forall a b. (a -> b) -> a -> b
$ Day -> RawValue
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
Day -> GenericValue map key tableMeta arrayMeta
GenericLocalDate (Day -> RawValue)
-> ParsecT Void Text Identity Day -> Parser RawValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void Text Identity Day -> ParsecT Void Text Identity Day
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"local-date" ParsecT Void Text Identity Day
parseLocalDate
    , Parser RawValue -> Parser RawValue
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser RawValue -> Parser RawValue)
-> Parser RawValue -> Parser RawValue
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> RawValue
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
TimeOfDay -> GenericValue map key tableMeta arrayMeta
GenericLocalTime (TimeOfDay -> RawValue)
-> ParsecT Void Text Identity TimeOfDay -> Parser RawValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void Text Identity TimeOfDay
-> ParsecT Void Text Identity TimeOfDay
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"local-time" ParsecT Void Text Identity TimeOfDay
parseLocalTime
    , Parser RawValue -> Parser RawValue
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser RawValue -> Parser RawValue)
-> Parser RawValue -> Parser RawValue
forall a b. (a -> b) -> a -> b
$ Double -> RawValue
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
Double -> GenericValue map key tableMeta arrayMeta
GenericFloat (Double -> RawValue)
-> ParsecT Void Text Identity Double -> Parser RawValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void Text Identity Double
-> ParsecT Void Text Identity Double
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"float" ParsecT Void Text Identity Double
parseFloat
    , Parser RawValue -> Parser RawValue
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser RawValue -> Parser RawValue)
-> Parser RawValue -> Parser RawValue
forall a b. (a -> b) -> a -> b
$ Integer -> RawValue
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
Integer -> GenericValue map key tableMeta arrayMeta
GenericInteger (Integer -> RawValue)
-> ParsecT Void Text Identity Integer -> Parser RawValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void Text Identity Integer
-> ParsecT Void Text Identity Integer
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"integer" ParsecT Void Text Identity Integer
parseInteger
    , Parser RawValue -> Parser RawValue
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser RawValue -> Parser RawValue)
-> Parser RawValue -> Parser RawValue
forall a b. (a -> b) -> a -> b
$ Bool -> RawValue
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
Bool -> GenericValue map key tableMeta arrayMeta
GenericBoolean (Bool -> RawValue)
-> ParsecT Void Text Identity Bool -> Parser RawValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void Text Identity Bool
-> ParsecT Void Text Identity Bool
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"boolean" ParsecT Void Text Identity Bool
parseBoolean
    ]

parseInlineTable :: Parser RawTable
parseInlineTable :: Parser RawTable
parseInlineTable = do
  Text -> Parser ()
hsymbol Text
"{"
  kvs <- ParsecT Void Text Identity (Key, RawValue)
parseKeyValue ParsecT Void Text Identity (Key, RawValue)
-> Parser () -> ParsecT Void Text Identity [(Key, RawValue)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` Parser () -> Parser ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Text -> Parser ()
hsymbol Text
",")
  hsymbol "}"
  return $ LookupMap kvs

parseInlineArray :: Parser [RawValue]
parseInlineArray :: ParsecT Void Text Identity [RawValue]
parseInlineArray = do
  _ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'[' ParsecT Void Text Identity Char
-> Parser () -> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
emptyLines
  vs <- (parseValue <* emptyLines) `sepEndBy` (char ',' <* emptyLines)
  _ <- char ']'
  return vs

parseString :: Parser Text
parseString :: ParsecT Void Text Identity Text
parseString =
  [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Text
parseMultilineBasicString
    , ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Text
parseMultilineLiteralString
    , ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Text
parseBasicString
    , ParsecT Void Text Identity Text
parseLiteralString
    ]

-- | A string in double quotes.
parseBasicString :: Parser Text
parseBasicString :: ParsecT Void Text Identity Text
parseBasicString =
  String
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"double-quoted string" (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$
    ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"') (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"') (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$
      (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Text.pack (ParsecT Void Text Identity String
 -> ParsecT Void Text Identity Text)
-> ([ParsecT Void Text Identity Char]
    -> ParsecT Void Text Identity String)
-> [ParsecT Void Text Identity Char]
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity String)
-> ([ParsecT Void Text Identity Char]
    -> ParsecT Void Text Identity Char)
-> [ParsecT Void Text Identity Char]
-> ParsecT Void Text Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParsecT Void Text Identity Char]
-> ParsecT Void Text Identity Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParsecT Void Text Identity Char]
 -> ParsecT Void Text Identity Text)
-> [ParsecT Void Text Identity Char]
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$
        [ (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isBasicChar
        , ParsecT Void Text Identity Char
parseEscaped
        ]

-- | A string in single quotes.
parseLiteralString :: Parser Text
parseLiteralString :: ParsecT Void Text Identity Text
parseLiteralString =
  String
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"single-quoted string" (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$
    ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'\'') (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'\'') (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$
      Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"literal-char") Char -> Bool
Token Text -> Bool
isLiteralChar

-- | A multiline string with three double quotes.
parseMultilineBasicString :: Parser Text
parseMultilineBasicString :: ParsecT Void Text Identity Text
parseMultilineBasicString =
  String
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"double-quoted multiline string" (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ do
    _ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"\"\"\"" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Maybe (Tokens Text))
-> ParsecT Void Text Identity (Maybe (Tokens Text))
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Maybe (Tokens Text))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
    lineContinuation
    Text.concat <$> manyTill (mlBasicContent <* lineContinuation) (exactly 3 '"')
  where
    mlBasicContent :: ParsecT Void Text Identity Text
mlBasicContent =
      [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Char -> Text
Text.singleton (Char -> Text)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Char
parseEscaped
        , Char -> Text
Text.singleton (Char -> Text)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isBasicChar
        , Char -> ParsecT Void Text Identity Text
parseMultilineDelimiter Char
'"'
        , ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
        ]
    lineContinuation :: Parser ()
lineContinuation = Parser () -> ParsecT Void Text Identity [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser () -> Parser ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'\\' ParsecT Void Text Identity Char -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace Parser ()
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol ParsecT Void Text Identity (Tokens Text) -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
space) ParsecT Void Text Identity [()] -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | A multiline string with three single quotes.
parseMultilineLiteralString :: Parser Text
parseMultilineLiteralString :: ParsecT Void Text Identity Text
parseMultilineLiteralString =
  String
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"single-quoted multiline string" (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ do
    _ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"'''" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Maybe (Tokens Text))
-> ParsecT Void Text Identity (Maybe (Tokens Text))
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Maybe (Tokens Text))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
    Text.concat <$> manyTill mlLiteralContent (exactly 3 '\'')
  where
    mlLiteralContent :: ParsecT Void Text Identity Text
mlLiteralContent =
      [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Char -> Text
Text.singleton (Char -> Text)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isLiteralChar
        , Char -> ParsecT Void Text Identity Text
parseMultilineDelimiter Char
'\''
        , ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
        ]

parseEscaped :: Parser Char
parseEscaped :: ParsecT Void Text Identity Char
parseEscaped = Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'\\' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Char
parseEscapedChar
  where
    parseEscapedChar :: ParsecT Void Text Identity Char
parseEscapedChar =
      [ParsecT Void Text Identity Char]
-> ParsecT Void Text Identity Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"'
        , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'\\'
        , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'b' ParsecT Void Text Identity Char
-> Char -> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\b'
        , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'f' ParsecT Void Text Identity Char
-> Char -> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\f'
        , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'n' ParsecT Void Text Identity Char
-> Char -> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\n'
        , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'r' ParsecT Void Text Identity Char
-> Char -> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\r'
        , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
't' ParsecT Void Text Identity Char
-> Char -> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\t'
        , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'u' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> ParsecT Void Text Identity Char
forall {s} {m :: * -> *} {e}.
(Token s ~ Char, MonadParsec e s m) =>
Int -> m Char
unicodeHex Int
4
        , Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'U' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> ParsecT Void Text Identity Char
forall {s} {m :: * -> *} {e}.
(Token s ~ Char, MonadParsec e s m) =>
Int -> m Char
unicodeHex Int
8
        ]

    unicodeHex :: Int -> m Char
unicodeHex Int
n = do
      code <- Text -> Int
forall a. (Show a, Num a, Eq a) => Text -> a
readHex (Text -> Int) -> (String -> Text) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Int) -> m String -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m Char -> m String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
n m Char
m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
      guard $ isUnicodeScalar code
      pure $ chr code

-- |
-- Parse the multiline delimiter (" in """ quotes, or ' in ''' quotes), unless
-- the delimiter indicates the end of the multiline string.
--
-- i.e. parse 1 or 2 delimiters, or 4 or 5, which is 1 or 2 delimiters at the
-- end of a multiline string (then backtrack 3 to mark the end).
parseMultilineDelimiter :: Char -> Parser Text
parseMultilineDelimiter :: Char -> ParsecT Void Text Identity Text
parseMultilineDelimiter Char
delim =
  [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Int -> Char -> ParsecT Void Text Identity Text
exactly Int
1 Char
delim
    , Int -> Char -> ParsecT Void Text Identity Text
exactly Int
2 Char
delim
    , do
        _ <- ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Int -> Char -> ParsecT Void Text Identity Text
exactly Int
4 Char
delim)
        Text.pack <$> count 1 (char delim)
    , do
        _ <- ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Int -> Char -> ParsecT Void Text Identity Text
exactly Int
5 Char
delim)
        Text.pack <$> count 2 (char delim)
    ]

isBasicChar :: Char -> Bool
isBasicChar :: Char -> Bool
isBasicChar Char
c =
  case Char
c of
    Char
' ' -> Bool
True
    Char
'\t' -> Bool
True
    Char
_ | Int
0x21 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7E -> 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 -> Bool
isNonAscii Char
c -> Bool
True
    Char
_ -> Bool
False
  where
    code :: Int
code = Char -> Int
ord Char
c

isLiteralChar :: Char -> Bool
isLiteralChar :: Char -> Bool
isLiteralChar Char
c =
  case Char
c of
    Char
' ' -> Bool
True
    Char
'\t' -> Bool
True
    Char
_ | Int
0x21 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7E -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\''
    Char
_ | Char -> Bool
isNonAscii Char
c -> Bool
True
    Char
_ -> Bool
False
  where
    code :: Int
code = Char -> Int
ord Char
c

parseOffsetDateTime :: Parser (LocalTime, TimeZone)
parseOffsetDateTime :: ParsecT Void Text Identity (LocalTime, TimeZone)
parseOffsetDateTime = (,) (LocalTime -> TimeZone -> (LocalTime, TimeZone))
-> ParsecT Void Text Identity LocalTime
-> ParsecT Void Text Identity (TimeZone -> (LocalTime, TimeZone))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity LocalTime
parseLocalDateTime ParsecT Void Text Identity (TimeZone -> (LocalTime, TimeZone))
-> ParsecT Void Text Identity TimeZone
-> ParsecT Void Text Identity (LocalTime, TimeZone)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity TimeZone
parseTimezone
  where
    parseTimezone :: ParsecT Void Text Identity TimeZone
parseTimezone =
      [ParsecT Void Text Identity TimeZone]
-> ParsecT Void Text Identity TimeZone
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
Token Text
'Z' ParsecT Void Text Identity Char
-> TimeZone -> ParsecT Void Text Identity TimeZone
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TimeZone
Time.utc
        , do
            applySign <- Parser (Int -> Int)
forall a. Num a => Parser (a -> a)
parseSign
            h <- parseHours
            _ <- char ':'
            m <- parseMinutes
            return $ Time.minutesToTimeZone $ applySign $ h * 60 + m
        ]

parseLocalDateTime :: Parser LocalTime
parseLocalDateTime :: ParsecT Void Text Identity LocalTime
parseLocalDateTime = do
  d <- ParsecT Void Text Identity Day
parseLocalDate
  _ <- char' 'T' <|> char ' '
  t <- parseLocalTime
  return $ Time.LocalTime d t

parseLocalDate :: Parser Day
parseLocalDate :: ParsecT Void Text Identity Day
parseLocalDate = do
  y <- Int -> ParsecT Void Text Identity Integer
forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
4
  _ <- char '-'
  m <- parseDecDigits 2
  _ <- char '-'
  d <- parseDecDigits 2
  maybe empty return $ Time.fromGregorianValid y m d

parseLocalTime :: Parser TimeOfDay
parseLocalTime :: ParsecT Void Text Identity TimeOfDay
parseLocalTime = do
  h <- Parser Int
parseHours
  _ <- char ':'
  m <- parseMinutes
  _ <- char ':'
  sInt <- parseSeconds
  sFracRaw <- optional $ fmap Text.pack $ char '.' >> some digitChar
  let sFrac = Integer -> Pico
forall k (a :: k). Integer -> Fixed a
MkFixed (Integer -> Pico) -> Integer -> Pico
forall a b. (a -> b) -> a -> b
$ Integer -> (Text -> Integer) -> Maybe Text -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
0 Text -> Integer
forall a. (Show a, Num a, Eq a) => Text -> a
readPicoDigits Maybe Text
sFracRaw
  return $ Time.TimeOfDay h m (fromIntegral sInt + sFrac)
  where
    readPicoDigits :: Text -> a
readPicoDigits Text
s = Text -> a
forall a. (Show a, Num a, Eq a) => Text -> a
readDec (Text -> a) -> Text -> a
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.take Int
12 (Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate Int
12 Text
"0")

parseHours :: Parser Int
parseHours :: Parser Int
parseHours = do
  h <- Int -> Parser Int
forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
2
  guard $ 0 <= h && h < 24
  return h

parseMinutes :: Parser Int
parseMinutes :: Parser Int
parseMinutes = do
  m <- Int -> Parser Int
forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
2
  guard $ 0 <= m && m < 60
  return m

parseSeconds :: Parser Int
parseSeconds :: Parser Int
parseSeconds = do
  s <- Int -> Parser Int
forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
2
  guard $ 0 <= s && s <= 60 -- include 60 for leap seconds
  return s

parseFloat :: Parser Double
parseFloat :: ParsecT Void Text Identity Double
parseFloat = do
  applySign <- Parser (Double -> Double)
forall a. Num a => Parser (a -> a)
parseSign
  num <-
    choice
      [ try normalFloat
      , try $ string "inf" $> inf
      , try $ string "nan" $> nan
      ]
  pure $ applySign num
  where
    normalFloat :: ParsecT Void Text Identity Double
normalFloat = do
      intPart <- ParsecT Void Text Identity Text
parseDecIntRaw
      (fracPart, expPart) <-
        choice
          [ try $ (,) <$> pure "" <*> parseExp
          , (,) <$> parseFrac <*> optionalOr "" parseExp
          ]

      -- guess if the exponent is too big to fit in a double precision float anyway.
      -- https://github.com/brandonchinn178/toml-reader/issues/8
      pure $
        if Text.length expPart > 7
          then inf
          else readFloat $ intPart <> fracPart <> expPart

    parseExp :: ParsecT Void Text Identity Text
parseExp =
      ([Text] -> Text)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity Text
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Text
Text.concat (ParsecT Void Text Identity [Text]
 -> ParsecT Void Text Identity Text)
-> ([ParsecT Void Text Identity Text]
    -> ParsecT Void Text Identity [Text])
-> [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity [Text]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([ParsecT Void Text Identity Text]
 -> ParsecT Void Text Identity Text)
-> [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$
        [ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Text
Tokens Text
"e"
        , ParsecT Void Text Identity Text
parseSignRaw
        , ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
parseNumRaw ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
        ]
    parseFrac :: ParsecT Void Text Identity Text
parseFrac =
      ([Text] -> Text)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity Text
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Text
Text.concat (ParsecT Void Text Identity [Text]
 -> ParsecT Void Text Identity Text)
-> ([ParsecT Void Text Identity Text]
    -> ParsecT Void Text Identity [Text])
-> [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity [Text]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([ParsecT Void Text Identity Text]
 -> ParsecT Void Text Identity Text)
-> [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$
        [ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
"."
        , ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
parseNumRaw ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
        ]

    inf :: Double
inf = String -> Double
forall a. Read a => String -> a
read String
"Infinity"
    nan :: Double
nan = String -> Double
forall a. Read a => String -> a
read String
"NaN"

parseInteger :: Parser Integer
parseInteger :: ParsecT Void Text Identity Integer
parseInteger =
  [ParsecT Void Text Identity Integer]
-> ParsecT Void Text Identity Integer
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ ParsecT Void Text Identity Integer
-> ParsecT Void Text Identity Integer
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Integer
parseBinInt
    , ParsecT Void Text Identity Integer
-> ParsecT Void Text Identity Integer
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Integer
parseOctInt
    , ParsecT Void Text Identity Integer
-> ParsecT Void Text Identity Integer
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Integer
parseHexInt
    , ParsecT Void Text Identity Integer
parseSignedDecInt
    ]
  where
    parseSignedDecInt :: ParsecT Void Text Identity Integer
parseSignedDecInt = do
      applySign <- Parser (Integer -> Integer)
forall a. Num a => Parser (a -> a)
parseSign
      num <- readDec <$> parseDecIntRaw
      pure $ applySign num
    parseHexInt :: ParsecT Void Text Identity Integer
parseHexInt =
      (Text -> Integer)
-> Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Integer
forall {b}.
(Text -> b)
-> Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity b
parsePrefixedInt Text -> Integer
forall a. (Show a, Num a, Eq a) => Text -> a
readHex Text
"0x" ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
    parseOctInt :: ParsecT Void Text Identity Integer
parseOctInt =
      (Text -> Integer)
-> Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Integer
forall {b}.
(Text -> b)
-> Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity b
parsePrefixedInt Text -> Integer
forall a. (Show a, Num a, Eq a) => Text -> a
readOct Text
"0o" ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
octDigitChar
    parseBinInt :: ParsecT Void Text Identity Integer
parseBinInt =
      (Text -> Integer)
-> Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Integer
forall {b}.
(Text -> b)
-> Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity b
parsePrefixedInt Text -> Integer
forall a. (Show a, Num a) => Text -> a
readBin Text
"0b" ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
binDigitChar

    parsePrefixedInt :: (Text -> b)
-> Tokens Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity b
parsePrefixedInt Text -> b
readInt Tokens Text
prefix ParsecT Void Text Identity Char
parseDigit = do
      _ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
prefix
      readInt <$> parseNumRaw parseDigit parseDigit

parseBoolean :: Parser Bool
parseBoolean :: ParsecT Void Text Identity Bool
parseBoolean =
  [ParsecT Void Text Identity Bool]
-> ParsecT Void Text Identity Bool
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Bool
True Bool
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Bool
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"true"
    , Bool
False Bool
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Bool
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"false"
    ]

{--- Normalize into Value ---}

-- | An annotated, normalized Value
type AnnValue = GenericValue Map Text TableMeta ArrayMeta

type AnnTable = Map Text AnnValue

unannotateTable :: AnnTable -> Table
unannotateTable :: AnnTable -> Table
unannotateTable = (GenericValue Map Text TableMeta ArrayMeta -> Value)
-> AnnTable -> Table
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenericValue Map Text TableMeta ArrayMeta -> Value
unannotateValue

unannotateValue :: AnnValue -> Value
unannotateValue :: GenericValue Map Text TableMeta ArrayMeta -> Value
unannotateValue = (AnnTable -> Table)
-> GenericValue Map Text TableMeta ArrayMeta -> Value
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
(map key (GenericValue map key tableMeta arrayMeta) -> Table)
-> GenericValue map key tableMeta arrayMeta -> Value
fromGenericValue AnnTable -> Table
unannotateTable

data TableType
  = -- | An inline table, e.g. "a.b" in:
    --
    -- @
    -- a.b = { c = 1 }
    -- @
    InlineTable
  | -- | A table created implicitly from a nested key, e.g. "a" in:
    --
    -- @
    -- a.b = 1
    -- @
    ImplicitKey
  | -- | An explicitly named section, e.g. "a.b.c" and "a.b" but not "a" in:
    --
    -- @
    -- [a.b.c]
    -- [a.b]
    -- @
    ExplicitSection
  | -- | An implicitly created section, e.g. "a" in:
    --
    -- @
    -- [a.b]
    -- @
    --
    -- Can later be converted into an explicit section
    ImplicitSection
  deriving (TableType -> TableType -> Bool
(TableType -> TableType -> Bool)
-> (TableType -> TableType -> Bool) -> Eq TableType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TableType -> TableType -> Bool
== :: TableType -> TableType -> Bool
$c/= :: TableType -> TableType -> Bool
/= :: TableType -> TableType -> Bool
Eq)

data TableMeta = TableMeta
  { TableMeta -> TableType
tableType :: TableType
  }

data ArrayMeta = ArrayMeta
  { ArrayMeta -> Bool
isStaticArray :: Bool
  }

newtype NormalizeM a = NormalizeM
  { forall a. NormalizeM a -> Either NormalizeError a
runNormalizeM :: Either NormalizeError a
  }

instance Functor NormalizeM where
  fmap :: forall a b. (a -> b) -> NormalizeM a -> NormalizeM b
fmap a -> b
f = Either NormalizeError b -> NormalizeM b
forall a. Either NormalizeError a -> NormalizeM a
NormalizeM (Either NormalizeError b -> NormalizeM b)
-> (NormalizeM a -> Either NormalizeError b)
-> NormalizeM a
-> NormalizeM b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Either NormalizeError a -> Either NormalizeError b
forall a b.
(a -> b) -> Either NormalizeError a -> Either NormalizeError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Either NormalizeError a -> Either NormalizeError b)
-> (NormalizeM a -> Either NormalizeError a)
-> NormalizeM a
-> Either NormalizeError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizeM a -> Either NormalizeError a
forall a. NormalizeM a -> Either NormalizeError a
runNormalizeM
instance Applicative NormalizeM where
  pure :: forall a. a -> NormalizeM a
pure = Either NormalizeError a -> NormalizeM a
forall a. Either NormalizeError a -> NormalizeM a
NormalizeM (Either NormalizeError a -> NormalizeM a)
-> (a -> Either NormalizeError a) -> a -> NormalizeM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either NormalizeError a
forall a. a -> Either NormalizeError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  NormalizeM Either NormalizeError (a -> b)
f <*> :: forall a b. NormalizeM (a -> b) -> NormalizeM a -> NormalizeM b
<*> NormalizeM Either NormalizeError a
x = Either NormalizeError b -> NormalizeM b
forall a. Either NormalizeError a -> NormalizeM a
NormalizeM (Either NormalizeError (a -> b)
f Either NormalizeError (a -> b)
-> Either NormalizeError a -> Either NormalizeError b
forall a b.
Either NormalizeError (a -> b)
-> Either NormalizeError a -> Either NormalizeError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either NormalizeError a
x)
instance Monad NormalizeM where
  NormalizeM a
m >>= :: forall a b. NormalizeM a -> (a -> NormalizeM b) -> NormalizeM b
>>= a -> NormalizeM b
f = Either NormalizeError b -> NormalizeM b
forall a. Either NormalizeError a -> NormalizeM a
NormalizeM (Either NormalizeError b -> NormalizeM b)
-> Either NormalizeError b -> NormalizeM b
forall a b. (a -> b) -> a -> b
$ NormalizeM b -> Either NormalizeError b
forall a. NormalizeM a -> Either NormalizeError a
runNormalizeM (NormalizeM b -> Either NormalizeError b)
-> (a -> NormalizeM b) -> a -> Either NormalizeError b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NormalizeM b
f (a -> Either NormalizeError b)
-> Either NormalizeError a -> Either NormalizeError b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NormalizeM a -> Either NormalizeError a
forall a. NormalizeM a -> Either NormalizeError a
runNormalizeM NormalizeM a
m

normalizeError :: NormalizeError -> NormalizeM a
normalizeError :: forall a. NormalizeError -> NormalizeM a
normalizeError = Either NormalizeError a -> NormalizeM a
forall a. Either NormalizeError a -> NormalizeM a
NormalizeM (Either NormalizeError a -> NormalizeM a)
-> (NormalizeError -> Either NormalizeError a)
-> NormalizeError
-> NormalizeM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizeError -> Either NormalizeError a
forall a b. a -> Either a b
Left

normalize :: TOMLDoc -> Either TOMLError Table
normalize :: TOMLDoc -> Either TOMLError Table
normalize = (NormalizeError -> TOMLError)
-> (AnnTable -> Table)
-> Either NormalizeError AnnTable
-> Either TOMLError Table
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap NormalizeError -> TOMLError
NormalizeError AnnTable -> Table
unannotateTable (Either NormalizeError AnnTable -> Either TOMLError Table)
-> (TOMLDoc -> Either NormalizeError AnnTable)
-> TOMLDoc
-> Either TOMLError Table
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizeM AnnTable -> Either NormalizeError AnnTable
forall a. NormalizeM a -> Either NormalizeError a
runNormalizeM (NormalizeM AnnTable -> Either NormalizeError AnnTable)
-> (TOMLDoc -> NormalizeM AnnTable)
-> TOMLDoc
-> Either NormalizeError AnnTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOMLDoc -> NormalizeM AnnTable
normalize'

normalize' :: TOMLDoc -> NormalizeM AnnTable
normalize' :: TOMLDoc -> NormalizeM AnnTable
normalize' TOMLDoc{[TableSection]
RawTable
rootTable :: TOMLDoc -> RawTable
subTables :: TOMLDoc -> [TableSection]
rootTable :: RawTable
subTables :: [TableSection]
..} = do
  root <- RawTable -> NormalizeM AnnTable
flattenTable RawTable
rootTable
  foldlM mergeTableSection root subTables
  where
    mergeTableSection :: AnnTable -> TableSection -> NormalizeM AnnTable
    mergeTableSection :: AnnTable -> TableSection -> NormalizeM AnnTable
mergeTableSection AnnTable
baseTable TableSection{TableSectionHeader
RawTable
tableSectionHeader :: TableSection -> TableSectionHeader
tableSectionTable :: TableSection -> RawTable
tableSectionHeader :: TableSectionHeader
tableSectionTable :: RawTable
..} = do
      case TableSectionHeader
tableSectionHeader of
        SectionTable Key
key ->
          Key -> RawTable -> AnnTable -> NormalizeM AnnTable
mergeTableSectionTable Key
key RawTable
tableSectionTable AnnTable
baseTable
        SectionTableArray Key
key ->
          Key -> RawTable -> AnnTable -> NormalizeM AnnTable
mergeTableSectionArray Key
key RawTable
tableSectionTable AnnTable
baseTable

mergeTableSectionTable :: Key -> RawTable -> AnnTable -> NormalizeM AnnTable
mergeTableSectionTable :: Key -> RawTable -> AnnTable -> NormalizeM AnnTable
mergeTableSectionTable Key
sectionKey RawTable
table AnnTable
baseTable =
  ValueAtPathOptions
-> Key
-> AnnTable
-> (Maybe (GenericValue Map Text TableMeta ArrayMeta)
    -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
-> NormalizeM AnnTable
setValueAtPath ValueAtPathOptions
valueAtPathOptions Key
sectionKey AnnTable
baseTable ((Maybe (GenericValue Map Text TableMeta ArrayMeta)
  -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
 -> NormalizeM AnnTable)
-> (Maybe (GenericValue Map Text TableMeta ArrayMeta)
    -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
-> NormalizeM AnnTable
forall a b. (a -> b) -> a -> b
$ \Maybe (GenericValue Map Text TableMeta ArrayMeta)
mVal -> do
    tableToExtend <-
      case Maybe (GenericValue Map Text TableMeta ArrayMeta)
mVal of
        -- if a value doesn't already exist, initialize an empty Map
        Maybe (GenericValue Map Text TableMeta ArrayMeta)
Nothing -> AnnTable -> NormalizeM AnnTable
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnnTable
forall k a. Map k a
Map.empty
        -- if a Table already exists at the path ...
        Just existingValue :: GenericValue Map Text TableMeta ArrayMeta
existingValue@(GenericTable TableMeta
meta AnnTable
existingTable) ->
          case TableMeta -> TableType
tableType TableMeta
meta of
            -- ... and is an inline table, error
            TableType
InlineTable -> GenericValue Map Text TableMeta ArrayMeta -> NormalizeM AnnTable
duplicateKeyError GenericValue Map Text TableMeta ArrayMeta
existingValue
            -- ... and was created as a nested key elsewhere, error
            TableType
ImplicitKey -> NormalizeM AnnTable
extendTableError
            -- ... and was created as a Table section explicitly defined elsewhere, error
            TableType
ExplicitSection -> NormalizeM AnnTable
duplicateSectionError
            -- ... otherwise, return the existing table
            TableType
_ -> AnnTable -> NormalizeM AnnTable
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnnTable
existingTable
        -- if some other Value already exists at the path, error
        Just GenericValue Map Text TableMeta ArrayMeta
existingValue -> GenericValue Map Text TableMeta ArrayMeta -> NormalizeM AnnTable
duplicateKeyError GenericValue Map Text TableMeta ArrayMeta
existingValue

    mergedTable <-
      mergeRawTable
        MergeOptions{recurseImplicitSections = False}
        tableToExtend
        table

    let newTableMeta = TableMeta{tableType :: TableType
tableType = TableType
ExplicitSection}
    pure $ GenericTable newTableMeta mergedTable
  where
    valueAtPathOptions :: ValueAtPathOptions
valueAtPathOptions =
      ValueAtPathOptions
        { shouldRecurse :: TableType -> Bool
shouldRecurse = \case
            TableType
InlineTable -> Bool
False
            TableType
ImplicitKey -> Bool
True
            TableType
ExplicitSection -> Bool
True
            TableType
ImplicitSection -> Bool
True
        , recurseArray :: Bool
recurseArray = Bool
True
        , implicitType :: TableType
implicitType = TableType
ImplicitSection
        , makeMidPathNotTableError :: Key -> GenericValue Map Text TableMeta ArrayMeta -> NormalizeError
makeMidPathNotTableError = Key
-> RawTable
-> Key
-> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeError
nonTableInNestedKeyError Key
sectionKey RawTable
table
        }
    duplicateKeyError :: GenericValue Map Text TableMeta ArrayMeta -> NormalizeM AnnTable
duplicateKeyError GenericValue Map Text TableMeta ArrayMeta
existingValue =
      NormalizeError -> NormalizeM AnnTable
forall a. NormalizeError -> NormalizeM a
normalizeError
        DuplicateKeyError
          { _path :: Key
_path = Key
sectionKey
          , _existingValue :: Value
_existingValue = GenericValue Map Text TableMeta ArrayMeta -> Value
unannotateValue GenericValue Map Text TableMeta ArrayMeta
existingValue
          , _valueToSet :: Value
_valueToSet = Table -> Value
Table (Table -> Value) -> Table -> Value
forall a b. (a -> b) -> a -> b
$ RawTable -> Table
rawTableToApproxTable RawTable
table
          }
    extendTableError :: NormalizeM AnnTable
extendTableError =
      NormalizeError -> NormalizeM AnnTable
forall a. NormalizeError -> NormalizeM a
normalizeError
        ExtendTableError
          { _path :: Key
_path = Key
sectionKey
          , _originalKey :: Key
_originalKey = Key
sectionKey
          }
    duplicateSectionError :: NormalizeM AnnTable
duplicateSectionError =
      NormalizeError -> NormalizeM AnnTable
forall a. NormalizeError -> NormalizeM a
normalizeError
        DuplicateSectionError
          { _sectionKey :: Key
_sectionKey = Key
sectionKey
          }

mergeTableSectionArray :: Key -> RawTable -> AnnTable -> NormalizeM AnnTable
mergeTableSectionArray :: Key -> RawTable -> AnnTable -> NormalizeM AnnTable
mergeTableSectionArray Key
sectionKey RawTable
table AnnTable
baseTable = do
  ValueAtPathOptions
-> Key
-> AnnTable
-> (Maybe (GenericValue Map Text TableMeta ArrayMeta)
    -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
-> NormalizeM AnnTable
setValueAtPath ValueAtPathOptions
valueAtPathOptions Key
sectionKey AnnTable
baseTable ((Maybe (GenericValue Map Text TableMeta ArrayMeta)
  -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
 -> NormalizeM AnnTable)
-> (Maybe (GenericValue Map Text TableMeta ArrayMeta)
    -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
-> NormalizeM AnnTable
forall a b. (a -> b) -> a -> b
$ \Maybe (GenericValue Map Text TableMeta ArrayMeta)
mVal -> do
    (meta, currArray) <-
      case Maybe (GenericValue Map Text TableMeta ArrayMeta)
mVal of
        -- if nothing exists, initialize an empty array
        Maybe (GenericValue Map Text TableMeta ArrayMeta)
Nothing -> do
          let meta :: ArrayMeta
meta = ArrayMeta{isStaticArray :: Bool
isStaticArray = Bool
False}
          (ArrayMeta, [GenericValue Map Text TableMeta ArrayMeta])
-> NormalizeM
     (ArrayMeta, [GenericValue Map Text TableMeta ArrayMeta])
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArrayMeta
meta, [])
        -- if an array exists, insert table to the end of the array
        Just (GenericArray ArrayMeta
meta [GenericValue Map Text TableMeta ArrayMeta]
existingArray)
          | Bool -> Bool
not (ArrayMeta -> Bool
isStaticArray ArrayMeta
meta) ->
              (ArrayMeta, [GenericValue Map Text TableMeta ArrayMeta])
-> NormalizeM
     (ArrayMeta, [GenericValue Map Text TableMeta ArrayMeta])
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArrayMeta
meta, [GenericValue Map Text TableMeta ArrayMeta]
existingArray)
        -- otherwise, error
        Just GenericValue Map Text TableMeta ArrayMeta
existingValue ->
          NormalizeError
-> NormalizeM
     (ArrayMeta, [GenericValue Map Text TableMeta ArrayMeta])
forall a. NormalizeError -> NormalizeM a
normalizeError
            ImplicitArrayForDefinedKeyError
              { _path :: Key
_path = Key
sectionKey
              , _existingValue :: Value
_existingValue = GenericValue Map Text TableMeta ArrayMeta -> Value
unannotateValue GenericValue Map Text TableMeta ArrayMeta
existingValue
              , _tableSection :: Table
_tableSection = RawTable -> Table
rawTableToApproxTable RawTable
table
              }

    let newTableMeta = TableMeta{tableType :: TableType
tableType = TableType
ExplicitSection}
    newTable <- GenericTable newTableMeta <$> flattenTable table
    pure $ GenericArray meta $ currArray <> [newTable]
  where
    valueAtPathOptions :: ValueAtPathOptions
valueAtPathOptions =
      ValueAtPathOptions
        { shouldRecurse :: TableType -> Bool
shouldRecurse = \case
            TableType
InlineTable -> Bool
False
            TableType
ImplicitKey -> Bool
True
            TableType
ExplicitSection -> Bool
True
            TableType
ImplicitSection -> Bool
True
        , recurseArray :: Bool
recurseArray = Bool
True
        , implicitType :: TableType
implicitType = TableType
ImplicitSection
        , makeMidPathNotTableError :: Key -> GenericValue Map Text TableMeta ArrayMeta -> NormalizeError
makeMidPathNotTableError = \Key
history GenericValue Map Text TableMeta ArrayMeta
existingValue ->
            NonTableInNestedImplicitArrayError
              { _path :: Key
_path = Key
history
              , _existingValue :: Value
_existingValue = GenericValue Map Text TableMeta ArrayMeta -> Value
unannotateValue GenericValue Map Text TableMeta ArrayMeta
existingValue
              , _sectionKey :: Key
_sectionKey = Key
sectionKey
              , _tableSection :: Table
_tableSection = RawTable -> Table
rawTableToApproxTable RawTable
table
              }
        }

flattenTable :: RawTable -> NormalizeM AnnTable
flattenTable :: RawTable -> NormalizeM AnnTable
flattenTable =
  MergeOptions -> AnnTable -> RawTable -> NormalizeM AnnTable
mergeRawTable
    MergeOptions{recurseImplicitSections :: Bool
recurseImplicitSections = Bool
True}
    AnnTable
forall k a. Map k a
Map.empty

data MergeOptions = MergeOptions
  { MergeOptions -> Bool
recurseImplicitSections :: Bool
  }

mergeRawTable :: MergeOptions -> AnnTable -> RawTable -> NormalizeM AnnTable
mergeRawTable :: MergeOptions -> AnnTable -> RawTable -> NormalizeM AnnTable
mergeRawTable MergeOptions{Bool
recurseImplicitSections :: MergeOptions -> Bool
recurseImplicitSections :: Bool
..} AnnTable
baseTable RawTable
table = (AnnTable -> (Key, RawValue) -> NormalizeM AnnTable)
-> AnnTable -> [(Key, RawValue)] -> NormalizeM AnnTable
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM AnnTable -> (Key, RawValue) -> NormalizeM AnnTable
insertRawValue AnnTable
baseTable (RawTable -> [(Key, RawValue)]
forall k v. LookupMap k v -> [(k, v)]
unLookupMap RawTable
table)
  where
    insertRawValue :: AnnTable -> (Key, RawValue) -> NormalizeM AnnTable
insertRawValue AnnTable
accTable (Key
key, RawValue
rawValue) = do
      let valueAtPathOptions :: ValueAtPathOptions
valueAtPathOptions =
            ValueAtPathOptions
              { shouldRecurse :: TableType -> Bool
shouldRecurse = \case
                  TableType
InlineTable -> Bool
False
                  TableType
ImplicitKey -> Bool
True
                  TableType
ExplicitSection -> Bool
True
                  TableType
ImplicitSection -> Bool
recurseImplicitSections
              , recurseArray :: Bool
recurseArray = Bool
False
              , implicitType :: TableType
implicitType = TableType
ImplicitKey
              , makeMidPathNotTableError :: Key -> GenericValue Map Text TableMeta ArrayMeta -> NormalizeError
makeMidPathNotTableError = Key
-> RawTable
-> Key
-> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeError
nonTableInNestedKeyError Key
key RawTable
table
              }
      ValueAtPathOptions
-> Key
-> AnnTable
-> (Maybe (GenericValue Map Text TableMeta ArrayMeta)
    -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
-> NormalizeM AnnTable
setValueAtPath ValueAtPathOptions
valueAtPathOptions Key
key AnnTable
accTable ((Maybe (GenericValue Map Text TableMeta ArrayMeta)
  -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
 -> NormalizeM AnnTable)
-> (Maybe (GenericValue Map Text TableMeta ArrayMeta)
    -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
-> NormalizeM AnnTable
forall a b. (a -> b) -> a -> b
$ \case
        Maybe (GenericValue Map Text TableMeta ArrayMeta)
Nothing -> RawValue -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
fromRawValue RawValue
rawValue
        Just GenericValue Map Text TableMeta ArrayMeta
existingValue ->
          NormalizeError
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall a. NormalizeError -> NormalizeM a
normalizeError
            DuplicateKeyError
              { _path :: Key
_path = Key
key
              , _existingValue :: Value
_existingValue = GenericValue Map Text TableMeta ArrayMeta -> Value
unannotateValue GenericValue Map Text TableMeta ArrayMeta
existingValue
              , _valueToSet :: Value
_valueToSet = RawValue -> Value
rawValueToApproxValue RawValue
rawValue
              }

    fromRawValue :: RawValue -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
fromRawValue = \case
      GenericTable ()
_ RawTable
rawTable -> do
        let meta :: TableMeta
meta = TableMeta{tableType :: TableType
tableType = TableType
InlineTable}
        TableMeta -> AnnTable -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
tableMeta
-> map key (GenericValue map key tableMeta arrayMeta)
-> GenericValue map key tableMeta arrayMeta
GenericTable TableMeta
meta (AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
-> NormalizeM AnnTable
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawTable -> NormalizeM AnnTable
flattenTable RawTable
rawTable
      GenericArray ()
_ [RawValue]
rawValues -> do
        let meta :: ArrayMeta
meta = ArrayMeta{isStaticArray :: Bool
isStaticArray = Bool
True}
        ArrayMeta
-> [GenericValue Map Text TableMeta ArrayMeta]
-> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
arrayMeta
-> [GenericValue map key tableMeta arrayMeta]
-> GenericValue map key tableMeta arrayMeta
GenericArray ArrayMeta
meta ([GenericValue Map Text TableMeta ArrayMeta]
 -> GenericValue Map Text TableMeta ArrayMeta)
-> NormalizeM [GenericValue Map Text TableMeta ArrayMeta]
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RawValue
 -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
-> [RawValue]
-> NormalizeM [GenericValue Map Text TableMeta ArrayMeta]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM RawValue -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
fromRawValue [RawValue]
rawValues
      GenericString Text
x -> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
Text -> GenericValue map key tableMeta arrayMeta
GenericString Text
x)
      GenericInteger Integer
x -> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
Integer -> GenericValue map key tableMeta arrayMeta
GenericInteger Integer
x)
      GenericFloat Double
x -> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
Double -> GenericValue map key tableMeta arrayMeta
GenericFloat Double
x)
      GenericBoolean Bool
x -> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
Bool -> GenericValue map key tableMeta arrayMeta
GenericBoolean Bool
x)
      GenericOffsetDateTime (LocalTime, TimeZone)
x -> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LocalTime, TimeZone) -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
(LocalTime, TimeZone) -> GenericValue map key tableMeta arrayMeta
GenericOffsetDateTime (LocalTime, TimeZone)
x)
      GenericLocalDateTime LocalTime
x -> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTime -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
LocalTime -> GenericValue map key tableMeta arrayMeta
GenericLocalDateTime LocalTime
x)
      GenericLocalDate Day
x -> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Day -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
Day -> GenericValue map key tableMeta arrayMeta
GenericLocalDate Day
x)
      GenericLocalTime TimeOfDay
x -> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeOfDay -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
TimeOfDay -> GenericValue map key tableMeta arrayMeta
GenericLocalTime TimeOfDay
x)

data ValueAtPathOptions = ValueAtPathOptions
  { ValueAtPathOptions -> TableType -> Bool
shouldRecurse :: TableType -> Bool
  , ValueAtPathOptions -> Bool
recurseArray :: Bool
  , ValueAtPathOptions -> TableType
implicitType :: TableType
  , ValueAtPathOptions
-> Key
-> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeError
makeMidPathNotTableError :: Key -> AnnValue -> NormalizeError
  }

-- | Implementation for makeMidPathNotTableError for NonTableInNestedKeyError
nonTableInNestedKeyError :: Key -> RawTable -> (Key -> AnnValue -> NormalizeError)
nonTableInNestedKeyError :: Key
-> RawTable
-> Key
-> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeError
nonTableInNestedKeyError Key
key RawTable
table = \Key
history GenericValue Map Text TableMeta ArrayMeta
existingValue ->
  NonTableInNestedKeyError
    { _path :: Key
_path = Key
history
    , _existingValue :: Value
_existingValue = GenericValue Map Text TableMeta ArrayMeta -> Value
unannotateValue GenericValue Map Text TableMeta ArrayMeta
existingValue
    , _originalKey :: Key
_originalKey = Key
key
    , _originalValue :: Value
_originalValue = Table -> Value
Table (Table -> Value) -> Table -> Value
forall a b. (a -> b) -> a -> b
$ RawTable -> Table
rawTableToApproxTable RawTable
table
    }

setValueAtPath ::
  ValueAtPathOptions
  -> Key
  -> AnnTable
  -> (Maybe AnnValue -> NormalizeM AnnValue)
  -> NormalizeM AnnTable
setValueAtPath :: ValueAtPathOptions
-> Key
-> AnnTable
-> (Maybe (GenericValue Map Text TableMeta ArrayMeta)
    -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta))
-> NormalizeM AnnTable
setValueAtPath ValueAtPathOptions{Bool
TableType
Key -> GenericValue Map Text TableMeta ArrayMeta -> NormalizeError
TableType -> Bool
shouldRecurse :: ValueAtPathOptions -> TableType -> Bool
recurseArray :: ValueAtPathOptions -> Bool
implicitType :: ValueAtPathOptions -> TableType
makeMidPathNotTableError :: ValueAtPathOptions
-> Key
-> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeError
shouldRecurse :: TableType -> Bool
recurseArray :: Bool
implicitType :: TableType
makeMidPathNotTableError :: Key -> GenericValue Map Text TableMeta ArrayMeta -> NormalizeError
..} Key
fullKey AnnTable
initialTable Maybe (GenericValue Map Text TableMeta ArrayMeta)
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
f = do
  (mValue, setValue) <- (Key
 -> Maybe (GenericValue Map Text TableMeta ArrayMeta)
 -> NormalizeM
      (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta))
-> Key
-> AnnTable
-> NormalizeM
     (Maybe (GenericValue Map Text TableMeta ArrayMeta),
      GenericValue Map Text TableMeta ArrayMeta -> AnnTable)
forall (m :: * -> *) k v.
(Monad m, Ord k) =>
(NonEmpty k -> Maybe v -> m (Map k v, Map k v -> v))
-> NonEmpty k -> Map k v -> m (Maybe v, v -> Map k v)
getPathLens Key
-> Maybe (GenericValue Map Text TableMeta ArrayMeta)
-> NormalizeM
     (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
doRecurse Key
fullKey AnnTable
initialTable
  setValue <$> f mValue
  where
    doRecurse :: Key
-> Maybe (GenericValue Map Text TableMeta ArrayMeta)
-> NormalizeM
     (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
doRecurse Key
history = \case
      -- If nothing exists, recurse into a new empty Map
      Maybe (GenericValue Map Text TableMeta ArrayMeta)
Nothing -> do
        let newTableMeta :: TableMeta
newTableMeta = TableMeta{tableType :: TableType
tableType = TableType
implicitType}
        (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
-> NormalizeM
     (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnTable
forall k a. Map k a
Map.empty, TableMeta -> AnnTable -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
tableMeta
-> map key (GenericValue map key tableMeta arrayMeta)
-> GenericValue map key tableMeta arrayMeta
GenericTable TableMeta
newTableMeta)
      -- If a Table exists, recurse into it
      Just (GenericTable TableMeta
meta AnnTable
subTable) -> do
        Bool -> NormalizeM () -> NormalizeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TableType -> Bool
shouldRecurse (TableType -> Bool) -> TableType -> Bool
forall a b. (a -> b) -> a -> b
$ TableMeta -> TableType
tableType TableMeta
meta) (NormalizeM () -> NormalizeM ()) -> NormalizeM () -> NormalizeM ()
forall a b. (a -> b) -> a -> b
$
          NormalizeError -> NormalizeM ()
forall a. NormalizeError -> NormalizeM a
normalizeError
            ExtendTableError
              { _path :: Key
_path = Key
history
              , _originalKey :: Key
_originalKey = Key
fullKey
              }
        (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
-> NormalizeM
     (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnTable
subTable, TableMeta -> AnnTable -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
tableMeta
-> map key (GenericValue map key tableMeta arrayMeta)
-> GenericValue map key tableMeta arrayMeta
GenericTable TableMeta
meta)
      -- If an Array exists, recurse into the last Table, per spec:
      --   Any reference to an array of tables points to the
      --   most recently defined table element of the array.
      Just (GenericArray ArrayMeta
aMeta [GenericValue Map Text TableMeta ArrayMeta]
vs)
        | Bool
recurseArray
        , Just NonEmpty (GenericValue Map Text TableMeta ArrayMeta)
vs' <- [GenericValue Map Text TableMeta ArrayMeta]
-> Maybe (NonEmpty (GenericValue Map Text TableMeta ArrayMeta))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [GenericValue Map Text TableMeta ArrayMeta]
vs
        , GenericTable TableMeta
tMeta AnnTable
subTable <- NonEmpty (GenericValue Map Text TableMeta ArrayMeta)
-> GenericValue Map Text TableMeta ArrayMeta
forall a. NonEmpty a -> a
NonEmpty.last NonEmpty (GenericValue Map Text TableMeta ArrayMeta)
vs' -> do
            Bool -> NormalizeM () -> NormalizeM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ArrayMeta -> Bool
isStaticArray ArrayMeta
aMeta) (NormalizeM () -> NormalizeM ()) -> NormalizeM () -> NormalizeM ()
forall a b. (a -> b) -> a -> b
$
              NormalizeError -> NormalizeM ()
forall a. NormalizeError -> NormalizeM a
normalizeError (NormalizeError -> NormalizeM ())
-> NormalizeError -> NormalizeM ()
forall a b. (a -> b) -> a -> b
$
                Key -> Key -> NormalizeError
ExtendTableInInlineArrayError Key
history Key
fullKey
            (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
-> NormalizeM
     (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
forall a. a -> NormalizeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnTable
subTable, ArrayMeta
-> [GenericValue Map Text TableMeta ArrayMeta]
-> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
arrayMeta
-> [GenericValue map key tableMeta arrayMeta]
-> GenericValue map key tableMeta arrayMeta
GenericArray ArrayMeta
aMeta ([GenericValue Map Text TableMeta ArrayMeta]
 -> GenericValue Map Text TableMeta ArrayMeta)
-> (AnnTable -> [GenericValue Map Text TableMeta ArrayMeta])
-> AnnTable
-> GenericValue Map Text TableMeta ArrayMeta
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenericValue Map Text TableMeta ArrayMeta]
-> GenericValue Map Text TableMeta ArrayMeta
-> [GenericValue Map Text TableMeta ArrayMeta]
forall {a}. [a] -> a -> [a]
snoc (NonEmpty (GenericValue Map Text TableMeta ArrayMeta)
-> [GenericValue Map Text TableMeta ArrayMeta]
forall a. NonEmpty a -> [a]
NonEmpty.init NonEmpty (GenericValue Map Text TableMeta ArrayMeta)
vs') (GenericValue Map Text TableMeta ArrayMeta
 -> [GenericValue Map Text TableMeta ArrayMeta])
-> (AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
-> AnnTable
-> [GenericValue Map Text TableMeta ArrayMeta]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableMeta -> AnnTable -> GenericValue Map Text TableMeta ArrayMeta
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
tableMeta
-> map key (GenericValue map key tableMeta arrayMeta)
-> GenericValue map key tableMeta arrayMeta
GenericTable TableMeta
tMeta)
      -- If something else exists, throw error with makeMidPathNotTableError
      Just GenericValue Map Text TableMeta ArrayMeta
v -> NormalizeError
-> NormalizeM
     (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
forall a. NormalizeError -> NormalizeM a
normalizeError (NormalizeError
 -> NormalizeM
      (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta))
-> NormalizeError
-> NormalizeM
     (AnnTable, AnnTable -> GenericValue Map Text TableMeta ArrayMeta)
forall a b. (a -> b) -> a -> b
$ Key -> GenericValue Map Text TableMeta ArrayMeta -> NormalizeError
makeMidPathNotTableError Key
history GenericValue Map Text TableMeta ArrayMeta
v

    snoc :: [a] -> a -> [a]
snoc [a]
xs a
x = [a]
xs [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a
x]

-- | Convert a RawTable into a Table, for use in errors + debugging.
rawTableToApproxTable :: RawTable -> Table
rawTableToApproxTable :: RawTable -> Table
rawTableToApproxTable =
  [(Text, Value)] -> Table
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    ([(Text, Value)] -> Table)
-> (RawTable -> [(Text, Value)]) -> RawTable -> Table
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, RawValue) -> (Text, Value))
-> [(Key, RawValue)] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Key
k, RawValue
v) -> (Text -> [Text] -> Text
Text.intercalate Text
"." ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Key -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList Key
k, RawValue -> Value
rawValueToApproxValue RawValue
v))
    ([(Key, RawValue)] -> [(Text, Value)])
-> (RawTable -> [(Key, RawValue)]) -> RawTable -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTable -> [(Key, RawValue)]
forall k v. LookupMap k v -> [(k, v)]
unLookupMap

-- | Convert a RawValue into a Value, for use in errors + debugging.
rawValueToApproxValue :: RawValue -> Value
rawValueToApproxValue :: RawValue -> Value
rawValueToApproxValue = (RawTable -> Table) -> RawValue -> Value
forall {k} (map :: k -> * -> *) (key :: k) tableMeta arrayMeta.
(map key (GenericValue map key tableMeta arrayMeta) -> Table)
-> GenericValue map key tableMeta arrayMeta -> Value
fromGenericValue RawTable -> Table
rawTableToApproxTable

{--- Parser Helpers ---}

-- | https://github.com/toml-lang/toml/blob/1.0.0/toml.abnf#L38
isNonAscii :: Char -> Bool
isNonAscii :: Char -> Bool
isNonAscii Char
c = (Int
0x80 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xD7FF) Bool -> Bool -> Bool
|| (Int
0xE000 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10FFFF)
  where
    code :: Int
code = Char -> Int
ord Char
c

-- | https://unicode.org/glossary/#unicode_scalar_value
isUnicodeScalar :: Int -> Bool
isUnicodeScalar :: Int -> Bool
isUnicodeScalar Int
code = (Int
0x0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xD7FF) Bool -> Bool -> Bool
|| (Int
0xE000 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10FFFF)

-- | Returns "", "-", or "+"
parseSignRaw :: Parser Text
parseSignRaw :: ParsecT Void Text Identity Text
parseSignRaw = Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a. a -> Parser a -> Parser a
optionalOr Text
"" (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
"-" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
"+")

parseSign :: (Num a) => Parser (a -> a)
parseSign :: forall a. Num a => Parser (a -> a)
parseSign = do
  sign <- ParsecT Void Text Identity Text
parseSignRaw
  pure $ if sign == "-" then negate else id

parseDecIntRaw :: Parser Text
parseDecIntRaw :: ParsecT Void Text Identity Text
parseDecIntRaw =
  [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
parseNumRaw ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text))
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall a b. (a -> b) -> a -> b
$ \Token Text
c -> Char -> Bool
isDigit Char
Token Text
c Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'0') ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
    , Char -> Text
Text.singleton (Char -> Text)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
    ]

parseDecDigits :: (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits :: forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
n = Text -> a
forall a. (Show a, Num a, Eq a) => Text -> a
readDec (Text -> a) -> (String -> Text) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> a)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
n ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar

parseNumRaw :: Parser Char -> Parser Char -> Parser Text
parseNumRaw :: ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
parseNumRaw ParsecT Void Text Identity Char
parseLeadingDigit ParsecT Void Text Identity Char
parseDigit = do
  leading <- ParsecT Void Text Identity Char
parseLeadingDigit
  rest <- many $ optional (char '_') *> parseDigit
  pure $ Text.pack $ leading : rest

{--- Parser Utilities ---}

hsymbol :: Text -> Parser ()
hsymbol :: Text -> Parser ()
hsymbol Text
s = Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace Parser ()
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
s ParsecT Void Text Identity (Tokens Text) -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace Parser () -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Parser ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Parse trailing whitespace/trailing comments + newline
endOfLine :: Parser ()
endOfLine :: Parser ()
endOfLine = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace1 Parser ()
skipComments Parser ()
forall a. ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a
empty Parser () -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol Parser () -> Parser () -> Parser ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) Parser () -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Parser ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Parse spaces, newlines, and comments
emptyLines :: Parser ()
emptyLines :: Parser ()
emptyLines = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space Parser ()
space1 Parser ()
skipComments Parser ()
forall a. ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a
empty

skipComments :: Parser ()
skipComments :: Parser ()
skipComments = do
  _ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"#"
  void . many $ do
    c <- satisfy (/= '\n')
    let code = Char -> Int
ord Char
c
    case c of
      Char
'\r' -> ParsecT Void Text Identity Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> Parser ())
-> ParsecT Void Text Identity Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'\n')
      Char
_
        | (Int
0x00 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x08) Bool -> Bool -> Bool
|| (Int
0x0A Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x1F) Bool -> Bool -> Bool
|| Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x7F ->
            String -> Parser ()
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"Comment has invalid character: \\" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
code
      Char
_ -> () -> Parser ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

space, space1 :: Parser ()
space :: Parser ()
space = ParsecT Void Text Identity [()] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity [()] -> Parser ())
-> ParsecT Void Text Identity [()] -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser () -> ParsecT Void Text Identity [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser ()
parseSpace
space1 :: Parser ()
space1 = ParsecT Void Text Identity [()] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity [()] -> Parser ())
-> ParsecT Void Text Identity [()] -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser () -> ParsecT Void Text Identity [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser ()
parseSpace

-- | TOML does not support bare '\r' without '\n'.
parseSpace :: Parser ()
parseSpace :: Parser ()
parseSpace = ParsecT Void Text Identity (Token Text) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (\Token Text
c -> Char -> Bool
isSpace Char
Token Text
c Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')) Parser () -> Parser () -> Parser ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity (Tokens Text) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"\r\n")

#if !MIN_VERSION_megaparsec(9,0,0)
hspace :: Parser ()
hspace = void $ takeWhileP (Just "white space") isHSpace

hspace1 :: Parser ()
hspace1 = void $ takeWhile1P (Just "white space") isHSpace

isHSpace :: Char -> Bool
isHSpace x = isSpace x && x /= '\n' && x /= '\r'
#endif

optionalOr :: a -> Parser a -> Parser a
optionalOr :: forall a. a -> Parser a -> Parser a
optionalOr a
def = (Maybe a -> a)
-> ParsecT Void Text Identity (Maybe a)
-> ParsecT Void Text Identity a
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def) (ParsecT Void Text Identity (Maybe a)
 -> ParsecT Void Text Identity a)
-> (ParsecT Void Text Identity a
    -> ParsecT Void Text Identity (Maybe a))
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity a
-> ParsecT Void Text Identity (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional

exactly :: Int -> Char -> Parser Text
exactly :: Int -> Char -> ParsecT Void Text Identity Text
exactly Int
n Char
c = ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
n (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
c) ParsecT Void Text Identity Text
-> Parser () -> ParsecT Void Text Identity Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> Parser ()
forall a. ParsecT Void Text Identity a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
c)

{--- Read Helpers ---}

-- | Assumes string satisfies @all isDigit@.
readFloat :: (Show a, RealFrac a) => Text -> a
readFloat :: forall a. (Show a, RealFrac a) => Text -> a
readFloat = ReadS a -> Text -> a
forall a. Show a => ReadS a -> Text -> a
runReader ReadS a
forall a. RealFrac a => ReadS a
Numeric.readFloat

-- | Assumes string satisfies @all isDigit@.
readDec :: (Show a, Num a, Eq a) => Text -> a
readDec :: forall a. (Show a, Num a, Eq a) => Text -> a
readDec = ReadS a -> Text -> a
forall a. Show a => ReadS a -> Text -> a
runReader ReadS a
forall a. (Eq a, Num a) => ReadS a
Numeric.readDec

-- | Assumes string satisfies @all isHexDigit@.
readHex :: (Show a, Num a, Eq a) => Text -> a
readHex :: forall a. (Show a, Num a, Eq a) => Text -> a
readHex = ReadS a -> Text -> a
forall a. Show a => ReadS a -> Text -> a
runReader ReadS a
forall a. (Eq a, Num a) => ReadS a
Numeric.readHex

-- | Assumes string satisfies @all isOctDigit@.
readOct :: (Show a, Num a, Eq a) => Text -> a
readOct :: forall a. (Show a, Num a, Eq a) => Text -> a
readOct = ReadS a -> Text -> a
forall a. Show a => ReadS a -> Text -> a
runReader ReadS a
forall a. (Eq a, Num a) => ReadS a
Numeric.readOct

-- | Assumes string satisfies @all (`elem` "01")@.
readBin :: (Show a, Num a) => Text -> a
readBin :: forall a. (Show a, Num a) => Text -> a
readBin = (a -> Char -> a) -> a -> String -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> Char -> a
forall {a}. Num a => a -> Char -> a
go a
0 (String -> a) -> (Text -> String) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
  where
    go :: a -> Char -> a
go a
acc Char
x =
      let digit :: a
digit
            | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0' = a
0
            | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'1' = a
1
            | Bool
otherwise = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"readBin got unexpected digit: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
x
       in a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
acc a -> a -> a
forall a. Num a => a -> a -> a
+ a
digit

runReader :: (Show a) => ReadS a -> Text -> a
runReader :: forall a. Show a => ReadS a -> Text -> a
runReader ReadS a
rdr Text
digits =
  case ReadS a
rdr ReadS a -> ReadS a
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
digits of
    [(a
x, String
"")] -> a
x
    [(a, String)]
result -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Unexpectedly unable to parse " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
digits String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(a, String)] -> String
forall a. Show a => a -> String
show [(a, String)]
result