Changeset 8699 for src/DrIFT/YAML.hs

Timestamp:

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

Author:

audreyt

Message:

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

Files:

• src/DrIFT/YAML.hs (modified) (4 diffs)

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