Skip to content

Commit

Permalink
Attribute array-of-tables to first entry
Browse files Browse the repository at this point in the history
  • Loading branch information
@glguy
glguy committed Feb 16, 2024
1 parent bb020a0 commit 93802b2
Show file tree
Hide file tree
Showing 3 changed files with 148 additions and 116 deletions.
194 changes: 101 additions & 93 deletions src/Toml/Parser.y
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,105 +33,113 @@ import Toml.Position (startPos)

}

%tokentype { Located Token }
%tokentype { Located Token }
%token
',' { Located $$ TokComma }
'=' { Located $$ TokEquals }
NEWLINE { Located $$ TokNewline }
'.' { Located $$ TokPeriod }
'[' { Located $$ TokSquareO }
']' { Located $$ TokSquareC }
'[[' { Located $$ Tok2SquareO }
']]' { Located $$ Tok2SquareC }
'{' { Located $$ TokCurlyO }
'}' { Located $$ TokCurlyC }
BAREKEY { (traverse asBareKey -> Just $$) }
STRING { (traverse asString -> Just $$) }
MLSTRING { (traverse asMlString -> Just $$) }
BOOL { (traverse asBool -> Just $$) }
INTEGER { (traverse asInteger -> Just $$) }
FLOAT { (traverse asFloat -> Just $$) }
OFFSETDATETIME { (traverse asOffsetDateTime -> Just $$) }
LOCALDATETIME { (traverse asLocalDateTime -> Just $$) }
LOCALDATE { (traverse asLocalDate -> Just $$) }
LOCALTIME { (traverse asLocalTime -> Just $$) }

%monad { Parser r } { thenP } { pureP }
%lexer { lexerP } { Located _ TokEOF }
%error { errorP }
',' { Located $$ TokComma }
'=' { Located $$ TokEquals }
NEWLINE { Located $$ TokNewline }
'.' { Located $$ TokPeriod }
'[' { Located $$ TokSquareO }
']' { Located $$ TokSquareC }
'[[' { Located $$ Tok2SquareO }
']]' { Located $$ Tok2SquareC }
'{' { Located $$ TokCurlyO }
'}' { Located $$ TokCurlyC }
BAREKEY { (traverse asBareKey -> Just $$) }
STRING { (traverse asString -> Just $$) }
MLSTRING { (traverse asMlString -> Just $$) }
BOOL { (traverse asBool -> Just $$) }
INTEGER { (traverse asInteger -> Just $$) }
FLOAT { (traverse asFloat -> Just $$) }
OFFSETDATETIME { (traverse asOffsetDateTime -> Just $$) }
LOCALDATETIME { (traverse asLocalDateTime -> Just $$) }
LOCALDATE { (traverse asLocalDate -> Just $$) }
LOCALTIME { (traverse asLocalTime -> Just $$) }

%monad { Parser r } { thenP } { pureP }
%lexer { lexerP } { Located _ TokEOF }
%error { errorP }

%name parseRawToml_ toml

%%

toml :: { [Expr Position] }
: sepBy1(expression, NEWLINE) { concat $1 }

expression :: { [Expr Position] }
: { [] }
| keyval { [KeyValExpr (fst $1) (snd $1)] }
| '[' key ']' { [TableExpr $2 ] }
| '[[' key ']]' { [ArrayTableExpr $2 ] }

keyval :: { (Key Position, Val Position) }
: key rhs '=' pop val { ($1,$5) }

key :: { Key Position }
: sepBy1(simplekey, '.') { $1 }

simplekey :: { (Position, String) }
: BAREKEY { locVal (,) $1 }
| STRING { locVal (,) $1 }

