groundhog-postgresql 0.3.1 → 0.4.0

raw patch · 4 files changed

+118/−192 lines, 4 filesdep +monad-loggerdep ~blaze-builderdep ~groundhogdep ~monad-controlPVP ok

version bump matches the API change (PVP)

Dependencies added: monad-logger

Dependency ranges changed: blaze-builder, groundhog, monad-control, postgresql-libpq, resource-pool, text, transformers

API changes (from Hackage documentation)

Files

• Database/Groundhog/Postgresql.hs +79/−93
• Database/Groundhog/Postgresql/Array.hs +5/−10
• Database/Groundhog/Postgresql/Geometry.hs +25/−81
• groundhog-postgresql.cabal +9/−8

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, MultiParamTypeClasses, TemplateHaskell #-} module Database.Groundhog.Postgresql     ( withPostgresqlPool     , withPostgresqlConn@@ -18,7 +18,6 @@ import qualified Database.Groundhog.Generic.PersistBackendHelpers as H  import qualified Database.PostgreSQL.Simple as PG-import qualified Database.PostgreSQL.Simple.BuiltinTypes as PG import qualified Database.PostgreSQL.Simple.Internal as PG import qualified Database.PostgreSQL.Simple.ToField as PGTF import qualified Database.PostgreSQL.Simple.FromField as PGFF@@ -28,18 +27,18 @@  import Control.Arrow ((***)) import Control.Exception (throw)-import Control.Monad (forM, liftM, liftM2)+import Control.Monad (forM, liftM, liftM2, (>=>)) import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Logger (MonadLogger, logDebugS) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Reader (ask) import Data.ByteString.Char8 (pack, unpack, copy)-import Data.Char (toUpper)-import Data.Either (partitionEithers)+import Data.Char (isAlphaNum, isSpace, toUpper) import Data.Function (on) import Data.Int (Int64) import Data.IORef-import Data.List (groupBy, intercalate)+import Data.List (groupBy, intercalate, stripPrefix) import Data.Maybe (fromJust, fromMaybe) import Data.Monoid import Data.Pool@@ -56,8 +55,7 @@ instance SqlDb Postgresql where   append a b = Expr $ operator 50 "||" a b -instance (MonadBaseControl IO m, MonadIO m) => PersistBackend (DbPersist Postgresql m) where-  {-# SPECIALIZE instance PersistBackend (DbPersist Postgresql IO) #-}+instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => PersistBackend (DbPersist Postgresql m) where   type PhantomDb (DbPersist Postgresql m) = Postgresql   insert v = insert' v   insert_ v = insert_' v@@ -82,7 +80,7 @@   insertList l = insertList' l   getList k = getList' k -instance (MonadBaseControl IO m, MonadIO m) => SchemaAnalyzer (DbPersist Postgresql m) where+instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => SchemaAnalyzer (DbPersist Postgresql m) where   listTables schema = queryRaw' "SELECT table_name FROM information_schema.tables WHERE table_schema=coalesce(?,current_schema())" [toPrimitivePersistValue proxy schema] (mapAllRows $ return . fst . fromPurePersistValues proxy)   listTableTriggers schema name = queryRaw' "SELECT trigger_name FROM information_schema.triggers WHERE event_object_schema=coalesce(?,current_schema()) AND event_object_table=?" [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)   analyzeTable = analyzeTable'@@ -143,8 +141,7 @@ close' :: Postgresql -> IO () close' (Postgresql conn) = PG.close conn -{-# SPECIALIZE insert' :: PersistEntity v => v -> DbPersist Postgresql IO (AutoKey v) #-}-insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Postgresql m (AutoKey v)+insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> DbPersist Postgresql m (AutoKey v) insert' v = do   -- constructor number and the rest of the field values   vals <- toEntityPersistValues' v@@ -170,8 +167,7 @@       executeRaw' cQuery (vals' [])       pureFromPersistValue [rowid] -{-# SPECIALIZE insert_' :: PersistEntity v => v -> DbPersist Postgresql IO () #-}-insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Postgresql m ()+insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> DbPersist Postgresql m () insert_' v = do   -- constructor number and the rest of the field values   vals <- toEntityPersistValues' v@@ -201,7 +197,7 @@   fieldNames   = renderFields escapeS fields   RenderS placeholders vals' = commasJoin $ map renderPersistValue vals -insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => [a] -> DbPersist Postgresql m Int64+insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => [a] -> DbPersist Postgresql m Int64 insertList' (l :: [a]) = do   let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))   k <- queryRaw' ("INSERT INTO " <> escapeS mainName <> " DEFAULT VALUES RETURNING(id)") [] getKey@@ -217,7 +213,7 @@   go 0 l   return $ fromPrimitivePersistValue proxy k   -getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => Int64 -> DbPersist Postgresql m [a]+getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => Int64 -> DbPersist Postgresql m [a] getList' k = do   let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))   let valuesName = mainName <> delim' <> "values"@@ -232,9 +228,9 @@  ---------- -executeRaw' :: MonadIO m => Utf8 -> [PersistValue] -> DbPersist Postgresql m ()+executeRaw' :: (MonadIO m, MonadLogger m) => Utf8 -> [PersistValue] -> DbPersist Postgresql m () executeRaw' query vals = do-  --liftIO $ print $ fromUtf8 query ""+  $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals   Postgresql conn <- DbPersist ask   let stmt = getStatement query   liftIO $ do@@ -252,34 +248,34 @@ delim' :: Utf8 delim' = fromChar delim -toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, PersistEntity v) => v -> DbPersist Postgresql m [PersistValue]+toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, PersistEntity v, MonadLogger m) => v -> DbPersist Postgresql m [PersistValue] toEntityPersistValues' = liftM ($ []) . toEntityPersistValues  --- MIGRATION -migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> Migration (DbPersist Postgresql m)+migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> Migration (DbPersist Postgresql m) migrate' v = do   x <- lift $ queryRaw' "SELECT current_schema()" [] id   let schema = fst $ fromPurePersistValues proxy $ fromJust x   migrateRecursively (migrateEntity $ migrationPack schema) (migrateList $ migrationPack schema) v -migrationPack :: (MonadBaseControl IO m, MonadIO m) => String -> GM.MigrationPack (DbPersist Postgresql m)+migrationPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => String -> GM.MigrationPack (DbPersist Postgresql m) migrationPack currentSchema = GM.MigrationPack   compareTypes   (compareRefs currentSchema)   compareUniqs+  compareDefaults   migTriggerOnDelete   migTriggerOnUpdate   GM.defaultMigConstr   escape-  DbInt64   "SERIAL PRIMARY KEY UNIQUE"-  "INT8"   mainTableId   defaultPriority   (\uniques refs -> ([], map AddUnique uniques ++ map AddReference refs))   showColumn   showAlterDb+  NoAction  showColumn :: Column -> String showColumn (Column n nu t def) = concat@@ -293,7 +289,7 @@         Just s  -> " DEFAULT " ++ s     ] -migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Postgresql m (Bool, [AlterDB])+migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> [(String, String)] -> DbPersist Postgresql m (Bool, [AlterDB]) migTriggerOnDelete schema name deletes = do   let funcName = name   let trigName = name@@ -326,7 +322,7 @@        -- | Table name and a  list of field names and according delete statements -- assume that this function is called only for ephemeral fields-migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Postgresql m [(Bool, [AlterDB])]+migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> [(String, String)] -> DbPersist Postgresql m [(Bool, [AlterDB])] migTriggerOnUpdate schema name dels = forM dels $ \(fieldName, del) -> do   let funcName = name ++ delim : fieldName   let trigName = name ++ delim : fieldName@@ -351,7 +347,7 @@             else [DropTrigger schema trigName schema name, addTrigger])   return (trigExisted, funcMig ++ trigMig)   -analyzeTable' :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> DbPersist Postgresql m (Either [String] (Maybe TableInfo))+analyzeTable' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> DbPersist Postgresql m (Maybe TableInfo) analyzeTable' schema name = do   table <- queryRaw' "SELECT * FROM information_schema.tables WHERE table_schema = coalesce(?, current_schema()) AND table_name = ?" [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] id   case table of@@ -368,8 +364,6 @@ \  ORDER BY c.ordinal_position"        cols <- queryRaw' colQuery [toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . getColumn name . fst . fromPurePersistValues proxy)-      let (col_errs, cols') = partitionEithers cols-             let constraintQuery = "SELECT u.constraint_name, u.column_name FROM information_schema.table_constraints tc INNER JOIN information_schema.constraint_column_usage u ON tc.constraint_catalog=u.constraint_catalog AND tc.constraint_schema=u.constraint_schema AND tc.constraint_name=u.constraint_name WHERE tc.constraint_type=? AND tc.table_schema=coalesce(?,current_schema()) AND u.table_name=? ORDER BY u.constraint_name, u.column_name"              uniqConstraints <- queryRaw' constraintQuery [toPrimitivePersistValue proxy ("UNIQUE" :: String), toPrimitivePersistValue proxy schema, toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)@@ -378,16 +372,14 @@       let mkUniqs typ = map (\us -> UniqueDef' (fst $ head us) typ (map snd us)) . groupBy ((==) `on` fst)       let uniqs = mkUniqs UniqueConstraint uniqConstraints ++ mkUniqs UniqueIndex uniqIndexes ++ mkUniqs UniquePrimary uniqPrimary       references <- analyzeTableReferences schema name-      return $ case col_errs of-        []   -> Right $ Just $ TableInfo cols' uniqs references-        errs -> Left errs-    Nothing -> return $ Right Nothing+      return $ Just $ TableInfo cols uniqs references+    Nothing -> return Nothing -getColumn :: String -> ((String, String, String, Maybe String), (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String), (Int, Maybe String)) -> Either String Column-getColumn _ ((column_name, is_nullable, udt_name, d), modifiers, arr_info) = Right $ Column column_name (is_nullable == "YES") t d where+getColumn :: String -> ((String, String, String, Maybe String), (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String), (Int, Maybe String)) -> Column+getColumn _ ((column_name, is_nullable, udt_name, d), modifiers, arr_info) = Column column_name (is_nullable == "YES") t d where   t = readSqlType udt_name modifiers arr_info -analyzeTableReferences :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> DbPersist Postgresql m [(Maybe String, Reference)]+analyzeTableReferences :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> DbPersist Postgresql m [(Maybe String, Reference)] analyzeTableReferences schema tName = do   let sql = "SELECT c.conname, sch_parent.nspname, cl_parent.relname, c. confdeltype, c.confupdtype, a_child.attname AS child, a_parent.attname AS parent FROM\ \  (SELECT r.conrelid, r.confrelid, unnest(r.conkey) AS conkey, unnest(r.confkey) AS confkey, r.conname, r.confupdtype, r.confdeltype\@@ -546,7 +538,7 @@   ])  -- | udt_name, character_maximum_length, numeric_precision, numeric_scale, datetime_precision, interval_type-readSqlType :: String -> (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String) -> (Int, Maybe String) -> DbType+readSqlType :: String -> (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String) -> (Int, Maybe String) -> DbTypePrimitive readSqlType typ (character_maximum_length, numeric_precision, numeric_scale, datetime_precision, _) (array_ndims, array_elem) = (case typ of   "int4" -> DbInt32   "int8" -> DbInt64@@ -570,22 +562,20 @@     defDateTimePrec = 6     datetime_precision' = datetime_precision >>= \p -> if p == defDateTimePrec then Nothing else Just p -showSqlType :: DbType -> String-showSqlType DbString = "VARCHAR"-showSqlType DbInt32 = "INT4"-showSqlType DbInt64 = "INT8"-showSqlType DbReal = "DOUBLE PRECISION"-showSqlType DbBool = "BOOLEAN"-showSqlType DbDay = "DATE"-showSqlType DbTime = "TIME"-showSqlType DbDayTime = "TIMESTAMP"-showSqlType DbDayTimeZoned = "TIMESTAMP WITH TIME ZONE"-showSqlType DbBlob = "BYTEA"-showSqlType (DbOther (OtherTypeDef f)) = f showSqlType-showSqlType (DbMaybe t) = showSqlType t-showSqlType (DbList _ _) = showSqlType DbInt64-showSqlType (DbEntity Nothing _ _ _) = showSqlType DbInt64-showSqlType t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t+showSqlType :: DbTypePrimitive -> String+showSqlType t = case t of+  DbString -> "VARCHAR"+  DbInt32 -> "INT4"+  DbInt64 -> "INT8"+  DbReal -> "DOUBLE PRECISION"+  DbBool -> "BOOLEAN"+  DbDay -> "DATE"+  DbTime -> "TIME"+  DbDayTime -> "TIMESTAMP"+  DbDayTimeZoned -> "TIMESTAMP WITH TIME ZONE"+  DbBlob -> "BYTEA"+  DbOther (OtherTypeDef f) -> f showSqlType+  DbAutoKey -> showSqlType DbInt64  compareUniqs :: UniqueDef' -> UniqueDef' -> Bool compareUniqs (UniqueDef' _ UniquePrimary cols1) (UniqueDef' _ UniquePrimary cols2) = haveSameElems (==) cols1 cols2@@ -602,10 +592,15 @@   && fromMaybe NoAction onUpd1 == fromMaybe NoAction onUpd2 where     unescape name = if head name == '"' && last name == '"' then tail $ init name else name -compareTypes :: DbType -> DbType -> Bool+compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool compareTypes type1 type2 = f type1 == f type2 where   f = map toUpper . showSqlType +compareDefaults :: String -> String -> Bool+compareDefaults def1 def2 = Just def2 `elem` [Just def1, stripType def1, stripType def1 >>= stripParens] where+  stripType = fmap reverse . stripPrefix "::" . dropWhile (\c -> isAlphaNum c || isSpace c) . reverse+  stripParens = stripPrefix "(" >=> fmap reverse . stripPrefix ")" . reverse+ defaultPriority, referencePriority, functionPriority, triggerPriority :: Int defaultPriority = 0 referencePriority = 1@@ -624,11 +619,12 @@ getStatement :: Utf8 -> PG.Query getStatement sql = PG.Query $ fromUtf8 sql -queryRawTyped' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a+queryRawTyped' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a queryRawTyped' query _ vals f = queryRaw' query vals f -queryRaw' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a+queryRaw' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a queryRaw' query vals f = do+  $logDebugS "SQL" $ fromString $ show (fromUtf8 query) ++ " " ++ show vals   Postgresql conn <- DbPersist ask   rawquery <- liftIO $ PG.formatQuery conn (getStatement query) (map P vals)   -- Take raw connection@@ -657,16 +653,7 @@         cols <- LibPQ.nfields ret         getters <- forM [0..cols-1] $ \col -> do           oid <- LibPQ.ftype ret col-          case PG.oid2builtin oid of-            -- TODO: this is a temporary hack until postgresql-simple supports arrays and has more builtin types. Restore fail clause then.-            Nothing -> return $ getGetter PG.Unknown $-                       PG.Field ret col oid-             {- fail $ "Postgresql.withStmt': could not " ++-                              "recognize " ++ show oid ++ " of column " ++-                              show (let LibPQ.Col i = col in i) ++-                              " (counting from zero)" -}-            Just bt -> return $ getGetter bt $-                       PG.Field ret col oid+          return $ getGetter oid $ PG.Field ret col oid         -- Ready to go!         rowRef   <- newIORef (LibPQ.Row 0)         rowCount <- LibPQ.ntuples ret@@ -708,35 +695,34 @@ convertPV :: PGFF.FromField a => (a -> b) -> Getter b convertPV f = (fmap f .) . PGFF.fromField --- FIXME: check if those are correct and complete.-getGetter :: PG.BuiltinType -> Getter PersistValue-getGetter PG.Bool                  = convertPV PersistBool-getGetter PG.ByteA                 = convertPV (PersistByteString . unBinary)-getGetter PG.Char                  = convertPV PersistString-getGetter PG.Name                  = convertPV PersistString-getGetter PG.Int8                  = convertPV PersistInt64-getGetter PG.Int2                  = convertPV PersistInt64-getGetter PG.Int4                  = convertPV PersistInt64-getGetter PG.Text                  = convertPV PersistString-getGetter PG.Xml                   = convertPV PersistString-getGetter PG.Float4                = convertPV PersistDouble-getGetter PG.Float8                = convertPV PersistDouble-getGetter PG.AbsTime               = convertPV PersistUTCTime-getGetter PG.RelTime               = convertPV PersistUTCTime---getGetter PG.Money                 = convertPV PersistString-getGetter PG.BpChar                = convertPV PersistString-getGetter PG.VarChar               = convertPV PersistString-getGetter PG.Date                  = convertPV PersistDay-getGetter PG.Time                  = convertPV PersistTimeOfDay-getGetter PG.Timestamp             = convertPV (PersistUTCTime . localTimeToUTC utc)-getGetter PG.TimestampTZ           = convertPV (PersistZonedTime . ZT)-getGetter PG.Bit                   = convertPV PersistInt64-getGetter PG.VarBit                = convertPV PersistInt64-getGetter PG.Numeric               = convertPV (PersistDouble . fromRational)-getGetter PG.Void                  = \_ _ -> return PersistNull-getGetter _ = \f dat -> fmap (PersistByteString . unBinary) $ case dat of-  Nothing -> PGFF.returnError PGFF.UnexpectedNull f ""-  Just str -> return $ PG.Binary $ copy $ str+getGetter :: PG.Oid -> Getter PersistValue+getGetter (PG.Oid oid) = case oid of+  16   -> convertPV PersistBool+  17   -> convertPV (PersistByteString . unBinary)+  18   -> convertPV PersistString+  19   -> convertPV PersistString+  20   -> convertPV PersistInt64+  21   -> convertPV PersistInt64+  23   -> convertPV PersistInt64+  25   -> convertPV PersistString+  142  -> convertPV PersistString+  700  -> convertPV PersistDouble+  701  -> convertPV PersistDouble+  702  -> convertPV PersistUTCTime+  703  -> convertPV PersistUTCTime+  1042 -> convertPV PersistString+  1043 -> convertPV PersistString+  1082 -> convertPV PersistDay+  1083 -> convertPV PersistTimeOfDay+  1114 -> convertPV (PersistUTCTime . localTimeToUTC utc)+  1184 -> convertPV (PersistZonedTime . ZT)+  1560 -> convertPV PersistInt64+  1562 -> convertPV PersistInt64+  1700 -> convertPV (PersistDouble . fromRational)+  2278 -> \_ _ -> return PersistNull+  _    -> \f dat -> fmap PersistByteString $ case dat of+    Nothing -> PGFF.returnError PGFF.UnexpectedNull f ""+    Just str -> return $ copy $ str  unBinary :: PG.Binary a -> a unBinary (PG.Binary x) = x

