{-# 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 (foldl', foldlM)
import Data.Functor (($>))
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time (Day, LocalTime, TimeOfDay, TimeZone)
import qualified Data.Time as Time
import Data.Void (Void)
import qualified Numeric
import Text.Megaparsec hiding (sepBy1)
import Text.Megaparsec.Char hiding (space, space1)
import qualified Text.Megaparsec.Char.Lexer as L

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

parseTOML ::
  -- | Name of file (for error messages)
  String ->
  -- | Input
  Text ->
  Either TOMLError Value
parseTOML :: String -> Text -> Either TOMLError Value
parseTOML String
filename Text
input =
  case forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parser TOMLDoc
parseTOMLDocument String
filename Text
input of
    Left ParseErrorBundle Text Void
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> TOMLError
ParseError forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
e
    Right TOMLDoc
result -> Table -> Value
Table 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 (map :: * -> * -> *) key 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 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (map :: * -> * -> *) key 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 :: Parser TOMLDoc
parseTOMLDocument = do
  Parser ()
emptyLines
  RawTable
rootTable <- Parser RawTable
parseRawTable
  Parser ()
emptyLines
  [TableSection]
subTables <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser TableSection
parseTableSection
  Parser ()
emptyLines
  forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  forall (m :: * -> *) a. Monad m => a -> m a
return TOMLDoc{[TableSection]
RawTable
subTables :: [TableSection]
rootTable :: RawTable
subTables :: [TableSection]
rootTable :: RawTable
..}

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

parseTableSection :: Parser TableSection
parseTableSection :: Parser TableSection
parseTableSection = do
  TableSectionHeader
tableSectionHeader <-
    forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
      [ Key -> TableSectionHeader
SectionTableArray 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> ParsecT Void Text Identity Key
parseHeader Text
"[" Text
"]"
      ]
  Parser ()
endOfLine
  Parser ()
emptyLines
  RawTable
tableSectionTable <- Parser RawTable
parseRawTable
  Parser ()
emptyLines
  forall (m :: * -> *) a. Monad m => a -> m a
return TableSection{TableSectionHeader
RawTable
tableSectionTable :: RawTable
tableSectionHeader :: TableSectionHeader
tableSectionTable :: RawTable
tableSectionHeader :: TableSectionHeader
..}
  where
    parseHeader :: Text -> Text -> ParsecT Void Text Identity Key
parseHeader Text
brackStart Text
brackEnd = Text -> Parser ()
hsymbol Text
brackStart forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Key
parseKey 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
key <- ParsecT Void Text Identity Key
parseKey
  Text -> Parser ()
hsymbol Text
"="
  RawValue
value <- Parser RawValue
parseValue
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key
key, RawValue
value)

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

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

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

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

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

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

-- | A multiline string with three double quotes.
parseMultilineBasicString :: Parser Text
parseMultilineBasicString :: ParsecT Void Text Identity Text
parseMultilineBasicString =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"double-quoted multiline string" forall a b. (a -> b) -> a -> b
$ do
    Maybe (Tokens Text)
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"\"\"\"" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
    Parser ()
lineContinuation
    [Text] -> Text
Text.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill (ParsecT Void Text Identity Text
mlBasicContent forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
lineContinuation) (Int -> Char -> ParsecT Void Text Identity Text
exactly Int
3 Char
'"')
  where
    mlBasicContent :: ParsecT Void Text Identity Text
mlBasicContent =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Char -> Text
Text.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Char
parseEscaped
        , Char -> Text
Text.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isBasicChar
        , Char -> ParsecT Void Text Identity Text
parseMultilineDelimiter Char
'"'
        , forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
        ]
    lineContinuation :: Parser ()
lineContinuation = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
space) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"single-quoted multiline string" forall a b. (a -> b) -> a -> b
$ do
    Maybe (Tokens Text)
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"'''" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
    [Text] -> Text
Text.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill ParsecT Void Text Identity Text
mlLiteralContent (Int -> Char -> ParsecT Void Text Identity Text
exactly Int
3 Char
'\'')
  where
    mlLiteralContent :: ParsecT Void Text Identity Text
