Expand use of QualifiedName to types, composites, enums

changelog.d/20230715_133657_shane.obrien_QualifiedName2.md

@@ -0,0 +1,40 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Removed
+
+- A bullet item for the Removed category.
+
+-->
+<!--
+### Added
+
+- A bullet item for the Added category.
+
+-->
+### Changed
+
+- Also use `QualifiedName` for `TypeInformation`.`typeName`, `enumTypeName` and `compositeTypeName`. This also means that `TypeInformation` now has an extra field, `arrayDepth`.
+
+<!--
+### Deprecated
+
+- A bullet item for the Deprecated category.
+
+-->
+<!--
+### Fixed
+
+- A bullet item for the Fixed category.
+
+-->
+<!--
+### Security
+
+- A bullet item for the Security category.
+
+-->

src/Rel8/Expr/Function.hs

@@ -29,7 +29,7 @@ import Rel8.Expr.Opaleye
   )
 import Rel8.Schema.HTable (hfoldMap)
 import Rel8.Schema.Null ( Sql )
-import Rel8.Schema.QualifiedName (QualifiedName, ppQualifiedName)
+import Rel8.Schema.QualifiedName (QualifiedName, showQualifiedName)
 import Rel8.Table (Table, toColumns)
 import Rel8.Type ( DBType )
 
@@ -61,7 +61,7 @@ primFunction :: Arguments arguments
   => QualifiedName -> arguments -> Opaleye.PrimExpr
 primFunction qualified = Opaleye.FunExpr name . arguments
   where
-    name = show (ppQualifiedName qualified)
+    name = showQualifiedName qualified
 
 
 -- | Construct an expression by applying an infix binary operator to two

src/Rel8/Expr/Opaleye.hs

@@ -25,7 +25,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
 import Rel8.Schema.Null ( Unnullify, Sql )
 import Rel8.Type ( DBType, typeInformation )
-import Rel8.Type.Information ( TypeInformation(..) )
+import Rel8.Type.Information (TypeInformation(..), showTypeName)
 
 -- profunctors
 import Data.Profunctor ( Profunctor, dimap )
@@ -47,8 +47,8 @@ scastExpr = sunsafeCastExpr
 
 sunsafeCastExpr :: ()
   => TypeInformation (Unnullify b) -> Expr a -> Expr b
-sunsafeCastExpr TypeInformation {typeName} =
+sunsafeCastExpr info =
-  fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
+  fromPrimExpr . Opaleye.CastExpr (showTypeName info) . toPrimExpr
 
 
 -- | Unsafely construct an expression from literal SQL.

src/Rel8/Expr/Sequence.hs

@@ -13,7 +13,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 -- rel8
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Opaleye (fromPrimExpr)
-import Rel8.Schema.QualifiedName (QualifiedName, ppQualifiedName)
+import Rel8.Schema.QualifiedName (QualifiedName, showQualifiedName)
 
 
 -- | See https://www.postgresql.org/docs/current/functions-sequence.html
@@ -21,5 +21,5 @@ nextval :: QualifiedName -> Expr Int64
 nextval name =
   fromPrimExpr $
     Opaleye.FunExpr "nextval"
