Expand use of QualifiedName to types, composites, enums (#263)

Types in PostgreSQL can also be qualified with a schema. However, it's not sufficient to just change the type of `TypeInformation`'s `typeName` to `QualifiedName`, because a type isn't *just* a name. Postgres types can also be parameterised by modifiers (e.g., `numeric(7, 2)`) and array types of arbitrary depth (e.g., `int4[][]`).

To accomodate this, a new type is introduced, `TypeName`. Like `QualifiedName`, it has an `IsString` instance, so the common case (`schema` set to `Nothing`, no modifiers, scalar type) will continue working as before.

changelog.d/20230715_173829_shane.obrien_TypeName.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
+
+- `TypeName` record, which gives a richer representation of the components of a PostgreSQL type name (name, schema, modifiers, scalar/array).
+
+### Changed
+
+- `TypeInformation`'s `typeName` parameter from `String` to `TypeName`.
+- `DBEnum`'s `enumTypeName` method from `String` to `QualifiedName`.
+- `DBComposite`'s `compositeTypeName` method from `String` to `QualifiedName`.
+
+<!--
+### Deprecated
+
+- A bullet item for the Deprecated category.
+
+-->
+<!--
+### Fixed
+
+- A bullet item for the Fixed category.
+
+-->
+<!--
+### Security
+
+- A bullet item for the Security category.
+
+-->

rel8.cabal

@@ -207,6 +207,7 @@ library
     Rel8.Type.JSONEncoded
     Rel8.Type.JSONBEncoded
     Rel8.Type.Monoid
+    Rel8.Type.Name
     Rel8.Type.Num
     Rel8.Type.Ord
     Rel8.Type.ReadShow

src/Rel8.hs

@@ -19,6 +19,7 @@ module Rel8
 
     -- *** @TypeInformation@
   , TypeInformation(..)
+  , TypeName(..)
   , mapTypeInformation
   , parseTypeInformation
 
@@ -474,6 +475,7 @@ import Rel8.Type.Information
 import Rel8.Type.JSONBEncoded
 import Rel8.Type.JSONEncoded
 import Rel8.Type.Monoid
+import Rel8.Type.Name
 import Rel8.Type.Num
 import Rel8.Type.Ord
 import Rel8.Type.ReadShow

src/Rel8/Expr/Opaleye.hs

@@ -26,6 +26,7 @@ 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.Name (showTypeName)
 
 -- profunctors
 import Data.Profunctor ( Profunctor, dimap )
@@ -48,7 +49,7 @@ scastExpr = sunsafeCastExpr
 sunsafeCastExpr :: ()
   => TypeInformation (Unnullify b) -> Expr a -> Expr b
 sunsafeCastExpr TypeInformation {typeName} =
-  fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr
+  fromPrimExpr . Opaleye.CastExpr (showTypeName typeName) . toPrimExpr
 
 
 -- | Unsafely construct an expression from literal SQL.

src/Rel8/Statement.hs

@@ -41,7 +41,6 @@ import Text.PrettyPrint
   , (<+>)
   , ($$)
   , comma
-  , doubleQuotes
   , hcat
   , parens
   , punctuate

src/Rel8/Table/Opaleye.hs

@@ -56,6 +56,7 @@ 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.Name (showTypeName)
 
 -- semigroupoids
 import Data.Functor.Apply ( WrappedApplicative(..) )
@@ -135,7 +136,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 . Rel8.Type.Information.typeName . 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 #-}
 
@@ -40,6 +41,7 @@ import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )
 import Rel8.Schema.Null ( NotNull, Sql, nullable )
 import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
 import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )
+import Rel8.Type.Name (TypeName (..))
 
 -- scientific
 import Data.Scientific ( Scientific )
@@ -95,7 +97,12 @@ instance DBType Char where
   typeInformation = TypeInformation
     { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure
     , decode = Hasql.char
-    , typeName = "char"
+    , typeName =
+        TypeName
+          { name = "bpchar"
+          , modifiers = ["1"]
+          , arrayDepth = 0
+          }
     }
 
 

src/Rel8/Type/Array.hs

@@ -26,12 +26,13 @@ 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.Type.Name (TypeName (..), showTypeName)
 
 
 array :: Foldable f
   => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr
 array info =
-  Opaleye.CastExpr (arrayType info <> "[]") .
+  Opaleye.CastExpr (showTypeName (arrayType info) <> "[]") .
   Opaleye.ArrayExpr . map (encodeArrayElement info) . toList
 {-# INLINABLE array #-}
 
@@ -54,7 +55,7 @@ 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 +73,10 @@ nonEmptyTypeInformation nullity =
 
 
 isArray :: TypeInformation a -> Bool
-isArray = \case
-  (reverse . typeName -> ']' : '[' : _) -> True
-  _ -> False
+isArray = (> 0) . arrayDepth . typeName
 
 
-arrayType :: TypeInformation a -> String
+arrayType :: TypeInformation a -> TypeName
 arrayType info
   | isArray info = "record"
   | otherwise = typeName info
@@ -107,7 +106,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 (typeName info))
         text = Opaleye.CastExpr "text" input
         unrow =
           Opaleye.CaseExpr

