Skip to content

Commit 1771cd1

Browse files
gmorphemegmorpheme
authored
YAML tags on non-scalars (#114)
* Force render meta for non-scalars too * Add render metadata to seq and mapping events * Turn on tags for seqs and mappings
1 parent a3bda00 commit 1771cd1

File tree

11 files changed

+98
-68
lines changed

11 files changed

+98
-68
lines changed

‎src/Eucalypt/Render/Json.hs

+8-8
Original file line numberDiff line numberDiff line change
@@ -71,15 +71,15 @@ putScalar e txt = do
7171
putText $
7272
case pre of
7373
Nothing -> txt
74-
Just E.OutputSequenceStart -> txt
74+
Just (E.OutputSequenceStart _) -> txt
7575
_ -> BS.concat [", ", txt]
7676
InObject -> do
7777
pre <- getLast
7878
pushContext InPair
7979
putText $
8080
case pre of
8181
Nothing -> txt
82-
Just E.OutputMappingStart -> txt
82+
Just (E.OutputMappingStart _) -> txt
8383
_ -> BS.concat [", ", txt]
8484
setLast e
8585

@@ -102,7 +102,7 @@ formatScalar (NativeDynamic _) = jsonStr "**#DYN**"
102102

103103

104104
putBSFragment :: MonadState JSONFormatState m => E.Event -> m ()
105-
putBSFragment e@E.OutputSequenceStart = do
105+
putBSFragment e@E.OutputSequenceStart {} = do
106106
c <- currentContext
107107
case c of
108108
InPair -> do
@@ -113,21 +113,21 @@ putBSFragment [email protected] = do
113113
putText $
114114
case pre of
115115
Nothing -> "["
116-
Just E.OutputSequenceStart -> "["
116+
Just E.OutputSequenceStart {} -> "["
117117
_ -> ", ["
118118
InObject -> do
119119
pre <- getLast
120120
putText $
121121
case pre of
122122
Nothing -> "["
123-
Just E.OutputMappingStart -> "["
123+
Just E.OutputMappingStart {} -> "["
124124
_ -> ", ["
125125
setLast e
126126
pushContext InArray
127127

128128
putBSFragment e@E.OutputSequenceEnd = setLast e >> popContext >> putText "]"
129129

130-
putBSFragment e@E.OutputMappingStart = do
130+
putBSFragment e@E.OutputMappingStart {} = do
131131
c <- currentContext
132132
case c of
133133
InPair -> do
@@ -138,14 +138,14 @@ putBSFragment [email protected] = do
138138
putText $
139139
case pre of
140140
Nothing -> "{"
141-
Just E.OutputSequenceStart -> "{"
141+
Just E.OutputSequenceStart {} -> "{"
142142
_ -> ", {"
143143
InObject -> do
144144
pre <- getLast
145145
putText $
146146
case pre of
147147
Nothing -> "{"
148-
Just E.OutputMappingStart -> "{"
148+
Just E.OutputMappingStart {} -> "{"
149149
_ -> ", {"
150150
setLast e
151151
pushContext InObject

‎src/Eucalypt/Render/Yaml.hs

+30-7
Original file line numberDiff line numberDiff line change
@@ -39,10 +39,27 @@ style RenderMetadata {metaTag = _} _ = L.Plain
3939
renderValue :: Native -> E.RenderMetadata -> [L.Event]
4040
renderValue (NativeNumber n) rm =
4141
case floatingOrInteger n of
42-
Left r -> [L.EventScalar (encodeUtf8 $ pack $ show r) (tag rm L.FloatTag) (style rm L.PlainNoTag) Nothing]
43-
Right i -> [L.EventScalar (encodeUtf8 $ pack $ show i) (tag rm L.IntTag) (style rm L.PlainNoTag) Nothing]
42+
Left r ->
43+
[ L.EventScalar
44+
(encodeUtf8 $ pack $ show r)
45+
(tag rm L.FloatTag)
46+
(style rm L.PlainNoTag)
47+
Nothing
48+
]
49+
Right i ->
50+
[ L.EventScalar
51+
(encodeUtf8 $ pack $ show i)
52+
(tag rm L.IntTag)
53+
(style rm L.PlainNoTag)
54+
Nothing
55+
]
4456
renderValue (NativeSymbol s) rm =
45-
[L.EventScalar (encodeUtf8 $ pack $ unintern s) (tag rm L.StrTag) (style rm L.PlainNoTag) Nothing]
57+
[ L.EventScalar
58+
(encodeUtf8 $ pack $ unintern s)
59+
(tag rm L.StrTag)
60+
(style rm L.PlainNoTag)
61+
Nothing
62+
]
4663
renderValue (NativeString s) rm =
4764
[L.EventScalar (encodeUtf8 $ pack s) (tag rm L.NoTag) (textStyle s) Nothing]
4865
where
@@ -75,14 +92,20 @@ toYamlEvents e =
7592
E.OutputDocumentStart -> [L.EventDocumentStart]
7693
E.OutputDocumentEnd -> [L.EventDocumentEnd]
7794
E.OutputScalar rm n -> renderValue n rm
78-
E.OutputNull -> [L.EventScalar (encodeUtf8 $ pack "null") L.NullTag L.PlainNoTag Nothing]
95+
E.OutputNull ->
96+
[L.EventScalar (encodeUtf8 $ pack "null") L.NullTag L.PlainNoTag Nothing]
7997
E.OutputTrue -> renderBool True
8098
E.OutputFalse -> renderBool False
81-
E.OutputSequenceStart -> [L.EventSequenceStart L.NoTag L.AnySequence Nothing]
99+
E.OutputSequenceStart rm ->
100+
[L.EventSequenceStart (tag rm L.NoTag) L.AnySequence Nothing]
82101
E.OutputSequenceEnd -> [L.EventSequenceEnd]
83-
E.OutputMappingStart -> [L.EventMappingStart L.NoTag L.AnyMapping Nothing]
102+
E.OutputMappingStart rm ->
103+
[L.EventMappingStart (tag rm L.NoTag) L.AnyMapping Nothing]
84104
E.OutputMappingEnd -> [L.EventMappingEnd]
85105
_ -> []
86106

107+
renderOptions :: L.FormatOptions
108+
renderOptions = L.setTagRendering L.renderUriTags L.defaultFormatOptions
109+
87110
pipeline :: (MonadIO m, MonadResource m) => ConduitT E.Event Void m BS.ByteString
88-
pipeline = mapC toYamlEvents .| C.concat .| L.encode
111+
pipeline = mapC toYamlEvents .| C.concat .| L.encodeWith renderOptions

‎src/Eucalypt/Stg/Event.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -33,9 +33,9 @@ data Event
3333
| OutputNull
3434
| OutputTrue
3535
| OutputFalse
36-
| OutputSequenceStart
36+
| OutputSequenceStart RenderMetadata
3737
| OutputSequenceEnd
38-
| OutputMappingStart
38+
| OutputMappingStart RenderMetadata
3939
| OutputMappingEnd
4040
| OutputAlias
4141
| DebugTrace !BS.ByteString

‎src/Eucalypt/Stg/Globals/Emit.hs

+19-16
Original file line numberDiff line numberDiff line change
@@ -40,14 +40,16 @@ panic msg = appfn_ (gref "PANIC") [V $ NativeString msg]
4040
euNull :: LambdaForm
4141
euNull = standardConstructor 0 stgUnit
4242

43-
emitMS :: StgSyn
44-
emitMS = appbif_ (intrinsicIndex "EMIT{") []
43+
-- | Emit mapping start using specified metadata
44+
emitMS :: Ref -> StgSyn
45+
emitMS m = appbif_ (intrinsicIndex "EMIT{") [m]
4546

4647
emitME :: StgSyn
4748
emitME = appbif_ (intrinsicIndex "EMIT}") []
4849

49-
emitSS :: StgSyn
50-
emitSS = appbif_ (intrinsicIndex "EMIT[") []
50+
-- | Emit sequence start using specified metadata
51+
emitSS :: Ref -> StgSyn
52+
emitSS m = appbif_ (intrinsicIndex "EMIT[") [m]
5153

5254
emitSE :: StgSyn
5355
emitSE = appbif_ (intrinsicIndex "EMIT]") []
@@ -149,10 +151,8 @@ startList =
149151
lam_ 0 2 $
150152
ann_ "Emit.startList" 0 $
151153
force_
152-
emitSS
153-
(force_
154-
(appfn_ (gref "RENDER") [L 0])
155-
(appfn_ (gref "Emit.continueList") [L 1]))
154+
(appfn_ (gref "RENDER") [L 0])
155+
(appfn_ (gref "Emit.continueList") [L 1])
156156

157157
-- | __Emit.continueKVList(l)
158158
continueKVList :: LambdaForm
@@ -173,24 +173,27 @@ euRender :: LambdaForm
173173
euRender =
174174
lam_ 0 1 $
175175
ann_ "__RENDER" 0 $
176+
force_ (appfn_ (gref "META") [L 0]) $
177+
force_ (appfn_ (gref "Emit.forceExportMetadata") [L 1]) $
176178
casedef_
177179
(Atom (L 0))
178180
[ ( stgBlock
179181
, ( 1
180-
, force_ (appfn_ (gref "ALIST.PRUNE") [L 1]) $
181-
forceall_ [emitMS, appfn_ (gref "Emit.continueKVList") [L 2], emitME]))
182-
, (stgCons, (2, appfn_ (gref "Emit.startList") [L 1, L 2]))
183-
, (stgNil, (0, force_ emitSS emitSE))
182+
, force_ (appfn_ (gref "ALIST.PRUNE") [L 3]) $
183+
forceall_
184+
[emitMS (L 1), appfn_ (gref "Emit.continueKVList") [L 4], emitME]))
185+
, ( stgCons
186+
, (2, force_ (emitSS (L 1)) $ appfn_ (gref "Emit.startList") [L 3, L 4]))
187+
, (stgNil, (0, force_ (emitSS (L 1)) emitSE))
184188
, (stgUnit, (0, emitNull))
185189
, (stgTrue, (0, emitTrue))
186190
, (stgFalse, (0, emitFalse))
187191
, ( stgIOSMBlock
188192
, ( 1
189-
, force_ (appfn_ (gref "IOSM.LIST") [L 1]) $
190-
forceall_ [emitMS, appfn_ (gref "Emit.continueKVList") [L 2], emitME]))
193+
, force_ (appfn_ (gref "IOSM.LIST") [L 3]) $
194+
forceall_ [emitMS (L 1), appfn_ (gref "Emit.continueKVList") [L 4], emitME]))
191195
] $
192-
force_ (appfn_ (gref "META") [L 1]) $
193-
force_ (appfn_ (gref "Emit.forceExportMetadata") [L 2]) $ emitScalar (L 1)
196+
emitScalar (L 3)
194197