mlLiteralContent =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ Char -> Text
Text.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isLiteralChar
        , Char -> ParsecT Void Text Identity Text
parseMultilineDelimiter Char
'\''
        , 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 = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\\' 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 =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"'
        , forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\\'
        , forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'b' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\b'
        , forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'f' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\f'
        , forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'n' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\n'
        , forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'r' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\r'
        , forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
't' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Char
'\t'
        , forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'u' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall {s} {m :: * -> *} {e}.
(Token s ~ Char, MonadParsec e s m) =>
Int -> m Char
unicodeHex Int
4
        , forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'U' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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
      Int
code <- forall a. (Show a, Num a, Eq a) => Text -> a
readHex forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
n forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
hexDigitChar
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int -> Bool
isUnicodeScalar Int
code
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> Char
chr Int
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 =
  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
        Text
_ <- 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)
        String -> Text
Text.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
1 (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
delim)
    , do
        Text
_ <- 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)
        String -> Text
Text.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
2 (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char 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 forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code forall a. Ord a => a -> a -> Bool
<= Int
0x7E -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
c 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 forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code forall a. Ord a => a -> a -> Bool
<= Int
0x7E -> Char
c 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 :: Parser (LocalTime, TimeZone)
parseOffsetDateTime = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser LocalTime
parseLocalDateTime 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 =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
'Z' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TimeZone
Time.utc
        , do
            Int -> Int
applySign <- forall a. Num a => Parser (a -> a)
parseSign
            Int
h <- Parser Int
parseHours
            Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':'
            Int
m <- Parser Int
parseMinutes
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> TimeZone
Time.minutesToTimeZone forall a b. (a -> b) -> a -> b
$ Int -> Int
applySign forall a b. (a -> b) -> a -> b
$ Int
h forall a. Num a => a -> a -> a
* Int
60 forall a. Num a => a -> a -> a
+ Int
m
        ]

parseLocalDateTime :: Parser LocalTime
parseLocalDateTime :: Parser LocalTime
parseLocalDateTime = do
  Day
d <- Parser Day
parseLocalDate
  Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' Char
'T' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
' '
  TimeOfDay
t <- Parser TimeOfDay
parseLocalTime
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Day -> TimeOfDay -> LocalTime
Time.LocalTime Day
d TimeOfDay
t

parseLocalDate :: Parser Day
parseLocalDate :: Parser Day
parseLocalDate = do
  Integer
y <- forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
4
  Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'-'
  Int
m <- forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
2
  Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'-'
  Int
d <- forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
2
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (f :: * -> *) a. Alternative f => f a
empty forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Maybe Day
Time.fromGregorianValid Integer
y Int
m Int
d

parseLocalTime :: Parser TimeOfDay
parseLocalTime :: Parser TimeOfDay
parseLocalTime = do
  Int
h <- Parser Int
parseHours
  Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':'
  Int
m <- Parser Int
parseMinutes
  Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':'
  Int
sInt <- Parser Int
parseSeconds
  Maybe Text
sFracRaw <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'.' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  let sFrac :: Pico
sFrac = forall k (a :: k). Integer -> Fixed a
MkFixed forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
0 forall a. (Show a, Num a, Eq a) => Text -> a
readPicoDigits Maybe Text
sFracRaw
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pico -> TimeOfDay
Time.TimeOfDay Int
h Int
m (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sInt forall a. Num a => a -> a -> a
+ Pico
sFrac)
  where
    readPicoDigits :: Text -> a
readPicoDigits Text
s = forall a. (Show a, Num a, Eq a) => Text -> a
readDec forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.take Int
12 (Text
s forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate Int
12 Text
"0")

parseHours :: Parser Int
parseHours :: Parser Int
parseHours = do
  Int
h <- forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
2
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
0 forall a. Ord a => a -> a -> Bool
<= Int
h Bool -> Bool -> Bool
&& Int
h forall a. Ord a => a -> a -> Bool
< Int
24
  forall (m :: * -> *) a. Monad m => a -> m a
return Int
h

