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

Show
Ignore:
Timestamp:
02/14/06 19:26:38 (3 years ago)
Author:
audreyt
Message:

* Dumping recursive YAML structures (currently only TVar) in DrIFT.YAML.

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Prim/Yaml.hs

    r8676 r8994  
    1212import qualified Data.Map as Map 
    1313import qualified Data.IntMap as IntMap 
     14import Foreign.StablePtr 
     15import Foreign.Ptr 
    1416 
    1517evalYaml :: Val -> Eval Val 
    … …  
    6264 
    6365dumpYaml :: Int -> Val -> Eval Val 
    64 dumpYaml limit v = let ?d = limit in do 
    65     obj  <- toYaml v 
     66dumpYaml limit v = do 
     67    obj  <- toYaml IntMap.empty v 
    6668    rv   <- liftIO (emitYaml obj) 
    6769    either (fail . ("YAML Emit Error: "++)) 
    … …  
    7173strNode = mkNode . YamlStr 
    7274 
    73 toYaml :: (?d :: Int) => Val -> Eval YamlNode 
    74 toYaml _ | ?d == 0  = return $ strNode "<deep recursion>" -- fail? make this configurable? 
    75 toYaml VUndef       = return $ mkNode YamlNil 
    76 toYaml (VBool x)    = return $ boolToYaml x 
    77 toYaml (VStr str)   = return $ strNode (encodeUTF8 str) 
    78 toYaml v@(VRef r)   = let ?d = pred ?d in do 
    79     t  <- evalValType v 
    80     ifValTypeIsa v "Hash" (hashToYaml r) $ do 
    81         v'      <- readRef r 
    82         nodes   <- toYaml v' 
    83         ifValTypeIsa v "Array" (return nodes) . return $ case v' of 
    84             VObject _   -> nodes 
    85             _           -> mkNode $ YamlMap [(strNode "<ref>", nodes)] 
    86 toYaml (VList nodes) = let ?d = pred ?d in do 
    87     n <- mapM toYaml nodes 
     75addressOf :: a -> IO Int 
     76addressOf x = do 
     77    ptr <- newStablePtr x 
     78    return (castStablePtrToPtr ptr `minusPtr` (nullPtr :: Ptr ())) 
     79 
     80toYaml :: IntMap YamlNode -> Val -> Eval YamlNode 
     81toYaml _ VUndef       = return $ mkNode YamlNil 
     82toYaml _ (VBool x)    = return $ boolToYaml x 
     83toYaml _ (VStr str)   = return $ strNode (encodeUTF8 str) 
     84toYaml seen v@(VRef r)   = do 
     85    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 
     96toYaml seen (VList nodes) = do 
     97    n <- mapM (toYaml seen) nodes 
    8898    return $ mkNode (YamlSeq n) 
    8999    -- fmap YamlSeq$ mapM toYaml nodes 
    90 toYaml v@(VObject obj) = let ?d = pred ?d in do 
     100toYaml seen v@(VObject obj) = do 
    91101    -- ... dump the objAttrs 
    92102    -- XXX this needs fixing WRT demagicalized pairs: 
    … …  
    94104    -- parens, which is, of course, wrong. 
    95105    hash    <- fromVal v :: Eval VHash 
    96     attrs   <- toYaml $ VRef (hashRef hash) 
     106    attrs   <- toYaml seen $ VRef (hashRef hash) 
    97107    return $ tagNode (Just $ "tag:pugs:object:" ++ showType (objType obj)) attrs 
    98 toYaml (VRule MkRulePGE{rxRule=rule, rxGlobal=global, rxStringify=stringify, rxAdverbs=adverbs}) = let ?d = pred ?d in do 
    99     adverbs' <- toYaml adverbs 
     108toYaml seen (VRule MkRulePGE{rxRule=rule, rxGlobal=global, rxStringify=stringify, rxAdverbs=adverbs}) =do 
     109    adverbs' <- toYaml seen adverbs 
    100110    return . mkTagNode "tag:pugs:Rule" $ YamlMap 
    101111        [ (strNode "rule", strNode rule) 
    … …  
    104114        , (strNode "adverbs", adverbs') 
    105115        ] 
    106 toYaml v = return $ strNode $ (encodeUTF8 . pretty) v 
     116toYaml _ v = return $ strNode $ (encodeUTF8 . pretty) v 
    107117 
    108 hashToYaml :: (?d :: Int) => VRef -> Eval YamlNode 
    109 hashToYaml (MkRef (IHash hv)) = do 
     118hashToYaml :: IntMap YamlNode -> VRef -> Eval YamlNode 
     119hashToYaml seen (MkRef (IHash hv)) = do 
    110120    h <- hash_fetch hv 
    111121    let assocs = Map.toList h 
    112122    yamlmap <- forM assocs $ \(ka, va) -> do 
    113         ka' <- toYaml $ VStr ka 
    114         va' <- toYaml va 
     123        ka' <- toYaml seen $ VStr ka 
     124        va' <- toYaml seen va 
    115125        return (ka', va') 
    116126    return $ mkNode (YamlMap yamlmap) 
    117 hashToYaml r = error ("unexpected node: " ++ show r) 
     127hashToYaml _ r = error ("unexpected node: " ++ show r) 
    118128 
    119129boolToYaml :: VBool -> YamlNode