Changeset 9005

Show
Ignore:
Timestamp:
02/15/06 14:13:33 (3 years ago)
Author:
audreyt
Message:

* Dumping recursive Yaml structures now Really Works (tm)

Location:
src
Files:
2 modified

Legend:

Unmodified
Added
Removed

  • src/Data/Yaml/Syck.hsc

    r8999 r9005  
    55module Data.Yaml.Syck ( 
    66    parseYaml, emitYaml, 
    7     YamlNode(..), YamlElem(..), tagNode, nilNode, mkNode, mkTagNode, SYMID, 
     7    YamlNode(..), YamlElem(..), YamlAnchor(..), tagNode, nilNode, mkNode, mkTagNode, SYMID, 
    88) where 
    99 
    … …  
    2121import Foreign.Storable 
    2222import Data.Generics 
     23import qualified Data.HashTable as Hash 
    2324 
    2425type YamlTag    = Maybe String 
    25 type YamlAnchor = Maybe String 
     26data YamlAnchor 
     27    = MkYamlAnchor    Int 
     28    | MkYamlReference Int 
     29    deriving (Show, Ord, Eq, Typeable, Data) 
    2630type SYMID = CULong 
    2731 
    28 cuLongType = mkIntType "Foreign.C.Types.CULong" 
    29  
    3032instance Data SYMID where 
    31   toConstr x = mkIntConstr cuLongType (fromIntegral x) 
     33  toConstr x = mkIntConstr (mkIntType "Foreign.C.Types.CULong") (fromIntegral x) 
    3234  gunfold k z c = case constrRep c of 
    3335                    (IntConstr x) -> z (fromIntegral x) 
    3436                    _ -> error "gunfold" 
    35   dataTypeOf _ = cuLongType 
     37  dataTypeOf _ = mkIntType "Foreign.C.Types.CULong" 
    3638 
    3739data YamlNode = MkYamlNode 
    … …  
    3941    , el       :: YamlElem 
    4042    , tag      :: YamlTag 
    41     , anchor   :: YamlAnchor 
    42     , shortcut :: (Maybe YamlNode) 
     43    , anchor   :: Maybe YamlAnchor 
    4344    } 
    4445    deriving (Show, Ord, Eq, Typeable, Data) 
    … …  
    6465 
    6566nilNode :: YamlNode 
    66 nilNode = MkYamlNode 0 YamlNil Nothing Nothing Nothing 
     67nilNode = MkYamlNode 0 YamlNil Nothing Nothing 
    6768 
    6869tagNode :: YamlTag -> YamlNode -> YamlNode 
    69 tagNode _   MkYamlNode{tag=Just x} = error ("can't add tag: already tagged with" ++ x) 
    70 tagNode tag node                   = node{tag = tag} 
     70tagNode _ MkYamlNode{tag=Just x} = error ("can't add tag: already tagged with" ++ x) 
     71tagNode tag node                 = node{tag = tag} 
    7172 
    7273mkNode :: YamlElem -> YamlNode 
    73 mkNode x = MkYamlNode 0 x Nothing Nothing Nothing 
     74mkNode x = MkYamlNode 0 x Nothing Nothing 
    7475 
    7576mkTagNode :: String -> YamlElem -> YamlNode 
    76 mkTagNode s x = MkYamlNode 0 x (Just s) Nothing Nothing 
     77mkTagNode s x = MkYamlNode 0 x (Just s) Nothing 
    7778 
    7879-- the extra commas here are not a bug 
    … …  
    9495        #{poke SyckEmitter, bonus} emitter outPtr 
    9596        #{poke SyckEmitter, style} emitter scalarFold 
     97        #{poke SyckEmitter, sort_keys} emitter (1 :: CInt) 
     98        withCString "%d" $ #{poke SyckEmitter, anchor_format} emitter 
     99 
     100        -- nodes <- Hash.new (==) (Hash.hashInt) 
     101        marks <- Hash.new (==) (Hash.hashInt) 
     102 
     103        let freeze = freezeNode marks 
     104        syck_emitter_handler emitter =<< mkEmitterCallback (emitterCallback freeze) 
    96105        syck_output_handler emitter =<< mkOutputCallback outputCallback 
    97         syck_emitter_handler emitter =<< mkEmitterCallback emitterCallback 
    98         markYamlNode emitter node 
    99         nodePtr <- freezeNode node 
     106 
     107        markYamlNode marks emitter node 
     108 
     109        nodePtr <- freeze node 
    100110        let nodePtr' = fromIntegral $ nodePtr `minusPtr` nullPtr 
    101111        syck_emit emitter nodePtr' 
    … …  
    103113        fmap Right $ readIORef out 
    104114 
    105 markYamlNode :: SyckEmitter -> YamlNode -> IO () 
    106 markYamlNode emitter node = do 
    107     nodePtr <- writeNode node 
     115markYamlNode :: Hash.HashTable Int SyckNodePtr -> SyckEmitter -> YamlNode -> IO () 
     116markYamlNode marks emitter node@MkYamlNode{ anchor = Just (MkYamlReference n) } = do 
     117    Just nodePtr <- Hash.lookup marks n 
     118    syck_emitter_mark_node emitter nodePtr 
     119    return () 
     120markYamlNode marks emitter node = do 
     121    nodePtr <- freezeNode marks node 
    108122    rv      <- syck_emitter_mark_node emitter nodePtr 
    109     if rv == 0 then return () else case el node of 
     123    if rv == 0 then return () else do 
     124    case anchor node of 
     125        Just (MkYamlAnchor n) -> Hash.insert marks n nodePtr 
     126        _                     -> return () 
     127    case el node of 
    110128        YamlMap xs  -> sequence_ [ mark x >> mark y | (x, y) <- xs ] 
    111129        YamlSeq xs  -> mapM_ mark xs 
    112130        _           -> return () 
    113131    where 
    114     mark = markYamlNode emitter 
     132    mark = markYamlNode marks emitter 
    115133 
    116134outputCallback :: SyckEmitter -> CString -> CLong -> IO () 
    … …  
    119137    out     <- deRefStablePtr (castPtrToStablePtr outPtr) 
    120138    str     <- peekCStringLen (buf, fromIntegral len) 
    121     #{poke SyckEmitter, headless} emitter (1 :: CInt) 
    122139    modifyIORef out (++ str) 
    123140 
    … …  
    132149    deRefStablePtr (castPtrToStablePtr ptr) 
    133150 
    134 emitterCallback :: SyckEmitter -> Ptr () -> IO () 
    135 emitterCallback e vp = emitNode e =<< thawNode vp 
     151 
     152emitterCallback :: (YamlNode -> IO SyckNodePtr) -> SyckEmitter -> Ptr () -> IO () 
     153emitterCallback f e vp = emitNode f e =<< thawNode vp 
    136154     
    137 emitNode :: SyckEmitter -> YamlNode -> IO () 
    138 emitNode e n@(MkYamlNode{el = YamlNil}) = do 
     155emitNode :: (YamlNode -> IO SyckNodePtr) -> SyckEmitter -> YamlNode -> IO () 
     156emitNode _ e n@(MkYamlNode{el = YamlNil}) = do 
    139157    withTag n "string" $ \tag -> 
    140158        withCString "~" $ \cs ->        
    141159            syck_emit_scalar e tag scalarNone 0 0 0 cs 1 
    142160 
    143 emitNode e n@(MkYamlNode{el = YamlStr "~"}) = do 
     161emitNode _ e n@(MkYamlNode{el = YamlStr "~"}) = do 
    144162    withTag n "string" $ \tag ->        
    145163        withCString "~" $ \cs ->        
    146164            syck_emit_scalar e tag scalar1quote 0 0 0 cs 1 
    147165 
    148 emitNode e n@(MkYamlNode{el = YamlStr str}) = do 
     166emitNode _ e n@(MkYamlNode{el = YamlStr str}) = do 
    149167    withTag n "string" $ \tag ->        
    150168        withCString str $ \cs ->        
    151169            syck_emit_scalar e tag scalarNone 0 0 0 cs (toEnum $ length str) 
    152170 
    153 emitNode e n@(MkYamlNode{el = YamlSeq seq}) = do 
     171emitNode freeze e n@(MkYamlNode{el = YamlSeq seq}) = do 
    154172    withTag n "array" $ \tag -> 
    155173        syck_emit_seq e tag seqNone 
    156     mapM_ (syck_emit_item e) =<< (mapM freezeNode seq) 
     174    mapM_ (syck_emit_item e) =<< mapM freeze seq 
    157175    syck_emit_end e 
    158176 
    159 emitNode e n@(MkYamlNode{el = YamlMap m}) = do 
     177emitNode freeze e n@(MkYamlNode{el = YamlMap m}) = do 
    160178    withTag n "hash" $ \tag ->  
    161179        syck_emit_map e tag mapNone 
    162180    flip mapM_ m (\(k,v) -> do 
    163         syck_emit_item e =<< freezeNode k 
    164         syck_emit_item e =<< freezeNode v) 
     181        syck_emit_item e =<< freeze k 
     182        syck_emit_item e =<< freeze v) 
    165183    syck_emit_end e 
    166184 
    … …  
    205223        ] 
    206224 
    207 freezeNode :: YamlNode -> IO (Ptr a) 
    208 freezeNode node = do 
     225freezeNode :: Hash.HashTable Int (Ptr a) -> YamlNode -> IO (Ptr a) 
     226freezeNode nodes node@MkYamlNode{ anchor = Just (MkYamlReference n) } = do 
     227    Just ptr <- Hash.lookup nodes n 
     228    return ptr 
     229freezeNode nodes node = do 
    209230    ptr     <- newStablePtr node 
    210     return (castPtr $ castStablePtrToPtr ptr) 
     231    let ptr' = castPtr $ castStablePtrToPtr ptr 
     232    case anchor node of 
     233        Just (MkYamlAnchor n) -> Hash.insert nodes n ptr' >> return ptr' 
     234        _                     -> return ptr' 
    211235 
    212236thawNode :: Ptr () -> IO YamlNode 

  • src/Pugs/Prim/Yaml.hs

    r8999 r9005  
    6767dumpYaml :: Int -> Val -> Eval Val 
    6868dumpYaml limit v = do 
    69     done        <- liftSTM $ newTVar IntMap.empty 
    7069    let ?seen = IntSet.empty 
    71         ?done = done 
    72     obj         <- toYaml v 
    73     nodeMap     <- liftSTM . readTVar $ done 
    74     let replaceNode node@MkYamlNode{ nid = n } 
    75             | n == 0    = node 
    76             | otherwise = (IntMap.!) nodeMap (fromEnum n) 
    77     rv   <- liftIO . emitYaml $ everywhere (mkT replaceNode) obj 
     70    obj     <- toYaml v 
     71    rv      <- liftIO . emitYaml $ obj 
    7872    either (fail . ("YAML Emit Error: "++)) 
    7973           (return . VStr . decodeUTF8) rv 
    … …  
    8781    return (castStablePtrToPtr ptr `minusPtr` (nullPtr :: Ptr ())) 
    8882 
    89 toYaml :: (?seen :: IntSet.IntSet, ?done :: TVar (IntMap.IntMap YamlNode)) => Val -> Eval YamlNode 
     83toYaml :: (?seen :: IntSet.IntSet) => Val -> Eval YamlNode 
    9084toYaml VUndef       = return $ mkNode YamlNil 
    9185toYaml (VBool x)    = return $ boolToYaml x 
    … …  
    9387toYaml v@(VRef r)   = do 
    9488    ptr <- liftIO $ addressOf r 
    95     if IntSet.member ptr ?seen then return nilNode{ nid = toEnum ptr } else do 
     89    if IntSet.member ptr ?seen then return nilNode{ anchor = Just (MkYamlReference ptr) } else do 
    9690        let ?seen = IntSet.insert ptr ?seen 
    9791        node <- ifValTypeIsa v "Hash" (hashToYaml r) $ do 
    … …  
    10195                VObject _   -> nodes 
    10296                _           -> mkNode $ YamlMap [(strNode "<ref>", nodes)] 
    103         liftSTM $ modifyTVar ?done (IntMap.insert ptr node) 
    104         return node 
     97        return node{ anchor = Just (MkYamlAnchor ptr) } 
    10598toYaml (VList nodes) = do 
    10699    n <- mapM toYaml nodes 
    … …  
    125118toYaml v = return $ strNode $ (encodeUTF8 . pretty) v 
    126119 
    127 hashToYaml :: (?seen :: IntSet.IntSet, ?done :: TVar (IntMap.IntMap YamlNode)) => VRef -> Eval YamlNode 
     120hashToYaml :: (?seen :: IntSet.IntSet) => VRef -> Eval YamlNode 
    128121hashToYaml (MkRef (IHash hv)) = do 
    129122    h <- hash_fetch hv