@@ -49,8 +49,11 @@   persistName a = "Array" ++ delim : persistName ((undefined :: Array a -> a) a)
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType a = DbOther $ OtherTypeDef $ \f -> f elemType ++ "[]" where
-    elemType = dbType ((undefined :: Array a -> a) a)
+  dbType a = DbTypePrimitive typ False Nothing Nothing where
+    typ = DbOther $ OtherTypeDef $ \f -> f elemType ++ "[]"
+    elemType = case dbType ((undefined :: Array a -> a) a) of
+      DbTypePrimitive t _ _ _ -> t
+      t -> error $ "dbType " ++ persistName a ++ ": expected DbTypePrimitive, got " ++ show t
 
 class ArrayElem a where
   -- this function is added to avoid GHC bug 7126 which appears when PrimitivePersistField is added as class constraint
@@ -71,14 +74,6 @@   fromPrimitivePersistValue p a = parseHelper parser a where
     dimensions = char '[' *> takeWhile1 (/= '=') *> char '='
     parser = optional dimensions *> parseArr p
-
-instance (ArrayElem a, PersistField a) => SinglePersistField (Array a) where
-  toSinglePersistValue = primToSinglePersistValue
-  fromSinglePersistValue = primFromSinglePersistValue
-
-instance (ArrayElem a, PersistField a) => PurePersistField (Array a) where
-  toPurePersistValues = primToPurePersistValues
-  fromPurePersistValues = primFromPurePersistValues
 
 parseString :: Parser ByteString
 parseString = (char '"' *> jstring_)

