Allow YAML tags to be specified / captured via metadata (#77)

* Scalar event to carry emit metadata

* Extend branch table to accept metadata

* Initial globals for forcing render meta

* WIP: globals to eval render meta and pass to emit

* Now outputs tags from metadata.

* Preserve metadata on natives through compilation

Author: gmorpheme

src/Eucalypt/Render/Json.hs

@@ -161,7 +161,7 @@ putBSFragment e@E.OutputMappingStart = do
   pushContext InObject
 
 putBSFragment e@E.OutputMappingEnd = setLast e >> popContext >> putText "}"
-putBSFragment e@(E.OutputScalar n) = putScalar e (formatScalar n)
+putBSFragment e@(E.OutputScalar _ n) = putScalar e (formatScalar n)
 putBSFragment e@E.OutputNull = putScalar e "null"
 putBSFragment _ = putText ""
 

src/Eucalypt/Render/Text.hs

@@ -45,7 +45,7 @@ formatScalar (NativeDict d) =
 
 
 toFragment :: E.Event -> Maybe Builder
-toFragment (E.OutputScalar n) = Just $ formatScalar n
+toFragment (E.OutputScalar _ n) = Just $ formatScalar n
 toFragment _ = Nothing
 
 pipeline :: Monad m => ConduitT E.Event Void m BS.ByteString

src/Eucalypt/Render/Yaml.hs

@@ -23,44 +23,56 @@ import Data.Text (pack)
 import Data.Text.Encoding (encodeUtf8)
 import qualified Text.Libyaml as L
 
+import Eucalypt.Stg.Event (RenderMetadata(..))
 import qualified Eucalypt.Stg.Event as E
 import Eucalypt.Stg.Syn (Native(..))
 
--- STG implementation
+tag :: RenderMetadata -> L.Tag -> L.Tag
+tag RenderMetadata {metaTag = Nothing} def = def
+tag RenderMetadata {metaTag = (Just t)} _ = L.UriTag t
 
-renderValue :: Native -> [L.Event]
-renderValue (NativeNumber n) =
+style :: RenderMetadata -> L.Style -> L.Style
+style RenderMetadata {metaTag = Nothing} def = def
+style RenderMetadata {metaTag = _} _ = L.Plain
+
+-- | Render a native value as a YAML scalar
+renderValue :: Native -> E.RenderMetadata -> [L.Event]
+renderValue (NativeNumber n) rm =
   case floatingOrInteger n of
-    Left r -> [L.EventScalar (encodeUtf8 $ pack $ show r) L.FloatTag L.PlainNoTag Nothing]
-    Right i -> [L.EventScalar (encodeUtf8 $ pack $ show i) L.IntTag L.PlainNoTag Nothing]
-renderValue (NativeSymbol s) =
-  [L.EventScalar (encodeUtf8 $ pack s) L.StrTag L.PlainNoTag Nothing]
-renderValue (NativeString s) =
-  [L.EventScalar (encodeUtf8 $ pack s) L.NoTag (style s) Nothing]
+    Left r -> [L.EventScalar (encodeUtf8 $ pack $ show r) (tag rm L.FloatTag) (style rm L.PlainNoTag) Nothing]
+    Right i -> [L.EventScalar (encodeUtf8 $ pack $ show i) (tag rm L.IntTag) (style rm L.PlainNoTag) Nothing]
+renderValue (NativeSymbol s) rm =
+  [L.EventScalar (encodeUtf8 $ pack s) (tag rm L.StrTag) (style rm L.PlainNoTag) Nothing]
+renderValue (NativeString s) rm =
+  [L.EventScalar (encodeUtf8 $ pack s) (tag rm L.NoTag) (textStyle s) Nothing]
   where
-    style "" = L.DoubleQuoted
-    style "*" = L.DoubleQuoted
-    style "/" = L.DoubleQuoted
-    style str | length str > 60 = L.Literal
-    style _ = L.PlainNoTag
-renderValue (NativeBool b) =
+    textStyle "" = L.DoubleQuoted
+    textStyle "*" = L.DoubleQuoted
+    textStyle "/" = L.DoubleQuoted
+    textStyle str
+      | length str > 60 = L.Literal
+    textStyle _ = style rm L.PlainNoTag
+renderValue (NativeBool b) rm =
   [L.EventScalar
     (encodeUtf8 $
      pack $
      if b
        then "true"
        else "false")
-    L.BoolTag
-    L.PlainNoTag
+    (tag rm L.BoolTag)
+    (style rm L.PlainNoTag)
     Nothing]
-renderValue (NativeSet s) =
+renderValue (NativeSet s) _ =
   [L.EventSequenceStart Nothing] ++
-  concatMap renderValue (toList s) ++ [L.EventSequenceEnd]
-renderValue (NativeDict d) =
+  concatMap (`renderValue` RenderMetadata {metaTag = Nothing}) (toList s) ++
+  [L.EventSequenceEnd]
+renderValue (NativeDict d) _ =
   [L.EventMappingStart Nothing] ++
   concatMap kv (MS.assocs d) ++ [L.EventMappingEnd]
   where
-    kv (k, v) = renderValue k ++ renderValue v
+    kv (k, v) =
+      renderValue k RenderMetadata {metaTag = Nothing} ++
+      renderValue v RenderMetadata {metaTag = Nothing}
 
 toYamlEvents :: E.Event -> [L.Event]
 toYamlEvents e =
@@ -69,7 +81,7 @@ toYamlEvents e =
     E.OutputStreamEnd -> [L.EventStreamEnd]
     E.OutputDocumentStart -> [L.EventDocumentStart]
     E.OutputDocumentEnd -> [L.EventDocumentEnd]
-    E.OutputScalar n -> renderValue n
+    E.OutputScalar rm n -> renderValue n rm
     E.OutputNull -> [L.EventScalar (encodeUtf8 $ pack "null") L.NullTag L.PlainNoTag Nothing]
     E.OutputSequenceStart -> [L.EventSequenceStart Nothing]
     E.OutputSequenceEnd -> [L.EventSequenceEnd]

src/Eucalypt/Source/YamlSource.hs

@@ -112,6 +112,9 @@ expressionFromString s =
     Left err -> throwM err
     Right expr -> return $ desugar expr
 
+tagMeta :: String -> CoreExpr
+tagMeta tag = anon S.block [anon element "tag" $ anon S.str tag]
+
 -- | Active translation scheme
 --
 -- @!eu@ tag causes expression parse, blocks become let expressions.
@@ -126,7 +129,7 @@ instance YamlTranslator ActiveTranslator where
       UriTag u ->
         if u == "!eu"
           then expressionFromString s
-          else return $ anon S.str s
+          else return $ anon S.withMeta (tagMeta u) $ anon S.str s
       _ -> return $ anon S.str s
     where
       s = (unpack . decodeUtf8) text

src/Eucalypt/Stg/Compiler.hs

@@ -23,6 +23,7 @@ import qualified Data.Vector as V
 import Eucalypt.Core.Syn as C
 import Eucalypt.Stg.GlobalInfo
 import Eucalypt.Stg.Globals
+import Eucalypt.Stg.Intrinsics (intrinsicIndex)
 import Eucalypt.Stg.Syn
 import Eucalypt.Stg.Tags
 
@@ -120,9 +121,16 @@ compile _ context _metaref (C.CoreVar _ v) = Atom $ context v
 compile _ _ _ (C.CoreBuiltin _ n) = App (Ref (Global n)) mempty
 
 -- | Compile primitive to STG native.
-compile _ _ _ (C.CorePrim _ p) = case convert p of
-  Just n -> Atom (Literal n)
-  Nothing -> Atom (Global "NULL")
+compile _ _context metaref (C.CorePrim _ p) =
+  case convert p of
+    Just n -> annotated n
+    Nothing -> Atom (Global "NULL")
+  where
+    annotated n =
+      maybe
+        (Atom (Literal n))
+        (\r -> appbif_ (intrinsicIndex "WITHMETA") [r, Literal n])
+        metaref
 
 -- | Block literals
 compile envSize context _metaref (C.CoreBlock _ content) = let_ [c] b

src/Eucalypt/Stg/Error.hs

@@ -42,6 +42,11 @@ data StgError
   | IntrinsicExpectedNativeList
   | IntrinsicExpectedStringList
   | IntrinsicExpectedEvaluatedList !StgSyn
+  | IntrinsicExpectedBlockFoundBlackHole
+  | IntrinsicExpectedBlockFoundPartialApplication
+  | IntrinsicExpectedBlockFoundNative !Native
+  | IntrinsicExpectedEvaluatedBlock !StgSyn
+  | IntrinsicExpectedBlock !StgSyn
   | InvalidRegex !String
   | UnknownGlobal !String
   | DictKeyNotFound !Native
@@ -91,11 +96,23 @@ instance Reportable StgException where
             bug "Expected a list, found a black hole."
           IntrinsicExpectedListFoundPartialApplication ->
             bug "Expected a list, found a partial application."
+          IntrinsicExpectedBlockFoundBlackHole ->
+            bug "Expected a block, found a black hole."
+          IntrinsicExpectedBlockFoundPartialApplication ->
+            bug "Expected a block, found a partial application."
           IntrinsicExpectedNativeList -> err "Expected list of native values."
           IntrinsicExpectedStringList -> err "Expected list of strings."
           IntrinsicExpectedEvaluatedList expr ->
             bug "Expected evaluated list, found unevaluated thunks." P.$$
             prettify expr
+          IntrinsicExpectedBlock expr ->
+            bug "Expected block, found something else." P.$$
+            prettify expr
+          IntrinsicExpectedEvaluatedBlock expr ->
+            bug "Expected evaluated block, found unevaluated thunks." P.$$
+            prettify expr
+          IntrinsicExpectedBlockFoundNative n ->
+            err "Expected a block but found native value: " P.$$ prettify n
           (InvalidRegex s) ->
             err "Regular expression was not valid:" P.$$
             P.nest 2 (P.text "-" P.<+> P.text s)

src/Eucalypt/Stg/Eval.hs

@@ -85,7 +85,7 @@ selectBranch (BranchTable bs _ _) t = Map.lookup t bs
 -- | Match a native branch table alternative, return the next
 -- expression to eval
 selectNativeBranch :: BranchTable -> Native -> Maybe StgSyn
-selectNativeBranch (BranchTable _ bs _) n = HM.lookup n bs
+selectNativeBranch (BranchTable _ bs _) n = snd <$> HM.lookup n bs
 
 -- | Halt the machine
 terminate :: MachineState -> MachineState

src/Eucalypt/Stg/Event.hs

@@ -13,14 +13,18 @@ module Eucalypt.Stg.Event where
 import Eucalypt.Stg.Syn
 import Data.ByteString as BS
 
+newtype RenderMetadata = RenderMetadata
+  { metaTag :: Maybe String
+  } deriving (Show, Eq)
+
 -- | Various events that can be emitted by the machine, including YAML
 -- / JSON output rendering and debug tracing.
 data Event
   = OutputStreamStart
   | OutputStreamEnd
   | OutputDocumentStart
   | OutputDocumentEnd
-  | OutputScalar !Native
+  | OutputScalar RenderMetadata !Native
   | OutputNull
   | OutputSequenceStart
   | OutputSequenceEnd

src/Eucalypt/Stg/Globals/Emit.hs

@@ -26,10 +26,18 @@ globals =
   , GlobalInfo "Emit.startList" startList [NonStrict, NonStrict]
   , GlobalInfo "Emit.continueList" continueList [NonStrict]
   , GlobalInfo "Emit.wrapBlock" wrapBlock [NonStrict]
+  , GlobalInfo "Emit.forceExportMetadata" forceExportMetadata [NonStrict]
+  , GlobalInfo "Emit.forceExportMetadataKVList" forceExportMetadataKVList [NonStrict]
+  , GlobalInfo "Emit.forceKVNatPair" forceKVNatPair [NonStrict]
+  , GlobalInfo "Emit.isRenderMetadataKey" isRenderMetadataKey [Strict]
   , GlobalInfo "RENDER" euRender [NonStrict]
   , GlobalInfo "NULL" euNull []
   ]
 