195198

196199
-- | Single argument is the metadata (not the annotated value)

‎src/Eucalypt/Stg/Intrinsics/Emit.hs

+19-16
Original file line numberDiff line numberDiff line change
@@ -29,9 +29,9 @@ import Eucalypt.Stg.Value
2929

3030
intrinsics :: [IntrinsicInfo]
3131
intrinsics =
32-
[ IntrinsicInfo "EMIT{" 0 emitMappingStart
32+
[ IntrinsicInfo "EMIT{" 0 (invoke emitMappingStart)
3333
, IntrinsicInfo "EMIT}" 0 emitMappingEnd
34-
, IntrinsicInfo "EMIT[" 0 emitSequenceStart
34+
, IntrinsicInfo "EMIT[" 0 (invoke emitSequenceStart)
3535
, IntrinsicInfo "EMIT]" 0 emitSequenceEnd
3636
, IntrinsicInfo "EMITx" 1 (invoke emitScalar)
3737
, IntrinsicInfo "EMIT0" 0 emitNull
@@ -48,37 +48,40 @@ emit s@MachineState {machineEmitHook = hook} e = do
4848
Nothing -> return s
4949
return $ (appendEvent e . setCode s') (ReturnCon stgUnit mempty Nothing)
5050

51-
emitMappingStart :: MachineState -> ValVec -> IO MachineState
52-
emitMappingStart s _ = emit s OutputMappingStart
51+
-- | Emit a mapping start, using 'v' to detemine render metadata.
52+
emitMappingStart :: MachineState -> StgValue -> IO MachineState
53+
emitMappingStart ms v = renderMeta ms v >>= emit ms . OutputMappingStart
5354

5455
emitMappingEnd :: MachineState -> ValVec -> IO MachineState
55-
emitMappingEnd s _ = emit s OutputMappingEnd
56+
emitMappingEnd ms _ = emit ms OutputMappingEnd
5657

57-
emitSequenceStart :: MachineState -> ValVec -> IO MachineState
58-
emitSequenceStart s _ = emit s OutputSequenceStart
58+
-- | Emit a sequence start, using 'v' to detemine render metadata.
59+
emitSequenceStart :: MachineState -> StgValue -> IO MachineState
60+
emitSequenceStart ms v = renderMeta ms v >>= emit ms . OutputSequenceStart
5961

6062
emitSequenceEnd :: MachineState -> ValVec -> IO MachineState
61-
emitSequenceEnd s _ = emit s OutputSequenceEnd
63+
emitSequenceEnd ms _ = emit ms OutputSequenceEnd
6264

6365
emitNull :: MachineState -> ValVec -> IO MachineState
64-
emitNull s _ = emit s OutputNull
66+
emitNull ms _ = emit ms OutputNull
6567

6668
emitTrue :: MachineState -> ValVec -> IO MachineState
67-
emitTrue s _ = emit s OutputTrue
69+
emitTrue ms _ = emit ms OutputTrue
6870

6971
emitFalse :: MachineState -> ValVec -> IO MachineState
70-
emitFalse s _ = emit s OutputFalse
72+
emitFalse ms _ = emit ms OutputFalse
7173

7274
-- | This assumes that all render-relevant metadata has been forced to
7375
-- native values.
7476
emitScalar :: MachineState -> StgValue -> IO MachineState
75-
emitScalar s x =
77+
emitScalar ms x =
7678
case x of
7779
(StgNat n m) -> do
78-
event <- case m of
79-
Just meta -> flip OutputScalar n <$> renderMeta s meta
80-
Nothing -> return $ OutputScalar (RenderMetadata Nothing) n
81-
(`setCode` ReturnLit n Nothing) <$> emit s event
80+
event <-
81+
case m of
82+
Just meta -> flip OutputScalar n <$> renderMeta ms meta
83+
Nothing -> return $ OutputScalar (RenderMetadata Nothing) n
84+
(`setCode` ReturnLit n Nothing) <$> emit ms event
8285
(StgAddr _) -> error "Received address in emitScalar"
8386

8487
getValue :: MachineState -> Address -> Symbol -> IO (Maybe StgValue)

‎stack.yaml

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
resolver: lts-13.7
1+
resolver: lts-13.9
22
packages:
33
- '.'
44
ghc-options:

‎test/Eucalypt/Render/JsonSpec.hs

+4-4
Original file line numberDiff line numberDiff line change
@@ -27,11 +27,11 @@ main = hspec spec
2727

2828
test1 :: [E.Event]
2929
test1 =
30-
[ E.OutputMappingStart
30+
[ E.OutputMappingStart (E.RenderMetadata Nothing)
3131
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeSymbol "a"
3232
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeNumber 1234
3333
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeSymbol "b"
34-
, E.OutputSequenceStart
34+
, E.OutputSequenceStart (E.RenderMetadata Nothing)
3535
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeString "x"
3636
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeString "y"
3737
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeString "z"
@@ -41,13 +41,13 @@ test1 =
4141

4242
test2 :: [E.Event]
4343
test2 =
44-
[E.OutputSequenceStart] <>
44+
[E.OutputSequenceStart (E.RenderMetadata Nothing)] <>
4545
map (E.OutputScalar (E.RenderMetadata Nothing) . NativeNumber . fromInteger) [1 .. 7] <>
4646
[E.OutputSequenceEnd]
4747

4848
testNull :: [E.Event]
4949
testNull =
50-
[ E.OutputMappingStart
50+
[ E.OutputMappingStart (E.RenderMetadata Nothing)
5151
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeSymbol "a"
5252
, E.OutputNull
5353
, E.OutputMappingEnd

‎test/Eucalypt/Render/TextSpec.hs

+4-4
Original file line numberDiff line numberDiff line change
@@ -24,11 +24,11 @@ main = hspec spec
2424

2525
test1 :: [E.Event]
2626
test1 =
27-
[ E.OutputMappingStart
27+
[ E.OutputMappingStart (E.RenderMetadata Nothing)
2828
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeSymbol "a"
2929
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeNumber 1234
3030
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeSymbol "b"
31-
, E.OutputSequenceStart
31+
, E.OutputSequenceStart (E.RenderMetadata Nothing)
3232
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeString "x"
3333
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeString "y"
3434
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeString "z"
@@ -38,13 +38,13 @@ test1 =
3838

3939
test2 :: [E.Event]
4040
test2 =
41-
[E.OutputSequenceStart] <>
41+
[E.OutputSequenceStart (E.RenderMetadata Nothing)] <>
4242
map (E.OutputScalar (E.RenderMetadata Nothing) . NativeNumber . fromInteger) [1 .. 7] <>
4343
[E.OutputSequenceEnd]
4444

4545
testNull :: [E.Event]
4646
testNull =
47-
[ E.OutputMappingStart
47+
[ E.OutputMappingStart (E.RenderMetadata Nothing)
4848
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeSymbol "a"
4949
, E.OutputNull
5050
, E.OutputMappingEnd

‎test/Eucalypt/Render/YamlSpec.hs

+4-4
Original file line numberDiff line numberDiff line change
@@ -24,11 +24,11 @@ main = hspec spec
2424

2525
test1 :: [E.Event]
2626
test1 =
27-
[ E.OutputMappingStart
27+
[ E.OutputMappingStart (E.RenderMetadata Nothing)
2828
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeSymbol "a"
2929
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeNumber 1234
3030
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeSymbol "b"
31-
, E.OutputSequenceStart
31+
, E.OutputSequenceStart (E.RenderMetadata Nothing)
3232
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeString "x"
3333
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeString "y"
3434
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeString "z"
@@ -38,13 +38,13 @@ test1 =
3838

3939
test2 :: [E.Event]
4040
test2 =
41-
[E.OutputSequenceStart] <>
41+
[E.OutputSequenceStart (E.RenderMetadata Nothing)] <>
4242
map (E.OutputScalar (E.RenderMetadata Nothing) . NativeNumber . fromInteger) [1 .. 7] <>
4343
[E.OutputSequenceEnd]
4444

4545
testNull :: [E.Event]
4646
testNull =
47-
[ E.OutputMappingStart
47+
[ E.OutputMappingStart (E.RenderMetadata Nothing)
4848
, E.OutputScalar (E.RenderMetadata Nothing) $ NativeSymbol "a"
4949
, E.OutputNull
5050
, E.OutputMappingEnd

‎test/Eucalypt/Stg/EvalSpec.hs

+3-2
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,7 @@ addTest =
5454
renderEmptyMap :: StgSyn
5555
renderEmptyMap = force_ emitMS emitME
5656
where
57-
emitMS = appbif_ (intrinsicIndex "EMIT{") []
57+
emitMS = appbif_ (intrinsicIndex "EMIT{") [gref "KEMPTYBLOCK"]
5858
emitME = appbif_ (intrinsicIndex "EMIT}") []
5959

6060

@@ -70,7 +70,8 @@ blockSpec =
7070
it "returns true" $
7171
(returnsConstructor stgTrue <$> test addTest) `shouldReturn` True
7272
it "emits empty map" $
73-
(emits [OutputMappingStart, OutputMappingEnd] <$> test renderEmptyMap) `shouldReturn`
73+
(emits [OutputMappingStart (RenderMetadata Nothing), OutputMappingEnd] <$>
74+
test renderEmptyMap) `shouldReturn`
7475
True
7576

7677
evalMetadata :: StgSyn

0 commit comments

Comments
 (0)