-      [ Opaleye.ConstExpr (Opaleye.StringLit (show (ppQualifiedName name)))
+      [ Opaleye.ConstExpr (Opaleye.StringLit (showQualifiedName name))
       ]

src/Rel8/Schema/QualifiedName.hs

@@ -7,6 +7,7 @@
 module Rel8.Schema.QualifiedName
   ( QualifiedName (..)
   , ppQualifiedName
+  , showQualifiedName
   )
 where
 
@@ -47,3 +48,7 @@ ppQualifiedName QualifiedName {..} = Opaleye.ppTable Opaleye.SqlTable
   { sqlTableSchemaName = schema
   , sqlTableName = name
   }
+
+
+showQualifiedName :: QualifiedName -> String
+showQualifiedName = show . ppQualifiedName

src/Rel8/Table/Opaleye.hs

@@ -55,7 +55,7 @@ import Rel8.Schema.QualifiedName (QualifiedName (QualifiedName))
 import Rel8.Schema.Spec ( Spec(..) )
 import Rel8.Schema.Table ( TableSchema(..), ppTable )
 import Rel8.Table ( Table, fromColumns, toColumns )
-import Rel8.Type.Information ( typeName )
+import Rel8.Type.Information (showTypeName)
 
 -- semigroupoids
 import Data.Functor.Apply ( WrappedApplicative(..) )
@@ -135,7 +135,7 @@ valuesspec :: Table Expr a => Opaleye.Valuesspec a a
 valuesspec = dimap toColumns fromColumns $
   htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)
   where
-    typeName = Rel8.Type.Information.typeName . info . hfield hspecs
+    typeName = showTypeName . info . hfield hspecs
 
 
 view :: Selects names exprs => names -> exprs

src/Rel8/Type.hs

@@ -2,6 +2,7 @@
 {-# language FlexibleInstances #-}
 {-# language MonoLocalBinds #-}
 {-# language MultiWayIf #-}
+{-# language OverloadedStrings #-}
 {-# language StandaloneKindSignatures #-}
 {-# language UndecidableInstances #-}
 
@@ -87,6 +88,7 @@ instance DBType Bool where
     { encode = Opaleye.ConstExpr . Opaleye.BoolLit
     , decode = Hasql.bool
     , typeName = "bool"
+    , arrayDepth = 0
     }
 
 
@@ -96,6 +98,7 @@ instance DBType Char where
     { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure
     , decode = Hasql.char
     , typeName = "char"
+    , arrayDepth = 0
     }
 
 
@@ -105,6 +108,7 @@ instance DBType Int16 where
     { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
     , decode = Hasql.int2
     , typeName = "int2"
+    , arrayDepth = 0
     }
 
 
@@ -114,6 +118,7 @@ instance DBType Int32 where
     { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
     , decode = Hasql.int4
     , typeName = "int4"
+    , arrayDepth = 0
     }
 
 
@@ -123,6 +128,7 @@ instance DBType Int64 where
     { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
     , decode = Hasql.int8
     , typeName = "int8"
+    , arrayDepth = 0
     }
 
 
@@ -136,6 +142,7 @@ instance DBType Float where
            | otherwise     -> Opaleye.NumericLit $ realToFrac x
     , decode = Hasql.float4
     , typeName = "float4"
+    , arrayDepth = 0
     }
 
 
@@ -149,6 +156,7 @@ instance DBType Double where
            | otherwise     -> Opaleye.NumericLit $ realToFrac x
     , decode = Hasql.float8
     , typeName = "float8"
+    , arrayDepth = 0
     }
 
 
@@ -158,6 +166,7 @@ instance DBType Scientific where
     { encode = Opaleye.ConstExpr . Opaleye.NumericLit
     , decode = Hasql.numeric
     , typeName = "numeric"
+    , arrayDepth = 0
     }
 
 
@@ -169,6 +178,7 @@ instance DBType UTCTime where
         formatTime defaultTimeLocale "'%FT%T%QZ'"
     , decode = Hasql.timestamptz
     , typeName = "timestamptz"
+    , arrayDepth = 0
     }
 
 
@@ -180,6 +190,7 @@ instance DBType Day where
         formatTime defaultTimeLocale "'%F'"
     , decode = Hasql.date
     , typeName = "date"
+    , arrayDepth = 0
     }
 
 
@@ -191,6 +202,7 @@ instance DBType LocalTime where
         formatTime defaultTimeLocale "'%FT%T%Q'"
     , decode = Hasql.timestamp
     , typeName = "timestamp"
+    , arrayDepth = 0
     }
 
 
@@ -202,6 +214,7 @@ instance DBType TimeOfDay where
         formatTime defaultTimeLocale "'%T%Q'"
     , decode = Hasql.time
     , typeName = "time"
+    , arrayDepth = 0
     }
 
 
