Merge pull request #52 from obsidiansystems/ym@sql_arrays

Support sql arrays

src/Database/Beam/AutoMigrate.hs

@@ -569,6 +569,10 @@ renderDataType = \case
   PgSpecificType (PgEnumeration (EnumerationName ty)) -> ty
   -- oid
   PgSpecificType PgOid -> "oid"
+  -- Arrays
+  SqlArrayType (SqlArrayType _ _) _ -> error "beam-automigrate: invalid nested array."
+  SqlArrayType _ 0 -> error "beam-automigrate: array with zero dimensions"
+  SqlArrayType t d -> renderDataType t <> mconcat (replicate (fromIntegral d) "[]")
 
 evalMigration :: Monad m => Migration m -> m (Either MigrationError [WithPriority Edit])
 evalMigration m = do

src/Database/Beam/AutoMigrate/Compat.hs

@@ -20,6 +20,7 @@ import Data.Time (LocalTime, TimeOfDay, UTCTime)
 import Data.Time.Calendar (Day)
 import Data.Typeable
 import Data.UUID
+import Data.Vector (Vector)
 import Data.Word
 import qualified Database.Beam as Beam
 import Database.Beam.AutoMigrate.Types
@@ -245,6 +246,15 @@ instance HasColumnType (Pg.PgRange Pg.PgTsTzRange a) where
 instance HasColumnType (Pg.PgRange Pg.PgDateRange a) where
   defaultColumnType _ = PgSpecificType PgRangeDate
 
+--
+-- support for arrays
+--
+
+instance HasColumnType a => HasColumnType (Vector a) where
+  defaultColumnType _ = case defaultColumnType (Proxy @a) of
+    SqlArrayType t d -> SqlArrayType t (d + 1)
+    t -> SqlArrayType t 1
+
 --
 -- Support for 'SqlSerial'. \"SERIAL\" is treated by Postgres as syntactic sugar for:
 ---

src/Database/Beam/AutoMigrate/Postgres.hs

@@ -123,7 +123,7 @@ tableColumnsQ :: Pg.Query
 tableColumnsQ =
   fromString $
     unlines
-      [ "SELECT attname, atttypid, atttypmod, attnotnull, pg_catalog.format_type(atttypid, atttypmod) ",
+      [ "SELECT attname, atttypid, atttypmod, attndims, attnotnull, pg_catalog.format_type(atttypid, atttypmod) ",
         "FROM pg_catalog.pg_attribute att ",
         "WHERE att.attrelid=? AND att.attnum>0 AND att.attisdropped='f' "
       ]
@@ -249,9 +249,9 @@ getSchema conn = do
       Map Pg.Oid (EnumerationName, Enumeration) ->
       AllDefaults ->
       Columns ->
-      (ByteString, Pg.Oid, Int, Bool, ByteString) ->
+      (ByteString, Pg.Oid, Int, Int, Bool, ByteString) ->
       IO Columns
-    getColumns tName enumData defaultData c (attname, atttypid, atttypmod, attnotnull, format_type) = do
+    getColumns tName enumData defaultData c (attname, atttypid, atttypmod, attndims, attnotnull, format_type) = do
       -- /NOTA BENE(adn)/: The atttypmod - 4 was originally taken from 'beam-migrate'
       -- (see: https://github.com/tathougies/beam/blob/d87120b58373df53f075d92ce12037a98ca709ab/beam-postgres/Database/Beam/Postgres/Migrate.hs#L343)
       -- but there are cases where this is not correct, for example in the case of bitstrings.
@@ -272,7 +272,8 @@ getSchema conn = do
       case asum
         [ pgSerialTyColumnType atttypid mbDefault,
           pgTypeToColumnType atttypid mbPrecision,
-          pgEnumTypeToColumnType enumData atttypid
+          pgEnumTypeToColumnType enumData atttypid,
+          pgArrayTypeToColumnType atttypid mbPrecision attndims
         ] of
         Just cType -> do
           let nullConstraint = if attnotnull then S.fromList [NotNull] else mempty
@@ -378,6 +379,13 @@ pgTypeToColumnType oid width
   | otherwise =
     Nothing
 
+pgArrayTypeToColumnType :: Pg.Oid -> Maybe Int -> Int -> Maybe ColumnType
+pgArrayTypeToColumnType oid width dims = case Pg.staticTypeInfo oid of
+  Just (Pg.Array _ _ _ _ subTypeInfo) -> case pgTypeToColumnType (Pg.typoid subTypeInfo) width of
+    Just columnType -> Just $ SqlArrayType columnType (fromIntegral dims)
+    _ -> Nothing
+  _ -> Nothing
+
 --
 -- Constraints discovery
 --

src/Database/Beam/AutoMigrate/Types.hs

@@ -141,6 +141,8 @@ data ColumnType
     PgSpecificType PgDataType
   | -- | An enumeration implemented with text-based encoding.
     DbEnumeration EnumerationName Enumeration
+  | -- | Array type.
+    SqlArrayType ColumnType Word
   deriving (Show, Eq, Generic)
 
 data PgDataType