{-# 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 (SemanticError(..), SemanticErrorKind(..), semantics) where

import Control.Monad (foldM)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Map (Map)
import Data.Map qualified as Map
import Toml.Located (locThing, Located)
import Toml.Parser.Types (SectionKind(..), Key, Val(..), Expr(..))
import Toml.Value (Table, Value(..))

-- | This type represents errors generated when resolving keys in a TOML
-- document.
--
-- @since 1.3.0.0
data SemanticError = SemanticError {
    SemanticError -> String
errorKey :: String,
    SemanticError -> SemanticErrorKind
errorKind :: SemanticErrorKind
    } deriving (
        ReadPrec [SemanticError]
ReadPrec SemanticError
Int -> ReadS SemanticError
ReadS [SemanticError]
(Int -> ReadS SemanticError)
-> ReadS [SemanticError]
-> ReadPrec SemanticError
-> ReadPrec [SemanticError]
-> Read SemanticError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SemanticError
readsPrec :: Int -> ReadS SemanticError
$creadList :: ReadS [SemanticError]
readList :: ReadS [SemanticError]
$creadPrec :: ReadPrec SemanticError
readPrec :: ReadPrec SemanticError
$creadListPrec :: ReadPrec [SemanticError]
readListPrec :: ReadPrec [SemanticError]
Read {- ^ Default instance -},
        Int -> SemanticError -> ShowS
[SemanticError] -> ShowS
SemanticError -> String
(Int -> SemanticError -> ShowS)
-> (SemanticError -> String)
-> ([SemanticError] -> ShowS)
-> Show SemanticError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SemanticError -> ShowS
showsPrec :: Int -> SemanticError -> ShowS
$cshow :: SemanticError -> String
show :: SemanticError -> String
$cshowList :: [SemanticError] -> ShowS
showList :: [SemanticError] -> ShowS
Show {- ^ Default instance -},
        SemanticError -> SemanticError -> Bool
(SemanticError -> SemanticError -> Bool)
-> (SemanticError -> SemanticError -> Bool) -> Eq SemanticError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SemanticError -> SemanticError -> Bool
== :: SemanticError -> SemanticError -> Bool
$c/= :: SemanticError -> SemanticError -> Bool
/= :: SemanticError -> SemanticError -> Bool
Eq   {- ^ Default instance -},
        Eq SemanticError
Eq SemanticError =>
(SemanticError -> SemanticError -> Ordering)
-> (SemanticError -> SemanticError -> Bool)
-> (SemanticError -> SemanticError -> Bool)
-> (SemanticError -> SemanticError -> Bool)
-> (SemanticError -> SemanticError -> Bool)
-> (SemanticError -> SemanticError -> SemanticError)
-> (SemanticError -> SemanticError -> SemanticError)
-> Ord SemanticError
SemanticError -> SemanticError -> Bool
SemanticError -> SemanticError -> Ordering
SemanticError -> SemanticError -> SemanticError
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 :: SemanticError -> SemanticError -> Ordering
compare :: SemanticError -> SemanticError -> Ordering
$c< :: SemanticError -> SemanticError -> Bool
< :: SemanticError -> SemanticError -> Bool
$c<= :: SemanticError -> SemanticError -> Bool
<= :: SemanticError -> SemanticError -> Bool
$c> :: SemanticError -> SemanticError -> Bool
> :: SemanticError -> SemanticError -> Bool
$c>= :: SemanticError -> SemanticError -> Bool
>= :: SemanticError -> SemanticError -> Bool
$cmax :: SemanticError -> SemanticError -> SemanticError
max :: SemanticError -> SemanticError -> SemanticError
$cmin :: SemanticError -> SemanticError -> SemanticError
min :: SemanticError -> SemanticError -> SemanticError
Ord  {- ^ Default instance -})

-- | 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.
--
-- @since 1.3.0.0
semantics :: [Expr] -> Either (Located SemanticError) Table
semantics :: [Expr] -> Either (Located SemanticError) Table
semantics [Expr]
exprs =
 do [(Key, Val)] -> Either (Located SemanticError) FrameTable
f <- (([(Key, Val)] -> Either (Located SemanticError) FrameTable)
 -> Expr
 -> Either
      (Located SemanticError)
      ([(Key, Val)] -> Either (Located SemanticError) FrameTable))
-> ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
-> [Expr]
-> Either
     (Located SemanticError)
     ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
-> Expr
-> Either
     (Located SemanticError)
     ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
processExpr (([(Key, Val)]
 -> FrameTable -> Either (Located SemanticError) FrameTable)
-> FrameTable
-> [(Key, Val)]
-> Either (Located SemanticError) FrameTable
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(Key, Val)]
-> FrameTable -> Either (Located SemanticError) FrameTable
assignKeyVals FrameTable
forall k a. Map k a
Map.empty) [Expr]
exprs
    FrameTable -> Table