+
+panic :: String -> StgSyn
+panic msg = appfn_ (Global "PANIC") [Literal $ NativeString msg]
+
 -- | __NULL - for emitting JSON / YAML null
 euNull :: LambdaForm
 euNull = standardConstructor 0 stgUnit
@@ -46,6 +54,11 @@ emitSS = appbif_ (intrinsicIndex "EMIT[") []
 emitSE :: StgSyn
 emitSE = appbif_ (intrinsicIndex "EMIT]") []
 
+-- | Emit a scalar.
+--
+-- The intrinsic requires that the value is already resolve to a
+-- native with metadata and that the metadata is already evaluated
+-- at all the relevant metadata keys (e.g. :export, :tag ...)
 emitScalar :: Ref -> StgSyn
 emitScalar n = appbif_ (intrinsicIndex "EMITx") [n]
 
@@ -132,10 +145,13 @@ continueList =
     (Atom (Local 0))
     [ ( stgCons
       , ( 2
-        , seq_ (appfn_ (Global "RENDER") [Local 1]) $ appfn_ (Global "Emit.continueList") [Local 2]))
+        , seq_ (appfn_ (Global "RENDER") [Local 1]) $
+          appfn_ (Global "Emit.continueList") [Local 2]))
     , (stgNil, (0, emitSE))
