Changeset 8999

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...

Location:
src
Files:
3 modified

Legend:

Unmodified
Added
Removed

  • src/Data/Yaml/Syck.hsc

    r8992 r8999  
    55module Data.Yaml.Syck ( 
    66    parseYaml, emitYaml, 
    7     YamlNode(..), YamlElem(..), tagNode, nilNode, mkNode, mkTagNode, 
     7    YamlNode(..), YamlElem(..), tagNode, nilNode, mkNode, mkTagNode, SYMID, 
    88) where 
    99 
    … …  
    2020import Foreign.Marshal.Utils 
    2121import Foreign.Storable 
     22import Data.Generics 
    2223 
    2324type YamlTag    = Maybe String 
    2425type YamlAnchor = Maybe String 
    2526type SYMID = CULong 
     27 
     28cuLongType = mkIntType "Foreign.C.Types.CULong" 
     29 
     30instance Data SYMID where 
     31  toConstr x = mkIntConstr cuLongType (fromIntegral x) 
     32  gunfold k z c = case constrRep c of 
     33                    (IntConstr x) -> z (fromIntegral x) 
     34                    _ -> error "gunfold" 
     35  dataTypeOf _ = cuLongType 
    2636 
    2737data YamlNode = MkYamlNode 
    … …  
    3242    , shortcut :: (Maybe YamlNode) 
    3343    } 
    34     deriving (Show, Ord, Eq) 
     44    deriving (Show, Ord, Eq, Typeable, Data) 
    3545 
    3646data YamlElem 
    … …  
    3949    | YamlStr String 
    4050    | YamlNil 
    41     deriving (Show, Ord, Eq) 
     51    deriving (Show, Ord, Eq, Typeable, Data) 
    4252 
    4353type SyckNode = Ptr () 

  • src/Pugs/Prim.hs

    r8993 r8999  
    4848import Pugs.Prim.Code 
    4949import Pugs.Prim.Param 
    50 import qualified Data.Set as Set 
    51 import Foreign.StablePtr 
    52 import Foreign.Ptr 
     50import qualified Data.IntSet as IntSet 
    5351 
    5452-- |Implementation of 0-ary and variadic primitive operators and functions 
    … …  
    226224op1 "perl" = \v -> do 
    227225    recur   <- liftSTM (newTVar False) 
    228     let ?seen  = Set.empty 
     226    let ?seen  = IntSet.empty 
    229227        ?recur = recur 
    230228    rv      <- prettyVal v 
    … …  
    14131411 
    14141412-- op1 "perl" 
    1415 prettyVal :: (?seen :: Set (Ptr ()), ?recur :: TVar Bool) => Val -> Eval VStr 
     1413prettyVal :: (?seen :: IntSet.IntSet, ?recur :: TVar Bool) => Val -> Eval VStr 
    14161414prettyVal v@(VRef r) = do 
    1417     ptr <- liftIO (fmap castStablePtrToPtr (newStablePtr r)) 
    1418     if Set.member ptr ?seen 
     1415    ptr <- liftIO (addressOf r) 
     1416    if IntSet.member ptr ?seen 
    14191417        then do 
    14201418            liftSTM $ writeTVar ?recur True 
    14211419            return "\\$_" 
    1422         else let ?seen = Set.insert ptr ?seen in doPrettyVal v 
     1420        else let ?seen = IntSet.insert ptr ?seen in doPrettyVal v 
    14231421prettyVal v = doPrettyVal v 
    14241422 
    1425 doPrettyVal :: (?seen :: Set (Ptr ()), ?recur :: TVar Bool) => Val -> Eval VStr 
     1423doPrettyVal :: (?seen :: IntSet.IntSet, ?recur :: TVar Bool) => Val -> Eval VStr 
    14261424doPrettyVal v@(VRef r) = do 
    14271425    v'  <- readRef r 

  • 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