Changeset 8600
- Timestamp:
- 01/07/06 09:46:00 (3 years ago)
- Location:
- src
- Files:
-
- 2 modified
-
Data/Yaml/Syck.hsc (modified) (5 diffs)
-
Pugs/Prim/Yaml.hs (modified) (5 diffs)
Legend:
- Unmodified
- Added
- Removed
-
src/Data/Yaml/Syck.hsc
r8587 r8600 20 20 import Foreign.Marshal.Utils 21 21 import Foreign.Storable 22 import Data.Maybe (isJust) 23 import Control.Monad (when) 22 24 23 25 import Debug.Trace 24 26 import Control.Monad.Trans 25 27 28 type YamlTag = Maybe String 29 30 -- XXX: add tags for other types except maps? 26 31 data YamlNode 27 = YamlMap [(YamlNode, YamlNode)]32 = YamlMap YamlTag [(YamlNode, YamlNode)] 28 33 | YamlSeq [YamlNode] 29 34 | YamlStr String … … 63 68 nodePtr <- freezeNode node 64 69 let nodePtr' = fromIntegral $ nodePtr `minusPtr` nullPtr 65 -- trace ("node: " ++ (show node) ++ " nodePtr': " ++ (show nodePtr')) $ return ()66 70 syck_emit emitter nodePtr' 67 71 syck_emitter_flush emitter 0 … … 86 90 87 91 emitterCallback :: SyckEmitter -> Ptr () -> IO () 88 emitterCallback e vp = do 89 node <- thawNode vp 90 case node of 91 YamlNil -> do 92 -- syck_emit_scalar(e, "string", scalar_none, 0, 0, 0, "~", 1); 93 withCString "string" $ \string_literal -> 94 withCString "~" $ \cs -> 95 syck_emit_scalar e string_literal scalarNone 0 0 0 cs 1 96 (YamlStr str) -> do 97 -- return syck_emit_scalar(e, "string", scalar_none, 0, 0, 0, SvPVX(sv), SvCUR(sv)); 98 withCString "string" $ \string_literal -> 99 withCString str $ \cs -> 100 syck_emit_scalar e string_literal scalarNone 0 0 0 cs (toEnum $ length str) 101 (YamlSeq seq) -> do 102 -- syck_emit_seq(e, "array", seq_none); 103 withCString "array" $ \array_literal -> 104 syck_emit_seq e array_literal seqNone 105 -- TODO: fix pesky warning about "integer from pointer without a cast" here 106 mapM_ (syck_emit_item e) =<< (mapM freezeNode seq) 107 syck_emit_end e 108 (YamlMap m) -> do 109 -- syck_emit_map(e, "hash", map_none); 110 trace ("a hash: " ++ (show m)) $ return () 111 withCString "hash" $ \hash_literal -> 112 syck_emit_map e hash_literal mapNone 113 mapM_ (\(k,v) -> (syck_emit_item e =<< freezeNode k) >> (syck_emit_item e =<< freezeNode v)) m 114 syck_emit_end e 92 emitterCallback e vp = emitNode e =<< thawNode vp 93 94 emitNode :: SyckEmitter -> YamlNode -> IO () 95 emitNode e YamlNil = do 96 -- syck_emit_scalar(e, "string", scalar_none, 0, 0, 0, "~", 1); 97 withCString "string" $ \string_literal -> 98 withCString "~" $ \cs -> 99 syck_emit_scalar e string_literal scalarNone 0 0 0 cs 1 100 101 emitNode e (YamlStr str) = do 102 -- return syck_emit_scalar(e, "string", scalar_none, 0, 0, 0, SvPVX(sv), SvCUR(sv)); 103 withCString "string" $ \string_literal -> 104 withCString str $ \cs -> 105 syck_emit_scalar e string_literal scalarNone 0 0 0 cs (toEnum $ length str) 106 107 emitNode e (YamlSeq seq) = do 108 -- syck_emit_seq(e, "array", seq_none); 109 withCString "array" $ \array_literal -> 110 syck_emit_seq e array_literal seqNone 111 -- TODO: fix pesky warning about "integer from pointer without a cast" here 112 mapM_ (syck_emit_item e) =<< (mapM freezeNode seq) 113 syck_emit_end e 114 115 emitNode e (YamlMap tag m) = do 116 -- syck_emit_map(e, "hash", map_none); 117 trace ("hash<" ++ maybe "" id tag ++">: " ++ (show m)) $ return () 118 withCString (maybe "hash" id tag) $ \hash_literal -> do 119 syck_emit_map e hash_literal mapNone 120 when (isJust tag) (do {syck_emit_tag e hash_literal nullPtr ; return ()}) 121 flip mapM_ m (\(k,v) -> do 122 syck_emit_item e =<< freezeNode k 123 syck_emit_item e =<< freezeNode v) 124 syck_emit_end e 115 125 116 126 … … 187 197 val <- readNode parser valId 188 198 return (key, val) 189 return $ YamlMap pairs199 return $ YamlMap Nothing pairs 190 200 191 201 parseNode SyckSeq parser syckNode len = do … … 284 294 syck_emit_map :: SyckEmitter -> CString -> CInt -> IO () 285 295 296 foreign import ccall 297 syck_emit_tag :: SyckEmitter -> CString -> CString -> IO () 298 -
src/Pugs/Prim/Yaml.hs
r8593 r8600 8 8 import Pugs.AST 9 9 import Pugs.Pretty 10 import Pugs.Types 10 11 import Data.Yaml.Syck 11 12 import qualified Data.Map as Map … … 22 23 23 24 fromYaml :: YamlNode -> Eval Val 25 fromYaml YamlNil = return VUndef 24 26 fromYaml (YamlStr str) = return $ VStr (decodeUTF8 str) 25 27 fromYaml (YamlSeq nodes) = do … … 28 30 IntMap.fromAscList ([0..] `zip` map lazyScalar vals) 29 31 return $ VRef (arrayRef av) 30 fromYaml (YamlMap nodes) = do32 fromYaml (YamlMap _ nodes) = do 31 33 vals <- forM nodes $ \(keyNode, valNode) -> do 32 34 key <- fromVal =<< fromYaml keyNode … … 34 36 return (key, val) 35 37 hv <- liftSTM $ (newTVar (Map.fromList vals) :: STM IHash) 38 -- XXX: if YamlMap (Just "!perl/":type) nodes then mkObject etc. 36 39 return $ VRef (hashRef hv) 37 40 … … 54 57 trace ("toYaml VRef: " ++ (show v) ++ " type=" ++ (show t)) $ return () 55 58 (ifValTypeIsa v "Hash" 56 (do 57 case r of 58 MkRef (IHash hv) -> do 59 h <- hash_fetch hv 60 let assocs = Map.toList h 61 yamlmap <- mapM ( \(k, v) -> do 62 k' <- toYaml d (VStr k) 63 v' <- toYaml d v 64 return (k', v')) assocs 65 return $ YamlMap yamlmap 66 _ -> error ("can't process hash: " ++ show v') -- XXX 59 (case r of 60 -- "My brain just exploded. I can't handle pattern bindings for existentially-quantified constructors." 61 -- let (MkRef (IHash hv)) = r 62 -- XXX golfme for readability! 63 MkRef (IHash hv) -> do 64 h <- hash_fetch hv 65 let assocs = Map.toList h 66 yamlmap <- flip mapM assocs (\(ka, va) -> do 67 ka' <- toYaml d (VStr ka) 68 va' <- toYaml d va 69 return (ka', va')) 70 return $ YamlMap Nothing yamlmap 71 _ -> error ("unexpected node: " ++ show v) 67 72 ) 68 73 (do nodes <- toYaml d v' 69 ifValTypeIsa v "Array" 70 (return $ nodes) 71 (return $ YamlMap [(YamlStr "<ref>", nodes)])) -- XXX 72 ) 74 (ifValTypeIsa v "Array" 75 (return $ nodes) --(return $ YamlMap Nothing [(YamlStr "<ref>", nodes)])) -- XXX 76 (return $ case v' of 77 VObject _ -> nodes 78 _ -> YamlMap Nothing [(YamlStr "<ref>", nodes)] -- XXX 79 )))) 73 80 toYaml (d+1) (VList nodes) = do 74 81 trace ("toYaml VList: " ++ (show nodes)) $ return () 75 82 fmap YamlSeq $ mapM (toYaml d) nodes 83 toYaml (d+1) v@(VObject obj) = do 84 -- ... dump the objAttrs 85 -- XXX this needs fixing WRT demagicalized pairs: 86 -- currently, this'll return Foo.new((attr => "value)), with the inner 87 -- parens, which is, of course, wrong. 88 hash <- fromVal v :: Eval VHash 89 attrs <- toYaml d (VRef (hashRef hash)) 90 return $ addTag (Just $ "!pugs:object/" ++ showType (objType obj)) attrs 91 where 92 addTag _ (YamlMap (Just x) _) = error ("can't add tag: already tagged with" ++ x) 93 addTag tag (YamlMap _ m) = YamlMap tag m 76 94 toYaml _ v = return $ YamlStr $ encodeUTF8 $ pretty v 77 95