framesToTable (FrameTable -> Table)
-> Either (Located SemanticError) FrameTable
-> Either (Located SemanticError) Table
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Val)] -> Either (Located SemanticError) FrameTable
f []
    where
        processExpr :: ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
-> Expr
-> Either
     (Located SemanticError)
     ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
processExpr [(Key, Val)] -> Either (Located SemanticError) FrameTable
f = \case
            KeyValExpr   Key
k Val
v -> ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
-> Either
     (Located SemanticError)
     ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
forall a b. b -> Either a b
Right ([(Key, Val)] -> Either (Located SemanticError) FrameTable
f ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
-> ([(Key, Val)] -> [(Key, Val)])
-> [(Key, Val)]
-> Either (Located SemanticError) FrameTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key
k,Val
v)(Key, Val) -> [(Key, Val)] -> [(Key, Val)]
forall a. a -> [a] -> [a]
:))
            TableExpr      Key
k -> SectionKind
-> Key
-> Either
     (Located SemanticError)
     ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
processSection SectionKind
TableKind      Key
k
            ArrayTableExpr Key
k -> SectionKind
-> Key
-> Either
     (Located SemanticError)
     ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
processSection SectionKind
ArrayTableKind Key
k
            where
                processSection :: SectionKind
-> Key
-> Either
     (Located SemanticError)
     ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
processSection SectionKind
kind Key
k = ([(Key, Val)]
 -> FrameTable -> Either (Located SemanticError) FrameTable)
-> FrameTable
-> [(Key, Val)]
-> Either (Located SemanticError) FrameTable
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SectionKind
-> Key
-> [(Key, Val)]
-> FrameTable
-> Either (Located SemanticError) FrameTable
addSection SectionKind
kind Key
k) (FrameTable
 -> [(Key, Val)] -> Either (Located SemanticError) FrameTable)
-> Either (Located SemanticError) FrameTable
-> Either
     (Located SemanticError)
     ([(Key, Val)] -> Either (Located SemanticError) FrameTable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Val)] -> Either (Located SemanticError) FrameTable
f []

-- | A top-level table used to distinguish top-level defined arrays
-- and tables from inline values.
type FrameTable = Map String Frame

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

-- | 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
    = FrameTable FrameKind FrameTable
    | FrameArray (NonEmpty FrameTable) -- stored in reverse order for easy "append"
    | FrameValue Value
    deriving Int -> Frame -> ShowS
[Frame] -> ShowS
Frame -> String
(Int -> Frame -> ShowS)
-> (Frame -> String) -> ([Frame] -> ShowS) -> Show Frame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Frame -> ShowS
showsPrec :: Int -> Frame -> ShowS
$cshow :: Frame -> String
show :: Frame -> String
$cshowList :: [Frame] -> ShowS
showList :: [Frame] -> 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 supertable 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 -> Table
framesToTable :: FrameTable -> Table
framesToTable =
    (Frame -> Value) -> FrameTable -> Table
forall a b. (a -> b) -> Map String a -> Map String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
        FrameTable FrameKind
_ FrameTable
t       -> FrameTable -> Value
framesToValue FrameTable
t
        FrameArray (FrameTable
t :| [FrameTable]
ts) -> [Value] -> Value
Array ([Value] -> [Value]
forall {a}. [a] -> [a]
rev ((FrameTable -> Value) -> [FrameTable] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map FrameTable -> Value
framesToValue (FrameTable
t FrameTable -> [FrameTable] -> [FrameTable]
forall a. a -> [a] -> [a]
: [FrameTable]
ts)))
        FrameValue Value
v         -> Value
v
    where
        rev :: [a] -> [a]
rev = ([a] -> a -> [a]) -> [a] -> [a] -> [a]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] -- GHC fails to inline reverse

-- | Convert 'FrameTable' to a 'Value' forgetting all of the
-- frame distinctions.
framesToValue :: FrameTable -> Value
framesToValue :: FrameTable -> Value
framesToValue = Table -> Value
Table (Table -> Value) -> (FrameTable -> Table) -> FrameTable -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameTable -> Table
framesToTable

