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

This module extracts the 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.Applicative ((<|>))
import Control.Monad (foldM)
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.List.NonEmpty qualified as 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(..))

-- | The type of errors that can be generated when resolving all the key
-- used in a TOML document. These errors always pertain to some key to
-- caused one of three conflicts.
--
-- @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]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SemanticError]
$creadListPrec :: ReadPrec [SemanticError]
readPrec :: ReadPrec SemanticError
$creadPrec :: ReadPrec SemanticError
readList :: ReadS [SemanticError]
$creadList :: ReadS [SemanticError]
readsPrec :: Int -> ReadS SemanticError
$creadsPrec :: Int -> ReadS SemanticError
Read {- ^ Default instance -},
        Int -> SemanticError -> ShowS
[SemanticError] -> ShowS
SemanticError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SemanticError] -> ShowS
$cshowList :: [SemanticError] -> ShowS
show :: SemanticError -> String
$cshow :: SemanticError -> String
showsPrec :: Int -> SemanticError -> ShowS
$cshowsPrec :: Int -> SemanticError -> ShowS
Show {- ^ Default instance -},
        SemanticError -> SemanticError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SemanticError -> SemanticError -> Bool
$c/= :: SemanticError -> SemanticError -> Bool
== :: SemanticError -> SemanticError -> Bool
$c== :: SemanticError -> SemanticError -> Bool
Eq   {- ^ Default instance -},
        Eq 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
min :: SemanticError -> SemanticError -> SemanticError
$cmin :: SemanticError -> SemanticError -> SemanticError
max :: SemanticError -> SemanticError -> SemanticError
$cmax :: SemanticError -> SemanticError -> SemanticError
>= :: SemanticError -> SemanticError -> Bool
$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
compare :: SemanticError -> SemanticError -> Ordering
$ccompare :: SemanticError -> SemanticError -> Ordering
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]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SemanticErrorKind]
$creadListPrec :: ReadPrec [SemanticErrorKind]
readPrec :: ReadPrec SemanticErrorKind
$creadPrec :: ReadPrec SemanticErrorKind
readList :: ReadS [SemanticErrorKind]
$creadList :: ReadS [SemanticErrorKind]
readsPrec :: Int -> ReadS SemanticErrorKind
$creadsPrec :: Int -> ReadS SemanticErrorKind
Read {- ^ Default instance -},
        Int -> SemanticErrorKind -> ShowS
[SemanticErrorKind] -> ShowS
SemanticErrorKind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SemanticErrorKind] -> ShowS
$cshowList :: [SemanticErrorKind] -> ShowS
show :: SemanticErrorKind -> String
$cshow :: SemanticErrorKind -> String
showsPrec :: Int -> SemanticErrorKind -> ShowS
$cshowsPrec :: Int -> SemanticErrorKind -> ShowS
Show {- ^ Default instance -},
        SemanticErrorKind -> SemanticErrorKind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SemanticErrorKind -> SemanticErrorKind -> Bool
$c/= :: SemanticErrorKind -> SemanticErrorKind -> Bool
== :: SemanticErrorKind -> SemanticErrorKind -> Bool
$c== :: SemanticErrorKind -> SemanticErrorKind -> Bool
Eq   {- ^ Default instance -},
        Eq 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
min :: SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind
$cmin :: SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind
max :: SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind
$cmax :: SemanticErrorKind -> SemanticErrorKind -> SemanticErrorKind
>= :: SemanticErrorKind -> SemanticErrorKind -> Bool
$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
compare :: SemanticErrorKind -> SemanticErrorKind -> Ordering
$ccompare :: SemanticErrorKind -> SemanticErrorKind -> Ordering
Ord  {- ^ Default instance -})

-- | Extract semantic value from sequence of raw TOML expressions
-- or report a semantic error.
--
-- @since 1.3.0.0
semantics :: [Expr] -> Either (Located SemanticError) Table
semantics :: [Expr] -> Either (Located SemanticError) Table
semantics [Expr]
exprs =
 do let (KeyVals
topKVs, [(SectionKind, Key, KeyVals)]
tables) = [Expr] -> (KeyVals, [(SectionKind, Key, KeyVals)])
gather [Expr]
exprs
    Map String Frame
