Permalink
Browse files

Began adding Template Haskell instances

  • Loading branch information...
1 parent ba50957 commit 2cb7fda7069b3f224eeb88fc9fe54dc1a8593bc4 @snoyberg committed Dec 15, 2009
Showing with 96 additions and 61 deletions.
  1. +82 −1 Data/Object/Base.hs
  2. +4 −26 Data/Object/String.hs
  3. +8 −33 Data/Object/Text.hs
  4. +2 −1 data-object.cabal
View
@@ -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:
--
View
@@ -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])
View
@@ -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
View
@@ -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

0 comments on commit 2cb7fda

Please sign in to comment.