Began adding Template Haskell instances

Data/Object/Base.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
 ---------------------------------------------------------
 --
 -- Module        : Data.Object.Base
@@ -66,6 +67,8 @@ module Data.Object.Base
     , olFO
     , omTO
     , omFO
+      -- * Automatic deriving of instances
+    , deriveSuccessConvs
       -- * Helper functions
     , lookupObject
     ) where
@@ -76,7 +79,7 @@ import Control.Monad (ap, (<=<))
 
 import Prelude hiding (mapM, sequence)
 
-import Data.Foldable
+import Data.Foldable hiding (concatMap)
 import Data.Traversable
 import Data.Monoid
 
@@ -86,6 +89,7 @@ import Control.Exception (Exception)
 import Data.Attempt
 
 import Data.Convertible.Text
+import Language.Haskell.TH
 
 -- | Can represent nested values as scalars, sequences and mappings.  A
 -- sequence is synonymous with a list, while a mapping is synonymous with a
@@ -400,6 +404,83 @@ omFO =
       mapM (runKleisli (Kleisli ca *** Kleisli fromObject))
   <=< fromMapping
 
+deriveSuccessConvs :: Name -- ^ dest key
+                   -> Name -- ^ dest value
+                   -> [Name] -- ^ source keys
+                   -> [Name] -- ^ source values
+                   -> Q [Dec]
+deriveSuccessConvs dk dv sks svs = do
+    let pairs = do
+            sk <- sks
+            sv <- svs
+            return (sk, sv)
+    sto <- [|sTO|]
+    sfo <- [|sFO|]
+    lto <- [|lTO|]
+    lfo <- [|lFO|]
+    mto <- [|mTO|]
+    mfo <- [|mFO|]
+    let valOnly = concatMap (helper1 sto sfo lto lfo) svs
+        both = concatMap (helper2 mto mfo) pairs
+    return $ valOnly ++ both
+      where
+        to = ConT $ mkName "ToObject"
+        fo = ConT $ mkName "FromObject"
+        to' = mkName "toObject"
+        fo' = mkName "fromObject"
+        helper1 sto sfo lto lfo sv =
+            [ InstanceD
+                []
+                (to `AppT` ConT sv `AppT` ConT dk `AppT` ConT dv)
+                [ FunD to'
+                    [ Clause [] (NormalB sto) []
+                    ]
+                ]
+            , InstanceD
+                []
+                (fo `AppT` ConT sv `AppT` ConT dk `AppT` ConT dv)
+                [ FunD fo'
+                    [ Clause [] (NormalB sfo) []
+                    ]
+                ]
+            , InstanceD
+                []
+                (to `AppT` (AppT ListT (ConT sv)) `AppT` ConT dk `AppT` ConT dv)
+                [ FunD to'
+                    [ Clause [] (NormalB lto) []
+                    ]
+                ]
+            , InstanceD
+                []
+                (fo `AppT` (AppT ListT (ConT sv)) `AppT` ConT dk `AppT` ConT dv)
+                [ FunD fo'
+                    [ Clause [] (NormalB lfo) []
+                    ]
+                ]
+            ]
+        helper2 mto mfo (sk, sv) =
+            [ InstanceD
+                []
+                (to `AppT` (ListT `AppT`
+                            (TupleT 2 `AppT` ConT sk `AppT` ConT sv)
+                           )
+                    `AppT` ConT dk `AppT` ConT dv)
+                [ FunD to'
+                    [ Clause [] (NormalB mto) []
+                    ]
+                ]
+            , InstanceD
+                []
+                (fo `AppT` (ListT `AppT`
+                            (TupleT 2 `AppT` ConT sk `AppT` ConT sv)
+                           )
+                    `AppT` ConT dk `AppT` ConT dv)
+                [ FunD fo'
+                    [ Clause [] (NormalB mfo) []
+                    ]
+                ]
+            ]
+
 -- | An equivalent of 'lookup' to deal specifically with maps of 'Object's. In
 -- particular, it will:
 --

Data/Object/String.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 ---------------------------------------------------------
 --