m1 <- KeyVals
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
assignKeyVals KeyVals
topKVs forall k a. Map k a
Map.empty
    Map String Frame
m2 <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Map String Frame
m (SectionKind
kind, Key
key, KeyVals
kvs) ->
        SectionKind
-> KeyVals
-> Key
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
addSection SectionKind
kind KeyVals
kvs Key
key Map String Frame
m) Map String Frame
m1 [(SectionKind, Key, KeyVals)]
tables
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map String Frame -> Table
framesToTable Map String Frame
m2)

-- | Line number, key, value
type KeyVals = [(Key, Val)]

-- | Arrange the expressions in a TOML file into the top-level key-value pairs
-- and then all the key-value pairs for each subtable.
gather :: [Expr] -> (KeyVals, [(SectionKind, Key, KeyVals)])
gather :: [Expr] -> (KeyVals, [(SectionKind, Key, KeyVals)])
gather = KeyVals -> [Expr] -> (KeyVals, [(SectionKind, Key, KeyVals)])
goTop []
    where
        goTop :: KeyVals -> [Expr] -> (KeyVals, [(SectionKind, Key, KeyVals)])
goTop KeyVals
acc []                           = (forall a. [a] -> [a]
reverse KeyVals
acc, [])
        goTop KeyVals
acc (ArrayTableExpr Key
key : [Expr]
exprs) = (forall a. [a] -> [a]
reverse KeyVals
acc, SectionKind
-> Key -> KeyVals -> [Expr] -> [(SectionKind, Key, KeyVals)]
goTable SectionKind
ArrayTableKind Key
key [] [Expr]
exprs)
        goTop KeyVals
acc (TableExpr      Key
key : [Expr]
exprs) = (forall a. [a] -> [a]
reverse KeyVals
acc, SectionKind
-> Key -> KeyVals -> [Expr] -> [(SectionKind, Key, KeyVals)]
goTable SectionKind
TableKind      Key
key [] [Expr]
exprs)
        goTop KeyVals
acc (KeyValExpr     Key
k Val
v : [Expr]
exprs) = KeyVals -> [Expr] -> (KeyVals, [(SectionKind, Key, KeyVals)])
goTop ((Key
k,Val
v)forall a. a -> [a] -> [a]
:KeyVals
acc) [Expr]
exprs

        goTable :: SectionKind
-> Key -> KeyVals -> [Expr] -> [(SectionKind, Key, KeyVals)]
goTable SectionKind
kind Key
key KeyVals
acc []                           = (SectionKind
kind, Key
key, forall a. [a] -> [a]
reverse KeyVals
acc) forall a. a -> [a] -> [a]
: []
        goTable SectionKind
kind Key
key KeyVals
acc (TableExpr      Key
k   : [Expr]
exprs) = (SectionKind
kind, Key
key, forall a. [a] -> [a]
reverse KeyVals
acc) forall a. a -> [a] -> [a]
: SectionKind
-> Key -> KeyVals -> [Expr] -> [(SectionKind, Key, KeyVals)]
goTable SectionKind
TableKind Key
k [] [Expr]
exprs
        goTable SectionKind
kind Key
key KeyVals
acc (ArrayTableExpr Key
k   : [Expr]
exprs) = (SectionKind
kind, Key
key, forall a. [a] -> [a]
reverse KeyVals
acc) forall a. a -> [a] -> [a]
: SectionKind
-> Key -> KeyVals -> [Expr] -> [(SectionKind, Key, KeyVals)]
goTable SectionKind
ArrayTableKind Key
k [] [Expr]
exprs
        goTable SectionKind
kind Key
key KeyVals
acc (KeyValExpr     Key
k Val
v : [Expr]
exprs) = SectionKind
-> Key -> KeyVals -> [Expr] -> [(SectionKind, Key, KeyVals)]
goTable SectionKind
kind Key
key ((Key
k,Val
v)forall a. a -> [a] -> [a]
:KeyVals
acc) [Expr]
exprs

