Changeset 8606

Timestamp:

01/07/06 13:49:41 (3 years ago)

Author:

gaal

Message:

.yaml:

• make YamlNode? resemble SyckNode? a little better in structure. This will come useful when eventually we need to serialize "undef but" etc.
• golfage (I hope it's sane, or in the right form of insanity at least)

Location:

src

Files:

• Data/Yaml/Syck.hsc (modified) (8 diffs)
• Pugs/Prim/Yaml.hs (modified) (5 diffs)

src/Data/Yaml/Syck.hsc

@@ -5 +5 @@
 module Data.Yaml.Syck (
     parseYaml, emitYaml,
-    YamlNode(..),
+    YamlNode(..), YamlElem(..), emptyYamlNode, tagNode
 ) where
 
@@ -26 +26 @@
 import Control.Monad.Trans
 
-type YamlTag = Maybe String
-
--- XXX: add tags for other types except maps?
-data YamlNode
-    = YamlMap YamlTag [(YamlNode, YamlNode)]
+type YamlTag    = Maybe String
+type YamlAnchor = Maybe String
+type SYMID = CULong
+
+data YamlNode = MkYamlNode
+    { nid    :: SYMID
+    , tag    :: YamlTag
+    , anchor :: YamlAnchor
+    , el     :: YamlElem
+    }
+    deriving (Show, Ord, Eq)
+
+data YamlElem
+    = YamlMap [(YamlNode, YamlNode)]
     | YamlSeq [YamlNode]
     | YamlStr String
@@ -36 +45 @@
     deriving (Show, Ord, Eq)
 
-type SYMID = CULong
 type SyckNode = Ptr ()
 type SyckParser = Ptr ()
@@ -48 +56 @@
 data SyckKind = SyckMap | SyckSeq | SyckStr | SyckNil
     deriving (Show, Ord, Eq, Enum)
+
+emptyYamlNode :: YamlNode
+emptyYamlNode = MkYamlNode 0 Nothing Nothing YamlNil
+
+tagNode :: YamlTag -> YamlNode -> YamlNode
+tagNode _   MkYamlNode{tag=Just x} = error ("can't add tag: already tagged with" ++ x)
+tagNode tag node                   = node{tag = tag}
 
 -- the extra comma here is not a bug
@@ -93 +108 @@
     
 emitNode :: (?e :: SyckEmitter) -> YamlNode -> IO ()
-emitNode YamlNil = do
-    withCString "string" $ \stringLiteral ->       
+emitNode n@(MkYamlNode{el = YamlNil}) = do
+    withTag n "string" $ \tag ->
         withCString "~" $ \cs ->       
-            syck_emit_scalar ?e stringLiteral scalarNone 0 0 0 cs 1
-
-emitNode (YamlStr str) = do
-    withCString "string" $ \stringLiteral ->       
+            syck_emit_scalar ?e tag scalarNone 0 0 0 cs 1
+
+emitNode n@(MkYamlNode{el = YamlStr str}) = do
+    withTag n "string" $ \tag ->       
         withCString str $ \cs ->       
-            syck_emit_scalar ?e stringLiteral scalarNone 0 0 0 cs (toEnum $ length str)
-
-emitNode (YamlSeq seq) = do
-    withCString "array" $ \arrayLiteral ->
-        syck_emit_seq ?e arrayLiteral seqNone
+            syck_emit_scalar ?e tag scalarNone 0 0 0 cs (toEnum $ length str)
+
+emitNode n@(MkYamlNode{el = YamlSeq seq}) = do
+    withTag n "array" $ \tag ->
+        syck_emit_seq ?e tag seqNone
     -- TODO: fix pesky warning about "integer from pointer without a cast" here
     mapM_ (syck_emit_item ?e) =<< (mapM freezeNode seq)
     syck_emit_end ?e
 
-emitNode (YamlMap tag m) = do
+emitNode n@(MkYamlNode{el = YamlMap m}) = do
     --trace ("hash<" ++ maybe "" id tag ++">: " ++ (show m)) $ return ()
-    withCString (maybe "hash" id tag) $ \hashLiteral -> do
-        syck_emit_map ?e hashLiteral mapNone
+    withTag n "hash" $ \tag -> 
+        syck_emit_map ?e tag mapNone
     flip mapM_ m (\(k,v) -> do
         syck_emit_item ?e =<< freezeNode k
@@ -119 +134 @@
     syck_emit_end ?e
 
+withTag :: YamlNode -> String -> (CString -> IO a) -> IO a
+withTag node def f = withCString (maybe def id (tag node)) f
 
 parseYaml :: String -> IO (Either String (Maybe YamlNode))
@@ -192 +209 @@
         val     <- readNode parser valId
         return (key, val)
-    return $ YamlMap Nothing pairs
+    return $ emptyYamlNode{ el = YamlMap pairs }
 
 parseNode SyckSeq parser syckNode len = do
@@ -198 +215 @@
         symId   <- syck_seq_read syckNode idx
         readNode parser symId
-    return $ YamlSeq nodes
+    return $ emptyYamlNode{ el = YamlSeq nodes }
 
 parseNode SyckStr _ syckNode len = do
     cstr    <- syck_str_read syckNode
     str     <- peekCStringLen (cstr, fromEnum len)
-    return $ YamlStr str
+    return $ emptyYamlNode{ el = YamlStr str }
 
 foreign import ccall "wrapper"  

src/Pugs/Prim/Yaml.hs

@@ -23 +23 @@
 
 fromYaml :: YamlNode -> Eval Val
-fromYaml YamlNil = return VUndef
-fromYaml (YamlStr str) = return $ VStr (decodeUTF8 str)
-fromYaml (YamlSeq nodes) = do
+fromYaml MkYamlNode{el=YamlNil}       = return VUndef
+fromYaml MkYamlNode{el=YamlStr str}   = return $ VStr (decodeUTF8 str)
+fromYaml MkYamlNode{el=YamlSeq nodes} = do
     vals    <- mapM fromYaml nodes
     av      <- liftSTM $ newTVar $
         IntMap.fromAscList ([0..] `zip` map lazyScalar vals)
     return $ VRef (arrayRef av)
-fromYaml (YamlMap _ nodes) = do
+fromYaml MkYamlNode{el=YamlMap nodes} = do
     vals    <- forM nodes $ \(keyNode, valNode) -> do
         key <- fromVal =<< fromYaml keyNode
@@ -47 +47 @@
 
 toYaml :: (?d :: Int) => Val -> Eval YamlNode
-toYaml _ | ?d == 0  = return $ YamlStr "<deep recursion>" -- fail? make this configurable?
-toYaml VUndef       = return YamlNil
-toYaml (VStr str)   = return $ YamlStr (encodeUTF8 str)
+toYaml _ | ?d == 0  = return $ emptyYamlNode{el = YamlStr "<deep recursion>"} -- fail? make this configurable?
+toYaml VUndef       = return emptyYamlNode
+toYaml (VStr str)   = return $ emptyYamlNode{el = YamlStr (encodeUTF8 str)}
 toYaml v@(VRef r)   = let ?d = pred ?d in do
     t  <- evalValType v
@@ -57 +57 @@
         ifValTypeIsa v "Array" (return nodes) $ case v' of
             VObject _   -> return nodes
-            _           -> return (YamlMap Nothing [(YamlStr "<ref>", nodes)])
+            _           -> return emptyYamlNode{el = YamlMap [(emptyYamlNode{el=YamlStr "<ref>"}, nodes)]}
 toYaml (VList nodes) = let ?d = pred ?d in do
-    fmap YamlSeq $ mapM toYaml nodes
+    n <- mapM toYaml nodes
+    return $ emptyYamlNode{el=YamlSeq n} -- golfme!
+    -- fmap YamlSeq$ mapM toYaml nodes
 toYaml v@(VObject obj) = let ?d = pred ?d in do
     -- ... dump the objAttrs
@@ -67 +69 @@
     hash    <- fromVal v :: Eval VHash
     attrs   <- toYaml $ VRef (hashRef hash)
-    return $ addTag (Just $ "tag: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
+    return $ tagNode (Just $ "tag:pugs:object:" ++ showType (objType obj)) attrs
+toYaml v = return $ emptyYamlNode{el=YamlStr p}
+    where p = (encodeUTF8 . pretty) v
+
 
 hashToYaml :: (?d :: Int) => VRef -> Eval YamlNode
@@ -81 +82 @@
         va' <- toYaml va
         return (ka', va')
-    return $ YamlMap Nothing yamlmap
+    return $ emptyYamlNode{el=YamlMap yamlmap}
 hashToYaml r = error ("unexpected node: " ++ show r)
-   
-{-
-ifValTypeIsa v "Pair"
-    (case v' of
-        VList [ks, vs] -> do
-            kStr <- toYaml d ks
-            vStr <- toYaml d vs
-            return $ YamlMap [(kStr, vStr)] -- assume a pair is a one-element hash
-        _ -> toYaml d v'                    -- XXX: probably broken to blithingly ignore ref levels here
-    )
-    (ifValTypeIsa v "Hash"
-        --fmap YamlMap $ mapM (\(k, v) -> do {k' <- toYaml k; v' <- toYaml v; return (k', v')}) Map.toList =<< hash_fetch v')
-        (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
-        )
-        (do nodes <- toYaml d v'
-            ifValTypeIsa v "Array"
-                (return $ nodes)
-                (return $ YamlMap [(YamlStr "<ref>", nodes)])) -- XXX
-    )
--}
+