Changeset 8994

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.

Location:
src
Files:
4 modified

Legend:

Unmodified
Added
Removed

  • src/DrIFT/YAML.hs

    r8990 r8994  
    1010import Control.Exception 
    1111import Control.Monad 
     12import Control.Concurrent.STM 
     13import Data.IORef 
     14import qualified Data.IntMap as IntMap 
     15import Foreign.StablePtr 
     16import Foreign.Ptr 
     17import System.IO.Unsafe 
     18import Control.Monad.Reader 
    1219 
    1320type YAMLClass = String 
    1421type YAMLKey = String 
    1522type YAMLVal = YamlNode 
     23type SeenCache = IntMap.IntMap YamlNode 
     24 
     25{-# NOINLINE _SeenCache #-} 
     26_SeenCache :: IORef (IntMap.IntMap YamlNode) 
     27_SeenCache = unsafePerformIO $ newIORef IntMap.empty 
    1628 
    1729showYaml :: YAML a => a -> IO String 
    1830showYaml x = do 
    19     node    <- asYAML x 
     31    node    <- (`runReaderT` IntMap.empty) (asYAMLrec x) 
    2032    rv      <- emitYaml node 
    2133    case rv of 
    … …  
    2436 
    2537class Typeable a => YAML a where 
     38    asYAMLrec :: a -> ReaderT SeenCache IO YamlNode 
     39    asYAMLrec = lift . asYAML 
    2640    asYAML :: a -> IO YamlNode 
    2741    asYAML x = do 
    … …  
    3145            "()" -> nilNode 
    3246            _    -> mkTagNode (tagHs ty) YamlNil 
    33     fromYAML:: YamlNode -> IO a 
     47    fromYAML :: YamlNode -> IO a 
    3448    fromYAML (MkYamlNode{el=x}) = fromYAMLElem x 
    3549    fromYAMLElem :: YamlElem -> IO a 
    … …  
    125139    fromYAML ~(MkYamlNode{el=YamlSeq [x, y, z]}) = liftM3 (,,) (fromYAML x) (fromYAML y) (fromYAML z) 
    126140 
     141instance (Typeable a, YAML a) => YAML (TVar a) where 
     142    asYAMLrec tv = do 
     143        ptr  <- liftIO $ addressOf tv 
     144        seen <- liftIO $ readIORef _SeenCache 
     145        case IntMap.lookup ptr seen of 
     146            Just node   -> return node 
     147            _           -> mdo 
     148                rv   <- local (IntMap.insert ptr rv) $ mdo 
     149                    v   <- lift (atomically (readTVar tv)) 
     150                    asYAMLrec v 
     151                return rv 
     152 
     153addressOf :: a -> IO Int 
     154addressOf x = do 
     155    ptr <- newStablePtr x 
     156    return (castStablePtrToPtr ptr `minusPtr` (nullPtr :: Ptr ())) 

  • src/Pugs/AST/Internals.hs

    r8985 r8994  
    829829    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML, Perl5, JSON!-} 
    830830 
    831 instance (Typeable a, YAML a) => YAML (TVar a) where 
    832     asYAML tv = do 
    833         v <- liftSTM (readTVar tv) 
    834         asYAML v 
    835  
    836831-- | A list of formal parameters. 
    837832type Params     = [Param] 

  • src/Pugs/AST/Internals.hs-drift

    r8775 r8994  
    835835    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML, Perl5, JSON!-} 
    836836 
    837 instance (Typeable a, YAML a) => YAML (TVar a) where 
    838     asYAML tv = do 
    839         v <- liftSTM (readTVar tv) 
    840         asYAML v 
    841  
    842837-- | A list of formal parameters. 
    843838type Params     = [Param] 

  • 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