4 import Control.Arrow ( (&&&), arr, returnA )
5 import Database.Groundhog.Core ( PersistEntity )
6 import Database.Groundhog.Sqlite (
7 defaultMigrationLogger,
13 import Text.XML.HXT.Core (
34 import System.Environment ( getArgs )
35 import qualified TSN.Injuries as Injuries (
37 Message ( listings ) )
38 import qualified TSN.InjuriesDetail as InjuriesDetail (
39 Listing ( player_listings ),
44 -- | A list of options passed to 'readDocument' when we parse an XML
45 -- document. We don't validate because the DTDs from TSN are
46 -- wrong. As a result, we don't want to keep useless DTDs
47 -- areound. Thus we disable 'withSubstDTDEntities' which, when
48 -- combined with "withValidate no", prevents HXT from trying to read
51 parse_opts :: SysConfigList
53 [ withPreserveComment no,
55 withSubstDTDEntities no,
59 -- | We put the 'XmlTree' argument last so that it's easy to eta
60 -- reduce all of the import_foo functions that call this.
62 import_generic :: (XmlPickler a, PersistEntity b)
63 => b -- ^ Dummy Listing instance needed for 'migrate'
64 -> (a -> [b]) -- ^ listings getter
67 import_generic dummy g xml =
68 withSqliteConn "foo.sqlite3" $ runDbConn $ do
69 runMigration defaultMigrationLogger $ do
71 let msg = unpickleDoc xpickle xml
73 Nothing -> error "Should unpickle!"
74 Just m -> mapM_ (\l -> insert l) (g m)
76 -- | Import TSN.Injuries from an 'XmlTree'.
77 import_injuries :: XmlTree -> IO ()
80 (undefined :: Injuries.Listing)
83 -- | Import TSN.InjuriesDetail from an 'XmlTree'.
84 import_injuries_detail :: XmlTree -> IO ()
85 import_injuries_detail =
87 (undefined :: InjuriesDetail.PlayerListing)
88 ( (concatMap InjuriesDetail.player_listings) . InjuriesDetail.listings)
90 import_file :: FilePath -> IO ()
92 results <- runX $ readA >>> (doctypeA &&& returnA) >>> (arr import_with_dtd)
94 [] -> error "ERROR: Unable to determine DOCTYPE."
95 (r:_) -> r -- Need to do something with the result or it gets GCed?
96 -- We do only expect one result fortunately.
98 -- | An arrow that reads a document into an 'XmlTree'.
99 readA :: IOStateArrow s a XmlTree
100 readA = readDocument parse_opts path
102 -- | An arrow which parses the doctype "SYSTEM" of an 'XmlTree'.
103 -- We use these to determine the parser to use.
104 doctypeA :: ArrowXml a => a XmlTree String
105 doctypeA = getAttrl >>> hasName "doctype-SYSTEM" /> getText
107 -- | Takes a 'Doctype', 'XmlTree' pair and uses the 'Doctype' to
108 -- determine which function to call on the 'XmlTree'.
109 import_with_dtd :: (String, XmlTree) -> IO ()
110 import_with_dtd (dtd,xml)
111 | dtd == "injuriesxml.dtd" = import_injuries xml
112 | dtd == "Injuries_Detail_XML.dtd" = import_injuries_detail xml
113 | otherwise = error "ERROR: Unrecognized DTD."
119 import_file (args !! 0)