parseMinutes :: Parser Int
parseMinutes :: Parser Int
parseMinutes = do
  Int
m <- forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
2
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
0 forall a. Ord a => a -> a -> Bool
<= Int
m Bool -> Bool -> Bool
&& Int
m forall a. Ord a => a -> a -> Bool
< Int
60
  forall (m :: * -> *) a. Monad m => a -> m a
return Int
m

parseSeconds :: Parser Int
parseSeconds :: Parser Int
parseSeconds = do
  Int
s <- forall a. (Show a, Num a, Eq a) => Int -> Parser a
parseDecDigits Int
2
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
0 forall a. Ord a => a -> a -> Bool
<= Int
s Bool -> Bool -> Bool
&& Int
s forall a. Ord a => a -> a -> Bool
<= Int
60 -- include 60 for leap seconds
  forall (m :: * -> *) a. Monad m => a -> m a
return Int
s

parseFloat :: Parser Double
parseFloat :: Parser Double
parseFloat = do
  Double -> Double
applySign <- forall a. Num a => Parser (a -> a)
parseSign
  Double
num <-
    forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
      [ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Double
normalFloat
      , forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"inf" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Double
inf
      , forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"nan" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Double
nan
      ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Double -> Double
applySign Double
num
  where
    normalFloat :: Parser Double
normalFloat = do
      Text
intPart <- ParsecT Void Text Identity Text
parseDecIntRaw
      (Text
fracPart, Text
expPart) <-
        forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
          [ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Text
parseExp
          , (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseFrac forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> Parser a -> Parser a
optionalOr Text
"" ParsecT Void Text Identity Text
parseExp
          ]

      -- guess if the exponent is too big to fit in a double precision float anyway.
      -- https://github.com/brandonchinn178/toml-reader/issues/8
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        if Text -> Int
Text.length Text
expPart forall a. Ord a => a -> a -> Bool
> Int
7
          then Double
inf
          else forall a. (Show a, RealFrac a) => Text -> a
readFloat forall a b. (a -> b) -> a -> b
$ Text
intPart forall a. Semigroup a => a -> a -> a
<> Text
fracPart forall a. Semigroup a => a -> a -> a
<> Text
expPart

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

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

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

parseBoolean :: Parser Bool
parseBoolean :: Parser Bool
parseBoolean =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"true"
    , Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 = 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 = forall (map :: * -> * -> *) key 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TableType -> TableType -> Bool
$c/= :: TableType -> TableType -> Bool
== :: TableType -> TableType -> Bool
$c== :: 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 = forall a. Either NormalizeError a -> NormalizeM a
NormalizeM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NormalizeM a -> Either NormalizeError a
runNormalizeM
instance Applicative NormalizeM where
  pure :: forall a. a -> NormalizeM a
pure = forall a. Either NormalizeError a -> NormalizeM a
NormalizeM forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Either NormalizeError a -> NormalizeM a
NormalizeM (Either NormalizeError (a -> b)
f 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 = forall a. Either NormalizeError a -> NormalizeM a
NormalizeM forall a b. (a -> b) -> a -> b
$ forall a. NormalizeM a -> Either NormalizeError a
runNormalizeM forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NormalizeM b
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. NormalizeM a -> Either NormalizeError a
runNormalizeM NormalizeM a
m

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

normalize :: TOMLDoc -> Either TOMLError Table
normalize :: TOMLDoc -> Either TOMLError Table
normalize = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NormalizeM a -> Either NormalizeError a
runNormalizeM 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
subTables :: [TableSection]
rootTable :: RawTable
subTables :: TOMLDoc -> [TableSection]
rootTable :: TOMLDoc -> RawTable
..} = do
  AnnTable
root <- RawTable -> NormalizeM AnnTable
flattenTable RawTable
rootTable
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM AnnTable -> TableSection -> NormalizeM AnnTable
mergeTableSection AnnTable
root [TableSection]
subTables
  where
    mergeTableSection :: AnnTable -> TableSection -> NormalizeM AnnTable
    mergeTableSection :: AnnTable -> TableSection -> NormalizeM AnnTable
mergeTableSection AnnTable
baseTable TableSection{TableSectionHeader
RawTable
tableSectionTable :: RawTable
tableSectionHeader :: TableSectionHeader
tableSectionTable :: TableSection -> RawTable
tableSectionHeader :: TableSection -> TableSectionHeader
..} = 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 forall a b. (a -> b) -> a -> b
$ \Maybe (GenericValue Map Text TableMeta ArrayMeta)
mVal -> do
    AnnTable
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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
_ -> 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

    AnnTable
mergedTable <-
      MergeOptions -> AnnTable -> RawTable -> NormalizeM AnnTable
mergeRawTable
        MergeOptions{recurseImplicitSections :: Bool
recurseImplicitSections = Bool
False}
        AnnTable
tableToExtend
        RawTable
table

    let newTableMeta :: TableMeta
newTableMeta = TableMeta{tableType :: TableType
tableType = TableType
ExplicitSection}
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (map :: * -> * -> *) key tableMeta arrayMeta.
tableMeta
-> map key (GenericValue map key tableMeta arrayMeta)
-> GenericValue map key tableMeta arrayMeta
GenericTable TableMeta
newTableMeta AnnTable
mergedTable
  where
    valueAtPathOptions :: ValueAtPathOptions
valueAtPathOptions =
      ValueAtPathOptions
        { shouldRecurse :: TableType -> Bool
shouldRecurse = \case
            TableType
InlineTable -> Bool
False
            TableType
ImplicitKey -> Bool
False
            TableType
ExplicitSection -> Bool
True
            TableType
ImplicitSection -> 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 =
      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 forall a b. (a -> b) -> a -> b
$ RawTable -> Table
rawTableToApproxTable RawTable
table
          }
    extendTableError :: NormalizeM AnnTable
extendTableError =
      forall a. NormalizeError -> NormalizeM a
normalizeError
        ExtendTableError
          { _path :: Key
_path = Key
sectionKey
          , _originalKey :: Key
_originalKey = Key
sectionKey
          }
    duplicateSectionError :: NormalizeM AnnTable
duplicateSectionError =
      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 forall a b. (a -> b) -> a -> b
$ \Maybe (GenericValue Map Text TableMeta ArrayMeta)
mVal -> do
    (ArrayMeta
meta, [GenericValue Map Text TableMeta ArrayMeta]
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}
          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) ->
              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 ->
          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
newTableMeta = TableMeta{tableType :: TableType
tableType = TableType
ExplicitSection}
    GenericValue Map Text TableMeta ArrayMeta
newTable <- forall (map :: * -> * -> *) key tableMeta arrayMeta.
tableMeta
-> map key (GenericValue map key tableMeta arrayMeta)
-> GenericValue map key tableMeta arrayMeta
GenericTable TableMeta
newTableMeta forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawTable -> NormalizeM AnnTable
flattenTable RawTable
table
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (map :: * -> * -> *) key tableMeta arrayMeta.
arrayMeta
-> [GenericValue map key tableMeta arrayMeta]
-> GenericValue map key tableMeta arrayMeta
GenericArray ArrayMeta
meta forall a b. (a -> b) -> a -> b
$ [GenericValue Map Text TableMeta ArrayMeta]
currArray forall a. Semigroup a => a -> a -> a
<> [GenericValue Map Text TableMeta ArrayMeta
newTable]
  where
    valueAtPathOptions :: ValueAtPathOptions
valueAtPathOptions =
      ValueAtPathOptions
        { shouldRecurse :: TableType -> Bool
shouldRecurse = \case
            TableType
InlineTable -> Bool
False
            TableType
ImplicitKey -> Bool
False
            TableType
ExplicitSection -> Bool
True
            TableType
ImplicitSection -> 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}
    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 :: Bool
recurseImplicitSections :: MergeOptions -> Bool
..} AnnTable
baseTable RawTable
table = 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 (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
              , 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 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 ->
          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}
        forall (map :: * -> * -> *) key tableMeta arrayMeta.
