Changeset 8600 for src/Pugs/Prim/Yaml.hs

Timestamp:

01/07/06 09:46:00 (3 years ago)

Author:

gaal

Message:

Yaml emitting:

• some readability improvements, need more work
• towards proper tagging of emitted arbitrary objects (probably need to add a tag to all YamlNode? types, not just YamlMap?... we'll see)

Files:

• src/Pugs/Prim/Yaml.hs (modified) (5 diffs)

src/Pugs/Prim/Yaml.hs

@@ -8 +8 @@
 import Pugs.AST
 import Pugs.Pretty
+import Pugs.Types
 import Data.Yaml.Syck
 import qualified Data.Map as Map
@@ -22 +23 @@
 
 fromYaml :: YamlNode -> Eval Val
+fromYaml YamlNil = return VUndef
 fromYaml (YamlStr str) = return $ VStr (decodeUTF8 str)
 fromYaml (YamlSeq nodes) = do
@@ -28 +30 @@
         IntMap.fromAscList ([0..] `zip` map lazyScalar vals)
     return $ VRef (arrayRef av)
-fromYaml (YamlMap nodes) = do
+fromYaml (YamlMap _ nodes) = do
     vals    <- forM nodes $ \(keyNode, valNode) -> do
         key <- fromVal =<< fromYaml keyNode
@@ -34 +36 @@
         return (key, val)
     hv      <- liftSTM $ (newTVar (Map.fromList vals) :: STM IHash)
+    -- XXX: if YamlMap (Just "!perl/":type) nodes then mkObject etc.
     return $ VRef (hashRef hv)
 
@@ -54 +57 @@
     trace ("toYaml VRef: " ++ (show v) ++ " type=" ++ (show t)) $ return ()
     (ifValTypeIsa v "Hash"
-        (do 
-            case r of
-                MkRef (IHash hv) -> do
-                    h <- hash_fetch hv
-                    let assocs = Map.toList h
-                    yamlmap <- mapM ( \(k, v) -> do
-                        k' <- toYaml d (VStr k)
-                        v' <- toYaml d v
-                        return (k', v')) assocs
-                    return $ YamlMap yamlmap
-                _ -> error ("can't process hash: " ++ show v') -- XXX
+        (case r of
+            -- "My brain just exploded. I can't handle pattern bindings for existentially-quantified constructors."
+            -- let (MkRef (IHash hv)) = r
+            -- XXX golfme for readability!
+            MkRef (IHash hv) -> do
+                h <- hash_fetch hv
+                let assocs = Map.toList h
+                yamlmap <- flip mapM assocs (\(ka, va) -> do
+                   ka' <- toYaml d (VStr ka)
+                   va' <- toYaml d va
+                   return (ka', va'))
+                return $ YamlMap Nothing yamlmap
+            _ -> error ("unexpected node: " ++ show v)
         )
         (do nodes <- toYaml d v'
-            ifValTypeIsa v "Array"
-                (return $ nodes)
-                (return $ YamlMap [(YamlStr "<ref>", nodes)])) -- XXX
-        )
+            (ifValTypeIsa v "Array"
+                (return $ nodes) --(return $ YamlMap Nothing [(YamlStr "<ref>", nodes)])) -- XXX
+                (return $ case v' of
+                    VObject _ -> nodes
+                    _ -> YamlMap Nothing [(YamlStr "<ref>", nodes)] -- XXX
+                ))))
 toYaml (d+1) (VList nodes) = do
     trace ("toYaml VList: " ++ (show nodes)) $ return ()
     fmap YamlSeq $ mapM (toYaml d) nodes
+toYaml (d+1) v@(VObject obj) = do
+    -- ... dump the objAttrs
+    -- XXX this needs fixing WRT demagicalized pairs:
+    -- currently, this'll return Foo.new((attr => "value)), with the inner
+    -- parens, which is, of course, wrong.
+    hash    <- fromVal v :: Eval VHash
+    attrs   <- toYaml d (VRef (hashRef hash))
+    return $ addTag (Just $ "!pugs:object/" ++ showType (objType obj)) attrs
+    where
+        addTag _ (YamlMap (Just x) _) = error ("can't add tag: already tagged with" ++ x)
+        addTag tag (YamlMap _ m) = YamlMap tag m
 toYaml _ v = return $ YamlStr $ encodeUTF8 $ pretty v