-- | Frames help distinguish tables and arrays written in block and inline
-- syntax. This allows us to enforce that inline tables and arrays can not
-- be extended by block syntax.
data Frame
    = FrameTable FrameKind (Map String Frame)
    | FrameArray (NonEmpty (Map String Frame)) -- stored in reverse order for easy "append"
    | FrameValue Value
    deriving Int -> Frame -> ShowS
[Frame] -> ShowS
Frame -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Frame] -> ShowS
$cshowList :: [Frame] -> ShowS
show :: Frame -> String
$cshow :: Frame -> String
showsPrec :: Int -> Frame -> ShowS
$cshowsPrec :: Int -> Frame -> ShowS
Show

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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FrameKind] -> ShowS
$cshowList :: [FrameKind] -> ShowS
show :: FrameKind -> String
$cshow :: FrameKind -> String
showsPrec :: Int -> FrameKind -> ShowS
$cshowsPrec :: Int -> FrameKind -> ShowS
Show

framesToTable :: Map String Frame -> Table
framesToTable :: Map String Frame -> Table
framesToTable =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
        FrameTable FrameKind
_ Map String Frame
t -> Table -> Value
Table (Map String Frame -> Table
framesToTable Map String Frame
t)
        FrameArray NonEmpty (Map String Frame)
a   -> [Value] -> Value
Array (NonEmpty (Map String Frame) -> [Value]
toArray NonEmpty (Map String Frame)
a)
        FrameValue Value
v   -> Value
v
    where
        -- reverses the list while converting the frames to tables
        toArray :: NonEmpty (Map String Frame) -> [Value]
toArray = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[Value]
acc Map String Frame
frame -> Table -> Value
Table (Map String Frame -> Table
framesToTable Map String Frame
frame) forall a. a -> [a] -> [a]
: [Value]
acc) []

constructTable :: [(Key, Value)] -> Either (Located SemanticError) Table
constructTable :: [(Key, Value)] -> Either (Located SemanticError) Table
constructTable [(Key, Value)]
entries =
    case [Key] -> Maybe (Located String)
findBadKey (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Key, Value)]
entries) of
        Just Located String
bad -> forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
bad SemanticErrorKind
AlreadyAssigned
        Maybe (Located String)
Nothing -> forall a b. b -> Either a b
Right (forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Value -> Value -> Value
merge [String -> [String] -> Value -> Table
singleValue (forall a. Located a -> a
locThing Located String
k) (forall a. Located a -> a
locThing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Located String]
ks) Value
v | (Located String
k:|[Located String]
ks, Value
v) <- [(Key, Value)]
entries])
    where
        merge :: Value -> Value -> Value
merge (Table Table
x) (Table Table
y) = Table -> Value
Table (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Value -> Value -> Value
merge Table
x Table
y)
        merge Value
_ Value
_ = forall a. HasCallStack => String -> a
error String
"constructFrame:merge: panic"

        singleValue :: String -> [String] -> Value -> Table
singleValue String
k []      Value
v = forall k a. k -> a -> Map k a
Map.singleton String
k Value
v
        singleValue String
k (String
k1:[String]
ks) Value
v = forall k a. k -> a -> Map k a
Map.singleton String
k (Table -> Value
Table (String -> [String] -> Value -> Table
singleValue String
k1 [String]
ks Value
v))

-- | Finds a key that overlaps with another in the same list
findBadKey :: [Key] -> Maybe (Located String)
findBadKey :: [Key] -> Maybe (Located String)
findBadKey = [Key] -> Maybe (Located String)
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Located a -> a
locThing)
    where
        check :: [Key] -> Maybe (Located String)
        check :: [Key] -> Maybe (Located String)
check (Key
x:Key
y:[Key]
z) = forall {a}.
Eq a =>
NonEmpty (Located a) -> NonEmpty (Located a) -> Maybe (Located a)
check1 Key
x Key
y forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Key] -> Maybe (Located String)
check (Key
yforall a. a -> [a] -> [a]
:[Key]
z)
        check [Key]