tableMeta
-> map key (GenericValue map key tableMeta arrayMeta)
-> GenericValue map key tableMeta arrayMeta
GenericTable TableMeta
meta 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}
        forall (map :: * -> * -> *) key tableMeta arrayMeta.
arrayMeta
-> [GenericValue map key tableMeta arrayMeta]
-> GenericValue map key tableMeta arrayMeta
GenericArray ArrayMeta
meta forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RawValue -> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
fromRawValue [RawValue]
rawValues
      GenericString Text
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (map :: * -> * -> *) key tableMeta arrayMeta.
Text -> GenericValue map key tableMeta arrayMeta
GenericString Text
x)
      GenericInteger Integer
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (map :: * -> * -> *) key tableMeta arrayMeta.
Integer -> GenericValue map key tableMeta arrayMeta
GenericInteger Integer
x)
      GenericFloat Double
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (map :: * -> * -> *) key tableMeta arrayMeta.
Double -> GenericValue map key tableMeta arrayMeta
GenericFloat Double
x)
      GenericBoolean Bool
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (map :: * -> * -> *) key tableMeta arrayMeta.
Bool -> GenericValue map key tableMeta arrayMeta
GenericBoolean Bool
x)
      GenericOffsetDateTime (LocalTime, TimeZone)
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (map :: * -> * -> *) key tableMeta arrayMeta.
(LocalTime, TimeZone) -> GenericValue map key tableMeta arrayMeta
GenericOffsetDateTime (LocalTime, TimeZone)
x)
      GenericLocalDateTime LocalTime
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (map :: * -> * -> *) key tableMeta arrayMeta.
LocalTime -> GenericValue map key tableMeta arrayMeta
GenericLocalDateTime LocalTime
x)
      GenericLocalDate Day
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (map :: * -> * -> *) key tableMeta arrayMeta.
Day -> GenericValue map key tableMeta arrayMeta
GenericLocalDate Day
x)
      GenericLocalTime TimeOfDay
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (map :: * -> * -> *) key tableMeta arrayMeta.
TimeOfDay -> GenericValue map key tableMeta arrayMeta
GenericLocalTime TimeOfDay
x)

