{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use list literal" #-}
module Toml.Semantics (semantics) where
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 Text.Printf (printf)
import Toml.Located (locThing, Located, locPosition)
import Toml.Parser (SectionKind(..), Key, Val(..), Expr(..))
import Toml.Value (Table, Value(..))
import Toml.Position (Position(..))
import Toml.Pretty (prettySimpleKey)
import Control.Applicative ((<|>))
semantics :: [Expr] -> Either String Table
semantics :: [Expr] -> Either String 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 String (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 String (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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Frame -> Value
frameToValue 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 [] = (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
data Frame
= FrameTable FrameKind (Map String Frame)
| FrameArray (NonEmpty (Map String Frame))
| 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
| Dotted
| Closed
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
frameToValue :: Frame -> Value
frameToValue :: Frame -> Value
frameToValue = \case
FrameTable FrameKind
_ Map String Frame
t -> Table -> Value
Table (Frame -> Value
frameToValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map String Frame
t)
FrameArray NonEmpty (Map String Frame)
a -> [Value] -> Value
Array (forall a. [a] -> [a]
reverse (Table -> Value
Table forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Frame -> Value
frameToValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Map String Frame)
a))
FrameValue Value
v -> Value
v
constructTable :: [(Key, Value)] -> Either String Table
constructTable :: [(Key, Value)] -> Either String 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 -> String -> Either String a
invalidKey Located String
bad String
"is already assigned"
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))
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
addSection ::
SectionKind ->
KeyVals ->
Key ->
Map String Frame ->
Either String (Map String Frame)
addSection :: SectionKind
-> KeyVals
-> Key
-> Map String Frame
-> Either String (Map String Frame)
addSection SectionKind
kind KeyVals
kvs = Key -> Map String Frame -> Either String (Map String Frame)
walk
where
walk :: Key -> Map String Frame -> Either String (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
Maybe Frame
Nothing ->
case SectionKind
kind of
SectionKind
TableKind -> forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either String (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 String (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
Just (FrameTable FrameKind
Open Map String Frame
t) ->
case SectionKind
kind of
SectionKind
TableKind -> forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either String (Maybe b)
go (FrameKind -> Map String Frame -> Frame
FrameTable FrameKind
Closed) Map String Frame
t
SectionKind
ArrayTableKind -> forall a. Located String -> String -> Either String a
invalidKey Located String
k1 String
"is already a table"
Just (FrameArray NonEmpty (Map String Frame)
a) ->
case SectionKind
kind of
SectionKind
ArrayTableKind -> forall {b}.
(Map String Frame -> b)
-> Map String Frame -> Either String (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 -> String -> Either String a
invalidKey Located String
k1 String
"is already an array of tables"
Just (FrameTable FrameKind
Closed Map String Frame
_) -> forall a. Located String -> String -> Either String a
invalidKey Located String
k1 String
"is a closed table"
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 -> String -> Either String a
invalidKey Located String
k1 String
"is already assigned"
where
go :: (Map String Frame -> b)
-> Map String Frame -> Either String (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 String (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 String (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 String (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 String (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 -> String -> Either String a
invalidKey Located String
k1 String
"is already assigned"
where
go :: (Map String Frame -> b)
-> Map String Frame -> Either String (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 String (Map String Frame)
walk (Located String
k2 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 =
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 String (Map String Frame)
assignKeyVals :: KeyVals -> Map String Frame -> Either String (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 String (Map String Frame)
f Map String Frame
t KeyVals
kvs
where
f :: Map String Frame -> (Key, Val) -> Either String (Map String Frame)
f Map String Frame
m (Key
k,Val
v) = Key -> Val -> Map String Frame -> Either String (Map String Frame)
assign Key
k Val
v Map String Frame
m
assign :: Key -> Val -> Map String Frame -> Either String (Map String Frame)
assign :: Key -> Val -> Map String Frame -> Either String (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 String Value
valToValue Val
val
Just{} -> forall a. Located String -> String -> Either String a
invalidKey Located String
key String
"is already assigned"
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 String (Maybe Frame)
go forall k a. Map k a
Map.empty
Just (FrameTable FrameKind
Open Map String Frame
t) -> Map String Frame -> Either String (Maybe Frame)
go Map String Frame
t
Just (FrameTable FrameKind
Dotted Map String Frame
t) -> Map String Frame -> Either String (Maybe Frame)
go Map String Frame
t
Just (FrameTable FrameKind
Closed Map String Frame
_) -> forall a. Located String -> String -> Either String a
invalidKey Located String
key String
"is a closed table"
Just (FrameArray NonEmpty (Map String Frame)
_) -> forall a. Located String -> String -> Either String a
invalidKey Located String
key String
"is a closed table"
Just (FrameValue Value
_) -> forall a. Located String -> String -> Either String a
invalidKey Located String
key String
"is already assigned"
where
go :: Map String Frame -> Either String (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 String (Map String Frame)
assign (Located String
k1 forall a. a -> [a] -> NonEmpty a
:| [Located String]
keys) Val
val Map String Frame
t
valToValue :: Val -> Either String Value
valToValue :: Val -> Either String 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 String 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 String Value
valToValue KeyVals
kvs
Table -> Value
Table forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Value)] -> Either String Table
constructTable [(Key, Value)]
entries
invalidKey :: Located String -> String -> Either String a
invalidKey :: forall a. Located String -> String -> Either String a
invalidKey Located String
k String
msg = forall a b. a -> Either a b
Left (forall r. PrintfType r => String -> r
printf String
"%d:%d: key error: %s %s"
(Position -> Int
posLine (forall a. Located a -> Position
locPosition Located String
k))
(Position -> Int
posColumn (forall a. Located a -> Position
locPosition Located String
k))
(forall a. Show a => a -> String
show (forall a. String -> Doc a
prettySimpleKey (forall a. Located a -> a
locThing Located String
k)))
String
msg)