{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use list literal" #-}
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(..))
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 ,
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 ,
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 ,
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 )
data SemanticErrorKind
= AlreadyAssigned
| ClosedTable
| ImplicitlyTable
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 ,
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 ,
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 ,
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 )
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 Map String Frame
forall k a. Map k a
Map.empty
Map String Frame
m2 <- (Map String Frame
-> (SectionKind, Key, KeyVals)
-> Either (Located SemanticError) (Map String Frame))
-> Map String Frame
-> [(SectionKind, Key, KeyVals)]
-> Either (Located SemanticError) (Map String Frame)
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
Table -> Either (Located SemanticError) Table
forall a. a -> Either (Located SemanticError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map String Frame -> Table
framesToTable Map String Frame
m2)
type KeyVals = [(Key, Val)]
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 [] = (KeyVals -> KeyVals
forall a. [a] -> [a]
reverse KeyVals
acc, [])
goTop KeyVals
acc (ArrayTableExpr Key
key : [Expr]
exprs) = (KeyVals -> KeyVals
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) = (KeyVals -> KeyVals
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)(Key, Val) -> KeyVals -> KeyVals
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, KeyVals -> KeyVals
forall a. [a] -> [a]
reverse KeyVals
acc) (SectionKind, Key, KeyVals)
-> [(SectionKind, Key, KeyVals)] -> [(SectionKind, Key, KeyVals)]
forall a. a -> [a] -> [a]
: []
goTable SectionKind
kind Key
key KeyVals
acc (TableExpr Key
k : [Expr]
exprs) = (SectionKind
kind, Key
key, KeyVals -> KeyVals
forall a. [a] -> [a]
reverse KeyVals
acc) (SectionKind, Key, KeyVals)
-> [(SectionKind, Key, KeyVals)] -> [(SectionKind, Key, KeyVals)]
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, KeyVals -> KeyVals
forall a. [a] -> [a]
reverse KeyVals
acc) (SectionKind, Key, KeyVals)
-> [(SectionKind, Key, KeyVals)] -> [(SectionKind, Key, KeyVals)]
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)(Key, Val) -> KeyVals -> KeyVals
forall a. a -> [a] -> [a]
:KeyVals
acc) [Expr]
exprs
data Frame
= FrameTable FrameKind (Map String Frame)
| FrameArray (NonEmpty (Map String Frame))
| 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
data FrameKind
= Open
| Dotted
| Closed
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
framesToTable :: Map String Frame -> Table
framesToTable :: Map String Frame -> Table
framesToTable =
(Frame -> Value) -> Map String Frame -> 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
_ 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
toArray :: NonEmpty (Map String Frame) -> [Value]
toArray = ([Value] -> Map String Frame -> [Value])
-> [Value] -> NonEmpty (Map String Frame) -> [Value]
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
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) Value -> [Value] -> [Value]
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 (((Key, Value) -> Key) -> [(Key, Value)] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Value) -> Key
forall a b. (a, b) -> a
fst [(Key, Value)]
entries) of
Just Located String
bad -> Located String
-> SemanticErrorKind -> Either (Located SemanticError) Table
forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
bad SemanticErrorKind
AlreadyAssigned
Maybe (Located String)
Nothing -> Table -> Either (Located SemanticError) Table
forall a b. b -> Either a b
Right ((Value -> Value -> Value) -> [Table] -> Table
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 (Located String -> String
forall a. Located a -> a
locThing Located String
k) (Located String -> String
forall a. Located a -> a
locThing (Located String -> String) -> [Located String] -> [String]
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 ((Value -> Value -> Value) -> Table -> Table -> 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
_ = String -> Value
forall a. HasCallStack => String -> a
error String
"constructFrame:merge: panic"
singleValue :: String -> [String] -> Value -> Table
singleValue String
k [] Value
v = String -> Value -> Table
forall k a. k -> a -> Map k a
Map.singleton String
k Value
v
singleValue String
k (String
k1:[String]
ks) Value
v = String -> Value -> Table
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))
findBadKey :: [Key] -> Maybe (Located String)
findBadKey :: [Key] -> Maybe (Located String)
findBadKey = [Key] -> Maybe (Located String)
check ([Key] -> Maybe (Located String))
-> ([Key] -> [Key]) -> [Key] -> Maybe (Located String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> NonEmpty String) -> [Key] -> [Key]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((Located String -> String) -> Key -> NonEmpty String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located String -> String
forall a. Located a -> a
locThing)
where
check :: [Key] -> Maybe (Located String)
check :: [Key] -> Maybe (Located String)
check (Key
x:Key
y:[Key]
z) = Key -> Key -> Maybe (Located String)
forall {a}.
Eq a =>
NonEmpty (Located a) -> NonEmpty (Located a) -> Maybe (Located a)
check1 Key
x Key
y Maybe (Located String)
-> Maybe (Located String) -> Maybe (Located String)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Key] -> Maybe (Located String)
check (Key
yKey -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:[Key]
z)
check [Key]
_ = Maybe (Located String)
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)
| Located a -> a
forall a. Located a -> a
locThing Located a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Located a -> a
forall a. Located a -> a
locThing Located a
y1 =
case [Located a]
xs of
[] -> Located a -> Maybe (Located a)
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' Located a -> [Located a] -> NonEmpty (Located a)
forall a. a -> [a] -> NonEmpty a
:| [Located a]
xs') (Located a
y2 Located a -> [Located a] -> NonEmpty (Located a)
forall a. a -> [a] -> NonEmpty a
:| [Located a]
ys)
check1 NonEmpty (Located a)
_ NonEmpty (Located a)
_ = Maybe (Located a)
forall a. Maybe a
Nothing
addSection ::
SectionKind ->
KeyVals ->
Key ->
Map String Frame ->
Either (Located SemanticError) (Map String Frame)
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 :| []) = ((Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> String
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame))
-> String
-> (Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> String
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (Located String -> String
forall a. Located a -> a
locThing Located String
k1) \case
Maybe Frame
Nothing ->
case SectionKind
kind of
SectionKind
TableKind -> (Map String Frame -> Frame)
-> Map String Frame -> Either (Located SemanticError) (Maybe Frame)
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
forall k a. Map k a
Map.empty
SectionKind
ArrayTableKind -> (Map String Frame -> Frame)
-> Map String Frame -> Either (Located SemanticError) (Maybe Frame)
forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (NonEmpty (Map String Frame) -> Frame
FrameArray (NonEmpty (Map String Frame) -> Frame)
-> (Map String Frame -> NonEmpty (Map String Frame))
-> Map String Frame
-> Frame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String Frame -> NonEmpty (Map String Frame)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Map String Frame
forall k a. Map k a
Map.empty
Just (FrameTable FrameKind
Open Map String Frame
t) ->
case SectionKind
kind of
SectionKind
TableKind -> (Map String Frame -> Frame)
-> Map String Frame -> Either (Located SemanticError) (Maybe Frame)
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 -> Located String
-> SemanticErrorKind
-> Either (Located SemanticError) (Maybe Frame)
forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
k1 SemanticErrorKind
ImplicitlyTable
Just (FrameArray NonEmpty (Map String Frame)
a) ->
case SectionKind
kind of
SectionKind
ArrayTableKind -> (Map String Frame -> Frame)
-> Map String Frame -> Either (Located SemanticError) (Maybe Frame)
forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (NonEmpty (Map String Frame) -> Frame
FrameArray (NonEmpty (Map String Frame) -> Frame)
-> (Map String Frame -> NonEmpty (Map String Frame))
-> Map String Frame
-> Frame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map String Frame
-> NonEmpty (Map String Frame) -> NonEmpty (Map String Frame)
forall a. a -> NonEmpty a -> NonEmpty a
`NonEmpty.cons` NonEmpty (Map String Frame)
a)) Map String Frame
forall k a. Map k a
Map.empty
SectionKind
TableKind -> Located String
-> SemanticErrorKind
-> Either (Located SemanticError) (Maybe Frame)
forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
k1 SemanticErrorKind
ClosedTable
Just (FrameTable FrameKind
Closed Map String Frame
_) -> Located String
-> SemanticErrorKind
-> Either (Located SemanticError) (Maybe Frame)
forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
k1 SemanticErrorKind
ClosedTable
Just (FrameTable FrameKind
Dotted Map String Frame
_) -> String -> Either (Located SemanticError) (Maybe Frame)
forall a. HasCallStack => String -> a
error String
"addSection: dotted table left unclosed"
Just (FrameValue {}) -> Located String
-> SemanticErrorKind
-> Either (Located SemanticError) (Maybe Frame)
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 = b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b)
-> (Map String Frame -> b) -> Map String Frame -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String Frame -> b
g (Map String Frame -> b)
-> (Map String Frame -> Map String Frame) -> Map String Frame -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String Frame -> Map String Frame
closeDots (Map String Frame -> Maybe b)
-> Either (Located SemanticError) (Map String Frame)
-> Either (Located SemanticError) (Maybe b)
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) = ((Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> String
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame))
-> String
-> (Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> String
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (Located String -> String
forall a. Located a -> a
locThing Located String
k1) \case
Maybe Frame
Nothing -> (Map String Frame -> Frame)
-> Map String Frame -> Either (Located SemanticError) (Maybe Frame)
forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (FrameKind -> Map String Frame -> Frame
FrameTable FrameKind
Open ) Map String Frame
forall k a. Map k a
Map.empty
Just (FrameTable FrameKind
tk Map String Frame
t) -> (Map String Frame -> Frame)
-> Map String Frame -> Either (Located SemanticError) (Maybe Frame)
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)) -> (Map String Frame -> Frame)
-> Map String Frame -> Either (Located SemanticError) (Maybe Frame)
forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either (Located SemanticError) (Maybe b)
go (NonEmpty (Map String Frame) -> Frame
FrameArray (NonEmpty (Map String Frame) -> Frame)
-> (Map String Frame -> NonEmpty (Map String Frame))
-> Map String Frame
-> Frame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map String Frame
-> [Map String Frame] -> NonEmpty (Map String Frame)
forall a. a -> [a] -> NonEmpty a
:| [Map String Frame]
ts)) Map String Frame
t
Just (FrameValue Value
_) -> Located String
-> SemanticErrorKind
-> Either (Located SemanticError) (Maybe Frame)
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 = b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b)
-> (Map String Frame -> b) -> Map String Frame -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String Frame -> b
g (Map String Frame -> Maybe b)
-> Either (Located SemanticError) (Map String Frame)
-> Either (Located SemanticError) (Maybe b)
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 Located String -> [Located String] -> Key
forall a. a -> [a] -> NonEmpty a
:| [Located String]
ks) Map String Frame
t
closeDots :: Map String Frame -> Map String Frame
closeDots :: Map String Frame -> Map String Frame
closeDots =
(Frame -> Frame) -> Map String Frame -> Map String Frame
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 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 (Map String Frame -> Map String Frame)
-> Either (Located SemanticError) (Map String Frame)
-> Either (Located SemanticError) (Map String Frame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map String Frame
-> (Key, Val) -> Either (Located SemanticError) (Map String Frame))
-> Map String Frame
-> KeyVals
-> Either (Located SemanticError) (Map String Frame)
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 :: 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 = ((Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> String
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame))
-> String
-> (Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> String
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (Located String -> String
forall a. Located a -> a
locThing Located String
key) \case
Maybe Frame
Nothing -> Frame -> Maybe Frame
forall a. a -> Maybe a
Just (Frame -> Maybe Frame) -> (Value -> Frame) -> Value -> Maybe Frame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Frame
FrameValue (Value -> Maybe Frame)
-> Either (Located SemanticError) Value
-> Either (Located SemanticError) (Maybe 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
-> Either (Located SemanticError) (Maybe Frame)
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 = ((Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> String
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame))
-> String
-> (Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> String
-> Map String Frame
-> Either (Located SemanticError) (Map String Frame)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF (Located String -> String
forall a. Located a -> a
locThing Located String
key) \case
Maybe Frame
Nothing -> Map String Frame -> Either (Located SemanticError) (Maybe Frame)
go Map String Frame
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
_) -> Located String
-> SemanticErrorKind
-> Either (Located SemanticError) (Maybe Frame)
forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
key SemanticErrorKind
ClosedTable
Just (FrameArray NonEmpty (Map String Frame)
_) -> Located String
-> SemanticErrorKind
-> Either (Located SemanticError) (Maybe Frame)
forall a.
Located String
-> SemanticErrorKind -> Either (Located SemanticError) a
invalidKey Located String
key SemanticErrorKind
ClosedTable
Just (FrameValue Value
_) -> Located String
-> SemanticErrorKind
-> Either (Located SemanticError) (Maybe Frame)
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 = Frame -> Maybe Frame
forall a. a -> Maybe a
Just (Frame -> Maybe Frame)
-> (Map String Frame -> Frame) -> Map String Frame -> Maybe Frame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameKind -> Map String Frame -> Frame
FrameTable FrameKind
Dotted (Map String Frame -> Maybe Frame)
-> Either (Located SemanticError) (Map String Frame)
-> Either (Located SemanticError) (Maybe Frame)
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 Located String -> [Located String] -> Key
forall a. a -> [a] -> NonEmpty a
:| [Located String]
keys) Val
val Map String Frame
t
valToValue :: Val -> Either (Located SemanticError) 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 KeyVals
kvs -> do [(Key, Value)]
entries <- (((Key, Val) -> Either (Located SemanticError) (Key, Value))
-> KeyVals -> Either (Located SemanticError) [(Key, 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 (((Key, Val) -> Either (Located SemanticError) (Key, Value))
-> KeyVals -> Either (Located SemanticError) [(Key, Value)])
-> ((Val -> Either (Located SemanticError) Value)
-> (Key, Val) -> Either (Located SemanticError) (Key, Value))
-> (Val -> Either (Located SemanticError) Value)
-> KeyVals
-> Either (Located SemanticError) [(Key, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Val -> Either (Located SemanticError) Value)
-> (Key, Val) -> Either (Located SemanticError) (Key, 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) -> (Key, a) -> f (Key, b)
traverse) Val -> Either (Located SemanticError) Value
valToValue KeyVals
kvs
Table -> Value
Table (Table -> Value)
-> Either (Located SemanticError) Table
-> Either (Located SemanticError) Value
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 = 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)