@@ -41,77 +41,45 @@ points :: Parser [Point]
 points = point `sepBy1` char ','
 
-instance PersistField Point where
-  persistName _ = "Point"
-  toPersistValues = primToPersistValue
-  fromPersistValues = primFromPersistValue
-  dbType _ = DbOther $ OtherTypeDef $ const "point"
-
 instance PrimitivePersistField Point where
   toPrimitivePersistValue _ (Point x y) = PersistString $ show (x, y)
   fromPrimitivePersistValue _ = parseHelper point
 
-instance SinglePersistField Point where
-  toSinglePersistValue = primToSinglePersistValue
-  fromSinglePersistValue = primFromSinglePersistValue
-
-instance PurePersistField Point where
-  toPurePersistValues = primToPurePersistValues
-  fromPurePersistValues = primFromPurePersistValues
-
-instance PersistField Line where
-  persistName _ = "Line"
+instance PersistField Point where
+  persistName _ = "Point"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbOther $ OtherTypeDef $ const "line"
+  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "point") False Nothing Nothing
 
 instance PrimitivePersistField Line where
   toPrimitivePersistValue _ (Line (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2))
   fromPrimitivePersistValue _ = error "fromPrimitivePersistValue Line is not supported yet"
 
-instance SinglePersistField Line where
-  toSinglePersistValue = primToSinglePersistValue
-  fromSinglePersistValue = primFromSinglePersistValue
-
-instance PurePersistField Line where
-  toPurePersistValues = primToPurePersistValues
-  fromPurePersistValues = primFromPurePersistValues
-
-instance PersistField Lseg where
-  persistName _ = "Lseg"
+instance PersistField Line where
+  persistName _ = "Line"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbOther $ OtherTypeDef $ const "lseg"
+  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "line") False Nothing Nothing
 
 instance PrimitivePersistField Lseg where
   toPrimitivePersistValue _ (Lseg (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2))
   fromPrimitivePersistValue _ = parseHelper $ pair Lseg '[' ']' point
 
