Changeset 9050 for src/Pugs/CodeGen

Timestamp:

02/18/06 17:03:32 (3 years ago)

Author:

audreyt

Message:

* Pugs.CodeGen?.YAML: "pugs -CParse-YAML" now omits the primitive

bindings for functions and types, just as "pugs -CPugs" used to do.

Files:

• src/Pugs/CodeGen/YAML.hs (modified) (1 diff)

src/Pugs/CodeGen/YAML.hs

@@ -8 +8 @@
 import Pugs.PIL1
 import DrIFT.YAML
+import qualified Data.Map as Map
 
 genParseYAML :: Eval Val
 genParseYAML = do
-    glob    <- asks envGlobal
+    glob        <- asks envGlobal
+    MkPad pad   <- liftSTM $ readTVar glob
+    pad'        <- fmap (MkPad . Map.fromAscList . catMaybes) . mapM checkPrim $ Map.toAscList pad
+    -- munge the glob to filter out prim stuff in it
     main    <- asks envBody
-    yaml    <- liftIO (showYaml (glob, main))
+    yaml    <- liftIO $ showYaml (pad', main)
     return (VStr yaml)
+
+checkPrim :: (String, PadEntry) -> Eval (Maybe (String, PadEntry))
+checkPrim ((':':'*':_), _) = return Nothing
+checkPrim e@((_, MkEntry (_, tv))) = do
+    rv <- isPrim tv
+    return $ if rv then Nothing else Just e
+checkPrim (key, MkEntryMulti xs) = do
+    xs' <- filterM (fmap not . isPrim . snd) xs
+    return $ if null xs' then Nothing else Just (key, MkEntryMulti xs')
+
+isPrim :: TVar VRef -> Eval Bool
+isPrim tv = do
+    vref <- liftSTM $ readTVar tv
+    case vref of
+        MkRef (ICode cv)    -> fmap (isPrimVal . VCode) (code_fetch cv)
+        MkRef (IScalar sv)  -> fmap isPrimVal (scalar_fetch sv)
+        _                   -> return False
+    where
+    isPrimVal (VCode MkCode{ subBody = Prim _ }) = True
+    isPrimVal _ = False
 
 genYAML :: Eval Val