-- | 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          {- ^ section key                                -} ->
    [(Key, Val)] {- ^ values to install                          -} ->
    FrameTable   {- ^ local frame map                            -} ->
    M FrameTable {- ^ error message or updated local frame table -}

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

        -- defining a super table of a previously defined subtable
        Just (FrameTable FrameKind
Open FrameTable
t) ->
            case SectionKind
kind of
                SectionKind
TableKind      -> FrameKind -> FrameTable -> Frame
FrameTable FrameKind
Closed (FrameTable -> Frame)
-> Either (Located SemanticError) FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> Either (Located SemanticError) FrameTable
go FrameTable
t
                SectionKind
ArrayTableKind -> Located String -> SemanticErrorKind -> M Frame
forall a. Located String -> SemanticErrorKind -> M a
invalidKey Located String
k SemanticErrorKind
ImplicitlyTable

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

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

addSection SectionKind
kind (Located String
k1 :| Located String
k2 : [Located String]
ks) [(Key, Val)]
kvs =
    Located String
-> (Maybe Frame -> M Frame)
-> FrameTable
-> Either (Located SemanticError) FrameTable
alterFrame Located String
k1 \case
        Maybe Frame
Nothing                     -> FrameKind -> FrameTable -> Frame
FrameTable FrameKind
Open      (FrameTable -> Frame)
-> Either (Located SemanticError) FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> Either (Located SemanticError) FrameTable
go FrameTable
forall a. Monoid a => a
mempty
        Just (FrameTable FrameKind
tk FrameTable
t)      -> FrameKind -> FrameTable -> Frame
FrameTable FrameKind
tk        (FrameTable -> Frame)
-> Either (Located SemanticError) FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> Either (Located SemanticError) FrameTable
go FrameTable
t
        Just (FrameArray (FrameTable
t :| [FrameTable]
ts)) -> NonEmpty FrameTable -> Frame
FrameArray (NonEmpty FrameTable -> Frame)
-> (FrameTable -> NonEmpty FrameTable) -> FrameTable -> Frame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FrameTable -> [FrameTable] -> NonEmpty FrameTable
forall a. a -> [a] -> NonEmpty a
:| [FrameTable]
ts) (FrameTable -> Frame)
-> Either (Located SemanticError) FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> Either (Located SemanticError) FrameTable
go FrameTable
t
        Just (FrameValue Value
_)         -> Located String -> SemanticErrorKind -> M Frame
forall a. Located String -> SemanticErrorKind -> M a
invalidKey Located String
k1 SemanticErrorKind
AlreadyAssigned
        where
            go :: FrameTable -> Either (Located SemanticError) FrameTable
go = SectionKind
-> Key
-> [(Key, Val)]
-> FrameTable
-> Either (Located SemanticError) FrameTable
addSection SectionKind
kind (Located String
k2 Located String -> [Located String] -> Key
forall a. a -> [a] -> NonEmpty a
:| [Located String]
ks) [(Key, Val)]
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 -> FrameTable
closeDots :: FrameTable -> FrameTable
closeDots =
    (Frame -> Frame) -> FrameTable -> FrameTable
forall a b. (a -> b) -> Map String a -> Map String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
        FrameTable FrameKind
Dotted FrameTable
t -> FrameKind -> FrameTable -> Frame
FrameTable FrameKind
Closed (FrameTable -> FrameTable
closeDots FrameTable
t)
        Frame
frame               -> Frame
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, Val)] -> FrameTable -> M FrameTable
assignKeyVals :: [(Key, Val)]
-> FrameTable -> Either (Located SemanticError) FrameTable
assignKeyVals [(Key, Val)]
kvs FrameTable
t = FrameTable -> FrameTable
closeDots (FrameTable -> FrameTable)
-> Either (Located SemanticError) FrameTable
-> Either (Located SemanticError) FrameTable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FrameTable
 -> (Key, Val) -> Either (Located SemanticError) FrameTable)
-> FrameTable
-> [(Key, Val)]
-> Either (Located SemanticError) FrameTable
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM FrameTable
-> (Key, Val) -> Either (Located SemanticError) FrameTable
f FrameTable
t [(Key, Val)]
kvs
    where
        f :: FrameTable
-> (Key, Val) -> Either (Located SemanticError) FrameTable
f FrameTable
m (Key
k,Val
v) = Key
-> Val -> FrameTable -> Either (Located SemanticError) FrameTable
assign Key
k Val
v FrameTable
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 -> Val -> FrameTable -> M FrameTable

assign :: Key
-> Val -> FrameTable -> Either (Located SemanticError) FrameTable
assign (Located String
key :| []) Val
val =
    Located String