-instance SinglePersistField Lseg where
-  toSinglePersistValue = primToSinglePersistValue
-  fromSinglePersistValue = primFromSinglePersistValue
-
-instance PurePersistField Lseg where
-  toPurePersistValues = primToPurePersistValues
-  fromPurePersistValues = primFromPurePersistValues
-
-instance PersistField Box where
-  persistName _ = "Box"
+instance PersistField Lseg where
+  persistName _ = "Lseg"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbOther $ OtherTypeDef $ const "box"
+  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "lseg") False Nothing Nothing
 
 instance PrimitivePersistField Box where
   toPrimitivePersistValue _ (Box (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2))
   fromPrimitivePersistValue _ = parseHelper $ Box <$> (point <* char ',') <*> point
 
-instance SinglePersistField Box where
-  toSinglePersistValue = primToSinglePersistValue
-  fromSinglePersistValue = primFromSinglePersistValue
-
-instance PurePersistField Box where
-  toPurePersistValues = primToPurePersistValues
-  fromPurePersistValues = primFromPurePersistValues
+instance PersistField Box where
+  persistName _ = "Box"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "box") False Nothing Nothing
 
 showPath :: Char -> Char -> [Point] -> ShowS
 showPath open close []     s = open : close : s
@@ -123,12 +91,6 @@ showPoint :: Point -> ShowS
 showPoint (Point x y) = shows (x, y)
 
