Add array template which has each offset of columns.

persistable-record/src/Database/Record/TH.hs

@@ -39,6 +39,8 @@ module Database.Record.TH (
   -- * Function declarations against defined record types
   makeRecordPersistableWithSqlTypeFromDefined,
   makeRecordPersistableWithSqlTypeDefaultFromDefined,
+  defineColumnOffsets,
+
   definePersistableWidthInstance,
 
   recordWidthTemplate,
@@ -51,9 +53,11 @@ module Database.Record.TH (
   -- * Reify
   reifyRecordType,
 
-  -- * Record type name
+  -- * Templates about record type name
   recordTypeNameDefault, recordTypeDefault,
 
+  columnOffsetsVarNameDefault,
+
   persistableFunctionNamesDefault,
 
   -- * Not nullable single column type
@@ -63,11 +67,12 @@ module Database.Record.TH (
 
 import Control.Applicative (pure, (<*>))
 import Data.List (foldl')
+import Data.Array (Array, listArray, (!))
 import Language.Haskell.TH.Name.CamelCase
   (ConName(conName), VarName(varName),
    conCamelcaseName, varCamelcaseName, varNameWithPrefix,
    toTypeCon, toDataCon, toVarExp)
-import Language.Haskell.TH.Lib.Extra (integralE)
+import Language.Haskell.TH.Lib.Extra (integralE, simpleValD)
 import Language.Haskell.TH
   (Q, newName, nameBase, reify, Info(TyConI), Name,
    TypeQ, conT, Con (NormalC, RecC),
@@ -100,6 +105,11 @@ recordTypeDefault :: String -- ^ Table name in SQL
                   -> TypeQ  -- ^ Result type template
 recordTypeDefault =  toTypeCon . recordTypeNameDefault
 
+-- | Variable expression of record column offset array.
+columnOffsetsVarNameDefault :: Name    -- ^ Table type name
+                            -> VarName -- ^ Result expression variable name
+columnOffsetsVarNameDefault =  (`varNameWithPrefix` "columnOffsets") . nameBase
+
 -- | Template of 'HasColumnConstraint' instance.
 defineHasColumnConstraintInstance :: TypeQ   -- ^ Type which represent constraint type
                                   -> TypeQ   -- ^ Type constructor of record
@@ -183,6 +193,21 @@ recordWidthTemplate ty =
      $(sigE [| persistableWidth |] [t| PersistableRecordWidth $(ty) |])
    |]
 
+-- | Column offset array and 'PersistableWidth' instance declaration.
+defineColumnOffsets :: ConName -- ^ Record type constructor.
+                    -> [TypeQ] -- ^ Types of record columns.
+                    -> Q [Dec] -- ^ Declaration of 'PersistableWidth' instance.
+defineColumnOffsets typeName' tys = do
+  let ofsVar = columnOffsetsVarNameDefault $ conName typeName'
+      widthIxE = integralE $ length tys
+  ar <- simpleValD (varName ofsVar) [t| Array Int Int |]
+        [| listArray (0 :: Int, $widthIxE) $
+           scanl (+) (0 :: Int) $(listE $ map recordWidthTemplate tys) |]
+  pw <- [d| instance PersistableWidth $(toTypeCon typeName') where
+              persistableWidth = unsafePersistableRecordWidth $ $(toVarExp ofsVar) ! $widthIxE
+          |]
+  return $ ar ++ pw
+
 -- | 'PersistableWidth' instance declaration.
 definePersistableWidthInstance :: TypeQ   -- ^ Record type constructor.
                                -> [TypeQ] -- ^ Types of record columns.
@@ -191,6 +216,7 @@ definePersistableWidthInstance typeCon tys = do
   [d| instance PersistableWidth $typeCon where
         persistableWidth = unsafePersistableRecordWidth $ foldl' (+) 0 $(listE $ map recordWidthTemplate tys)
     |]
+{-# DEPRECATED definePersistableWidthInstance "Use defineColumnOffsets instead of this." #-}
 
 -- | Record type declaration template.
 defineRecordType :: ConName            -- ^ Name of the data type of table record type.
@@ -200,10 +226,9 @@ defineRecordType :: ConName            -- ^ Name of the data type of table recor
 defineRecordType typeName' columns derives = do
   let typeName = conName typeName'
       fld (n, tq) = varStrictType (varName n) (strictType isStrict tq)
-  rec <- dataD (cxt []) typeName [] [recC typeName (map fld columns)] (map conName derives)
-  let typeCon = toTypeCon typeName'
-  ins <- definePersistableWidthInstance typeCon $ map snd columns
-  return $ rec : ins
+  rec  <- dataD (cxt []) typeName [] [recC typeName (map fld columns)] (map conName derives)
+  offs <- defineColumnOffsets typeName' [ty | (_, ty) <- columns]
+  return $ rec : offs
 
 -- | Generate column name from 'String'.
 columnDefault :: String -> TypeQ -> (VarName, TypeQ)