@@ -24,14 +25,9 @@ module Data.Object.String
     ) where
 
 import Data.Object.Base
-import Data.Object.Text
 import Data.Attempt
-import Control.Monad ((<=<))
-
-import Data.Convertible.Text
 
 import Data.Time.Calendar
-import Data.Ratio (Ratio)
 
 type StringObject = Object String String
 
@@ -45,24 +41,6 @@ fromStringObject :: FromObject a String String
                  -> Attempt a
 fromStringObject = fromObject
 
-instance ToObject String String String where
-    toObject = Scalar
-instance ToObject Day String String where
-    toObject = Scalar . convertSuccess
-instance ToObject Int String String where
-    toObject = Scalar . convertSuccess
-instance ToObject (Ratio Integer) String String where
-    toObject = Scalar . convertSuccess
-instance ToObject Bool String String where
-    toObject = Scalar . convertSuccess
-
-instance FromObject String String String where
-    fromObject = convertAttempt <=< fromScalar
-instance FromObject Day String String where
-    fromObject = convertAttempt <=< fromScalar
-instance FromObject Int String String where
-    fromObject = convertAttempt <=< fromScalar
-instance FromObject (Ratio Integer) String String where
-    fromObject = convertAttempt <=< fromScalar
-instance FromObject Bool String String where
-    fromObject = convertAttempt <=< fromScalar
+$(deriveSuccessConvs ''String ''String
+    [''String]
+    [''String, ''Day, ''Int, ''Rational, ''Bool])

Data/Object/Text.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 ---------------------------------------------------------
 --
@@ -32,12 +33,11 @@ import Data.Object.Base
 import Data.Text.Lazy (Text)
 import Data.Attempt
 
-import Data.Convertible.Text
-
 import Data.Time.Calendar
 
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as TS
 
 #if TEST
 import Test.Framework (testGroup, Test)
@@ -47,6 +47,7 @@ import Test.HUnit hiding (Test)
 import Test.QuickCheck
 
 import Control.Arrow ((***))
+import Data.Convertible.Text
 #endif
 
 -- | 'Object's with keys and values of type 'Text'.
@@ -63,37 +64,11 @@ fromTextObject = fromObject
 instance ToObject (Object String String) Text Text where
     toObject = convertObject
 
-instance ToObject String Text Text where
-    toObject = sTO
-instance ToObject Day Text Text where
-    toObject = sTO
-instance ToObject Int Text Text where
-    toObject = sTO
-instance ToObject Rational Text Text where
-    toObject = sTO
-instance ToObject Bool Text Text where
-    toObject = sTO
-
-instance FromObject String Text Text where
-    fromObject = sFO
-instance FromObject Day Text Text where
-    fromObject = sFO
-instance FromObject Int Text Text where
-    fromObject = sFO
-instance FromObject Rational Text Text where
-    fromObject = sFO
-instance FromObject Bool Text Text where
-    fromObject = sFO
-
-instance ToObject BL.ByteString Text Text where
-    toObject = sTO
-instance FromObject BL.ByteString Text Text where
-    fromObject = sFO
-
-instance ToObject BS.ByteString Text Text where
-    toObject = sTO
-instance FromObject BS.ByteString Text Text where
-    fromObject = sFO
+$(deriveSuccessConvs ''Text ''Text
+    [''Text, ''String, ''BS.ByteString, ''BL.ByteString, ''TS.Text]
+    [''String, ''Day, ''Int, ''Rational, ''Bool, ''BS.ByteString,
+     ''BL.ByteString, ''TS.Text
+    ])
 
 #if TEST
 testSuite :: Test

data-object.cabal

@@ -36,7 +36,8 @@ library
                      old-locale >= 1 && < 1.1,
                      syb,
                      attempt >= 0.2.0 && < 0.3,
-                     convertible-text >= 0.0.0 && < 0.1
+                     convertible-text >= 0.0.0 && < 0.1,
+                     template-haskell
     exposed-modules: Data.Object
                      Data.Object.Base
                      Data.Object.Text