_ = forall a. Maybe a
Nothing

        check1 :: NonEmpty (Located a) -> NonEmpty (Located a) -> Maybe (Located a)
check1 (Located a
x :| [Located a]
xs) (Located a
y1 :| Located a
y2 : [Located a]
ys)
            | forall a. Located a -> a
locThing Located a
x forall a. Eq a => a -> a -> Bool
== forall a. Located a -> a
locThing Located a
y1 =
                case [Located a]
xs of
                    [] -> forall a. a -> Maybe a
Just Located a
y1
                    Located a
x' : [Located a]
xs' -> NonEmpty (Located a) -> NonEmpty (Located a) -> Maybe (Located a)
check1 (Located a
x' forall a. a -> [a] -> NonEmpty a
:| [Located a]
xs') (Located a
y2 forall a. a -> [a] -> NonEmpty a
:| [Located a]
ys)
        check1 NonEmpty (Located a)
_ NonEmpty (Located a)
_ = forall a. Maybe a
Nothing

-- | 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        -} ->
    KeyVals                          {- ^ values to install   -} ->
    Key                              {- ^ section key         -} ->
    Map String Frame                 {- ^ local frame map     -} ->
    Either (Located SemanticError) (Map String Frame) {- ^ error message or updated local frame map -}
addSection :: SectionKind
-> KeyVals
-> Key
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
addSection SectionKind
kind KeyVals
kvs = Key
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
walk
    where
        walk :: Key
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
walk (Located String
k1 :| []) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (forall a. Located a -> a
locThing Located String
k1) \case
            -- defining a new table
            Maybe Frame
Nothing ->
                case SectionKind
kind of
                    SectionKind
TableKind      -> forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (FrameKind -> Map String Frame -> Frame
FrameTable FrameKind
Closed) forall k a. Map k a
Map.empty
                    SectionKind
ArrayTableKind -> forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (NonEmpty (Map String Frame) -> Frame
FrameArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall k a. Map k a
Map.empty

            -- defining a super table of a previously defined subtable
            Just (FrameTable FrameKind
Open Map String Frame
t) ->
                case SectionKind
kind of
                    SectionKind
TableKind      -> forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (FrameKind -> Map String Frame -> Frame
FrameTable FrameKind
Closed) Map String Frame
t
                    SectionKind
ArrayTableKind -> forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
k1 SemanticErrorKind
ImplicitlyTable

            -- Add a new array element to an existing table array
            Just (FrameArray NonEmpty (Map String Frame)
a) ->
                case SectionKind
kind of
                    SectionKind
ArrayTableKind -> forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (NonEmpty (Map String Frame) -> Frame
FrameArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> NonEmpty a -> NonEmpty a
`NonEmpty.cons` NonEmpty (Map String Frame)
a)) forall k a. Map k a
Map.empty
                    SectionKind
TableKind      -> forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
k1 SemanticErrorKind
ClosedTable

            -- failure cases
            Just (FrameTable FrameKind
Closed Map String Frame
_) -> forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
k1 SemanticErrorKind
ClosedTable
            Just (FrameTable FrameKind
Dotted Map String Frame
_) -> forall a. HasCallStack => String -> a
error String
"addSection: dotted table left unclosed"
            Just (FrameValue {})       -> forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