-    ]
-    (emitScalar (Local 1))
+    ] $
+  force_ (appfn_ (Global "META") [Local 1]) $
+  force_ (appfn_ (Global "Emit.forceExportMetadata") [Local 2]) $
+  emitScalar (Local 1) -- force is effectful
 
 -- | Emit.startList(l)
 startList :: LambdaForm
@@ -181,5 +197,71 @@ euRender =
     , (stgCons, (2, appfn_ (Global "Emit.startList") [Local 1, Local 2]))
     , (stgNil, (0, appfn_ (Global "Emit.emptyList") []))
     , (stgUnit, (0, emitNull))
-    ]
-    (emitScalar (Local 1))
+    ] $
+  force_ (appfn_ (Global "META") [Local 1]) $
+  force_ (appfn_ (Global "Emit.forceExportMetadata") [Local 2]) $
+  emitScalar (Local 1)
+
+-- | Single argument is the metadata (not the annotated value)
+forceExportMetadata :: LambdaForm
+forceExportMetadata =
+  lam_ 0 1 $
+  ann_ "Emit.forceExportMetadata" 0 $
+  let b = Local 0
+      l = Local 1
+   in case_
+        (Atom b)
+        [ ( stgBlock
+          , ( 1
+            , force_
+                (appfn_ (Global "Emit.forceExportMetadataKVList") [l])
+                (appcon_ stgUnit [])))
+        ]
+
+
+forceExportMetadataKVList :: LambdaForm
+forceExportMetadataKVList =
+  lam_ 0 1 $
+  ann_ "Emit.forceExportMetadataKVList" 0 $
+  let l = Local 0
+      h = Local 1
+      t = Local 2
+   in case_
+        (Atom l)
+        [ (stgNil, (0, Atom (Global "KNIL")))
+        , ( stgCons
+          , ( 2
+            , force_ (appfn_ (Global "Emit.forceKVNatPair") [h]) $
+              force_ (appfn_ (Global "Emit.forceExportMetadataKVList") [t]) $
+              appcon_ stgUnit []))
+        ]
+
+
+isRenderMetadataKey :: LambdaForm
+isRenderMetadataKey =
+  lam_ 0 1 $
+  ann_ "Emit.isRenderMetadataKey" 0 $
+  caselit_
+    (Atom (Local 0))
+    [ (NativeSymbol "export", Atom (Global "TRUE"))
+    , (NativeSymbol "tag", Atom (Global "TRUE"))
+    ] $
+  Just (Atom (Global "FALSE"))
+
+
+forceKVNatPair :: LambdaForm
+forceKVNatPair =
+  lam_ 0 1 $
+  ann_ "Emit.forceKVNatPair" 0 $
+  let pr = Local 0
+      prh = Local 1
+   in casedef_
+        (Atom pr)
+        [ ( stgCons
+          , ( 2
+            , caselit_
+                (appfn_ (Global "Emit.isRenderMetadataKey") [prh])
+                [(NativeBool True, appfn_ (Global "seqNatList") [pr])]
+                (Just (Atom pr))))
+        ]
+        (panic "Invalid pair (not cons) while evaluating render metadata")