{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use section" #-}
{-|
Module      : Toml.Semantics
Description : Semantic interpretation of raw TOML expressions
Copyright   : (c) Eric Mertens, 2023
License     : ISC
Maintainer  : emertens@gmail.com

This module extracts a nested Map representation of a TOML
file. It detects invalid key assignments and resolves dotted
key assignments.

-}
module Toml.Semantics (

    -- * Types
    Value, Value'(..),
    Table, Table'(..),

    -- * Validation
    semantics,
    SemanticError(..), SemanticErrorKind(..),

    -- * Annotations
    forgetTableAnns,
    forgetValueAnns,
    valueAnn,
    valueType,

    ) where

import Control.Monad (foldM)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Text (Text)
import Toml.Syntax.Types (SectionKind(..), Key, Val(..), Expr(..))
import Toml.Semantics.Types

-- | This type represents errors generated when resolving keys in a TOML
-- document.
--
-- @since 1.3.0.0
data SemanticError a = SemanticError {
    forall a. SemanticError a -> a
errorAnn :: a, -- ^ Annotation associated with offending key
    forall a. SemanticError a -> Text
errorKey :: Text,
    forall a. SemanticError a -> SemanticErrorKind
errorKind :: SemanticErrorKind
    } deriving (
        ReadPrec [SemanticError a]
ReadPrec (SemanticError a)
Int -> ReadS (SemanticError a)
ReadS [SemanticError a]
(Int -> ReadS (SemanticError a))
-> ReadS [SemanticError a]
-> ReadPrec (SemanticError a)
-> ReadPrec [SemanticError a]
-> Read (SemanticError a)
forall a. Read a => ReadPrec [SemanticError a]
forall a. Read a => ReadPrec (SemanticError a)
forall a. Read a => Int -> ReadS (SemanticError a)
forall a. Read a => ReadS [SemanticError a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (SemanticError a)
readsPrec :: Int -> ReadS (SemanticError a)
$creadList :: forall a. Read a => ReadS [SemanticError a]
readList :: ReadS [SemanticError a]
$creadPrec :: forall a. Read a => ReadPrec (SemanticError a)
readPrec :: ReadPrec (SemanticError a)
$creadListPrec :: forall a. Read a => ReadPrec [SemanticError a]
readListPrec :: ReadPrec [SemanticError a]
Read {- ^ Default instance -},
        Int -> SemanticError a -> ShowS
[SemanticError a] -> ShowS
SemanticError a -> String
(Int -> SemanticError a -> ShowS)
-> (SemanticError a -> String)
-> ([SemanticError a] -> ShowS)
-> Show (SemanticError a)
forall a. Show a => Int -> SemanticError a -> ShowS
forall a. Show a => [SemanticError a] -> ShowS
forall a. Show a => SemanticError a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> SemanticError a -> ShowS
showsPrec :: Int -> SemanticError a -> ShowS
$cshow :: forall a. Show a => SemanticError a -> String
show :: SemanticError a -> String
$cshowList :: forall a. Show a => [SemanticError a] -> ShowS
showList :: [SemanticError a] -> ShowS
Show {- ^ Default instance -},
        SemanticError a -> SemanticError a -> Bool
(SemanticError a -> SemanticError a -> Bool)
-> (SemanticError a -> SemanticError a -> Bool)
-> Eq (SemanticError a)
forall a. Eq a => SemanticError a -> SemanticError a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => SemanticError a -> SemanticError a -> Bool
== :: SemanticError a -> SemanticError a -> Bool
$c/= :: forall a. Eq a => SemanticError a -> SemanticError a -> Bool
/= :: SemanticError a -> SemanticError a -> Bool
Eq   {- ^ Default instance -},
        Eq (SemanticError a)
Eq (SemanticError a) =>
(SemanticError a -> SemanticError a -> Ordering)
-> (SemanticError a -> SemanticError a -> Bool)
-> (SemanticError a -> SemanticError a -> Bool)
-> (SemanticError a -> SemanticError a -> Bool)
-> (SemanticError a -> SemanticError a -> Bool)
-> (SemanticError a -> SemanticError a -> SemanticError a)
-> (SemanticError a -> SemanticError a -> SemanticError a)
-> Ord (SemanticError a)
SemanticError a -> SemanticError a -> Bool
SemanticError a -> SemanticError a -> Ordering
SemanticError a -> SemanticError a -> SemanticError a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (SemanticError a)
forall a. Ord a => SemanticError a -> SemanticError a -> Bool
forall a. Ord a => SemanticError a -> SemanticError a -> Ordering
forall a.
Ord a =>
SemanticError a -> SemanticError a -> SemanticError a
$ccompare :: forall a. Ord a => SemanticError a -> SemanticError a -> Ordering
compare :: SemanticError a -> SemanticError a -> Ordering
$c< :: forall a. Ord a => SemanticError a -> SemanticError a -> Bool
< :: SemanticError a -> SemanticError a -> Bool
$c<= :: forall a. Ord a => SemanticError a -> SemanticError a -> Bool
<= :: SemanticError a -> SemanticError a -> Bool
$c> :: forall a. Ord a => SemanticError a -> SemanticError a -> Bool
> :: SemanticError a -> SemanticError a -> Bool
$c>= :: forall a. Ord a => SemanticError a -> SemanticError a -> Bool
>= :: SemanticError a -> SemanticError a -> Bool
$cmax :: forall a.
Ord a =>
SemanticError a -> SemanticError a -> SemanticError a
max :: SemanticError a -> SemanticError a -> SemanticError a
$cmin :: forall a.
Ord a =>
SemanticError a -> SemanticError a -> SemanticError a
min :: SemanticError a -> SemanticError a -> SemanticError a
Ord  {- ^ Default instance -},
        (forall a b. (a -> b) -> SemanticError a -> SemanticError b)
-> (forall a b. a -> SemanticError b -> SemanticError a)
-> Functor SemanticError
forall a b. a -> SemanticError b -> SemanticError a
forall a b. (a -> b) -> SemanticError a -> SemanticError b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> SemanticError a -> SemanticError b
fmap :: forall a b. (a -> b) -> SemanticError a -> SemanticError b
$c<$ :: forall a b. a -> SemanticError b -> SemanticError a
<$ :: forall a b. a -> SemanticError b -> SemanticError a
Functor, (forall m. Monoid m => SemanticError m -> m)
-> (forall m a. Monoid m => (a -> m) -> SemanticError a -> m)
-> (forall m a. Monoid m => (a -> m) -> SemanticError a -> m)
-> (forall a b. (a -> b -> b) -> b -> SemanticError a -> b)
-> (forall a b. (a -> b -> b) -> b -> SemanticError a -> b)
-> (forall b a. (b -> a -> b) -> b -> SemanticError a -> b)
-> (forall b a. (b -> a -> b) -> b -> SemanticError a -> b)
-> (forall a. (a -> a -> a) -> SemanticError a -> a)
-> (forall a. (a -> a -> a) -> SemanticError a -> a)
-> (forall a. SemanticError a -> [a])
-> (forall a. SemanticError a -> Bool)
-> (forall a. SemanticError a -> Int)
-> (forall a. Eq a => a -> SemanticError a -> Bool)
-> (forall a. Ord a => SemanticError a -> a)
-> (forall a. Ord a => SemanticError a -> a)
-> (forall a. Num a => SemanticError a -> a)
-> (forall a. Num a => SemanticError a -> a)
-> Foldable SemanticError
forall a. Eq a => a -> SemanticError a -> Bool
forall a. Num a => SemanticError a -> a
forall a. Ord a => SemanticError a -> a
forall m. Monoid m => SemanticError m -> m
forall a. SemanticError a -> Bool
forall a. SemanticError a -> Int
forall a. SemanticError a -> [a]
forall a. (a -> a -> a) -> SemanticError a -> a
forall m a. Monoid m => (a -> m) -> SemanticError a -> m
forall b a. (b -> a -> b) -> b -> SemanticError a -> b
forall a b. (a -> b -> b) -> b -> SemanticError a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => SemanticError m -> m
fold :: forall m. Monoid m => SemanticError m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> SemanticError a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> SemanticError a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> SemanticError a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> SemanticError a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> SemanticError a -> b
foldr :: forall a b. (a -> b -> b) -> b -> SemanticError a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> SemanticError a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> SemanticError a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> SemanticError a -> b
foldl :: forall b a. (b -> a -> b) -> b -> SemanticError a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> SemanticError a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> SemanticError a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> SemanticError a -> a
foldr1 :: forall a. (a -> a -> a) -> SemanticError a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> SemanticError a -> a
foldl1 :: forall a. (a -> a -> a) -> SemanticError a -> a
$ctoList :: forall a. SemanticError a -> [a]
toList :: forall a. SemanticError a -> [a]
$cnull :: forall a. SemanticError a -> Bool
null :: forall a. SemanticError a -> Bool
$clength :: forall a. SemanticError a -> Int
length :: forall a. SemanticError a -> Int
$celem :: forall a. Eq a => a -> SemanticError a -> Bool
elem :: forall a. Eq a => a -> SemanticError a -> Bool
$cmaximum :: forall a. Ord a => SemanticError a -> a
maximum :: forall a. Ord a => SemanticError a -> a
$cminimum :: forall a. Ord a => SemanticError a -> a
minimum :: forall a. Ord a => SemanticError a -> a
$csum :: forall a. Num a => SemanticError a -> a
sum :: forall a. Num a => SemanticError a -> a
$cproduct :: forall a. Num a => SemanticError a -> a
product :: forall a. Num a => SemanticError a -> a
Foldable, Functor SemanticError
Foldable SemanticError
(Functor SemanticError, Foldable SemanticError) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> SemanticError a -> f (SemanticError b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    SemanticError (f a) -> f (SemanticError a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> SemanticError a -> m (SemanticError b))
-> (forall (m :: * -> *) a.
    Monad m =>
    SemanticError (m a) -> m (SemanticError a))
-> Traversable SemanticError
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
SemanticError (m a) -> m (SemanticError a)
forall (f :: * -> *) a.
Applicative f =>
SemanticError (f a) -> f (SemanticError a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SemanticError a -> m (SemanticError b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SemanticError a -> f (SemanticError b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SemanticError a -> f (SemanticError b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SemanticError a -> f (SemanticError b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
SemanticError (f a) -> f (SemanticError a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
SemanticError (f a) -> f (SemanticError a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SemanticError a -> m (SemanticError b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SemanticError a -> m (SemanticError b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
SemanticError (m a) -> m (SemanticError a)
sequence :: forall (m :: * -> *) a.
Monad m =>
SemanticError (m a) -> m (SemanticError a)
Traversable)

-- | Enumeration of the kinds of conflicts a key can generate.
--
-- @since 1.3.0.0
data SemanticErrorKind
    = AlreadyAssigned -- ^ Attempted to assign to a key that was already assigned
    | ClosedTable     -- ^ Attempted to open a table already closed
    | ImplicitlyTable -- ^ Attempted to open a tables as an array of tables that was implicitly defined to be a table
    deriving (
        ReadPrec [SemanticErrorKind]
ReadPrec SemanticErrorKind
Int -> ReadS SemanticErrorKind
ReadS [SemanticErrorKind]
(Int -> ReadS SemanticErrorKind)
-> ReadS [SemanticErrorKind]
-> ReadPrec SemanticErrorKind
-> ReadPrec [SemanticErrorKind]
-> Read SemanticErrorKind
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SemanticErrorKind
readsPrec :: Int -> ReadS SemanticErrorKind
$creadList :: ReadS [SemanticErrorKind]
readList :: ReadS [SemanticErrorKind]
$creadPrec :: ReadPrec SemanticErrorKind
readPrec :: ReadPrec SemanticErrorKind
$creadListPrec :: ReadPrec [SemanticErrorKind]
readListPrec :: ReadPrec [SemanticErrorKind]
Read {- ^ Default instance -},
        Int -> SemanticErrorKind -> ShowS
[SemanticErrorKind] -> ShowS
SemanticErrorKind -> String
(Int -> SemanticErrorKind -> ShowS)
-> (SemanticErrorKind -> String)
-> ([SemanticErrorKind] -> ShowS)
-> Show SemanticErrorKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SemanticErrorKind -> ShowS
showsPrec :: Int -> SemanticErrorKind -> ShowS
$cshow :: SemanticErrorKind -> String
show :: SemanticErrorKind -> String
$cshowList :: [SemanticErrorKind] -> ShowS
showList :: [SemanticErrorKind] -> ShowS
Show {- ^ Default instance -},
        SemanticErrorKind -> SemanticErrorKind -> Bool
(SemanticErrorKind -> SemanticErrorKind -> Bool)
-> (SemanticErrorKind -> SemanticErrorKind -> Bool)
-> Eq SemanticErrorKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SemanticErrorKind -> SemanticErrorKind -> Bool
== :: SemanticErrorKind -> SemanticErrorKind -> Bool
$c/= :: SemanticErrorKind -> SemanticErrorKind -> Bool
/= :: SemanticErrorKind -> SemanticErrorKind -> Bool
Eq   {- ^ Default instance -},
        Eq SemanticErrorKind
Eq SemanticErrorKind =>
(SemanticErrorKind -> SemanticErrorKind -> Ordering)
-> (SemanticErrorKind -> SemanticErrorKind -> Bool)
-> (SemanticErrorKind -> SemanticErrorKind -> Bool)
-> (SemanticErrorKind -> SemanticErrorKind -> Bool)
-> (SemanticErrorKind -> SemanticErrorKind -> Bool)
-> (SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind)
-> (SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind)
-> Ord SemanticErrorKind
SemanticErrorKind -> SemanticErrorKind -> Bool
SemanticErrorKind -> SemanticErrorKind -> Ordering
SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SemanticErrorKind -> SemanticErrorKind -> Ordering
compare :: SemanticErrorKind -> SemanticErrorKind -> Ordering
$c< :: SemanticErrorKind -> SemanticErrorKind -> Bool
< :: SemanticErrorKind -> SemanticErrorKind -> Bool
$c<= :: SemanticErrorKind -> SemanticErrorKind -> Bool
<= :: SemanticErrorKind -> SemanticErrorKind -> Bool
$c> :: SemanticErrorKind -> SemanticErrorKind -> Bool
> :: SemanticErrorKind -> SemanticErrorKind -> Bool
$c>= :: SemanticErrorKind -> SemanticErrorKind -> Bool
>= :: SemanticErrorKind -> SemanticErrorKind -> Bool
$cmax :: SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind
max :: SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind
$cmin :: SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind
min :: SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind
Ord  {- ^ Default instance -})

-- | Extracts a semantic value from a sequence of raw TOML expressions,
-- or reports a semantic error if one occurs.
semantics :: [Expr a] -> Either (SemanticError a) (Table' a)
semantics :: forall a. [Expr a] -> Either (SemanticError a) (Table' a)
semantics [Expr a]
exprs =
 do [(Key a, Val a)] -> Either (SemanticError a) (FrameTable a)
f <- (([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
 -> Expr a
 -> Either
      (SemanticError a)
      ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a)))
-> ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
-> [Expr a]
-> Either
     (SemanticError a)
     ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
-> Expr a
-> Either
     (SemanticError a)
     ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
forall {a}.
([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
-> Expr a
-> Either
     (SemanticError a)
     ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
processExpr (([(Key a, Val a)]
 -> FrameTable a -> Either (SemanticError a) (FrameTable a))
-> FrameTable a
-> [(Key a, Val a)]
-> Either (SemanticError a) (FrameTable a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(Key a, Val a)]
-> FrameTable a -> Either (SemanticError a) (FrameTable a)
forall a. [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a)
assignKeyVals FrameTable a
forall k a. Map k a
Map.empty) [Expr a]
exprs
    FrameTable a -> Table' a
forall a. FrameTable a -> Table' a
framesToTable (FrameTable a -> Table' a)
-> Either (SemanticError a) (FrameTable a)
-> Either (SemanticError a) (Table' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key a, Val a)] -> Either (SemanticError a) (FrameTable a)
f []
    where
        processExpr :: ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
-> Expr a
-> Either
     (SemanticError a)
     ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
processExpr [(Key a, Val a)] -> Either (SemanticError a) (FrameTable a)
f = \case
            KeyValExpr   Key a
k Val a
v -> ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
-> Either
     (SemanticError a)
     ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
forall a b. b -> Either a b
Right ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a)
f ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
-> ([(Key a, Val a)] -> [(Key a, Val a)])
-> [(Key a, Val a)]
-> Either (SemanticError a) (FrameTable a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key a
k,Val a
v)(Key a, Val a) -> [(Key a, Val a)] -> [(Key a, Val a)]
forall a. a -> [a] -> [a]
:))
            TableExpr      Key a
k -> SectionKind
-> Key a
-> Either
     (SemanticError a)
     ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
processSection SectionKind
TableKind      Key a
k
            ArrayTableExpr Key a
k -> SectionKind
-> Key a
-> Either
     (SemanticError a)
     ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
processSection SectionKind
ArrayTableKind Key a
k
            where
                processSection :: SectionKind
-> Key a
-> Either
     (SemanticError a)
     ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
processSection SectionKind
kind Key a
k = ([(Key a, Val a)]
 -> FrameTable a -> Either (SemanticError a) (FrameTable a))
-> FrameTable a
-> [(Key a, Val a)]
-> Either (SemanticError a) (FrameTable a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SectionKind
-> Key a
-> [(Key a, Val a)]
-> FrameTable a
-> Either (SemanticError a) (FrameTable a)
forall a.
SectionKind
-> Key a -> [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a)
addSection SectionKind
kind Key a
k) (FrameTable a
 -> [(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
-> Either (SemanticError a) (FrameTable a)
-> Either
     (SemanticError a)
     ([(Key a, Val a)] -> Either (SemanticError a) (FrameTable a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key a, Val a)] -> Either (SemanticError a) (FrameTable a)
f []

-- | A top-level table used to distinguish top-level defined arrays
-- and tables from inline values.
type FrameTable a = Map Text (a, Frame a)

-- | M is the error-handling monad used through this module for
-- propagating semantic errors through the 'semantics' function.
type M a = Either (SemanticError a)

-- | Frames are the top-level skeleton of the TOML file that mirror the
-- subset of values that can be constructed with with top-level syntax.
-- TOML syntax makes a distinction between tables and arrays that are
-- defined at the top-level and those defined with inline syntax. This
-- separate type keeps these syntactic differences separate while table
-- and array resolution is still happening. Frames can keep track of which
-- tables finished and which are eligible for extension.
data Frame a
    = FrameTable a FrameKind (FrameTable a)
    | FrameArray (NonEmpty (a, FrameTable a)) -- stored in reverse order for easy "append"
    | FrameValue (Value' a)
    deriving Int -> Frame a -> ShowS
[Frame a] -> ShowS
Frame a -> String
(Int -> Frame a -> ShowS)
-> (Frame a -> String) -> ([Frame a] -> ShowS) -> Show (Frame a)
forall a. Show a => Int -> Frame a -> ShowS
forall a. Show a => [Frame a] -> ShowS
forall a. Show a => Frame a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Frame a -> ShowS
showsPrec :: Int -> Frame a -> ShowS
$cshow :: forall a. Show a => Frame a -> String
show :: Frame a -> String
$cshowList :: forall a. Show a => [Frame a] -> ShowS
showList :: [Frame a] -> ShowS
Show

-- | Top-level tables can be in various states of completeness. This type
-- keeps track of the current state of a top-level defined table.
data FrameKind
    = Open   -- ^ table implicitly defined as super-table of [x.y.z]
    | Dotted -- ^ table implicitly defined using dotted key assignment
    | Closed -- ^ table closed to further extension
    deriving Int -> FrameKind -> ShowS
[FrameKind] -> ShowS
FrameKind -> String
(Int -> FrameKind -> ShowS)
-> (FrameKind -> String)
-> ([FrameKind] -> ShowS)
-> Show FrameKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FrameKind -> ShowS
showsPrec :: Int -> FrameKind -> ShowS
$cshow :: FrameKind -> String
show :: FrameKind -> String
$cshowList :: [FrameKind] -> ShowS
showList :: [FrameKind] -> ShowS
Show

-- | Convert a top-level table "frame" representation into the plain Value
-- representation once the distinction is no longer needed.
framesToTable :: FrameTable a -> Table' a
framesToTable :: forall a. FrameTable a -> Table' a
framesToTable = (Map Text (a, Value' a) -> Table' a)
-> (FrameTable a -> Map Text (a, Value' a))
-> FrameTable a
-> Table' a
forall a b. (a -> b) -> (FrameTable a -> a) -> FrameTable a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Text (a, Value' a) -> Table' a
forall a. Map Text (a, Value' a) -> Table' a
MkTable ((FrameTable a -> Map Text (a, Value' a))
 -> FrameTable a -> Table' a)
-> (FrameTable a -> Map Text (a, Value' a))
-> FrameTable a
-> Table' a
forall a b. (a -> b) -> a -> b
$ ((a, Frame a) -> (a, Value' a))
-> FrameTable a -> Map Text (a, Value' a)
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, Frame a) -> (a, Value' a))
 -> FrameTable a -> Map Text (a, Value' a))
-> ((a, Frame a) -> (a, Value' a))
-> FrameTable a
-> Map Text (a, Value' a)
forall a b. (a -> b) -> a -> b
$ (Frame a -> Value' a) -> (a, Frame a) -> (a, Value' a)
forall a b. (a -> b) -> (a, a) -> (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    \case
        FrameTable a
a FrameKind
_kind FrameTable a
t -> a -> Table' a -> Value' a
forall a. a -> Table' a -> Value' a
Table' a
a (FrameTable a -> Table' a
forall a. FrameTable a -> Table' a
framesToTable FrameTable a
t)
        FrameArray (NonEmpty (a, FrameTable a) -> NonEmpty (a, FrameTable a)
forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse -> (a, FrameTable a)
t :| [(a, FrameTable a)]
ts) ->
            -- the array itself is attributed to the first table defined
            a -> [Value' a] -> Value' a
forall a. a -> [Value' a] -> Value' a
List' ((a, FrameTable a) -> a
forall a b. (a, b) -> a
fst (a, FrameTable a)
t) [a -> Table' a -> Value' a
forall a. a -> Table' a -> Value' a
Table' a
a (FrameTable a -> Table' a
forall a. FrameTable a -> Table' a
framesToTable FrameTable a
x) | (a
a, FrameTable a
x) <- (a, FrameTable a)
t (a, FrameTable a) -> [(a, FrameTable a)] -> [(a, FrameTable a)]
forall a. a -> [a] -> [a]
: [(a, FrameTable a)]
ts]
        FrameValue Value' a
v -> Value' a
v

-- | Attempts to insert the key-value pairs given into a new section
-- located at the given key-path in a frame map.
addSection ::
    SectionKind      {- ^ section kind                           -} ->
    Key a            {- ^ section key                            -} ->
    [(Key a, Val a)] {- ^ values to install                      -} ->
    FrameTable a     {- ^ local frame map                        -} ->
    M a (FrameTable a) {- ^ error message or updated local frame table -}

addSection :: forall a.
SectionKind
-> Key a -> [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a)
addSection SectionKind
kind ((a, Text)
k :| []) [(NonEmpty (a, Text), Val a)]
kvs =
    (a, Text)
-> M a (Frame a)
-> (Frame a -> M a (Frame a))
-> FrameTable a
-> M a (FrameTable a)
forall a.
(a, Text)
-> M a (Frame a)
-> (Frame a -> M a (Frame a))
-> FrameTable a
-> M a (FrameTable a)
alterFrame (a, Text)
k
        -- defining a new table
        (case SectionKind
kind of
                SectionKind
TableKind      -> a -> FrameKind -> FrameTable a -> Frame a
forall a. a -> FrameKind -> FrameTable a -> Frame a
FrameTable ((a, Text) -> a
forall a b. (a, b) -> a
fst (a, Text)
k) FrameKind
Closed (FrameTable a -> Frame a) -> M a (FrameTable a) -> M a (Frame a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable a -> M a (FrameTable a)
go FrameTable a
forall a. Monoid a => a
mempty
                SectionKind
ArrayTableKind -> NonEmpty (a, FrameTable a) -> Frame a
forall a. NonEmpty (a, FrameTable a) -> Frame a
FrameArray (NonEmpty (a, FrameTable a) -> Frame a)
-> (FrameTable a -> NonEmpty (a, FrameTable a))
-> FrameTable a
-> Frame a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, FrameTable a)
-> [(a, FrameTable a)] -> NonEmpty (a, FrameTable a)
forall a. a -> [a] -> NonEmpty a
:| []) ((a, FrameTable a) -> NonEmpty (a, FrameTable a))
-> (FrameTable a -> (a, FrameTable a))
-> FrameTable a
-> NonEmpty (a, FrameTable a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) ((a, Text) -> a
forall a b. (a, b) -> a
fst (a, Text)
k) (FrameTable a -> Frame a) -> M a (FrameTable a) -> M a (Frame a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable a -> M a (FrameTable a)
go FrameTable a
forall a. Monoid a => a
mempty)

        \case
        -- defining a super table of a previously defined sub-table
        FrameTable a
_ FrameKind
Open FrameTable a
t ->
            case SectionKind
kind of
                -- the annotation of the open table changes from the first mention closing key
                SectionKind
TableKind      -> a -> FrameKind -> FrameTable a -> Frame a
forall a. a -> FrameKind -> FrameTable a -> Frame a
FrameTable ((a, Text) -> a
forall a b. (a, b) -> a
fst (a, Text)
k) FrameKind
Closed (FrameTable a -> Frame a) -> M a (FrameTable a) -> M a (Frame a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable a -> M a (FrameTable a)
go FrameTable a
t
                SectionKind
ArrayTableKind -> (a, Text) -> SemanticErrorKind -> M a (Frame a)
forall a b. (a, Text) -> SemanticErrorKind -> M a b
invalidKey (a, Text)
k SemanticErrorKind
ImplicitlyTable

        -- Add a new array element to an existing table array
        FrameArray ((a, FrameTable a)
t :| [(a, FrameTable a)]
ts) ->
            case SectionKind
kind of
                SectionKind
TableKind      -> (a, Text) -> SemanticErrorKind -> M a (Frame a)
forall a b. (a, Text) -> SemanticErrorKind -> M a b
invalidKey (a, Text)
k SemanticErrorKind
ClosedTable
                SectionKind
ArrayTableKind -> NonEmpty (a, FrameTable a) -> Frame a
forall a. NonEmpty (a, FrameTable a) -> Frame a
FrameArray (NonEmpty (a, FrameTable a) -> Frame a)
-> (FrameTable a -> NonEmpty (a, FrameTable a))
-> FrameTable a
-> Frame a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, FrameTable a)
-> [(a, FrameTable a)] -> NonEmpty (a, FrameTable a)
forall a. a -> [a] -> NonEmpty a
:| (a, FrameTable a)
t (a, FrameTable a) -> [(a, FrameTable a)] -> [(a, FrameTable a)]
forall a. a -> [a] -> [a]
: [(a, FrameTable a)]
ts) ((a, FrameTable a) -> NonEmpty (a, FrameTable a))
-> (FrameTable a -> (a, FrameTable a))
-> FrameTable a
-> NonEmpty (a, FrameTable a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) ((a, Text) -> a
forall a b. (a, b) -> a
fst (a, Text)
k) (FrameTable a -> Frame a) -> M a (FrameTable a) -> M a (Frame a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable a -> M a (FrameTable a)
go FrameTable a
forall a. Monoid a => a
mempty

        -- failure cases
        FrameTable a
_ FrameKind
Closed FrameTable a
_ -> (a, Text) -> SemanticErrorKind -> M a (Frame a)
forall a b. (a, Text) -> SemanticErrorKind -> M a b
invalidKey (a, Text)
k SemanticErrorKind
ClosedTable
        FrameTable a
_ FrameKind
Dotted FrameTable a
_ -> String -> M a (Frame a)
forall a. HasCallStack => String -> a
error String
"addSection: dotted table left unclosed"
        FrameValue {}         -> (a, Text) -> SemanticErrorKind -> M a (Frame a)
forall a b. (a, Text) -> SemanticErrorKind -> M a b
invalidKey (a, Text)
k SemanticErrorKind
AlreadyAssigned
        where
            go :: FrameTable a -> M a (FrameTable a)
go = [(NonEmpty (a, Text), Val a)] -> FrameTable a -> M a (FrameTable a)
forall a. [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a)
assignKeyVals [(NonEmpty (a, Text), Val a)]
kvs

addSection SectionKind
kind ((a, Text)
k1 :| (a, Text)
k2 : [(a, Text)]
ks) [(NonEmpty (a, Text), Val a)]
kvs =
    (a, Text)
-> M a (Frame a)
-> (Frame a -> M a (Frame a))
-> FrameTable a
-> M a (FrameTable a)
forall a.
(a, Text)
-> M a (Frame a)
-> (Frame a -> M a (Frame a))
-> FrameTable a
-> M a (FrameTable a)
alterFrame (a, Text)
k1
        (a -> FrameKind -> FrameTable a -> Frame a
forall a. a -> FrameKind -> FrameTable a -> Frame a
FrameTable ((a, Text) -> a
forall a b. (a, b) -> a
fst (a, Text)
k1) FrameKind
Open      (FrameTable a -> Frame a) -> M a (FrameTable a) -> M a (Frame a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable a -> M a (FrameTable a)
go FrameTable a
forall a. Monoid a => a
mempty)
        \case
        FrameTable a
a FrameKind
tk FrameTable a
t    -> a -> FrameKind -> FrameTable a -> Frame a
forall a. a -> FrameKind -> FrameTable a -> Frame a
FrameTable a
a FrameKind
tk      (FrameTable a -> Frame a) -> M a (FrameTable a) -> M a (Frame a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable a -> M a (FrameTable a)
go FrameTable a
t
        FrameArray ((a, FrameTable a)
t :| [(a, FrameTable a)]
ts) -> NonEmpty (a, FrameTable a) -> Frame a
forall a. NonEmpty (a, FrameTable a) -> Frame a
FrameArray (NonEmpty (a, FrameTable a) -> Frame a)
-> ((a, FrameTable a) -> NonEmpty (a, FrameTable a))
-> (a, FrameTable a)
-> Frame a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, FrameTable a)
-> [(a, FrameTable a)] -> NonEmpty (a, FrameTable a)
forall a. a -> [a] -> NonEmpty a
:| [(a, FrameTable a)]
ts) ((a, FrameTable a) -> Frame a)
-> Either (SemanticError a) (a, FrameTable a) -> M a (Frame a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FrameTable a -> M a (FrameTable a))
-> (a, FrameTable a) -> Either (SemanticError a) (a, FrameTable a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (a, a) -> f (a, b)
traverse FrameTable a -> M a (FrameTable a)
go (a, FrameTable a)
t
        FrameValue Value' a
_         -> (a, Text) -> SemanticErrorKind -> M a (Frame a)
forall a b. (a, Text) -> SemanticErrorKind -> M a b
invalidKey (a, Text)
k1 SemanticErrorKind
AlreadyAssigned
        where
            go :: FrameTable a -> M a (FrameTable a)
go = SectionKind
-> NonEmpty (a, Text)
-> [(NonEmpty (a, Text), Val a)]
-> FrameTable a
-> M a (FrameTable a)
forall a.
SectionKind
-> Key a -> [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a)
addSection SectionKind
kind ((a, Text)
k2 (a, Text) -> [(a, Text)] -> NonEmpty (a, Text)
forall a. a -> [a] -> NonEmpty a
:| [(a, Text)]
ks) [(NonEmpty (a, Text), Val a)]
kvs

-- | Close all of the tables that were implicitly defined with
-- dotted prefixes. These tables are only eligible for extension
-- within the @[table]@ section in which they were introduced.
closeDots :: FrameTable a -> FrameTable a
closeDots :: forall a. FrameTable a -> FrameTable a
closeDots =
    ((a, Frame a) -> (a, Frame a))
-> Map Text (a, Frame a) -> Map Text (a, Frame a)
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, Frame a) -> (a, Frame a))
 -> Map Text (a, Frame a) -> Map Text (a, Frame a))
-> ((a, Frame a) -> (a, Frame a))
-> Map Text (a, Frame a)
-> Map Text (a, Frame a)
forall a b. (a -> b) -> a -> b
$ (Frame a -> Frame a) -> (a, Frame a) -> (a, Frame a)
forall a b. (a -> b) -> (a, a) -> (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
        FrameTable a
a FrameKind
Dotted Map Text (a, Frame a)
t -> a -> FrameKind -> Map Text (a, Frame a) -> Frame a
forall a. a -> FrameKind -> FrameTable a -> Frame a
FrameTable a
a FrameKind
Closed (Map Text (a, Frame a) -> Map Text (a, Frame a)
forall a. FrameTable a -> FrameTable a
closeDots Map Text (a, Frame a)
t)
        Frame a
frame                 -> Frame a
frame

-- | Extend the given frame table with a list of key-value pairs.
-- Any tables created through dotted keys will be closed after
-- all of the key-value pairs are processed.
assignKeyVals :: [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a)
assignKeyVals :: forall a. [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a)
assignKeyVals [(Key a, Val a)]
kvs FrameTable a
t = FrameTable a -> FrameTable a
forall a. FrameTable a -> FrameTable a
closeDots (FrameTable a -> FrameTable a)
-> Either (SemanticError a) (FrameTable a)
-> Either (SemanticError a) (FrameTable a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FrameTable a
 -> (Key a, Val a) -> Either (SemanticError a) (FrameTable a))
-> FrameTable a
-> [(Key a, Val a)]
-> Either (SemanticError a) (FrameTable a)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM FrameTable a
-> (Key a, Val a) -> Either (SemanticError a) (FrameTable a)
forall {a}. FrameTable a -> (Key a, Val a) -> M a (FrameTable a)
f FrameTable a
t [(Key a, Val a)]
kvs
    where
        f :: FrameTable a -> (Key a, Val a) -> M a (FrameTable a)
f FrameTable a
m (Key a
k,Val a
v) = Key a -> Val a -> FrameTable a -> M a (FrameTable a)
forall a. Key a -> Val a -> FrameTable a -> M a (FrameTable a)
assign Key a
k Val a
v FrameTable a
m

-- | Assign a single dotted key in a frame. Any open table traversed
-- by a dotted key will be marked as dotted so that it will become
-- closed at the end of the current call to 'assignKeyVals'.
assign :: Key a -> Val a -> FrameTable a -> M a (FrameTable a)

assign :: forall a. Key a -> Val a -> FrameTable a -> M a (FrameTable a)
assign ((a, Text)
key :| []) Val a
val =
    (a, Text)
-> M a (Frame a)
-> (Frame a -> M a (Frame a))
-> FrameTable a
-> M a (FrameTable a)
forall a.
(a, Text)
-> M a (Frame a)
-> (Frame a -> M a (Frame a))
-> FrameTable a
-> M a (FrameTable a)
alterFrame (a, Text)
key
        (Value' a -> Frame a
forall a. Value' a -> Frame a
FrameValue (Value' a -> Frame a)
-> Either (SemanticError a) (Value' a) -> M a (Frame a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val a -> Either (SemanticError a) (Value' a)
forall a. Val a -> M a (Value' a)
valToValue Val a
val)
        (\Frame a
_ -> (a, Text) -> SemanticErrorKind -> M a (Frame a)
forall a b. (a, Text) -> SemanticErrorKind -> M a b
invalidKey (a, Text)
key SemanticErrorKind
AlreadyAssigned)

assign ((a, Text)
key :| (a, Text)
k1 : [(a, Text)]
keys) Val a
val =
    (a, Text)
-> M a (Frame a)
-> (Frame a -> M a (Frame a))
-> FrameTable a
-> M a (FrameTable a)
forall a.
(a, Text)
-> M a (Frame a)
-> (Frame a -> M a (Frame a))
-> FrameTable a
-> M a (FrameTable a)
alterFrame (a, Text)
key (a -> FrameTable a -> M a (Frame a)
go ((a, Text) -> a
forall a b. (a, b) -> a
fst (a, Text)
key) FrameTable a
forall a. Monoid a => a
mempty)
        \case
        FrameTable a
a FrameKind
Open   FrameTable a
t -> a -> FrameTable a -> M a (Frame a)
go a
a FrameTable a
t
        FrameTable a
a FrameKind
Dotted FrameTable a
t -> a -> FrameTable a -> M a (Frame a)
go a
a FrameTable a
t
        FrameTable a
_ FrameKind
Closed FrameTable a
_ -> (a, Text) -> SemanticErrorKind -> M a (Frame a)
forall a b. (a, Text) -> SemanticErrorKind -> M a b
invalidKey (a, Text)
key SemanticErrorKind
ClosedTable
        FrameArray          NonEmpty (a, FrameTable a)
_ -> (a, Text) -> SemanticErrorKind -> M a (Frame a)
forall a b. (a, Text) -> SemanticErrorKind -> M a b
invalidKey (a, Text)
key SemanticErrorKind
ClosedTable
        FrameValue          Value' a
_ -> (a, Text) -> SemanticErrorKind -> M a (Frame a)
forall a b. (a, Text) -> SemanticErrorKind -> M a b
invalidKey (a, Text)
key SemanticErrorKind
AlreadyAssigned
    where
        go :: a -> FrameTable a -> M a (Frame a)
go a
a FrameTable a
t = a -> FrameKind -> FrameTable a -> Frame a
forall a. a -> FrameKind -> FrameTable a -> Frame a
FrameTable a
a FrameKind
Dotted (FrameTable a -> Frame a) -> M a (FrameTable a) -> M a (Frame a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (a, Text) -> Val a -> FrameTable a -> M a (FrameTable a)
forall a. Key a -> Val a -> FrameTable a -> M a (FrameTable a)
assign ((a, Text)
k1 (a, Text) -> [(a, Text)] -> NonEmpty (a, Text)
forall a. a -> [a] -> NonEmpty a
:| [(a, Text)]
keys) Val a
val FrameTable a
t

-- | Convert 'Val' to 'Value' potentially raising an error if
-- it contains inline tables with key-conflicts.
valToValue :: Val a -> M a (Value' a)
valToValue :: forall a. Val a -> M a (Value' a)
valToValue =
    \case
        ValInteger   a
a Integer
x    -> Value' a -> M a (Value' a)
forall a b. b -> Either a b
Right (a -> Integer -> Value' a
forall a. a -> Integer -> Value' a
Integer'   a
a Integer
x)
        ValFloat     a
a Double
x    -> Value' a -> M a (Value' a)
forall a b. b -> Either a b
Right (a -> Double -> Value' a
forall a. a -> Double -> Value' a
Double'    a
a Double
x)
        ValBool      a
a Bool
x    -> Value' a -> M a (Value' a)
forall a b. b -> Either a b
Right (a -> Bool -> Value' a
forall a. a -> Bool -> Value' a
Bool'      a
a Bool
x)
        ValString    a
a Text
x    -> Value' a -> M a (Value' a)
forall a b. b -> Either a b
Right (a -> Text -> Value' a
forall a. a -> Text -> Value' a
Text'      a
a Text
x)
        ValTimeOfDay a
a TimeOfDay
x    -> Value' a -> M a (Value' a)
forall a b. b -> Either a b
Right (a -> TimeOfDay -> Value' a
forall a. a -> TimeOfDay -> Value' a
TimeOfDay' a
a TimeOfDay
x)
        ValZonedTime a
a ZonedTime
x    -> Value' a -> M a (Value' a)
forall a b. b -> Either a b
Right (a -> ZonedTime -> Value' a
forall a. a -> ZonedTime -> Value' a
ZonedTime' a
a ZonedTime
x)
        ValLocalTime a
a LocalTime
x    -> Value' a -> M a (Value' a)
forall a b. b -> Either a b
Right (a -> LocalTime -> Value' a
forall a. a -> LocalTime -> Value' a
LocalTime' a
a LocalTime
x)
        ValDay       a
a Day
x    -> Value' a -> M a (Value' a)
forall a b. b -> Either a b
Right (a -> Day -> Value' a
forall a. a -> Day -> Value' a
Day'       a
a Day
x)
        ValArray     a
a [Val a]
xs   -> a -> [Value' a] -> Value' a
forall a. a -> [Value' a] -> Value' a
List' a
a ([Value' a] -> Value' a)
-> Either (SemanticError a) [Value' a] -> M a (Value' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val a -> M a (Value' a))
-> [Val a] -> Either (SemanticError a) [Value' a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Val a -> M a (Value' a)
forall a. Val a -> M a (Value' a)
valToValue [Val a]
xs
        ValTable     a
a [(Key a, Val a)]
kvs  -> a -> Table' a -> Value' a
forall a. a -> Table' a -> Value' a
Table' a
a (Table' a -> Value' a)
-> (FrameTable a -> Table' a) -> FrameTable a -> Value' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameTable a -> Table' a
forall a. FrameTable a -> Table' a
framesToTable (FrameTable a -> Value' a)
-> Either (SemanticError a) (FrameTable a) -> M a (Value' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key a, Val a)]
-> FrameTable a -> Either (SemanticError a) (FrameTable a)
forall a. [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a)
assignKeyVals [(Key a, Val a)]
kvs FrameTable a
forall a. Monoid a => a
mempty

-- | Abort validation by reporting an error about the given key.
invalidKey ::
    (a, Text)         {- ^ sub-key    -} ->
    SemanticErrorKind {- ^ error kind -} ->
    M a b
invalidKey :: forall a b. (a, Text) -> SemanticErrorKind -> M a b
invalidKey (a
a, Text
key) SemanticErrorKind
kind = SemanticError a -> Either (SemanticError a) b
forall a b. a -> Either a b
Left (a -> Text -> SemanticErrorKind -> SemanticError a
forall a. a -> Text -> SemanticErrorKind -> SemanticError a
SemanticError a
a Text
key SemanticErrorKind
kind)

-- | Specialization of 'Map.alterF' used to adjust a location in a 'FrameTable'
alterFrame ::
    (a, Text)                  {- ^ annotated key     -} ->
    M a (Frame a)              {- ^ new value case    -} ->
    (Frame a -> M a (Frame a)) {- ^ update value case -} ->
    FrameTable a -> M a (FrameTable a)
alterFrame :: forall a.
(a, Text)
-> M a (Frame a)
-> (Frame a -> M a (Frame a))
-> FrameTable a
-> M a (FrameTable a)
alterFrame (a
a, Text
k) M a (Frame a)
create Frame a -> M a (Frame a)
update = (Maybe (a, Frame a)
 -> Either (SemanticError a) (Maybe (a, Frame a)))
-> Text
-> Map Text (a, Frame a)
-> Either (SemanticError a) (Map Text (a, Frame a))
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF Maybe (a, Frame a) -> Either (SemanticError a) (Maybe (a, Frame a))
g Text
k
    where
        -- insert a new value
        g :: Maybe (a, Frame a) -> Either (SemanticError a) (Maybe (a, Frame a))
g Maybe (a, Frame a)
Nothing =
            do Frame a
lf <- M a (Frame a)
create
               Maybe (a, Frame a) -> Either (SemanticError a) (Maybe (a, Frame a))
forall a. a -> Either (SemanticError a) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, Frame a) -> Maybe (a, Frame a)
forall a. a -> Maybe a
Just (a
a, Frame a
lf))

        -- update an existing value and preserve its annotation
        g (Just (a
op, Frame a
ov)) =
            do Frame a
lf <- Frame a -> M a (Frame a)
update Frame a
ov
               Maybe (a, Frame a) -> Either (SemanticError a) (Maybe (a, Frame a))
forall a. a -> Either (SemanticError a) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, Frame a) -> Maybe (a, Frame a)
forall a. a -> Maybe a
Just (a
op, Frame a
lf))