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

Show
Ignore:
Timestamp:
02/14/06 21:23:12 (3 years ago)
Author:
audreyt
Message:

* first cut (incomplete) of dumping recursive YAML

structures via .yaml. SYMID resolution still needs work.
At least it doesn't infinite loop now...

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Prim/Yaml.hs

    r8994 r8999  
    33 
    44module Pugs.Prim.Yaml ( 
    5   evalYaml, dumpYaml 
     5  evalYaml, dumpYaml, addressOf, 
    66) where 
    77import Pugs.Internals 
    … …  
    1111import Data.Yaml.Syck 
    1212import qualified Data.Map as Map 
     13import qualified Data.IntSet as IntSet 
    1314import qualified Data.IntMap as IntMap 
    1415import Foreign.StablePtr 
    1516import Foreign.Ptr 
     17import Data.Generics 
    1618 
    1719evalYaml :: Val -> Eval Val 
    … …  
    6567dumpYaml :: Int -> Val -> Eval Val 
    6668dumpYaml limit v = do 
    67     obj  <- toYaml IntMap.empty v 
    68     rv   <- liftIO (emitYaml obj) 
     69    done        <- liftSTM $ newTVar IntMap.empty 
     70    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 
    6978    either (fail . ("YAML Emit Error: "++)) 
    7079           (return . VStr . decodeUTF8) rv 
    … …  
    7887    return (castStablePtrToPtr ptr `minusPtr` (nullPtr :: Ptr ())) 
    7988 
    80 toYaml :: IntMap YamlNode -> Val -> Eval YamlNode 
    81 toYaml _ VUndef       = return $ mkNode YamlNil 
    82 toYaml _ (VBool x)    = return $ boolToYaml x 
    83 toYaml _ (VStr str)   = return $ strNode (encodeUTF8 str) 
    84 toYaml seen v@(VRef r)   = do 
     89toYaml :: (?seen :: IntSet.IntSet, ?done :: TVar (IntMap.IntMap YamlNode)) => Val -> Eval YamlNode 
     90toYaml VUndef       = return $ mkNode YamlNil 
     91toYaml (VBool x)    = return $ boolToYaml x 
     92toYaml (VStr str)   = return $ strNode (encodeUTF8 str) 
     93toYaml v@(VRef r)   = do 
    8594    ptr <- liftIO $ addressOf r 
    86     case IntMap.lookup ptr seen of 
    87         Just node   -> return node 
    88         Nothing     -> do 
    89             rv <- ifValTypeIsa v "Hash" (hashToYaml seen r) $ do 
    90                 v'      <- readRef r 
    91                 nodes   <- toYaml seen v' -- XXX -- (IntMap.insert ptr rv seen) v' 
    92                 ifValTypeIsa v "Array" (return nodes) . return $ case v' of 
    93                     VObject _   -> nodes 
    94                     _           -> mkNode $ YamlMap [(strNode "<ref>", nodes)] 
    95             return rv 
    96 toYaml seen (VList nodes) = do 
    97     n <- mapM (toYaml seen) nodes 
     95    if IntSet.member ptr ?seen then return nilNode{ nid = toEnum ptr } else do 
     96        let ?seen = IntSet.insert ptr ?seen 
     97        node <- ifValTypeIsa v "Hash" (hashToYaml r) $ do 
     98            v'      <- readRef r 
     99            nodes   <- toYaml v' 
     100            ifValTypeIsa v "Array" (return nodes) . return $ case v' of 
     101                VObject _   -> nodes 
     102                _           -> mkNode $ YamlMap [(strNode "<ref>", nodes)] 
     103        liftSTM $ modifyTVar ?done (IntMap.insert ptr node) 
     104        return node 
     105toYaml (VList nodes) = do 
     106    n <- mapM toYaml nodes 
    98107    return $ mkNode (YamlSeq n) 
    99108    -- fmap YamlSeq$ mapM toYaml nodes 
    100 toYaml seen v@(VObject obj) = do 
     109toYaml v@(VObject obj) = do 
    101110    -- ... dump the objAttrs 
    102111    -- XXX this needs fixing WRT demagicalized pairs: 
    … …  
    104113    -- parens, which is, of course, wrong. 
    105114    hash    <- fromVal v :: Eval VHash 
    106     attrs   <- toYaml seen $ VRef (hashRef hash) 
     115    attrs   <- toYaml $ VRef (hashRef hash) 
    107116    return $ tagNode (Just $ "tag:pugs:object:" ++ showType (objType obj)) attrs 
    108 toYaml seen (VRule MkRulePGE{rxRule=rule, rxGlobal=global, rxStringify=stringify, rxAdverbs=adverbs}) =do 
    109     adverbs' <- toYaml seen adverbs 
     117toYaml (VRule MkRulePGE{rxRule=rule, rxGlobal=global, rxStringify=stringify, rxAdverbs=adverbs}) =do 
     118    adverbs' <- toYaml adverbs 
    110119    return . mkTagNode "tag:pugs:Rule" $ YamlMap 
    111120        [ (strNode "rule", strNode rule) 
    … …  
    114123        , (strNode "adverbs", adverbs') 
    115124        ] 
    116 toYaml _ v = return $ strNode $ (encodeUTF8 . pretty) v 
     125toYaml v = return $ strNode $ (encodeUTF8 . pretty) v 
    117126 
    118 hashToYaml :: IntMap YamlNode -> VRef -> Eval YamlNode 
    119 hashToYaml seen (MkRef (IHash hv)) = do 
     127hashToYaml :: (?seen :: IntSet.IntSet, ?done :: TVar (IntMap.IntMap YamlNode)) => VRef -> Eval YamlNode 
     128hashToYaml (MkRef (IHash hv)) = do 
    120129    h <- hash_fetch hv 
    121130    let assocs = Map.toList h 
    122131    yamlmap <- forM assocs $ \(ka, va) -> do 
    123         ka' <- toYaml seen $ VStr ka 
    124         va' <- toYaml seen va 
     132        ka' <- toYaml $ VStr ka 
     133        va' <- toYaml va 
    125134        return (ka', va') 
    126135    return $ mkNode (YamlMap yamlmap) 
    127 hashToYaml _ r = error ("unexpected node: " ++ show r) 
     136hashToYaml r = error ("unexpected node: " ++ show r) 
    128137 
    129138boolToYaml :: VBool -> YamlNode