val :: { Val Position }
: INTEGER { locVal ValInteger $1 }
| FLOAT { locVal ValFloat $1 }
| BOOL { locVal ValBool $1 }
| STRING { locVal ValString $1 }
| MLSTRING { locVal ValString $1 }
| LOCALDATE { locVal ValDay $1 }
| LOCALTIME { locVal ValTimeOfDay $1 }
| OFFSETDATETIME { locVal ValZonedTime $1 }
| LOCALDATETIME { locVal ValLocalTime $1 }
| array { locVal ValArray $1 }
| inlinetable { locVal ValTable $1 }

inlinetable :: { Located [(Key Position, Val Position)] }
: lhs '{' sepBy(keyval, ',') pop '}'
{ Located $2 $3 }

array :: { Located [Val Position] }
: rhs '[' newlines pop ']' { Located $2 [] }
| rhs '[' newlines arrayvalues pop ']' { Located $2 (reverse $4) }
| rhs '[' newlines arrayvalues ',' newlines pop ']' { Located $2 (reverse $4) }

arrayvalues :: { [Val Position] }
: val newlines { [$1] }
| arrayvalues ',' newlines val newlines { $4 : $1 }

newlines :: { () }
: { () }
| newlines NEWLINE{ () }

sepBy(p,q) :: { [p] }
: { [] }
| sepBy1(p,q) { NonEmpty.toList $1 }

sepBy1(p,q) :: { NonEmpty p }
: sepBy1_(p,q) { NonEmpty.reverse $1 }

sepBy1_(p,q) :: { NonEmpty p }
: p{ pure $1 }
| sepBy1_(p,q) q p{ NonEmpty.cons $3 $1 }

rhs :: { () }
: {% push ValueContext }

lhs :: { () }
: {% push TableContext }

pop :: { () }
: {% pop }
toml :: { [Expr Position] }
: sepBy1(expression, NEWLINE)
{ concat $1 }

expression :: { [Expr Position] }
: { [] }
| keyval { [uncurry KeyValExpr $1] }
| '[' key ']' { [TableExpr $2 ] }
| '[[' key ']]' { [ArrayTableExpr $2 ] }

keyval :: { (Key Position, Val Position) }
: key rhs '=' pop val
{ ($1,$5) }

key :: { Key Position }
: sepBy1(simplekey, '.')
{ $1 }

simplekey :: { (Position, String) }
: BAREKEY { locVal (,) $1 }
| STRING { locVal (,) $1 }

val :: { Val Position }
: INTEGER { locVal ValInteger $1 }
| FLOAT { locVal ValFloat $1 }
| BOOL { locVal ValBool $1 }
| STRING { locVal ValString $1 }
| MLSTRING { locVal ValString $1 }
| LOCALDATE { locVal ValDay $1 }
| LOCALTIME { locVal ValTimeOfDay $1 }
| OFFSETDATETIME { locVal ValZonedTime $1 }
| LOCALDATETIME { locVal ValLocalTime $1 }
| array { locVal ValArray $1 }
| inlinetable { locVal ValTable $1 }

inlinetable :: { Located [(Key Position, Val Position)] }
: lhs '{' sepBy(keyval, ',') pop '}'
{ Located $2 $3 }

array :: { Located [Val Position] }
: rhs '[' newlines pop ']'
{ Located $2 [] }
| rhs '[' newlines arrayvalues pop ']'
{ Located $2 (reverse $4) }
| rhs '[' newlines arrayvalues ',' newlines pop ']'
{ Located $2 (reverse $4) }

arrayvalues :: { [Val Position] }
: val newlines
{ [$1] }
| arrayvalues ',' newlines val newlines
{ $4 : $1 }

newlines :: { () }
: { () }
| newlines NEWLINE { () }

sepBy(p,q) :: { [p] }
: { [] }
| sepBy1(p,q) { NonEmpty.toList $1 }

sepBy1(p,q) :: { NonEmpty p }
: sepBy1_(p,q) { NonEmpty.reverse $1 }

sepBy1_(p,q) :: { NonEmpty p }
: p { pure $1 }
| sepBy1_(p,q) q p { NonEmpty.cons $3 $1 }

