{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use section" #-}
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(..))
data SemanticError = SemanticError {
SemanticError -> String
errorKey :: String,
SemanticError -> SemanticErrorKind
errorKind :: SemanticErrorKind
} deriving (
Read ,
Show ,
Eq ,
Ord )
data SemanticErrorKind
= AlreadyAssigned
| ClosedTable
| ImplicitlyTable
deriving (
Read ,
Show ,
Eq ,
Ord )
semantics :: [Expr] -> Either (Located SemanticError) Table
semantics :: [Expr] -> Either (Located SemanticError) Table
semantics [Expr]
exprs =
do [(Key, Val)] -> M FrameTable
f <- (([(Key, Val)] -> M FrameTable)
-> Expr
-> Either (Located SemanticError) ([(Key, Val)] -> M FrameTable))
-> ([(Key, Val)] -> M FrameTable)
-> [Expr]
-> Either (Located SemanticError) ([(Key, Val)] -> M FrameTable)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(Key, Val)] -> M FrameTable)
-> Expr
-> Either (Located SemanticError) ([(Key, Val)] -> M FrameTable)
processExpr (([(Key, Val)] -> FrameTable -> M FrameTable)
-> FrameTable -> [(Key, Val)] -> M FrameTable
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(Key, Val)] -> FrameTable -> M FrameTable
assignKeyVals FrameTable
forall k a. Map k a
Map.empty) [Expr]
exprs
FrameTable -> Table
framesToTable (FrameTable -> Table)
-> M FrameTable -> Either (Located SemanticError) Table
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Val)] -> M FrameTable
f []
where
processExpr :: ([(Key, Val)] -> M FrameTable)
-> Expr
-> Either (Located SemanticError) ([(Key, Val)] -> M FrameTable)
processExpr [(Key, Val)] -> M FrameTable
f = \case
KeyValExpr Key
k Val
v -> ([(Key, Val)] -> M FrameTable)
-> Either (Located SemanticError) ([(Key, Val)] -> M FrameTable)
forall a b. b -> Either a b
Right ([(Key, Val)] -> M FrameTable
f ([(Key, Val)] -> M FrameTable)
-> ([(Key, Val)] -> [(Key, Val)]) -> [(Key, Val)] -> M 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)] -> M FrameTable)
processSection SectionKind
TableKind Key
k
ArrayTableExpr Key
k -> SectionKind
-> Key
-> Either (Located SemanticError) ([(Key, Val)] -> M FrameTable)
processSection SectionKind
ArrayTableKind Key
k
where
processSection :: SectionKind
-> Key
-> Either (Located SemanticError) ([(Key, Val)] -> M FrameTable)
processSection SectionKind
kind Key
k = ([(Key, Val)] -> FrameTable -> M FrameTable)
-> FrameTable -> [(Key, Val)] -> M FrameTable
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SectionKind -> Key -> [(Key, Val)] -> FrameTable -> M FrameTable
addSection SectionKind
kind Key
k) (FrameTable -> [(Key, Val)] -> M FrameTable)
-> M FrameTable
-> Either (Located SemanticError) ([(Key, Val)] -> M FrameTable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Val)] -> M FrameTable
f []
type FrameTable = Map String Frame
type M = Either (Located SemanticError)
data Frame
= FrameTable FrameKind FrameTable
| FrameArray (NonEmpty FrameTable)
| 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
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
(Int -> FrameKind -> ShowS)
-> (FrameKind -> String)
-> ([FrameKind] -> ShowS)
-> Show FrameKind
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 :: FrameTable -> Table
framesToTable :: FrameTable -> Table
framesToTable =
(Frame -> Value) -> FrameTable -> Table
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 (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 (:)) []
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
addSection ::
SectionKind ->
Key ->
[(Key, Val)] ->
FrameTable ->
M FrameTable
addSection :: SectionKind -> Key -> [(Key, Val)] -> FrameTable -> M FrameTable
addSection SectionKind
kind (Located String
k :| []) [(Key, Val)]
kvs =
Located String
-> (Maybe Frame -> M Frame) -> FrameTable -> M FrameTable
alterFrame Located String
k \case
Maybe Frame
Nothing ->
case SectionKind
kind of
SectionKind
TableKind -> FrameKind -> FrameTable -> Frame
FrameTable FrameKind
Closed (FrameTable -> Frame) -> M FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> M 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) -> M FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> M FrameTable
go FrameTable
forall a. Monoid a => a
mempty
Just (FrameTable FrameKind
Open FrameTable
t) ->
case SectionKind
kind of
SectionKind
TableKind -> FrameKind -> FrameTable -> Frame
FrameTable FrameKind
Closed (FrameTable -> Frame) -> M FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> M FrameTable
go FrameTable
t
SectionKind
ArrayTableKind -> Located String -> SemanticErrorKind -> M Frame
forall a. Located String -> SemanticErrorKind -> M a
invalidKey Located String
k SemanticErrorKind
ImplicitlyTable
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) -> M FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> M FrameTable
go FrameTable
forall a. Monoid a => a
mempty
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 -> M FrameTable
go = [(Key, Val)] -> FrameTable -> M 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 -> M FrameTable
alterFrame Located String
k1 \case
Maybe Frame
Nothing -> FrameKind -> FrameTable -> Frame
FrameTable FrameKind
Open (FrameTable -> Frame) -> M FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> M FrameTable
go FrameTable
forall a. Monoid a => a
mempty
Just (FrameTable FrameKind
tk FrameTable
t) -> FrameKind -> FrameTable -> Frame
FrameTable FrameKind
tk (FrameTable -> Frame) -> M FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> M 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) -> M FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTable -> M 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 -> M FrameTable
go = SectionKind -> Key -> [(Key, Val)] -> FrameTable -> M FrameTable
addSection SectionKind
kind (Located String
k2 Located String -> [Located String] -> Key
forall a. a -> [a] -> NonEmpty a
:| [Located String]
ks) [(Key, Val)]
kvs
closeDots :: FrameTable -> FrameTable
closeDots :: FrameTable -> FrameTable
closeDots =
(Frame -> Frame) -> FrameTable -> FrameTable
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
assignKeyVals :: [(Key, Val)] -> FrameTable -> M FrameTable
assignKeyVals :: [(Key, Val)] -> FrameTable -> M FrameTable
assignKeyVals [(Key, Val)]
kvs FrameTable
t = FrameTable -> FrameTable
closeDots (FrameTable -> FrameTable) -> M FrameTable -> M FrameTable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FrameTable -> (Key, Val) -> M FrameTable)
-> FrameTable -> [(Key, Val)] -> M FrameTable
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM FrameTable -> (Key, Val) -> M FrameTable
f FrameTable
t [(Key, Val)]
kvs
where
f :: FrameTable -> (Key, Val) -> M FrameTable
f FrameTable
m (Key
k,Val
v) = Key -> Val -> FrameTable -> M FrameTable
assign Key
k Val
v FrameTable
m
assign :: Key -> Val -> FrameTable -> M FrameTable
assign :: Key -> Val -> FrameTable -> M FrameTable
assign (Located String
key :| []) Val
val =
Located String
-> (Maybe Frame -> M Frame) -> FrameTable -> M 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 -> M 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) -> M FrameTable -> M Frame
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Val -> FrameTable -> M FrameTable
assign (Located String
k1 Located String -> [Located String] -> Key
forall a. a -> [a] -> NonEmpty a
:| [Located String]
keys) Val
val FrameTable
t
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)
traverse Val -> Either (Located SemanticError) Value
valToValue [Val]
xs
ValTable [(Key, Val)]
kvs -> FrameTable -> Value
framesToValue (FrameTable -> Value)
-> M FrameTable -> Either (Located SemanticError) Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Val)] -> FrameTable -> M FrameTable
assignKeyVals [(Key, Val)]
kvs FrameTable
forall a. Monoid a => a
mempty
invalidKey ::
Located String ->
SemanticErrorKind ->
M a
invalidKey :: Located String -> SemanticErrorKind -> M a
invalidKey Located String
key SemanticErrorKind
kind = Located SemanticError -> M 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)
alterFrame :: Located String -> (Maybe Frame -> M Frame) -> FrameTable -> M FrameTable
alterFrame :: Located String
-> (Maybe Frame -> M Frame) -> FrameTable -> M FrameTable
alterFrame Located String
k Maybe Frame -> M Frame
f = (Maybe Frame -> Either (Located SemanticError) (Maybe Frame))
-> String -> FrameTable -> M 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 (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)