]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - src/TSN/XmlImport.hs
Add a minor TODO note.
[dead/htsn-import.git] / src / TSN / XmlImport.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE GADTs #-}
3
4 -- | Definition of the XmlImport class.
5 --
6 module TSN.XmlImport (
7 XmlImport(..),
8 XmlImportFk(..) )
9 where
10
11 import Database.Groundhog (
12 AutoKey,
13 DefaultKey,
14 insert,
15 insert_,
16 insertByAll )
17 import Database.Groundhog.Core ( PersistBackend, PersistEntity )
18
19 import Xml ( FromXml(..), FromXmlFk(..), ToDb(..) )
20
21
22 -- | In Groundhog, there is a typeclass of things you can insert into
23 -- the database. What we usually have, though, is an XML
24 -- representation of something that has a Groundhog analogue that we
25 -- could insert into the database. It would be real nice if we could
26 -- just insert the XML thing and not have to convert back and
27 -- forth. That's what the 'XmlImport' class lets you do.
28 --
29 -- Moreover, there is a contraint on the class that the type must
30 -- also be a member of the 'FromXml' class. This allows us to define
31 -- default implementations of \"insert me\" generically. Given any
32 -- XML thing that can be converted to a database thing, we just do
33 -- the conversion and then insert normally (however Groundhog would
34 -- do it).
35 --
36 class (FromXml a, PersistEntity (Db a)) => XmlImport a where
37 -- | This is similar to the signature for Groundhog's 'insert'
38 -- function, except the 'AutoKey' we return is for our 'Db'
39 -- counterpart.
40 insert_xml :: (PersistBackend m) => a -> m (AutoKey (Db a))
41 insert_xml = insert . from_xml
42
43 -- | Identical to 'insert_xml', except it doesn't return anything.
44 insert_xml_ :: (PersistBackend m) => a -> m ()
45 insert_xml_ = insert_ . from_xml
46
47 -- | Same rationale as 'insert_xml', except it uses 'insertByAll'.
48 insertByAll_xml :: (PersistBackend m)
49 => a
50 -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
51 insertByAll_xml = insertByAll . from_xml
52
53
54 -- | Try to insert the given object and get its primary key
55 -- back. Or, if there's a unique constraint violation, get the
56 -- primary key of the unique thing already present.
57 --
58 -- Note: we can switch to using fmap here as soon as Functor is a
59 -- superclass of Monad (PersistBackend is a Monad).
60 --
61 insert_xml_or_select :: (PersistBackend m)
62 => a
63 -> m (AutoKey (Db a))
64 insert_xml_or_select x = do
65 tmp <- insertByAll_xml x
66 return $ (either id id) tmp
67
68
69
70 -- | A total copy of 'XmlImport' for instances of 'FromXmlFk'.
71 --
72 class (FromXmlFk a, PersistEntity (Db a)) => XmlImportFk a where
73 insert_xml_fk :: (PersistBackend m)
74 => DefaultKey (Parent a)
75 -> a
76 -> m (AutoKey (Db a))
77 insert_xml_fk fk x = insert $ from_xml_fk fk x
78
79 insert_xml_fk_ :: (PersistBackend m) => DefaultKey (Parent a) -> a -> m ()
80 insert_xml_fk_ fk x = insert_ $ from_xml_fk fk x
81
82 insertByAll_xml_fk :: (PersistBackend m)
83 => DefaultKey (Parent a)
84 -> a
85 -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
86 insertByAll_xml_fk fk x = insertByAll $ from_xml_fk fk x
87
88 insert_xml_or_select_fk :: (PersistBackend m)
89 => DefaultKey (Parent a)
90 -> a
91 -> m (AutoKey (Db a))
92 insert_xml_or_select_fk fk x = do
93 tmp <- insertByAll_xml_fk fk x
94 return $ (either id id) tmp