Changeset 8699

Timestamp:

01/16/06 13:08:43 (3 years ago)

Author:

audreyt

Message:

* DrIFT.YAML: Do not die when the Typeable instance is undefined.

Location:

src

Files:

• DrIFT/YAML.hs (modified) (4 diffs)
• Emit/PIR.hs (modified) (1 diff)
• Emit/PIR.hs-drift (modified) (1 diff)
• Pugs/AST/Internals.hs (modified) (1 diff)
• Pugs/AST/Internals.hs-drift (modified) (1 diff)
• Pugs/Eval.hs (modified) (1 diff)
• Pugs/Monads.hs (modified) (1 diff)
• Pugs/Prim.hs (modified) (2 diffs)
• Pugs/Types/Code.hs (modified) (1 diff)

src/DrIFT/YAML.hs

@@ -9 +9 @@
 import UTF8
 import Data.Typeable
+import Control.Exception
 
 type YAMLClass = String
@@ -16 +17 @@
 showYaml :: YAML a => a -> IO String
 showYaml x = do
-    rv <- emitYaml =<< asYAML x
+    node    <- asYAML x
+    rv      <- emitYaml node
     case rv of
         Left e  -> error e
@@ -23 +25 @@
 class Typeable a => YAML a where
     asYAML :: a -> IO YamlNode
-    asYAML x | ty == "()" = return nilNode
-             | otherwise  = return $ mkTagNode (tagHs ty) YamlNil
-        where
-        ty = (reverse (takeWhile (/= '.') (reverse (show (typeOf x)))))
+    asYAML x = do
+        ty <- Control.Exception.handle (const $ return "()") $
+            evaluate (reverse (takeWhile (/= '.') (reverse (show (typeOf x)))))
+        return $ case ty of
+            "()" -> nilNode
+            _    -> mkTagNode (tagHs ty) YamlNil
 
 asYAMLseq :: YAMLClass -> [IO YAMLVal] -> IO YamlNode
@@ -48 +52 @@
 tagHs :: YAMLClass -> String
 tagHs = ("tag:hs:" ++)
+
+instance YAML () where
 
 instance YAML Int where

src/Emit/PIR.hs

@@ -970 +970 @@
     asYAML = asYAML . render
 instance Typeable Doc where
-    typeOf = undefined
+    typeOf _ = typeOf ()
 
 ------------------------------------------------------------------------

src/Emit/PIR.hs-drift

@@ -968 +968 @@
     asYAML = asYAML . render
 instance Typeable Doc where
-    typeOf = undefined
+    typeOf _ = typeOf ()
 
 ------------------------------------------------------------------------

src/Pugs/AST/Internals.hs

@@ -1794 +1794 @@
 instance YAML VOpaque
 instance YAML VSocket
-instance YAML PerlSV
 instance Typeable Unique where typeOf _ = typeOf ()
 instance Typeable ProcessHandle where typeOf _ = typeOf ()

src/Pugs/AST/Internals.hs-drift

@@ -1826 +1826 @@
 instance YAML VOpaque
 instance YAML VSocket
-instance YAML PerlSV
 instance Typeable Unique where typeOf _ = typeOf ()
 instance Typeable ProcessHandle where typeOf _ = typeOf ()

src/Pugs/Eval.hs

@@ -390 +390 @@
     env  <- ask
     cont <- if subType sub /= SubCoroutine then return Nothing else liftSTM $ do
-        tvar <- newTVar undefined
+        tvar <- newTVar (error "empty sub")
         let thunk = (`MkThunk` anyType) . fix $ \redo -> do
             evalExp $ subBody sub

src/Pugs/Monads.hs

@@ -224 +224 @@
         if typ >= SubBlock
             then do
-                doFix <- fixEnv undefined env
+                doFix <- fixEnv return env
                 local doFix action
             else resetT $ callCC $ \cc -> do

src/Pugs/Prim.hs

@@ -15 +15 @@
     primDecl,
     initSyms,
-    op2DefinedOr,
     op2ChainedList,
     op1Exit,
@@ -1241 +1240 @@
     ref <- fromVal y
     forceRef ref
-
-op2DefinedOr :: Val
-op2DefinedOr = undefined
 
 op2Identity :: Val -> Val -> Eval Val

src/Pugs/Types/Code.hs

@@ -17 +17 @@
     code_store    = (liftSTM .) . writeTVar
     code_assuming c [] [] = code_fetch c
-    code_assuming _ _ _   = undefined
+    code_assuming _ _ _   = error "assuming"
     code_apply    = error "apply"
     code_assoc c  = code_assoc . unsafePerformSTM $ readTVar c