-instance PersistField Path where
-  persistName _ = "Path"
-  toPersistValues = primToPersistValue
-  fromPersistValues = primFromPersistValue
-  dbType _ = DbOther $ OtherTypeDef $ const "path"
-
 instance PrimitivePersistField Path where
   toPrimitivePersistValue _ path = PersistString $ case path of
     ClosedPath ps -> showPath '(' ')' ps ""
@@ -136,46 +98,28 @@   fromPrimitivePersistValue _ = parseHelper $ path' ClosedPath '(' ')' <|> path' OpenPath '[' ']' where
     path' f open close = f <$> (char open *> points <* char close)
 
-instance SinglePersistField Path where
-  toSinglePersistValue = primToSinglePersistValue
-  fromSinglePersistValue = primFromSinglePersistValue
-
-instance PurePersistField Path where
-  toPurePersistValues = primToPurePersistValues
-  fromPurePersistValues = primFromPurePersistValues
-
-instance PersistField Polygon where
-  persistName _ = "Polygon"
+instance PersistField Path where
+  persistName _ = "Path"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbOther $ OtherTypeDef $ const "polygon"
+  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "path") False Nothing Nothing
 
 instance PrimitivePersistField Polygon where
   toPrimitivePersistValue _ (Polygon ps) = PersistString $ showPath '(' ')' ps ""
   fromPrimitivePersistValue _ = parseHelper $ Polygon <$> (char '(' *> points <* char ')')
 