@@ -213,6 +226,7 @@ instance DBType CalendarDiffTime where
         formatTime defaultTimeLocale "'%bmon %0Es'"
     , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval
     , typeName = "interval"
+    , arrayDepth = 0
     }
 
 
@@ -222,6 +236,7 @@ instance DBType Text where
     { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack
     , decode = Hasql.text
     , typeName = "text"
+    , arrayDepth = 0
     }
 
 
@@ -251,6 +266,7 @@ instance DBType ByteString where
     { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit
     , decode = Hasql.bytea
     , typeName = "bytea"
+    , arrayDepth = 0
     }
 
 
@@ -267,6 +283,7 @@ instance DBType UUID where
     { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString
     , decode = Hasql.uuid
     , typeName = "uuid"
+    , arrayDepth = 0
     }
 
 
@@ -279,6 +296,7 @@ instance DBType Value where
         Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode
     , decode = Hasql.jsonb
     , typeName = "jsonb"
+    , arrayDepth = 0
     }
 
 -- | Corresponds to @inet@
@@ -288,6 +306,7 @@ instance DBType (NetAddr IP) where
         Opaleye.ConstExpr . Opaleye.StringLit . printNetAddr
     , decode = Hasql.inet
     , typeName = "inet"
+    , arrayDepth = 0
     }
 
 

src/Rel8/Type/Array.hs

@@ -25,13 +25,18 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
 -- rel8
 import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ) )
-import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )
+import Rel8.Schema.QualifiedName (QualifiedName, showQualifiedName)
+import Rel8.Type.Information
+  ( TypeInformation(..)
+  , parseTypeInformation
+  , showTypeName
+  )
 
 
 array :: Foldable f
   => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr
 array info =
-  Opaleye.CastExpr (arrayType info <> "[]") .
+  Opaleye.CastExpr (showQualifiedName (arrayType info) <> "[]") .
   Opaleye.ArrayExpr . map (encodeArrayElement info) . toList
 {-# INLINABLE array #-}
 
@@ -54,7 +59,8 @@ listTypeInformation nullity info@TypeInformation {encode, decode} =
         NotNull ->
           Opaleye.ArrayExpr .
           fmap (encodeArrayElement info . encode)
-    , typeName = arrayType info <> "[]"
+    , typeName = arrayType info
+    , arrayDepth = 1
     }
   where
     null = Opaleye.ConstExpr Opaleye.NullLit
@@ -72,12 +78,10 @@ nonEmptyTypeInformation nullity =
 
 
 isArray :: TypeInformation a -> Bool
-isArray = \case
+isArray = (> 0) . arrayDepth
-  (reverse . typeName -> ']' : '[' : _) -> True
-  _ -> False
 
 
-arrayType :: TypeInformation a -> String
+arrayType :: TypeInformation a -> QualifiedName
 arrayType info
   | isArray info = "record"
   | otherwise = typeName info
@@ -107,7 +111,7 @@ extractArrayElement info
         minus a b = Opaleye.BinExpr (Opaleye.:-) a b
         len = Opaleye.FunExpr "length" . pure
         substr s a b = Opaleye.FunExpr "substr" [s, a, b]
-        cast = Opaleye.CastExpr (typeName info)
+        cast = Opaleye.CastExpr (showTypeName info)
         text = Opaleye.CastExpr "text" input
         unrow =
           Opaleye.CaseExpr

src/Rel8/Type/Composite.hs

@@ -34,6 +34,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
 import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
+import Rel8.Schema.QualifiedName (QualifiedName)
 import Rel8.Schema.Name ( Name( Name ) )
 import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
 import Rel8.Schema.Result ( Result )
