Divide code required only in compile time.

--HG--
rename : schema-th/src/Database/HDBC/Record/TH.hs => schema-th/src/Database/HDBC/Record/InternalTH.hs

schema-th/HDBC-schema-th.cabal

@@ -29,6 +29,9 @@ library
                        Database.HDBC.Schema.IBMDB2
                        Database.HDBC.Schema.PostgreSQL
 
+  other-modules:
+                       Database.HDBC.Record.InternalTH
+
   build-depends:         base <5
                        , containers
                        , time

schema-th/src/Database/HDBC/Record/InternalTH.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+
+module Database.HDBC.Record.InternalTH (
+  derivePersistableInstancesFromConvertibleSqlValues
+  ) where
+
+import Data.Maybe (catMaybes)
+import Data.List (intersect, find)
+
+import Language.Haskell.TH
+  (Q, Dec (InstanceD), Type(AppT, ConT),
+   Info (ClassI), reify)
+import Language.Haskell.TH.Name.Extra (compileError)
+import Data.Convertible (Convertible)
+import Database.HDBC (SqlValue)
+import Database.HDBC.SqlValueExtra ()
+import Database.Record (PersistableWidth(persistableWidth))
+import Database.Record.Instances ()
+import qualified Database.Record.Persistable as Persistable
+
+import Database.HDBC.Record.TH (derivePersistableInstanceFromValue)
+
+
+sqlValueType :: Q Type
+sqlValueType =  [t| SqlValue |]
+
+convertibleSqlValues' :: Q [(Type, Type)]
+convertibleSqlValues' =  cvInfo >>= d0  where
+  cvInfo = reify ''Convertible
+  unknownDeclaration = compileError
+                       . ("convertibleSqlValues: Unknown declaration pattern: " ++)
+  d0 (ClassI _ is) = fmap catMaybes . sequence . map d1 $ is  where
+    d1 (InstanceD _cxt (AppT (AppT (ConT _n) a) b) _ds)
+      = do qvt <- sqlValueType
+           return
+             $ if qvt == a || qvt == b
+               then case (a, b) of
+                 (ConT _, ConT _) -> Just (a, b)
+                 _                -> Nothing
+               else Nothing
+    d1 decl
+      =    unknownDeclaration $ show decl
+  d0 cls           = unknownDeclaration $ show cls
+
+convertibleSqlValues :: Q [Type]
+convertibleSqlValues =  do
+  qvt <- sqlValueType
+  vs  <- convertibleSqlValues'
+  let from = map snd . filter ((== qvt) . fst) $ vs
+      to   = map fst . filter ((== qvt) . snd) $ vs
+  return $ intersect from to
+
+persistableWidthValues :: Q [Type]
+persistableWidthValues =  cvInfo >>= d0  where
+  cvInfo = reify ''PersistableWidth
+  unknownDeclaration = compileError
+                       . ("persistableWidthValues: Unknown declaration pattern: " ++)
+  d0 (ClassI _ is) = sequence . map d1 $ is  where
+    d1 (InstanceD _cxt (AppT (ConT _n) a) _ds) = return a
+    d1 decl                                    = unknownDeclaration $ show decl
+  d0 cls           = unknownDeclaration $ show cls
+
+derivePersistableWidth :: Q Type -> Q [Dec]
+derivePersistableWidth typ =
+  [d| instance PersistableWidth $(typ)  where
+        persistableWidth = Persistable.valueWidth
+    |]
+
+mapInstanceD :: (Q Type -> Q [Dec]) -> [Type] -> Q [Dec]
+mapInstanceD fD = fmap concat . mapM (fD . return)
+
+derivePersistableInstancesFromConvertibleSqlValues :: Q [Dec]
+derivePersistableInstancesFromConvertibleSqlValues =  do
+  ds <- persistableWidthValues
+  ts <- convertibleSqlValues
+  let defineNotDefined qt = do
+        t <- qt
+        case find (== t) ds of
+          Nothing -> derivePersistableWidth qt
+          Just _  -> return []
+  ws <- mapInstanceD defineNotDefined ts
+  ps <- mapInstanceD derivePersistableInstanceFromValue ts
+  return $ ws ++ ps

schema-th/src/Database/HDBC/Record/Persistable.hs