rhs :: { () }
: {% push ValueContext }

lhs :: { () }
: {% push TableContext }

pop :: { () }
: {% pop }

{

Expand Down
45 changes: 25 additions & 20 deletions src/Toml/Semantics.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,7 @@ module Toml.Semantics (SemanticError(..), SemanticErrorKind(..), semantics) wher

import Control.Monad (foldM)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map (Map)
import Data.Map qualified as Map
import Toml.Parser.Types (SectionKind(..), Key, Val(..), Expr(..))
Expand All @@ -26,7 +27,7 @@ import Toml.Value (Table'(MkTable), Value'(..))
--
-- @since 1.3.0.0
data SemanticError a = SemanticError {
errorAnn :: a,
errorAnn :: a, -- ^ Annotation associated with offending key
errorKey :: String,
errorKind :: SemanticErrorKind
} deriving (
Expand Down Expand Up @@ -97,29 +98,29 @@ data FrameKind
-- | Convert a top-level table "frame" representation into the plain Value
-- representation once the distinction is no longer needed.
framesToTable :: FrameTable a -> Table' a
framesToTable =
MkTable . fmap (fmap \case
FrameTable a _ t -> Table' a (framesToTable t)
FrameArray (t :| ts) -> Array' (fst t) (rev (map (\(a,fs) -> Table' a (framesToTable fs)) (t : ts)))
FrameValue v -> v)
where
rev = foldl (flip (:)) [] -- GHC fails to inline reverse
framesToTable = fmap MkTable $ fmap $ fmap
\case
FrameTable a _kind t -> Table' a (framesToTable t)
FrameArray (NonEmpty.reverse -> t :| ts) ->
-- the array itself is attributed to the first table defined
Array' (fst t) [Table' a (framesToTable x) | (a, x) <- t : ts]
FrameValue v -> v

-- | Attempts to insert the key-value pairs given into a new section
-- located at the given key-path in a frame map.
addSection ::
SectionKind {- ^ section kind -} ->
Key a {- ^ section key -} ->
SectionKind {- ^ section kind -} ->
Key a {- ^ section key -} ->
[(Key a, Val a)] {- ^ values to install -} ->
FrameTable a {- ^ local frame map -} ->
FrameTable a {- ^ local frame map -} ->
M a (FrameTable a) {- ^ error message or updated local frame table -}

addSection kind (k :| []) kvs =
alterFrame k
-- defining a new table
(case kind of
TableKind -> FrameTable (fst k) Closed <$> go mempty
ArrayTableKind -> FrameArray . (\x -> (fst k, x) :| []) <$> go mempty)
ArrayTableKind -> FrameArray . (:| []) . (,) (fst k) <$> go mempty)

\case
-- defining a super table of a previously defined subtable
Expand All @@ -133,12 +134,12 @@ addSection kind (k :| []) kvs =
FrameArray (t :| ts) ->
case kind of
TableKind -> invalidKey k ClosedTable
ArrayTableKind -> FrameArray . (\x -> (fst k, x) :| t : ts) <$> go mempty
ArrayTableKind -> FrameArray . (:| t : ts) . (,) (fst k) <$> go mempty

-- failure cases
FrameTable _ Closed _ -> invalidKey k ClosedTable
FrameTable _ Dotted _ -> error "addSection: dotted table left unclosed"
FrameValue {} -> invalidKey k AlreadyAssigned
FrameValue {} -> invalidKey k AlreadyAssigned
where
go = assignKeyVals kvs

Expand Down Expand Up @@ -185,8 +186,8 @@ assign (key :| k1 : keys) val =
FrameTable a Open t -> go a t
FrameTable a Dotted t -> go a t
FrameTable _ Closed _ -> invalidKey key ClosedTable
FrameArray _ -> invalidKey key ClosedTable
FrameValue _ -> invalidKey key AlreadyAssigned
FrameArray _ -> invalidKey key ClosedTable
FrameValue _ -> invalidKey key AlreadyAssigned
where
go a t = FrameTable a Dotted <$> assign (k1 :| keys) val t

