X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FXml.hs;fp=src%2FXml.hs;h=2e9c18bfad5fec0cd9599667c07ae7ed060aae0e;hb=0aaa57457c219ab35f37050a09a71889e3f38469;hp=3242dacd8b2a7a69c997acb527846dfaaeb0ff75;hpb=bba78b2c78bb7796cc7ac4edabf61bae75fa06c9;p=dead%2Fhtsn-import.git

diff --git a/src/Xml.hs b/src/Xml.hs
index 3242dac..2e9c18b 100644
--- a/src/Xml.hs
+++ b/src/Xml.hs
@@ -5,6 +5,7 @@
 module Xml (
   DtdName(..),
   FromXml(..),
+  FromXmlFk(..),
   parse_opts,
   pickle_unpickle,
   unpickleable )
@@ -12,6 +13,7 @@ where
 
 -- System imports.
 import Control.Exception ( SomeException(..), catch )
+import Database.Groundhog.Core ( DefaultKey )
 import Text.XML.HXT.Core (
   (>>>),
   (/>),
@@ -47,6 +49,24 @@ class FromXml a where
   from_xml :: a -> Db a
 
 
+-- | Some database types cannot be constructed from the XML type
+--   alone; they must be supplied a foreign key to a parent object
+--   first. Members of this class can be converted from an XML
+--   representation to a database representation in this manner.
+--
+class FromXmlFk a where
+  -- | Each instance @a@ must declare its associated database type @DbFk a@.
+  type DbFk a :: *
+
+  -- | The type of our parent object, i.e. to the type to whom our
+  --   foreign key will point.
+  type Parent a :: *
+
+  -- | The function that produces a @DbFk a@ out of an @a@ and a foreign
+  --   key.
+  from_xml_fk :: a -> DefaultKey (Parent a) -> DbFk a
+
+
 -- | Represents the DTD filename (\"SYSTEM\") part of the DOCTYPE
 --   definition.
 newtype DtdName = DtdName String