-> (Maybe Frame -> M Frame)
-> FrameTable
-> Either (Located SemanticError) FrameTable
alterFrame Located String
key \case
        Maybe Frame
Nothing -> Value -> Frame
FrameValue (Value -> Frame) -> Either (Located SemanticError) Value -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Either (Located SemanticError) Value
valToValue Val
val
        Just{}  -> Located String -> SemanticErrorKind -> M Frame
forall a. Located String -> SemanticErrorKind -> M a
invalidKey Located String
key SemanticErrorKind
AlreadyAssigned

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

-- | Convert 'Val' to 'Value' potentially raising an error if
-- it contains inline tables with key-conflicts.
valToValue :: Val -> M Value
valToValue :: Val -> Either (Located SemanticError) Value
valToValue = \case
    ValInteger   Integer
x    -> Value -> Either (Located SemanticError) Value
forall a b. b -> Either a b
Right (Integer -> Value
Integer   Integer
x)
    ValFloat     Double
x    -> Value -> Either (Located SemanticError) Value
forall a b. b -> Either a b
Right (Double -> Value
Float     Double
x)
    ValBool      Bool
x    -> Value -> Either (Located SemanticError) Value
forall a b. b -> Either a b
Right (Bool -> Value
Bool      Bool
x)
    ValString    String
x    -> Value -> Either (Located SemanticError) Value
forall a b. b -> Either a b
Right (String -> Value
String    String
x)
    ValTimeOfDay TimeOfDay
x    -> Value -> Either (Located SemanticError) Value
forall a b. b -> Either a b
Right (TimeOfDay -> Value
TimeOfDay TimeOfDay
x)
    ValZonedTime ZonedTime
x    -> Value -> Either (Located SemanticError) Value
forall a b. b -> Either a b
Right (ZonedTime -> Value
ZonedTime ZonedTime
x)
    ValLocalTime LocalTime
x    -> Value -> Either (Located SemanticError) Value
forall a b. b -> Either a b
Right (LocalTime -> Value
LocalTime LocalTime
x)
    ValDay       Day
x    -> Value -> Either (Located SemanticError) Value
forall a b. b -> Either a b
Right (Day -> Value
Day       Day
x)
    ValArray [Val]
xs       -> [Value] -> Value
Array ([Value] -> Value)
-> Either (Located SemanticError) [Value]
-> Either (Located SemanticError) Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> Either (Located SemanticError) Value)
-> [Val] -> Either (Located SemanticError) [Value]
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 -> Either (Located SemanticError) Value
valToValue [Val]
xs
    ValTable [(Key, Val)]
kvs      -> FrameTable -> Value
framesToValue (FrameTable -> Value)
-> Either (Located SemanticError) FrameTable
-> Either (Located SemanticError) Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Val)]
-> FrameTable -> Either (Located SemanticError) FrameTable
assignKeyVals [(Key, Val)]
kvs FrameTable
forall a. Monoid a => a
mempty

-- | Abort validation by reporting an error about the given key.
invalidKey ::
    Located String    {- ^ subkey     -} ->
    SemanticErrorKind {- ^ error kind -} ->
    M a
invalidKey :: forall a. Located String -> SemanticErrorKind -> M a
invalidKey Located String
key SemanticErrorKind
kind = Located SemanticError -> Either (Located SemanticError) a
forall a b. a -> Either a b
Left ((String -> SemanticErrorKind -> SemanticError
`SemanticError` SemanticErrorKind
kind) (String -> SemanticError)
-> Located String -> Located SemanticError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located String
key)

-- | Specialization of 'Map.alterF' used to adjust a location in a 'FrameTable'
alterFrame :: Located String -> (Maybe Frame -> M Frame) -> FrameTable -> M FrameTable
alterFrame :: Located String
-> (Maybe Frame -> M Frame)
-> FrameTable
-> Either (Located SemanticError) FrameTable
alterFrame Located String
k Maybe Frame -> M Frame
f = (Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> String
-> FrameTable
-> Either (Located SemanticError) FrameTable
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF ((Frame -> Maybe Frame)
-> M Frame -> Either (Located SemanticError) (Maybe Frame)
forall a b.
(a -> b)
-> Either (Located SemanticError) a
-> Either (Located SemanticError) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Frame -> Maybe Frame
forall a. a -> Maybe a
Just (M Frame -> Either (Located SemanticError) (Maybe Frame))
-> (Maybe Frame -> M Frame)
-> Maybe Frame
-> Either (Located SemanticError) (Maybe Frame)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Frame -> M Frame
f) (Located String -> String
forall a. Located a -> a
locThing Located String
k)