src/Rel8/Type/Composite.hs

@@ -36,6 +36,7 @@ import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
 import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
 import Rel8.Schema.Name ( Name( Name ) )
 import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
+import Rel8.Schema.QualifiedName (QualifiedName)
 import Rel8.Schema.Result ( Result )
 import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
 import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )
@@ -47,6 +48,7 @@ import Rel8.Table.Serialize ( litHTable )
 import Rel8.Type ( DBType, typeInformation )
 import Rel8.Type.Eq ( DBEq )
 import Rel8.Type.Information ( TypeInformation(..) )
+import Rel8.Type.Name (TypeName (..))
 import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
 
 -- semigroupoids
@@ -70,7 +72,12 @@ instance DBComposite a => DBType (Composite a) where
   typeInformation = TypeInformation
     { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
     , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite
-    , typeName = compositeTypeName @a
+    , typeName =
+        TypeName
+          { name = compositeTypeName @a
+          , modifiers = []
+          , arrayDepth = 0
+          }
     }
 
 
@@ -94,7 +101,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,9 +38,11 @@ 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(..) )
+import Rel8.Type.Name (TypeName (..))
 import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
 
 -- text
@@ -75,7 +77,12 @@ instance DBEnum a => DBType (Enum a) where
         Opaleye.StringLit .
         enumValue @a .
         unEnum
-    , typeName = enumTypeName @a
+    , typeName =
+        TypeName
+          { name = enumTypeName @a
+          , modifiers = []
+          , arrayDepth = 0
+          }
     }
 
 
@@ -101,7 +108,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

@@ -1,6 +1,7 @@
 {-# language GADTs #-}
 {-# language NamedFieldPuns #-}
 {-# language StandaloneKindSignatures #-}
+{-# language StrictData #-}
 
 module Rel8.Type.Information
   ( TypeInformation(..)
@@ -20,6 +21,9 @@ import qualified Hasql.Decoders as Hasql
 -- opaleye
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
+-- rel8
+import Rel8.Type.Name (TypeName)
+
 -- text
 import qualified Data.Text as Text
 
@@ -33,7 +37,7 @@ 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 :: TypeName
     -- ^ The name of the SQL type.
   }
 

src/Rel8/Type/JSONBEncoded.hs

@@ -1,3 +1,4 @@
+{-# language OverloadedStrings #-}
 {-# language StandaloneKindSignatures #-}
 
 module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where

src/Rel8/Type/Name.hs

@@ -0,0 +1,58 @@
+{-# language RecordWildCards #-}
+{-# language StrictData #-}
+
+module Rel8.Type.Name
+  ( TypeName (..)
+  , showTypeName
+  )
+where
+
+-- base
+import Data.Semigroup (mtimesDefault)
+import Data.String (IsString, fromString)
+import Prelude
+
+-- pretty
+import Text.PrettyPrint (Doc, comma, hcat, parens, punctuate, text)
+
+-- rel8
+import Rel8.Schema.QualifiedName (QualifiedName, ppQualifiedName)
+
+
+-- | A PostgreSQL type consists of a 'QualifiedName' (name, schema), and
+-- optional 'modifiers' and 'arrayDepth'. 'modifiers' will usually be @[]@,
+-- but a type like @numeric(6, 2)@ will have @["6", "2"]@. 'arrayDepth' is
+-- always @0@ for non-array types.
+data TypeName = TypeName
+  { name :: QualifiedName
+    -- ^ The name (and schema) of the type.
+  , modifiers :: [String]
+    -- ^ Any modifiers applied to the underlying type.
+  , arrayDepth :: Word
+    -- ^ If this is an array type, the depth of that array (@1@ for @[]@, @2@
+    -- for @[][]@, etc).
+  }
+
+
+-- | Constructs 'TypeName's with 'schema' set to 'Nothing', 'modifiers' set
+-- to @[]@ and 'arrayDepth' set to @0@.
+instance IsString TypeName where
+  fromString string =
+    TypeName
+      { name = fromString string
+      , modifiers = []
+      , arrayDepth = 0
+      }
+
+
+ppTypeName :: TypeName -> Doc
+ppTypeName TypeName {..} =
+  ppQualifiedName name <> modifier <> mtimesDefault arrayDepth (text "[]")
+  where
+    modifier
+      | null modifiers = mempty
+      | otherwise = parens (hcat $ punctuate comma $ text <$> modifiers)
+
+
+showTypeName :: TypeName -> String
+showTypeName = show . ppTypeName