@@ -12,7 +12,7 @@ module Database.HDBC.Record.Persistable (
 import Database.Record (PersistableSqlValue, PersistableType (..), PersistableValue (..))
 import Database.Record.Persistable (persistableSqlTypeFromNull)
 import qualified Database.Record.Persistable as Record
-import Database.HDBC.Record.TH (derivePersistableInstancesFromConvertibleSqlValues)
+import Database.HDBC.Record.InternalTH (derivePersistableInstancesFromConvertibleSqlValues)
 
 import Data.Convertible (Convertible)
 import Database.HDBC (SqlValue(SqlNull), fromSql, toSql)

schema-th/src/Database/HDBC/Record/TH.hs

@@ -3,72 +3,16 @@
 
 module Database.HDBC.Record.TH (
   derivePersistableInstanceFromValue,
-  derivePersistableInstancesFromConvertibleSqlValues
   ) where
 
-import Data.Maybe (catMaybes)
-import Data.List (intersect, find)
-
-import Language.Haskell.TH
-  (Q, Dec (InstanceD), Type(AppT, ConT),
-   Info (ClassI), reify)
-import Language.Haskell.TH.Name.Extra (compileError)
-import Data.Convertible (Convertible)
+import Language.Haskell.TH (Q, Dec, Type)
 import Database.HDBC (SqlValue)
 import Database.HDBC.SqlValueExtra ()
 import Database.Record
-  (Persistable(persistable), derivedPersistableValueRecord, PersistableWidth(persistableWidth),
-   FromSql(recordFromSql), recordFromSql',
-   ToSql(recordToSql), recordToSql')
-import Database.Record.Instances ()
-import qualified Database.Record.Persistable as Persistable
+  (Persistable(persistable), derivedPersistableValueRecord,
+   FromSql(recordFromSql), recordFromSql', ToSql(recordToSql), recordToSql')
 
 
-sqlValueType :: Q Type
-sqlValueType =  [t| SqlValue |]
-
-convertibleSqlValues' :: Q [(Type, Type)]
-convertibleSqlValues' =  cvInfo >>= d0  where
-  cvInfo = reify ''Convertible
-  unknownDeclaration = compileError
-                       . ("convertibleSqlValues: Unknown declaration pattern: " ++)
-  d0 (ClassI _ is) = fmap catMaybes . sequence . map d1 $ is  where
-    d1 (InstanceD _cxt (AppT (AppT (ConT _n) a) b) _ds)
-      = do qvt <- sqlValueType
-           return
-             $ if qvt == a || qvt == b
-               then case (a, b) of
-                 (ConT _, ConT _) -> Just (a, b)
-                 _                -> Nothing
-               else Nothing
-    d1 decl
-      =    unknownDeclaration $ show decl
-  d0 cls           = unknownDeclaration $ show cls
-
-convertibleSqlValues :: Q [Type]
-convertibleSqlValues =  do
-  qvt <- sqlValueType
-  vs  <- convertibleSqlValues'
-  let from = map snd . filter ((== qvt) . fst) $ vs
-      to   = map fst . filter ((== qvt) . snd) $ vs
-  return $ intersect from to
-
-persistableWidthValues :: Q [Type]
-persistableWidthValues =  cvInfo >>= d0  where
-  cvInfo = reify ''PersistableWidth
-  unknownDeclaration = compileError
-                       . ("persistableWidthValues: Unknown declaration pattern: " ++)
-  d0 (ClassI _ is) = sequence . map d1 $ is  where
-    d1 (InstanceD _cxt (AppT (ConT _n) a) _ds) = return a
-    d1 decl                                    = unknownDeclaration $ show decl
-  d0 cls           = unknownDeclaration $ show cls
-
-derivePersistableWidth :: Q Type -> Q [Dec]
-derivePersistableWidth typ =
-  [d| instance PersistableWidth $(typ)  where
-        persistableWidth = Persistable.valueWidth
-    |]
-
 derivePersistableInstanceFromValue :: Q Type -> Q [Dec]
 derivePersistableInstanceFromValue typ =
   [d| instance Persistable SqlValue $(typ)  where
@@ -80,19 +24,3 @@ derivePersistableInstanceFromValue typ =
       instance ToSql SqlValue $(typ)  where
         recordToSql = recordToSql'
     |]
-
-mapInstanceD :: (Q Type -> Q [Dec]) -> [Type] -> Q [Dec]
-mapInstanceD fD = fmap concat . mapM (fD . return)
-
-derivePersistableInstancesFromConvertibleSqlValues :: Q [Dec]
-derivePersistableInstancesFromConvertibleSqlValues =  do
-  ds <- persistableWidthValues
-  ts <- convertibleSqlValues
-  let defineNotDefined qt = do
-        t <- qt
-        case find (== t) ds of
-          Nothing -> derivePersistableWidth qt
-          Just _  -> return []
-  ws <- mapInstanceD defineNotDefined ts
-  ps <- mapInstanceD derivePersistableInstanceFromValue ts
-  return $ ws ++ ps