Changeset 9039

Show
Ignore:
Timestamp:
02/16/06 19:06:21 (3 years ago)
Author:
audreyt
Message:

* Strictify the whole yaml dumping process.

Location:
src
Files:
3 modified

Legend:

Unmodified
Added
Removed

  • src/Data/Yaml/Syck.hsc

    r9035 r9039  
    1 {-# OPTIONS_GHC -fglasgow-exts -fvia-C -optc-w -fno-warn-unused-binds #-} 
     1{-# OPTIONS_GHC -fglasgow-exts -fvia-C -optc-w -funbox-strict-fields #-} 
    22#include "../../syck/syck.h" 
    33#include "../../cbits/fpstring.h" 
    … …  
    2424import qualified Data.HashTable as Hash 
    2525import qualified Data.FastPackedString as Str 
     26import GHC.Ptr  (Ptr(..)) 
    2627 
    2728type Str        = Str.FastString 
    2829type YamlTag    = Maybe Str 
    2930data YamlAnchor 
    30     = MkYamlAnchor    Int 
    31     | MkYamlReference Int 
     31    = MkYamlAnchor    !Int 
     32    | MkYamlReference !Int 
     33    | MkYamlSingleton 
    3234    deriving (Show, Ord, Eq, Typeable, Data) 
    3335type SYMID = CULong 
    … …  
    4143 
    4244data YamlNode = MkYamlNode 
    43     { nid      :: SYMID 
    44     , el       :: YamlElem 
    45     , tag      :: YamlTag 
    46     , anchor   :: Maybe YamlAnchor 
     45    { nid      :: !SYMID 
     46    , el       :: !YamlElem 
     47    , tag      :: !YamlTag 
     48    , anchor   :: !YamlAnchor 
    4749    } 
    4850    deriving (Show, Ord, Eq, Typeable, Data) 
    … …  
    5153    = YamlMap [(YamlNode, YamlNode)] 
    5254    | YamlSeq [YamlNode] 
    53     | YamlStr Str 
     55    | YamlStr !Str 
    5456    | YamlNil 
    5557    deriving (Show, Ord, Eq, Typeable, Data) 
    … …  
    6870 
    6971nilNode :: YamlNode 
    70 nilNode = MkYamlNode 0 YamlNil Nothing Nothing 
     72nilNode = MkYamlNode 0 YamlNil Nothing MkYamlSingleton 
    7173 
    7274tagNode :: YamlTag -> YamlNode -> YamlNode 
    … …  
    7577 
    7678mkNode :: YamlElem -> YamlNode 
    77 mkNode x = MkYamlNode 0 x Nothing Nothing 
     79mkNode x = MkYamlNode 0 x Nothing MkYamlSingleton 
    7880 
    7981mkTagNode :: String -> YamlElem -> YamlNode 
    80 mkTagNode s x = MkYamlNode 0 x (Just $ Str.pack s) Nothing 
     82mkTagNode s x = MkYamlNode 0 x (Just $ Str.pack s) MkYamlSingleton 
    8183 
    8284-- the extra commas here are not a bug 
    … …  
    8991type EmitterExtras = Ptr () 
    9092-} 
    91  
    92 {-# NOINLINE _decLiteralFS #-} 
    93 _decLiteralFS = Str.unsafePackAddress 3 "%d"## 
    9493 
    9594emitYamlFS :: YamlNode -> IO (Either Str.FastString Str.FastString) 
    … …  
    10099        #{poke SyckEmitter, style} emitter scalarFold 
    101100        -- #{poke SyckEmitter, sort_keys} emitter (1 :: CInt) 
    102         Str.useAsCString _decLiteralFS $ #{poke SyckEmitter, anchor_format} emitter 
     101        #{poke SyckEmitter, anchor_format} emitter (Ptr "%d"## :: CString) 
    103102 
    104103        marks <- Hash.new (==) (Hash.hashInt) 
    … …  
    108107        syck_output_handler emitter =<< mkOutputCallback (outputCallbackPS out) 
    109108 
    110         markYamlNode marks emitter node 
     109        markYamlNode freeze emitter node 
    111110 
    112111        nodePtr <- freeze node 
    … …  
    119118emitYaml node = fmap (either (Left . Str.unpack) (Right . Str.unpack)) (emitYamlFS node) 
    120119 
    121 markYamlNode :: Hash.HashTable Int SyckNodePtr -> SyckEmitter -> YamlNode -> IO () 
    122 markYamlNode marks emitter MkYamlNode{ anchor = Just (MkYamlReference n) } = do 
     120markYamlNode :: (YamlNode -> IO SyckNodePtr) -> SyckEmitter -> YamlNode -> IO () 
     121{- 
     122markYamlNode marks emitter MkYamlNode{ anchor = MkYamlReference n } = do 
    123123    Just nodePtr <- Hash.lookup marks n 
    124124    syck_emitter_mark_node emitter nodePtr 
    125125    return () 
    126 markYamlNode marks emitter node = do 
    127     nodePtr <- freezeNode marks node 
     126-} 
     127markYamlNode freeze emitter node = do 
     128    nodePtr <- freeze node 
    128129    rv      <- syck_emitter_mark_node emitter nodePtr 
    129130    if rv == 0 then return () else do 
    130     case anchor node of 
    131         Just (MkYamlAnchor n) -> Hash.insert marks n nodePtr 
    132         _                     -> return () 
    133131    case el node of 
    134132        YamlMap xs  -> sequence_ [ mark x >> mark y | (x, y) <- xs ] 
    … …  
    136134        _           -> return () 
    137135    where 
    138     mark = markYamlNode marks emitter 
     136    mark = markYamlNode freeze emitter 
    139137 
    140138outputCallbackPS :: IORef [Str.FastString] -> SyckEmitter -> CString -> CLong -> IO () 
    … …  
    150148    modifyIORef out (++ str) 
    151149 
    152 freezeFS :: ForeignPtr Word8 -> IO FSPtr 
    153 freezeFS ps = do 
    154     ptr     <- newStablePtr ps 
    155     return (castPtr $ castStablePtrToPtr ptr) 
    156  
    157 readFS :: FSPtr -> IO (ForeignPtr Word8) 
    158 readFS fs = do 
    159     ptr     <- peek . castPtr =<< peek fs 
    160     deRefStablePtr (castPtrToStablePtr ptr) 
    161  
    162 {-# NOINLINE _stringLiteralFS #-} 
    163 {-# NOINLINE _tildeLiteralFS #-} 
    164 {-# NOINLINE _arrayLiteralFS #-} 
    165 {-# NOINLINE _hashLiteralFS #-} 
    166 _stringLiteralFS = Str.unsafePackAddress 7 "string"## 
    167 _tildeLiteralFS  = Str.unsafePackAddress 2 "~"## 
    168 _arrayLiteralFS  = Str.unsafePackAddress 6 "array"## 
    169 _hashLiteralFS   = Str.unsafePackAddress 5 "hash"## 
    170  
    171150emitterCallback :: (YamlNode -> IO SyckNodePtr) -> SyckEmitter -> Ptr () -> IO () 
    172151emitterCallback f e vp = emitNode f e =<< thawNode vp 
    173152 
     153{-# NOINLINE _tildeLiteralFS #-} 
     154_tildeLiteralFS = Str.pack "~" 
     155 
    174156emitNode :: (YamlNode -> IO SyckNodePtr) -> SyckEmitter -> YamlNode -> IO () 
    175157emitNode _ e n@(MkYamlNode{el = YamlNil}) = do 
    176     withTag n _stringLiteralFS $ \tag -> 
    177         Str.useAsCString _tildeLiteralFS $ \cs ->        
    178             syck_emit_scalar e tag scalarNone 0 0 0 cs 1 
    179  
    180 emitNode _ e n@(MkYamlNode{el = YamlStr s}) | s == _tildeLiteralFS = do 
    181     withTag n _stringLiteralFS $ \tag -> 
    182         Str.useAsCString _tildeLiteralFS $ \cs -> 
    183             syck_emit_scalar e tag scalar1quote 0 0 0 cs 1 
     158    withTag n (Ptr "string"##) $ \tag -> 
     159        syck_emit_scalar e tag scalarNone 0 0 0 (Ptr "~"##) 1 
     160 
     161emitNode _ e n@(MkYamlNode{el = YamlStr s}) | Str.length s == 1, Str.head s == '~' = do 
     162    withTag n (Ptr "string"##) $ \tag -> 
     163        syck_emit_scalar e tag scalar1quote 0 0 0 (Ptr "~"##) 1 
    184164 
    185165emitNode _ e n@(MkYamlNode{el = YamlStr str}) = do 
    186     withTag n _stringLiteralFS $ \tag ->        
     166    withTag n (Ptr "string"##) $ \tag -> 
    187167        Str.unsafeUseAsCStringLen str $ \(cs, l) ->        
    188             syck_emit_scalar e tag scalarNone 0 0 0 cs (toEnum l) 
     168        syck_emit_scalar e tag scalarNone 0 0 0 cs (toEnum l) 
    189169 
    190170emitNode freeze e n@(MkYamlNode{el = YamlSeq seq}) = do 
    191     withTag n _arrayLiteralFS $ \tag -> 
     171    withTag n (Ptr "array"##) $ \tag -> 
    192172        syck_emit_seq e tag seqNone 
    193173    mapM_ (syck_emit_item e) =<< mapM freeze seq 
    … …  
    195175 
    196176emitNode freeze e n@(MkYamlNode{el = YamlMap m}) = do 
    197     withTag n _hashLiteralFS $ \tag ->  
     177    withTag n (Ptr "map"##) $ \tag -> 
    198178        syck_emit_map e tag mapNone 
    199179    flip mapM_ m (\(k,v) -> do 
    … …  
    202182    syck_emit_end e 
    203183 
    204 withTag :: YamlNode -> Str -> (CString -> IO a) -> IO a 
    205 withTag node def f = Str.useAsCString (maybe def id (tag node)) f 
     184withTag :: YamlNode -> CString -> (CString -> IO a) -> IO a 
     185withTag node def f = maybe (f def) (`Str.useAsCString` f) (tag node) 
    206186 
    207187parseYaml :: String -> IO (Either String (Maybe YamlNode)) 
    … …  
    249229 
    250230freezeNode :: Hash.HashTable Int (Ptr a) -> YamlNode -> IO (Ptr a) 
    251 freezeNode nodes node@MkYamlNode{ anchor = Just (MkYamlReference n) } = do 
     231freezeNode nodes node@MkYamlNode{ anchor = MkYamlReference n } = do 
    252232    Just ptr <- Hash.lookup nodes n 
    253233    return ptr 
    … …  
    256236    let ptr' = castPtr $ castStablePtrToPtr ptr 
    257237    case anchor node of 
    258         Just (MkYamlAnchor n) -> Hash.insert nodes n ptr' >> return ptr' 
    259         _                     -> return ptr' 
     238        MkYamlAnchor n -> do 
     239            Hash.insert nodes n ptr' 
     240            return ptr' 
     241        _              -> return ptr' 
    260242 
    261243thawNode :: Ptr () -> IO YamlNode 
    … …  
    275257{-# NOINLINE _tagLiteralFS #-} 
    276258{-# NOINLINE  _colonLiteralFS #-} 
    277 _tagLiteralFS   = Str.unsafePackAddress 4 "tag:"## 
    278 _colonLiteralFS = Str.unsafePackAddress 1 ":"## 
     259_tagLiteralFS   = Str.pack "tag:" 
     260_colonLiteralFS = Str.pack ":" 
    279261 
    280262syckNodeTag :: SyckNode -> IO (Maybe Str) 

  • src/DrIFT/YAML.hs

    r9035 r9039  
    1212import Control.Concurrent.STM 
    1313import Data.IORef 
    14 import qualified Data.IntMap as IntMap 
     14import qualified Data.IntSet as IntSet 
    1515import Foreign.StablePtr 
    1616import Foreign.Ptr 
    … …  
    2424type YAMLKey = String 
    2525type YAMLVal = YamlNode 
    26 type SeenCache = IntMap.IntMap YamlNode 
     26type SeenCache = IntSet.IntSet 
    2727 
    2828showYaml :: YAML a => a -> IO String 
    2929showYaml x = do 
    30     node    <- (`runReaderT` IntMap.empty) (asYAML x) 
     30    node    <- (`runReaderT` IntSet.empty) (asYAML x) 
    3131    rv      <- emitYaml node 
    3232    case rv of 
    … …  
    8686instance YAML () where 
    8787    asYAML _ = return nilNode 
    88     fromYAML _ = return () 
     88    fromYAMLElem _ = return () 
    8989 
    9090instance YAML Int where 
    … …  
    101101    fromYAML MkYamlNode{tag=Just s} | s == Str.pack "bool#yes" = return True 
    102102    fromYAML MkYamlNode{tag=Just s} | s == Str.pack "bool#no"  = return False 
     103    fromYAML MkYamlNode{el=x} = fromYAMLElem x 
     104    fromYAMLElem ~(YamlStr x) = return (x == Str.pack "0") 
    103105 
    104106instance YAML Integer where  
    … …  
    123125    fromYAML MkYamlNode{tag=Just s} | s == Str.pack "float#neginf" = return $ -1/0 -- "-Infinity"  
    124126    fromYAML MkYamlNode{tag=Just s} | s == Str.pack "float#nan"    = return $  0/0 -- "NaN"  
    125     fromYAML ~MkYamlNode{el=YamlStr x}                             = return $ read $ Str.unpack x 
     127    fromYAML MkYamlNode{el=x} = fromYAMLElem x 
     128    fromYAMLElem ~(YamlStr x) = return $ read $ Str.unpack x 
    126129 
    127130instance (YAML a) => YAML (Maybe a) where 
    … …  
    130133    fromYAML MkYamlNode{el=YamlNil} = return Nothing 
    131134    fromYAML x = return . Just =<< fromYAML x 
     135    fromYAMLElem YamlNil = return Nothing 
     136    fromYAMLElem x = return . Just =<< fromYAMLElem x 
    132137 
    133138instance (YAML a) => YAML [a] where 
    … …  
    135140        xs' <- mapM asYAML xs 
    136141        (return . mkNode . YamlSeq) xs' 
    137     fromYAML ~MkYamlNode{el=YamlSeq s} = mapM fromYAML s 
     142    fromYAMLElem ~(YamlSeq s) = mapM fromYAML s 
    138143 
    139144instance (YAML a, YAML b) => YAML (a, b) where 
    … …  
    142147        y' <- asYAML y 
    143148        return $ mkNode (YamlSeq [x', y']) 
    144     fromYAML ~MkYamlNode{el=YamlSeq [x, y]} = do 
     149    fromYAMLElem ~(YamlSeq [x, y]) = do 
    145150        x' <- fromYAML x 
    146151        y' <- fromYAML y 
    … …  
    153158        z' <- asYAML z 
    154159        return $ mkNode (YamlSeq [x', y', z']) 
    155     fromYAML ~MkYamlNode{el=YamlSeq [x, y, z]} = do 
     160    fromYAMLElem ~(YamlSeq [x, y, z]) = do 
    156161        x' <- fromYAML x 
    157162        y' <- fromYAML y 
    … …  
    161166instance (Typeable a, YAML a) => YAML (TVar a) where 
    162167    asYAML = asYAMLwith (lift . atomically . readTVar) 
     168    fromYAML = (atomically . newTVar =<<) . fromYAML 
     169    fromYAMLElem = (atomically . newTVar =<<) . fromYAMLElem 
    163170 
    164171asYAMLwith :: (YAML a, YAML b) => (a -> EmitAs b) -> a -> EmitAs YamlNode 
    … …  
    166173    ptr  <- liftIO $ addressOf x 
    167174    seen <- ask 
    168     case IntMap.lookup ptr seen of 
    169         Just node   -> return node 
    170         _           -> mdo 
    171             rv   <- local (IntMap.insert ptr rv) (asYAML =<< f x) 
    172             return rv 
     175    if IntSet.member ptr seen 
     176        then return nilNode{ anchor = MkYamlReference ptr }  
     177        else do 
     178            rv   <- local (IntSet.insert ptr) (asYAML =<< f x) 
     179            return rv{ anchor = MkYamlAnchor ptr } 
    173180 
    174181addressOf :: a -> IO Int 

  • src/Pugs/Prim/Yaml.hs

    r9021 r9039  
    9292toYaml v@(VRef r)   = do 
    9393    ptr <- liftIO $ addressOf r 
    94     if IntSet.member ptr ?seen then return nilNode{ anchor = Just (MkYamlReference ptr) } else do 
     94    if IntSet.member ptr ?seen then return nilNode{ anchor = MkYamlReference ptr } else do 
    9595        let ?seen = IntSet.insert ptr ?seen 
    9696        node <- ifValTypeIsa v "Hash" (hashToYaml r) $ do 
    … …  
    100100                VObject _   -> nodes 
    101101                _           -> mkNode $ YamlMap [(strNode "<ref>", nodes)] 
    102         return node{ anchor = Just (MkYamlAnchor ptr) } 
     102        return node{ anchor = MkYamlAnchor ptr } 
    103103toYaml (VList nodes) = do 
    104104    n <- mapM toYaml nodes