Commit persistent stuff.

diff --git a/htsn-rdbms-import.cabal b/htsn-rdbms-import.cabal
index f95a7a6d775176c586eea294300dd28da46c9adc..0167c841580febafee5fcea0b539fa81100745a2 100644 (file)
--- a/htsn-rdbms-import.cabal
+++ b/htsn-rdbms-import.cabal
@@ -15,11 +15,15 @@ description:
 executable htsn-rdbms-import
   build-depends:
     base                        == 4.*,
+    cmdargs                     >= 0.10.6,
+    configurator                == 0.2.*,
     hxt                         == 9.3.*,
     persistent                  == 1.2.*,
+    persistent-postgresql       == 1.2.*,
+    persistent-sqlite           == 1.2.*,
     persistent-template         == 1.2.*,
     pretty-show                 == 1.*,
-    regular                     == 0.3.*
+    transformers                == 0.3.*
 
   main-is:
     Main.hs

diff --git a/src/Main.hs b/src/Main.hs
index d2e51727f9468b58417c0ecbb7ba71cdefeef324..950a2a117a04915821042e94979b01f381a6e817 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,18 +1,54 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module Main
 where
 
+import Control.Monad.IO.Class  (liftIO)
+import Data.Maybe ( listToMaybe )
+import Database.Persist ( insert )
+import Database.Persist.Sql ( runMigration )
+import Database.Persist.Sqlite ( runSqlite )
 import Text.Show.Pretty ( ppShow )
-import Text.XML.HXT.Core
+import Text.XML.HXT.Core (
+  SysConfigList,
+  XmlPickler,
+  no,
+  runX,
+  withPreserveComment,
+  withRemoveWS,
+  withValidate,
+  xpickle,
+  xunpickleDocument,
+  yes )
+
+import TSN.Injuries ( InjuriesMessage, migrate_injuries )
+
+
+parse_opts :: SysConfigList
+parse_opts =
+  [ withPreserveComment no,
+    withRemoveWS yes,
+    withValidate no ]
 
-import qualified TSN.Injuries as Injuries
+parse_file :: XmlPickler a => FilePath -> IO (Maybe a)
+parse_file path =
+  fmap listToMaybe $
+    runX ( xunpickleDocument xpickle parse_opts path )
 
+main_sql :: IO ()
+main_sql =
+  runSqlite "foo.sqlite3" $ do
+    runMigration migrate_injuries
+    msg :: Maybe InjuriesMessage <- liftIO $ parse_file
+                                               "test/xml/injuriesxml.xml"
+    case msg of
+      Nothing -> return ()
+      Just m  -> do
+        msg_id <- insert m
+        return ()
 
 main :: IO ()
 main = do
-  res <- runX ( xunpickleDocument Injuries.pickle_message
-                       [ withValidate no
-                       , withTrace 1
-                       , withRemoveWS yes
-                       , withPreserveComment no
-                       ] "test/xml/injuriesxml.xml" )
-  putStr $ ppShow res
+  msg :: Maybe InjuriesMessage <- parse_file "test/xml/injuriesxml.xml"
+  putStr $ ppShow msg

diff --git a/src/TSN/Injuries.hs b/src/TSN/Injuries.hs
index 7425ab5241025a6273ae9388710cf193ea00ed3b..956aa9d896e0ad8a12fc1f19a843c4f15526c88e 100644 (file)
--- a/src/TSN/Injuries.hs
+++ b/src/TSN/Injuries.hs
@@ -2,75 +2,88 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 module TSN.Injuries
 where
 
-import Generics.Regular
-import Database.Persist.TH
-import Text.XML.HXT.Core
+import Database.Persist.TH (
+  mkDeleteCascade,
+  mkMigrate,
+  mkPersist,
+  persistLowerCase,
+  share,
+  sqlOnlySettings )
+import Text.XML.HXT.Core (
+  PU,
+  XmlPickler(..),
+  xp4Tuple,
+  xp6Tuple,
+  xpElem,
+  xpList,
+  xpPrim,
+  xpText,
+  xpWrap )
 
-share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-Listing
+import Uncurry (uncurry4, uncurry5, uncurry6)
+
+share [mkPersist sqlOnlySettings,
+       mkDeleteCascade sqlOnlySettings,
+       mkMigrate "migrate_injuries"] [persistLowerCase|
+InjuriesListing
   team String
   teamno Int
   injuries String
   updated Bool
   deriving Show
 
-Message
+InjuriesMessage
   xml_file_id Int
   heading String
   category String
   sport String
-  listings [Listing]
+  listings [InjuriesListing]
   time_stamp String
   deriving Show
 |]
 
-pickle_listing :: PU Listing
-pickle_listing =
+
+pickle_injurieslisting :: PU InjuriesListing
+pickle_injurieslisting =
   xpElem "listing" $
-    xpWrap (\(w,x,y,z) -> Listing w x y z,
-            \l -> (listingTeam l,
-                   listingTeamno l,
-                   listingInjuries l,
-                   listingUpdated l)) $
+    xpWrap (uncurry4 InjuriesListing,
+            \l -> (injuriesListingTeam l,
+                   injuriesListingTeamno l,
+                   injuriesListingInjuries l,
+                   injuriesListingUpdated l)) $
     xp4Tuple (xpElem "team" xpText)
              (xpElem "teamno" xpPrim)
              (xpElem "injuries" xpText)
              (xpElem "updated" xpPrim)
 
-instance XmlPickler Listing where
-  xpickle = pickle_listing
+instance XmlPickler InjuriesListing where
+  xpickle = pickle_injurieslisting
 
-$(deriveAll ''Listing "PFListing")
-type instance PF Listing = PFListing
 
-
-pickle_message :: PU Message
-pickle_message =
+pickle_injuriesmessage :: PU InjuriesMessage
+pickle_injuriesmessage =
   xpElem "message" $
-    xpWrap (\(u,v,w,x,y,z) -> Message u v w x y z,
-            \m -> (messageXml_file_id m,
-                   messageHeading m,
-                   messageCategory m,
-                   messageSport m,
-                   messageListings m,
-                   messageTime_stamp m)) $
+    xpWrap (uncurry6 InjuriesMessage,
+            \m -> (injuriesMessageXml_file_id m,
+                   injuriesMessageHeading m,
+                   injuriesMessageCategory m,
+                   injuriesMessageSport m,
+                   injuriesMessageListings m,
+                   injuriesMessageTime_stamp m)) $
     xp6Tuple (xpElem "XML_File_ID" xpPrim)
              (xpElem "heading" xpText)
              (xpElem "category" xpText)
              (xpElem "sport" xpText)
-             (xpList pickle_listing)
+             (xpList pickle_injurieslisting)
              (xpElem "time_stamp" xpText)
 
-instance XmlPickler Message where
-  xpickle = pickle_message
-
-$(deriveAll ''Message "PFMessage")
-type instance PF Message = PFMessage
+instance XmlPickler InjuriesMessage where
+  xpickle = pickle_injuriesmessage