-instance SinglePersistField Polygon where
-  toSinglePersistValue = primToSinglePersistValue
-  fromSinglePersistValue = primFromSinglePersistValue
-
-instance PurePersistField Polygon where
-  toPurePersistValues = primToPurePersistValues
-  fromPurePersistValues = primFromPurePersistValues
-
-instance PersistField Circle where
-  persistName _ = "Circle"
+instance PersistField Polygon where
+  persistName _ = "Polygon"
   toPersistValues = primToPersistValue
   fromPersistValues = primFromPersistValue
-  dbType _ = DbOther $ OtherTypeDef $ const "circle"
+  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "polygon") False Nothing Nothing
 
 instance PrimitivePersistField Circle where
   toPrimitivePersistValue _ (Circle (Point x1 y1) r) = PersistString $ show ((x1, y1), r)
   fromPrimitivePersistValue _ = parseHelper $ Circle <$> (char '<' *> point) <* char ',' <*> double <* char '>'
 
-instance SinglePersistField Circle where
-  toSinglePersistValue = primToSinglePersistValue
-  fromSinglePersistValue = primFromSinglePersistValue
-
-instance PurePersistField Circle where
-  toPurePersistValues = primToPurePersistValues
-  fromPurePersistValues = primFromPurePersistValues
+instance PersistField Circle where
+  persistName _ = "Circle"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ = DbTypePrimitive (DbOther $ OtherTypeDef $ const "circle") False Nothing Nothing