k1 SemanticErrorKind
AlreadyAssigned
            where
                go :: (Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go Map String Frame -> b
g Map String Frame
t = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String Frame -> b
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String Frame -> Map String Frame
closeDots forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyVals
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
assignKeyVals KeyVals
kvs Map String Frame
t

        walk (Located String
k1 :| Located String
k2 : [Located String]
ks) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (forall a. Located a -> a
locThing Located String
k1) \case
            Maybe Frame
Nothing                     -> forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (FrameKind -> Map String Frame -> Frame
FrameTable FrameKind
Open     ) forall k a. Map k a
Map.empty
            Just (FrameTable FrameKind
tk Map String Frame
t)      -> forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (FrameKind -> Map String Frame -> Frame
FrameTable FrameKind
tk       ) Map String Frame
t
            Just (FrameArray (Map String Frame
t :| [Map String Frame]
ts)) -> forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (NonEmpty (Map String Frame) -> Frame
FrameArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> NonEmpty a
:| [Map String Frame]
ts)) Map String Frame
t
            Just (FrameValue Value
_)         -> forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
k1 SemanticErrorKind
AlreadyAssigned
            where
                go :: (Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go Map String Frame -> b
g Map String Frame
t = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String Frame -> b
g forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
walk (Located String
k2 forall a. a -> [a] -> NonEmpty a
:| [Located String]
ks) Map String Frame
t

-- | Close all of the tables that were implicitly defined with
-- dotted prefixes.
closeDots :: Map String Frame -> Map String Frame
closeDots :: Map String Frame -> Map String Frame
closeDots =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
        FrameTable FrameKind
Dotted Map String Frame
t -> FrameKind -> Map String Frame -> Frame
FrameTable FrameKind
Closed (Map String Frame -> Map String Frame
closeDots Map String Frame
t)
        Frame
frame               -> Frame
frame

assignKeyVals :: KeyVals -> Map String Frame -> Either (Located SemanticError) (Map String Frame)
assignKeyVals :: KeyVals
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
assignKeyVals KeyVals
kvs Map String Frame
t = Map String Frame -> Map String Frame
closeDots forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map String Frame
-> (Key, Val) -> Either (Located SemanticError) (Map String Frame)
f Map String Frame
t KeyVals
kvs
    where
        f :: Map String Frame
-> (Key, Val) -> Either (Located SemanticError) (Map String Frame)
f Map String Frame
m (Key
k,Val
v) = Key
-> Val
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
assign Key
k Val
v Map String Frame
m

-- | Assign a single dotted key in a frame.
assign :: Key -> Val -> Map String Frame -> Either (Located SemanticError) (Map String Frame)

assign :: Key
-> Val
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
assign (Located String
key :| []) Val
val = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (forall a. Located a -> a
locThing Located String
key) \case
    Maybe Frame
Nothing -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Frame
FrameValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Either (Located SemanticError) Value
valToValue Val
val
    Just{}  -> forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
key SemanticErrorKind
AlreadyAssigned

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

-- | Convert 'Val' to 'Value' potentially raising an error if
-- it has inline tables with key-conflicts.
valToValue :: Val -> Either (Located SemanticError) Value
valToValue :: Val -> Either (Located SemanticError) Value
valToValue = \case
    ValInteger   Integer
x    -> forall a b. b -> Either a b
Right (Integer -> Value
Integer   Integer
x)
    ValFloat     Double
x    -> forall a b. b -> Either a b
Right (Double -> Value
Float     Double
x)
    ValBool      Bool
x    -> forall a b. b -> Either a b
Right (Bool -> Value
Bool      Bool
x)
    ValString    String
x    -> forall a b. b -> Either a b
Right (String -> Value
String    String
x)
    ValTimeOfDay TimeOfDay
x    -> forall a b. b -> Either a b
Right (TimeOfDay -> Value
TimeOfDay TimeOfDay
x)
    ValZonedTime ZonedTime
x    -> forall a b. b -> Either a b
Right (ZonedTime -> Value
ZonedTime ZonedTime
x)
    ValLocalTime LocalTime
x    -> forall a b. b -> Either a b
Right (LocalTime -> Value
LocalTime LocalTime
x)
    ValDay       Day
x    -> forall a b. b -> Either a b
Right (Day -> Value
Day       Day
x)
    ValArray [Val]
xs       -> [Value] -> Value
Array forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Val -> Either (Located SemanticError) Value
valToValue [Val]
xs
    ValTable KeyVals
kvs      -> do [(Key, Value)]
entries <- (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) Val -> Either (Located SemanticError) Value
valToValue KeyVals
kvs
                            Table -> Value
Table forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Value)] -> Either (Located SemanticError) Table
constructTable [(Key, Value)]
entries

invalidKey :: Located String -> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey :: forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
key SemanticErrorKind
kind = forall a b. a -> Either a b
Left ((String -> SemanticErrorKind -> SemanticError
`SemanticError` SemanticErrorKind
kind) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located String
key)