data ValueAtPathOptions = ValueAtPathOptions
  { ValueAtPathOptions -> TableType -> Bool
shouldRecurse :: TableType -> 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 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{TableType
Key -> GenericValue Map Text TableMeta ArrayMeta -> NormalizeError
TableType -> Bool
makeMidPathNotTableError :: Key -> GenericValue Map Text TableMeta ArrayMeta -> NormalizeError
implicitType :: TableType
shouldRecurse :: TableType -> Bool
makeMidPathNotTableError :: ValueAtPathOptions
-> Key
-> GenericValue Map Text TableMeta ArrayMeta
-> NormalizeError
implicitType :: ValueAtPathOptions -> TableType
shouldRecurse :: ValueAtPathOptions -> TableType -> Bool
..} Key
fullKey AnnTable
initialTable Maybe (GenericValue Map Text TableMeta ArrayMeta)
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
f = do
  (Maybe (GenericValue Map Text TableMeta ArrayMeta)
mValue, GenericValue Map Text TableMeta ArrayMeta -> AnnTable
setValue) <- 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
  GenericValue Map Text TableMeta ArrayMeta -> AnnTable
setValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GenericValue Map Text TableMeta ArrayMeta)
-> NormalizeM (GenericValue Map Text TableMeta ArrayMeta)
f Maybe (GenericValue Map Text TableMeta ArrayMeta)
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}
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Map k a
Map.empty, forall (map :: * -> * -> *) key 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TableType -> Bool
shouldRecurse forall a b. (a -> b) -> a -> b
$ TableMeta -> TableType
tableType TableMeta
meta) forall a b. (a -> b) -> a -> b
$
          forall a. NormalizeError -> NormalizeM a
normalizeError
            ExtendTableError
              { _path :: Key
_path = Key
history
              , _originalKey :: Key
_originalKey = Key
fullKey
              }
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnTable
subTable, forall (map :: * -> * -> *) key 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)
        | Just NonEmpty (GenericValue Map Text TableMeta ArrayMeta)