@@ -1,5 +1,5 @@ name:            groundhog-postgresql-version:         0.3.1+version:         0.4.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>@@ -14,16 +14,17 @@ library     build-depends:   base                    >= 4         && < 5                    , postgresql-simple       >= 0.3       && < 0.4-                   , postgresql-libpq        >= 0.6.1     && < 0.9+                   , postgresql-libpq        >= 0.6.1                    , bytestring              >= 0.9-                   , blaze-builder           >= 0.3.0.0   && < 0.4-                   , transformers            >= 0.2.1     && < 0.4-                   , groundhog               >= 0.3.0     && < 0.4.0-                   , monad-control           >= 0.3       && < 0.4+                   , blaze-builder           >= 0.3.0.0+                   , transformers            >= 0.2.1+                   , groundhog               >= 0.4.0     && < 0.5.0+                   , monad-control           >= 0.3+                   , monad-logger            >= 0.3                    , containers              >= 0.2-                   , text                    >= 0.8       && < 0.12+                   , text                    >= 0.8                    , attoparsec              >= 0.8.5.3-                   , resource-pool           >= 0.2.1     && < 0.3+                   , resource-pool           >= 0.2.1                    , time                    >= 1.1     exposed-modules: Database.Groundhog.Postgresql                      Database.Groundhog.Postgresql.Array