Changeset 8566

Timestamp:

01/03/06 23:03:30 (3 years ago)

Author:

gaal

Message:

* beginning of .yaml emitter. "string".yaml.say segfaults, but hey,

it's a start :)

Location:

src

Files:

• Data/Yaml/Syck.hsc (modified) (7 diffs)
• Pugs/Prim.hs (modified) (2 diffs)
• Pugs/Prim/Yaml.hs (modified) (2 diffs)

src/Data/Yaml/Syck.hsc

@@ -1 +1 @@
 {-# OPTIONS_GHC -fglasgow-exts -fvia-C #-}
 #include "../../syck/syck.h"
+#include "../../cbits/fpstring.h"
 
 module Data.Yaml.Syck (
-    parseYaml,
+    parseYaml, emitYaml,
     YamlNode(..),
 ) where
@@ -9 +10 @@
 import Control.Exception (bracket)
 import Data.IORef
+import Data.Word                (Word8)
+import qualified Data.FastPackedString as P
 import Foreign.Ptr
 import Foreign.StablePtr
+import Foreign.ForeignPtr
 import Foreign.C.Types
 import Foreign.C.String
@@ -17 +21 @@
 import Foreign.Storable
 
+import Debug.Trace
+import Control.Monad.Trans
+
 data YamlNode
     = YamlMap [(YamlNode, YamlNode)]
     | YamlSeq [YamlNode]
     | YamlStr String
+    | YamlNil
     deriving (Show, Ord, Eq)
 
@@ -29 +37 @@
 type SyckErrorHandler = SyckParser -> CString -> IO ()
 type SyckNodePtr = Ptr CString
-data SyckKind = SyckMap | SyckSeq | SyckStr
+type FSPtr = Ptr CString
+type SyckEmitter = Ptr ()  
+type SyckEmitterHandler = SyckEmitter -> Ptr () -> IO ()
+type SyckOutputHandler = SyckEmitter -> CString -> CLong -> IO ()
+data SyckKind = SyckMap | SyckSeq | SyckStr | SyckNil
     deriving (Show, Ord, Eq, Enum)
+
+-- the extra comma here is not a bug
+#enum CInt, , scalar_none, scalar_1quote, scalar_2quote, scalar_fold, scalar_literal, scalar_plain
+
+#def typedef struct _EmitterExtras { char * ps; int l; } EmitterExtras;
+type EmitterExtras = Ptr ()
+
+emitYaml :: YamlNode -> IO (Either String String)
+emitYaml node = do
+    alloca $ \(emitterExtras :: Ptr EmitterExtras) -> do
+        bracket syck_new_emitter syck_free_emitter $ \emitter -> do
+            -- set up output port
+            let out = P.empty
+                (outps, _, l) = P.toForeignPtr out
+            outpsF <- freezeFS outps
+            #{poke EmitterExtras, ps}  emitterExtras outpsF
+            #{poke EmitterExtras, l}   emitterExtras l
+            #{poke SyckEmitter, bonus} emitter       emitterExtras
+            syck_output_handler emitter =<< mkOutputCallback outputCallback
+            syck_emitter_handler emitter =<< mkEmitterCallback emitterCallback
+            nodePtr <- freezeNode node
+            let nodePtr' = fromIntegral $ nodePtr `minusPtr` nullPtr
+            trace ("node: " ++ (show node) ++ " nodePtr': " ++ (show nodePtr')) $ return ()
+            syck_emit emitter nodePtr'
+            syck_emitter_flush emitter 0
+            return . Right $ P.unpack out -- TODO: handle Left
+
+outputCallback :: SyckEmitter -> CString -> CLong -> IO ()
+outputCallback emitter buf len = do
+    bonus <- #{peek SyckEmitter, bonus} emitter
+    fp    <- readFS =<< #{peek EmitterExtras, ps}  bonus
+    l     <- #{peek EmitterExtras, l}   bonus
+    let fps = P.fromForeignPtr fp l
+    let new = P.packCStringLen (buf, fromIntegral len)
+    let (catPS, _, catL) = P.toForeignPtr $ P.append fps new
+    catPSF <- freezeFS catPS
+    #{poke EmitterExtras, ps} bonus catPSF
+    #{poke EmitterExtras, l}  bonus catL
+    return ()
+
+freezeFS :: ForeignPtr Word8 -> IO FSPtr
+freezeFS ps = do
+    ptr     <- newStablePtr ps
+    new (castPtr $ castStablePtrToPtr ptr)
+
+readFS :: FSPtr -> IO (ForeignPtr Word8)
+readFS fs = do
+    ptr     <- peek . castPtr =<< peek fs
+    deRefStablePtr (castPtrToStablePtr ptr)
+
+emitterCallback :: SyckEmitter -> Ptr () -> IO ()
+emitterCallback e vp = do 
+    node <- thawNode vp
+    case node of
+        (YamlStr str) -> do
+            -- return syck_emit_scalar(e, "string", scalar_none, 0, 0, 0, SvPVX(sv), SvCUR(sv));
+            withCString "string" $ \string_literal ->       
+                withCString str $ \cs ->       
+                    syck_emit_scalar e string_literal scalarNone 0 0 0 cs (toEnum $ length str)
 
 parseYaml :: String -> IO (Either String (Maybe YamlNode))
@@ -69 +140 @@
         ]
 
-freezeNode :: YamlNode -> IO SyckNodePtr
+--freezeNode :: YamlNode -> IO SyckNodePtr
 freezeNode node = do
     ptr     <- newStablePtr node
     new (castPtr $ castStablePtrToPtr ptr)
+
+thawNode :: Ptr () -> IO YamlNode
+thawNode nodePtr = do
+    trace ("thawNode: nodePtr=" ++ show nodePtr) $ return ()
+    --let ptr = castPtr nodePtr
+    --trace ("thawNode: ptr=" ++ show ptr) $ return ()
+    -- deRefStablePtr (castPtrToStablePtr ptr)
+    rv <- deRefStablePtr (castPtrToStablePtr nodePtr)
+    rv' <- rv
+    trace ("thawNode: rv=" ++ show rv') $ return ()
+    rv
+    
 
 readNode :: SyckParser -> SYMID -> IO YamlNode
@@ -115 +198 @@
     mkErrorCallback :: SyckErrorHandler -> IO (FunPtr SyckErrorHandler)
 
+foreign import ccall "wrapper"
+    mkOutputCallback :: SyckOutputHandler -> IO (FunPtr SyckOutputHandler)
+
+foreign import ccall "wrapper"
+    mkEmitterCallback :: SyckEmitterHandler -> IO (FunPtr SyckEmitterHandler)
+
 foreign import ccall
     syck_new_parser :: IO SyckParser
@@ -153 +242 @@
 foreign import ccall
     syck_map_read :: SyckNode -> CInt -> CLong -> IO SYMID
+
+foreign import ccall
+    syck_new_emitter :: IO SyckEmitter
+
+foreign import ccall
+    syck_free_emitter :: SyckEmitter -> IO ()
+
+foreign import ccall
+    syck_emitter_handler :: SyckEmitter -> FunPtr SyckEmitterHandler -> IO ()
+
+foreign import ccall
+    syck_output_handler :: SyckEmitter -> FunPtr SyckOutputHandler -> IO ()
+
+foreign import ccall
+    syck_emit :: SyckEmitter -> CLong -> IO ()
+
+foreign import ccall
+    syck_emitter_flush :: SyckEmitter -> CLong -> IO ()
+
+foreign import ccall
+    syck_emit_scalar :: SyckEmitter -> CString -> CInt -> CInt -> CInt -> CInt -> CString -> CInt -> IO ()
+

src/Pugs/Prim.hs

@@ -223 +223 @@
 op1 "none" = op1Cast opJuncNone
 op1 "perl" = fmap VStr . prettyVal 0
+op1 "yaml" = dumpYaml
 op1 "require_haskell" = \v -> do
     name    <- fromVal v
@@ -1559 +1560 @@
 \\n   Any       pre     Pugs::Internals::eval_haskell unsafe (Str)\
 \\n   Any       pre     Pugs::Internals::eval_yaml    safe   (Str)\
+\\n   Any       pre     yaml    safe   (Any)\
 \\n   Any       pre     require unsafe (?Str=$_)\
 \\n   Any       pre     use     unsafe (?Str=$_)\

src/Pugs/Prim/Yaml.hs

@@ -3 +3 @@
 
 module Pugs.Prim.Yaml (
-  evalYaml
+  evalYaml, dumpYaml
 ) where
 import Pugs.Internals
@@ -34 +34 @@
     hv      <- liftSTM $ (newTVar (Map.fromList vals) :: STM IHash)
     return $ VRef (hashRef hv)
+
+dumpYaml :: Val -> Eval Val
+dumpYaml v = do
+    obj  <- toYaml =<< fromVal v
+    rv   <- liftIO (emitYaml obj)
+    case rv of
+        Left err  -> fail $ "YAML Emit Error: " ++ err
+        Right str -> return $ VStr str
+
+toYaml :: Val -> Eval YamlNode
+toYaml VUndef = return YamlNil
+toYaml (VStr str) = return $ YamlStr (encodeUTF8 str)
+toYaml (VList nodes) = do
+    fmap YamlSeq $ mapM toYaml nodes
+--toYaml (VHash hash) = do
+--    fmap YamlMap $ Map.toList hash
+
+
+