vs' <- forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [GenericValue Map Text TableMeta ArrayMeta]
vs
        , GenericTable TableMeta
tMeta AnnTable
subTable <- forall a. NonEmpty a -> a
NonEmpty.last NonEmpty (GenericValue Map Text TableMeta ArrayMeta)
vs' -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ArrayMeta -> Bool
isStaticArray ArrayMeta
aMeta) forall a b. (a -> b) -> a -> b
$
              forall a. NormalizeError -> NormalizeM a
normalizeError forall a b. (a -> b) -> a -> b
$
                Key -> Key -> NormalizeError
ExtendTableInInlineArrayError Key
history Key
fullKey
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnTable
subTable, forall (map :: * -> * -> *) key tableMeta arrayMeta.
arrayMeta
-> [GenericValue map key tableMeta arrayMeta]
-> GenericValue map key tableMeta arrayMeta
GenericArray ArrayMeta
aMeta forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> a -> [a]
snoc (forall a. NonEmpty a -> [a]
NonEmpty.init NonEmpty (GenericValue Map Text TableMeta ArrayMeta)
vs') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (map :: * -> * -> *) key 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 -> forall a. NormalizeError -> NormalizeM a
normalizeError 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 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 =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(Key
k, RawValue
v) -> (Text -> [Text] -> Text
Text.intercalate Text
"." forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NonEmpty.toList Key
k, RawValue -> Value
rawValueToApproxValue RawValue
v))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (map :: * -> * -> *) key 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 forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code forall a. Ord a => a -> a -> Bool
<= Int
0xD7FF) Bool -> Bool -> Bool
|| (Int
0xE000 forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code 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 forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code forall a. Ord a => a -> a -> Bool
<= Int
0xD7FF) Bool -> Bool -> Bool
|| (Int
0xE000 forall a. Ord a => a -> a -> Bool
<= Int
code Bool -> Bool -> Bool
&& Int
code forall a. Ord a => a -> a -> Bool
<= Int
0x10FFFF)

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

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

parseDecIntRaw :: Parser Text
parseDecIntRaw :: ParsecT Void Text Identity Text
parseDecIntRaw =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
parseNumRaw (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy forall a b. (a -> b) -> a -> b
$ \Token Text
c -> Char -> Bool
isDigit Token Text
c Bool -> Bool -> Bool
&& Token Text
c forall a. Eq a => a -> a -> Bool
/= Char
'0') forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
    , Char -> Text
Text.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. (Show a, Num a, Eq a) => Text -> a
readDec forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
n 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
  Char
leading <- ParsecT Void Text Identity Char
parseLeadingDigit
  String
rest <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'_') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Char
parseDigit
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ Char
leading forall a. a -> [a] -> [a]
: String
rest

{--- Parser Utilities ---}

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

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

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

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

space, space1 :: Parser ()
space :: Parser ()
space = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser ()
parseSpace
space1 :: Parser ()
space1 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (\Token Text
c -> Char -> Bool
isSpace Token Text
c Bool -> Bool -> Bool
&& Token Text
c forall a. Eq a => a -> a -> Bool
/= Char
'\r')) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Functor f => f a -> f ()
void (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe a
def) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
n (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
c) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
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 = forall a. Show a => ReadS a -> Text -> a
runReader 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 = forall a. Show a => ReadS a -> Text -> a
runReader 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 = forall a. Show a => ReadS a -> Text -> a
runReader 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 = forall a. Show a => ReadS a -> Text -> a
runReader 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Num a => a -> Char -> a
go a
0 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 forall a. Eq a => a -> a -> Bool
== Char
'0' = a
0
            | Char
x forall a. Eq a => a -> a -> Bool
== Char
'1' = a
1
            | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"readBin got unexpected digit: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Char
x
       in a
2 forall a. Num a => a -> a -> a
* a
acc 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 forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
digits of
    [(a
x, String
"")] -> a
x
    [(a, String)]
result -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unexpectedly unable to parse " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
digits forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [(a, String)]
result