Expand Down Expand Up @@ -215,14 +216,18 @@ invalidKey (a, key) kind = Left (SemanticError a key kind)

-- | Specialization of 'Map.alterF' used to adjust a location in a 'FrameTable'
alterFrame ::
(a, String) ->
M a (Frame a) ->
(Frame a -> M a (Frame a)) -> FrameTable a -> M a (FrameTable a)
(a, String) {- ^ annotated key -} ->
M a (Frame a) {- ^ new value case -} ->
(Frame a -> M a (Frame a)) {- ^ update value case -} ->
FrameTable a -> M a (FrameTable a)
alterFrame (a, k) create update = Map.alterF g k
where
-- insert a new value
g Nothing =
do lf <- create
pure (Just (a, lf))
g (Just (op,ov)) =

-- update an existing value and preserve its annotation
g (Just (op, ov)) =
do lf <- update ov
pure (Just (op, lf))
25 changes: 22 additions & 3 deletions src/Toml/Value.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,13 @@ This module provides the type for the semantics of a TOML file.
All dotted keys are resolved in this representation. Each table
is a Map with a single level of keys.
Values are parameterized over an annotation type to allow values
to be attributed to a file location. When values are constructed
programmatically, there might not be any interesting annotations.
In this case a trivial @()@ unit annotation can be used. The
'Value' type-synonym and related pattern synonyms can make using
this case more convenient.
-}
module Toml.Value (
-- * Unlocated value synonyms
Expand Down Expand Up @@ -78,6 +85,8 @@ pattern Day x <- Day' _ x
{-# Complete Array, Table, String, Bool, Integer, Float, Day, LocalTime, ZonedTime, TimeOfDay #-}

-- | Semantic TOML value with all table assignments resolved.
--
-- @since 2.0.0.0
data Value' a
= Integer' a Integer
| Float' a Double
Expand All @@ -94,6 +103,9 @@ data Value' a
Read {- ^ Default instance -},
Functor, Foldable, Traversable)

-- | Extract the top-level annotation from a value.
--
-- @since 2.0.0.0
valueAnn :: Value' a -> a
valueAnn = \case
Integer' a _ -> a
Expand All @@ -107,6 +119,9 @@ valueAnn = \case
LocalTime' a _ -> a
Day' a _ -> a

-- | String representation of the kind of value using TOML vocabulary
--
-- @since 2.0.0.0
valueType :: Value' l -> String
valueType = \case
Integer' {} -> "integer"
Expand All @@ -128,17 +143,21 @@ newtype Table' a = MkTable (Map String (a, Value' a))
instance Eq (Table' a) where
MkTable x == MkTable y = [(k,v) | (k, (_, v)) <- Map.assocs x] == [(k,v) | (k, (_, v)) <- Map.assocs y]

-- | A 'Table'' without annotations
-- | A 'Table'' with trivial annotations
type Table = Table' ()

-- | A 'Value'' without annotations
-- | A 'Value'' with trivial annotations
type Value = Value' ()

-- | Replaces annotations with a unit.
--
-- @since 2.0.0.0
forgetTableAnns :: Table' a -> Table
forgetTableAnns (MkTable t) = MkTable (fmap (\(_, v) -> ((), forgetValueAnns v)) t)

-- | Replaces annotations with a unit.
--
-- @since 2.0.0.0
forgetValueAnns :: Value' a -> Value
forgetValueAnns =
\case
Expand Down Expand Up @@ -182,5 +201,5 @@ projectZT x = (zonedTimeToLocalTime x, timeZoneMinutes (zonedTimeZone x))
-- @
--
-- @since 1.3.3.0
instance IsString Value where
instance () ~ a => IsString (Value' a) where
fromString = String' ()

0 comments on commit 93802b2

Please sign in to comment.