@@ -71,6 +72,7 @@ instance DBComposite a => DBType (Composite a) where
     { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
     , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite
     , typeName = compositeTypeName @a
+    , arrayDepth = 0
     }
 
 
@@ -94,7 +96,7 @@ class (DBType a, HKDable a) => DBComposite a where
   compositeFields :: HKD a Name
 
   -- | The name of the composite type that @a@ maps to.
-  compositeTypeName :: String
+  compositeTypeName :: QualifiedName
 
 
 -- | Collapse a 'HKD' into a PostgreSQL composite type.

src/Rel8/Type/Enum.hs

@@ -38,6 +38,7 @@ import qualified Hasql.Decoders as Hasql
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
 -- rel8
+import Rel8.Schema.QualifiedName (QualifiedName)
 import Rel8.Type ( DBType, typeInformation )
 import Rel8.Type.Eq ( DBEq )
 import Rel8.Type.Information ( TypeInformation(..) )
@@ -76,6 +77,7 @@ instance DBEnum a => DBType (Enum a) where
         enumValue @a .
         unEnum
     , typeName = enumTypeName @a
+    , arrayDepth = 0
     }
 
 
@@ -101,7 +103,7 @@ class (DBType a, Enumable a) => DBEnum a where
   enumValue = gshow @(Rep a) . from
 
   -- | The name of the PostgreSQL @enum@ type that @a@ maps to.
-  enumTypeName :: String
+  enumTypeName :: QualifiedName
 
 
 -- | Types that are sum types, where each constructor is unary (that is, has no

src/Rel8/Type/Information.hs

@@ -6,12 +6,14 @@ module Rel8.Type.Information
   ( TypeInformation(..)
   , mapTypeInformation
   , parseTypeInformation
+  , showTypeName
   )
 where
 
 -- base
 import Data.Bifunctor ( first )
 import Data.Kind ( Type )
+import Data.Semigroup (mtimesDefault)
 import Prelude
 
 -- hasql
@@ -20,6 +22,9 @@ import qualified Hasql.Decoders as Hasql
 -- opaleye
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
+-- rel8
+import Rel8.Schema.QualifiedName (QualifiedName, showQualifiedName)
+
 -- text
 import qualified Data.Text as Text
 
@@ -33,8 +38,10 @@ data TypeInformation a = TypeInformation
     -- ^ How to encode a single Haskell value as a SQL expression.
   , decode :: Hasql.Value a
     -- ^ How to deserialize a single result back to Haskell.
-  , typeName :: String
+  , typeName :: QualifiedName
     -- ^ The name of the SQL type.
+  , arrayDepth :: Word
+    -- ^ How many levels of @[]@ (or 0 if type is not array).
   }
 
 
@@ -59,9 +66,15 @@ mapTypeInformation = parseTypeInformation . fmap pure
 parseTypeInformation :: ()
   => (a -> Either String b) -> (b -> a)
   -> TypeInformation a -> TypeInformation b
-parseTypeInformation to from TypeInformation {encode, decode, typeName} =
+parseTypeInformation to from TypeInformation {encode, decode, typeName, arrayDepth} =
   TypeInformation
     { encode = encode . from
     , decode = Hasql.refine (first Text.pack . to) decode
     , typeName
+    , arrayDepth
     }
+
+
+showTypeName :: TypeInformation a -> String
+showTypeName TypeInformation {typeName, arrayDepth} =
+  showQualifiedName typeName <> mtimesDefault arrayDepth "[]"

src/Rel8/Type/JSONBEncoded.hs

@@ -1,3 +1,4 @@
+{-# language OverloadedStrings #-}
 {-# language StandaloneKindSignatures #-}
 
 module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where
@@ -32,4 +33,5 @@ instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where
     { encode = encode typeInformation . toJSON . fromJSONBEncoded
     , decode = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb
     , typeName = "jsonb"
+    , arrayDepth = 0
     }