Changeset 9021

Show
Ignore:
Timestamp:
02/15/06 21:26:43 (3 years ago)
Author:
gaal
svk:copy_cache_prev:
11571
Message:

* change pugs' YAML emission client code to use audreyt++'s speedupped FastString?

Location:
src
Files:
5 modified

Legend:

Unmodified
Added
Removed

  • src/Data/Yaml/Syck.hsc

    r9018 r9021  
    2323import Data.Generics 
    2424import qualified Data.HashTable as Hash 
    25  
    26 type YamlTag    = Maybe String 
     25import qualified Data.FastPackedString as Str 
     26 
     27type Str        = Str.FastString 
     28type YamlTag    = Maybe Str 
    2729data YamlAnchor 
    2830    = MkYamlAnchor    Int 
    … …  
    4951    = YamlMap [(YamlNode, YamlNode)] 
    5052    | YamlSeq [YamlNode] 
    51     | YamlStr String 
     53    | YamlStr Str 
    5254    | YamlNil 
    5355    deriving (Show, Ord, Eq, Typeable, Data) 
    … …  
    6971 
    7072tagNode :: YamlTag -> YamlNode -> YamlNode 
    71 tagNode _ MkYamlNode{tag=Just x} = error ("can't add tag: already tagged with" ++ x) 
     73tagNode _ MkYamlNode{tag=Just x} = error ("can't add tag: already tagged with" ++ (Str.unpack x)) 
    7274tagNode tag node                 = node{tag = tag} 
    7375 
    … …  
    7678 
    7779mkTagNode :: String -> YamlElem -> YamlNode 
    78 mkTagNode s x = MkYamlNode 0 x (Just s) Nothing 
     80mkTagNode s x = MkYamlNode 0 x (Just $ Str.pack s) Nothing 
    7981 
    8082-- the extra commas here are not a bug 
    … …  
    165167            syck_emit_scalar e tag scalarNone 0 0 0 cs 1 
    166168 
    167 emitNode _ e n@(MkYamlNode{el = YamlStr "~"}) = do 
    168     withTag n "string" $ \tag ->        
    169         withCString "~" $ \cs ->        
     169emitNode _ e n@(MkYamlNode{el = YamlStr s}) | s == Str.pack "~" = do 
     170    withTag n "string" $ \tag -> 
     171        withCString "~" $ \cs -> 
    170172            syck_emit_scalar e tag scalar1quote 0 0 0 cs 1 
    171173 
    172174emitNode _ e n@(MkYamlNode{el = YamlStr str}) = do 
    173175    withTag n "string" $ \tag ->        
    174         withCString str $ \cs ->        
    175             syck_emit_scalar e tag scalarNone 0 0 0 cs (toEnum $ length str) 
     176        Str.unsafeUseAsCStringLen str $ \(cs, l) ->        
     177            syck_emit_scalar e tag scalarNone 0 0 0 cs (toEnum l) 
    176178 
    177179emitNode freeze e n@(MkYamlNode{el = YamlSeq seq}) = do 
    … …  
    190192 
    191193withTag :: YamlNode -> String -> (CString -> IO a) -> IO a 
    192 withTag node def f = withCString (maybe def id (tag node)) f 
     194withTag node def f = Str.useAsCString (maybe (Str.pack def) id (tag node)) f 
    193195 
    194196parseYaml :: String -> IO (Either String (Maybe YamlNode)) 
    … …  
    260262    deRefStablePtr (castPtrToStablePtr ptr) 
    261263 
    262 syckNodeTag :: SyckNode -> IO (Maybe String) 
     264syckNodeTag :: SyckNode -> IO (Maybe Str) 
    263265syckNodeTag syckNode = do 
    264266    tag <- #{peek SyckNode, type_id} syckNode 
    265267    if (tag == nullPtr) then (return Nothing) else do 
    266         tag' <- peekCString tag 
    267         return $ Just tag' 
     268        return $ Just $ Str.packMallocCString tag 
    268269 
    269270syckNodeKind :: SyckNode -> IO SyckKind 
    … …  
    296297    tag   <- syckNodeTag syckNode 
    297298    cstr  <- syck_str_read syckNode 
    298     str   <- peekCStringLen (cstr, fromEnum len) 
     299    let str = Str.packCStringLen (cstr, fromEnum len) 
    299300    return $ nilNode{ el = YamlStr str, tag = tag } 
    300301 

  • src/DrIFT/YAML.hs

    r9008 r9021  
    1717import System.IO.Unsafe 
    1818import Control.Monad.Reader 
     19import qualified Data.FastPackedString as Str 
     20 
     21type Str = Str.FastString 
    1922 
    2023type YAMLClass = String 
    … …  
    6669    fromYAMLpair ~(MkYamlNode{el=YamlStr k}, v) = do 
    6770        v' <- fromYAML v 
    68         return (k, v') 
     71        return (Str.unpack k, v') 
    6972     
    7073 
    7174asYAMLcls :: YAMLClass -> EmitAs YamlNode 
    72 asYAMLcls c = return $ mkTagNode (tagHs c) (YamlStr c) 
     75asYAMLcls c = return $ mkTagNode (tagHs c) (YamlStr $ Str.pack c) 
    7376 
    7477tagHs :: YAMLClass -> String 
    7578tagHs = ("tag:hs:" ++) 
     79 
     80deTag :: YamlNode -> YAMLClass 
     81deTag MkYamlNode{tag=Just s} = 
     82    let 't':'a':'g':':':'h':'s':':':tag = s' in tag 
     83    where s' = Str.unpack s 
     84deTag _ = error "not a Haskell tag" 
    7685 
    7786instance YAML () where 
    … …  
    8089 
    8190instance YAML Int where 
    82     asYAML x = return $ mkTagNode "int" (YamlStr $ show x) 
    83     fromYAMLElem ~(YamlStr x) = return $ read x 
     91    asYAML x = return $ mkTagNode "int" (YamlStr $ Str.pack $ show x) 
     92    fromYAMLElem ~(YamlStr x) = return $ read $ Str.unpack x 
    8493 
    8594instance YAML String where 
    86     asYAML str = return $ mkTagNode "str" (YamlStr str) 
    87     fromYAMLElem ~(YamlStr str) = return $ read str 
     95    asYAML str = return $ mkTagNode "str" (YamlStr $ Str.pack str) 
     96    fromYAMLElem ~(YamlStr str) = return $ read $ Str.unpack str 
    8897 
    8998instance YAML Bool where 
    90     asYAML True = return $ mkTagNode "bool#yes" (YamlStr "1") 
    91     asYAML False = return $ mkTagNode "bool#no" (YamlStr "0") 
    92     fromYAML MkYamlNode{tag=Just "bool#yes"} = return True 
    93     fromYAML MkYamlNode{tag=Just "bool#no"}  = return False 
     99    asYAML True = return $ mkTagNode "bool#yes" (YamlStr $ Str.pack "1") 
     100    asYAML False = return $ mkTagNode "bool#no" (YamlStr $ Str.pack "0") 
     101    fromYAML MkYamlNode{tag=Just s} | s == Str.pack "bool#yes" = return True 
     102    fromYAML MkYamlNode{tag=Just s} | s == Str.pack "bool#no"  = return False 
    94103 
    95104instance YAML Integer where  
    96     asYAML x = return $ mkTagNode "int" (YamlStr $ show x) 
    97     fromYAMLElem ~(YamlStr x) = return $ read x 
     105    asYAML x = return $ mkTagNode "int" (YamlStr $ Str.pack $ show x) 
     106    fromYAMLElem ~(YamlStr x) = return $ read $ Str.unpack x 
    98107 
    99108instance YAML Rational where  
    … …  
    104113    fromYAMLElem ~(YamlStr str) = return $ (read x) / (read y) 
    105114        where 
    106         (x,y) = break (== '/') str 
     115        (x,y) = break (== '/') (Str.unpack str) 
    107116     
    108117instance YAML Double where  
    109     asYAML num | show num == "Infinity"  = return $ mkTagNode "float#inf"    (YamlStr ".Inf") 
    110                | show num == "-Infinity" = return $ mkTagNode "float#neginf" (YamlStr "-.Inf") 
    111                | show num == "NaN"       = return $ mkTagNode "float#nan"    (YamlStr "-.NaN") 
    112                | otherwise               = return $ mkTagNode "float"        (YamlStr $ show num) 
    113     fromYAML MkYamlNode{tag=Just "float#inf"}    = return $  1/0 -- "Infinity"  
    114     fromYAML MkYamlNode{tag=Just "float#neginf"} = return $ -1/0 -- "-Infinity"  
    115     fromYAML MkYamlNode{tag=Just "float#nan"}    = return $  0/0 -- "NaN"  
    116     fromYAML ~MkYamlNode{el=YamlStr x}           = return $ read x 
     118    asYAML num | show num == "Infinity"  = return $ mkTagNode "float#inf"    (YamlStr $ Str.pack ".Inf") 
     119               | show num == "-Infinity" = return $ mkTagNode "float#neginf" (YamlStr $ Str.pack "-.Inf") 
     120               | show num == "NaN"       = return $ mkTagNode "float#nan"    (YamlStr $ Str.pack "-.NaN") 
     121               | otherwise               = return $ mkTagNode "float"        (YamlStr $ Str.pack $ show num) 
     122    fromYAML MkYamlNode{tag=Just s} | s == Str.pack "float#inf"    = return $  1/0 -- "Infinity"  
     123    fromYAML MkYamlNode{tag=Just s} | s == Str.pack "float#neginf" = return $ -1/0 -- "-Infinity"  
     124    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 
    117126 
    118127instance (YAML a) => YAML (Maybe a) where 

  • src/Pugs/AST/Internals.hs

    r9016 r9021  
    106106import qualified Data.Map       as Map 
    107107import qualified Data.IntMap    as IntMap 
     108import qualified Data.FastPackedString as Str 
    108109 
    109110import Data.Yaml.Syck 
    … …  
    128129#include "../Types/Pair.hs" 
    129130#include "../Types/Object.hs" 
     131 
     132type Str = Str.FastString 
    130133 
    131134errIndex :: Show a => Maybe b -> a -> Eval b 
    … …  
    768771    --     junctions, contains the set of values that appear exactly 
    769772    --     /once/. 
    770     } deriving (Eq, Ord, Typeable) {-!derive: YAML!-} 
     773    } deriving (Eq, Ord, Typeable) 
     774 
     775instance YAML VJunc where 
     776    asYAML (MkJunc aa ab ac) = asYAMLmap "MkJunc" 
     777           [("juncType", asYAML aa) , ("juncDup", asYAML ab) , 
     778            ("juncSet", asYAML ac)] 
     779    fromYAML node = do 
     780        let YamlMap assocs = el node 
     781        let [aa, ab, ac] = map snd assocs 
     782        liftM3 MkJunc (fromYAML aa) (fromYAML ab) (fromYAML ac) 
     783 
    771784 
    772785-- | The combining semantics of a junction. See 'VJunc' for more info. 
    … …  
    929942    | Pos !Pos                -- ^ Position 
    930943    | Prag ![Pragma]          -- ^ Lexical pragmas 
    931     deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
     944    deriving (Show, Eq, Ord, Typeable) 
     945 
     946instance YAML Ann where 
     947    asYAML (Cxt aa) = asYAMLseq "Cxt" [asYAML aa] 
     948    asYAML (Pos aa) = asYAMLseq "Pos" [asYAML aa] 
     949    asYAML (Prag aa) = asYAMLseq "Prag" [asYAML aa] 
     950    fromYAML node = case deTag node of 
     951        "Cxt" -> do 
     952            let YamlSeq [aa] = el node 
     953            fmap Cxt $ fromYAML aa 
     954        "Pos" -> do 
     955            let YamlSeq [aa] = el node 
     956            fmap Pos $ fromYAML aa 
     957        "Prag" -> do 
     958            let YamlSeq [aa] = el node 
     959            fmap Prag $ fromYAML aa 
    932960 
    933961{- Expressions 
    … …  
    18391867instance YAML a => YAML (Map String a) where 
    18401868    asYAML x = asYAMLmap "Map" $ Map.toList (Map.map asYAML x) 
    1841     fromYAML node@MkYamlNode{tag=Just "tag:hs:Map"} = fmap Map.fromList (fromYAMLmap node) 
     1869    fromYAML node = fmap Map.fromList (fromYAMLmap node) 
    18421870instance Typeable a => YAML (IVar a) where 
    18431871    asYAML x = asYAML (MkRef x) 
    … …  
    18711899        liftIO $ print svC 
    18721900        fail ("not implemented: asYAML \"" ++ showType (refType ref) ++ "\"") 
    1873     fromYAML node@MkYamlNode{tag=Just "tag:hs:VCode"} = 
     1901    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:VCode" = 
    18741902        fmap (MkRef . ICode) (fromYAML node :: IO VCode) 
    1875     fromYAML node@MkYamlNode{tag=Just "tag:hs:VScalar"} = 
     1903    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:VScalar" = 
    18761904        fmap (MkRef . IScalar) (fromYAML node :: IO VScalar) 
    1877     fromYAML node@MkYamlNode{tag=Just "tag:hs:IScalar"} = 
     1905    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:IScalar" = 
    18781906        fmap MkRef (newScalar =<< fromYAML node) 
    1879     fromYAML node@MkYamlNode{tag=Just "tag:hs:Array"} = 
     1907    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:Array" = 
    18801908        fmap MkRef (newArray =<< fromYAML node) 
    1881     fromYAML node@MkYamlNode{tag=Just "tag:hs:Hash"} = do 
     1909    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:Hash" = do 
    18821910        fmap MkRef (newHash =<< fromYAML node) 
    1883     fromYAML node@MkYamlNode{tag=Just "tag:hs:Pair"} = do 
     1911    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:Pair" = do 
    18841912        fmap pairRef (fromYAML node :: IO VPair) 
    18851913 
    … …  
    20612089    asYAML (PerlSV aa) = asYAMLseq "PerlSV" [asYAML aa] 
    20622090 
    2063 instance YAML VJunc where 
    2064     asYAML (MkJunc aa ab ac) = asYAMLmap "MkJunc" 
    2065            [("juncType", asYAML aa) , ("juncDup", asYAML ab) , 
    2066             ("juncSet", asYAML ac)] 
    2067  
    20682091instance YAML JuncType where 
    20692092    asYAML (JAny) = asYAMLcls "JAny" 
    … …  
    21342157            ("subReturns", asYAML ai) , ("subLValue", asYAML aj) , 
    21352158            ("subBody", asYAML ak) , ("subCont", asYAML al)] 
    2136  
    2137 instance YAML Ann where 
    2138     asYAML (Cxt aa) = asYAMLseq "Cxt" [asYAML aa] 
    2139     asYAML (Pos aa) = asYAMLseq "Pos" [asYAML aa] 
    2140     asYAML (Prag aa) = asYAMLseq "Prag" [asYAML aa] 
    21412159 
    21422160instance YAML Exp where 

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

    r9016 r9021  
    7878import qualified Data.Map       as Map 
    7979import qualified Data.IntMap    as IntMap 
     80import qualified Data.FastPackedString as Str 
    8081 
    8182import Data.Yaml.Syck 
    … …  
    100101#include "../Types/Pair.hs" 
    101102#include "../Types/Object.hs" 
     103 
     104type Str = Str.FastString 
    102105 
    103106errIndex :: Show a => Maybe b -> a -> Eval b 
    … …  
    774777    --     junctions, contains the set of values that appear exactly 
    775778    --     /once/. 
    776     } deriving (Eq, Ord, Typeable) {-!derive: YAML!-} 
     779    } deriving (Eq, Ord, Typeable) 
     780 
     781instance YAML VJunc where 
     782    asYAML (MkJunc aa ab ac) = asYAMLmap "MkJunc" 
     783           [("juncType", asYAML aa) , ("juncDup", asYAML ab) , 
     784            ("juncSet", asYAML ac)] 
     785    fromYAML node = do 
     786        let YamlMap assocs = el node 
     787        let [aa, ab, ac] = map snd assocs 
     788        liftM3 MkJunc (fromYAML aa) (fromYAML ab) (fromYAML ac) 
     789 
    777790 
    778791-- | The combining semantics of a junction. See 'VJunc' for more info. 
    … …  
    935948    | Pos !Pos                -- ^ Position 
    936949    | Prag ![Pragma]          -- ^ Lexical pragmas 
    937     deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
     950    deriving (Show, Eq, Ord, Typeable) 
     951 
     952instance YAML Ann where 
     953    asYAML (Cxt aa) = asYAMLseq "Cxt" [asYAML aa] 
     954    asYAML (Pos aa) = asYAMLseq "Pos" [asYAML aa] 
     955    asYAML (Prag aa) = asYAMLseq "Prag" [asYAML aa] 
     956    fromYAML node = case deTag node of 
     957        "Cxt" -> do 
     958            let YamlSeq [aa] = el node 
     959            fmap Cxt $ fromYAML aa 
     960        "Pos" -> do 
     961            let YamlSeq [aa] = el node 
     962            fmap Pos $ fromYAML aa 
     963        "Prag" -> do 
     964            let YamlSeq [aa] = el node 
     965            fmap Prag $ fromYAML aa 
    938966 
    939967{- Expressions 
    … …  
    18451873instance YAML a => YAML (Map String a) where 
    18461874    asYAML x = asYAMLmap "Map" $ Map.toList (Map.map asYAML x) 
    1847     fromYAML node@MkYamlNode{tag=Just "tag:hs:Map"} = fmap Map.fromList (fromYAMLmap node) 
     1875    fromYAML node = fmap Map.fromList (fromYAMLmap node) 
    18481876instance Typeable a => YAML (IVar a) where 
    18491877    asYAML x = asYAML (MkRef x) 
    … …  
    18771905        liftIO $ print svC 
    18781906        fail ("not implemented: asYAML \"" ++ showType (refType ref) ++ "\"") 
    1879     fromYAML node@MkYamlNode{tag=Just "tag:hs:VCode"} = 
     1907    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:VCode" = 
    18801908        fmap (MkRef . ICode) (fromYAML node :: IO VCode) 
    1881     fromYAML node@MkYamlNode{tag=Just "tag:hs:VScalar"} = 
     1909    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:VScalar" = 
    18821910        fmap (MkRef . IScalar) (fromYAML node :: IO VScalar) 
    1883     fromYAML node@MkYamlNode{tag=Just "tag:hs:IScalar"} = 
     1911    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:IScalar" = 
    18841912        fmap MkRef (newScalar =<< fromYAML node) 
    1885     fromYAML node@MkYamlNode{tag=Just "tag:hs:Array"} = 
     1913    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:Array" = 
    18861914        fmap MkRef (newArray =<< fromYAML node) 
    1887     fromYAML node@MkYamlNode{tag=Just "tag:hs:Hash"} = do 
     1915    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:Hash" = do 
    18881916        fmap MkRef (newHash =<< fromYAML node) 
    1889     fromYAML node@MkYamlNode{tag=Just "tag:hs:Pair"} = do 
     1917    fromYAML node@MkYamlNode{tag=Just s} | s == Str.pack "tag:hs:Pair" = do 
    18901918        fmap pairRef (fromYAML node :: IO VPair) 
    18911919 

  • src/Pugs/Prim/Yaml.hs

    r9005 r9021  
    1313import qualified Data.IntSet as IntSet 
    1414import qualified Data.IntMap as IntMap 
     15import qualified Data.FastPackedString as Str 
    1516import Foreign.StablePtr 
    1617import Foreign.Ptr 
    1718import Data.Generics 
     19 
     20type Str = Str.FastString 
    1821 
    1922evalYaml :: Val -> Eval Val 
    … …  
    2831fromYaml :: YamlNode -> Eval Val 
    2932fromYaml MkYamlNode{el=YamlNil}       = return VUndef 
    30 fromYaml MkYamlNode{el=YamlStr str}   = return $ VStr (decodeUTF8 str) 
     33fromYaml MkYamlNode{el=YamlStr str}   = return $ VStr $ decodeUTF8 $ Str.unpack str 
    3134fromYaml MkYamlNode{el=YamlSeq nodes} = do 
    3235    vals    <- mapM fromYaml nodes 
    … …  
    4346            hv      <- liftSTM $ (newTVar (Map.fromList vals) :: STM IHash) 
    4447            return $ VRef (hashRef hv) 
    45         Just ('p':'u':'g':'s':'/':'o':'b':'j':'e':'c':'t':':':typ) -> do 
     48        Just s | Just (pre, post) <- Str.breakFirst ':' s 
     49               , pre == Str.pack "pugs/Object" -> do 
     50            let typ = Str.unpack post 
    4651            vals    <- forM nodes $ \(keyNode, valNode) -> do 
    4752                key <- fromVal =<< fromYaml keyNode 
    … …  
    4954                return (key, val) 
    5055            return . VObject =<< createObject (mkType typ) vals 
    51         Just "pugs/Rule" -> do 
     56        Just s | s == Str.pack "pugs/Rule" -> do 
    5257            vals    <- forM nodes $ \(keyNode, valNode) -> do 
    5358                key <- fromVal =<< fromYaml keyNode 
    … …  
    6368            adverbs <- Map.lookup "adverbs" spec 
    6469            return $ VRule MkRulePGE{rxRule=rule, rxGlobal=global, rxStringify=stringify, rxAdverbs=adverbs} 
    65         Just x   -> error ("can't deserialize: " ++ x) 
     70        Just x   -> error ("can't deserialize: " ++ (Str.unpack x)) 
    6671 
    6772dumpYaml :: Int -> Val -> Eval Val 
    … …  
    7479 
    7580strNode :: String -> YamlNode 
    76 strNode = mkNode . YamlStr 
     81strNode = mkNode . YamlStr . Str.pack 
    7782 
    7883addressOf :: a -> IO Int 
    … …  
    107112    hash    <- fromVal v :: Eval VHash 
    108113    attrs   <- toYaml $ VRef (hashRef hash) 
    109     return $ tagNode (Just $ "tag:pugs:object:" ++ showType (objType obj)) attrs 
     114    return $ tagNode (Just $ Str.pack $ "tag:pugs:object:" ++ showType (objType obj)) attrs 
    110115toYaml (VRule MkRulePGE{rxRule=rule, rxGlobal=global, rxStringify=stringify, rxAdverbs=adverbs}) =do 
    111116    adverbs' <- toYaml adverbs