diff --git a/squeal-postgresql.cabal b/squeal-postgresql.cabal --- a/squeal-postgresql.cabal +++ b/squeal-postgresql.cabal @@ -1,5 +1,5 @@ name: squeal-postgresql -version: 0.8.0.0 +version: 0.8.1.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal diff --git a/src/Squeal/PostgreSQL/Expression/Aggregate.hs b/src/Squeal/PostgreSQL/Expression/Aggregate.hs --- a/src/Squeal/PostgreSQL/Expression/Aggregate.hs +++ b/src/Squeal/PostgreSQL/Expression/Aggregate.hs @@ -566,6 +566,48 @@ varPop = unsafeAggregate "var_pop" varSamp = unsafeAggregate "var_samp" +-- provides a nicer type error when we forget to group by +-- note that we need to make our 'a' polymorphic so that we can still match when it's ambiguous +instance ( TypeError ('Text "Cannot use aggregate functions to construct an Ungrouped Expression. Add a 'groupBy' to your TableExpression. If you want to aggregate across the entire result set, use 'groupBy Nil'.") + , a ~ AggregateArg + ) => Aggregate a (Expression 'Ungrouped) where + countStar = impossibleAggregateError + count = impossibleAggregateError + sum_ = impossibleAggregateError + arrayAgg = impossibleAggregateError + jsonAgg = impossibleAggregateError + jsonbAgg = impossibleAggregateError + bitAnd = impossibleAggregateError + bitOr = impossibleAggregateError + boolAnd = impossibleAggregateError + boolOr = impossibleAggregateError + every = impossibleAggregateError + max_ = impossibleAggregateError + min_ = impossibleAggregateError + avg = impossibleAggregateError + corr = impossibleAggregateError + covarPop = impossibleAggregateError + covarSamp = impossibleAggregateError + regrAvgX = impossibleAggregateError + regrAvgY = impossibleAggregateError + regrCount = impossibleAggregateError + regrIntercept = impossibleAggregateError + regrR2 = impossibleAggregateError + regrSlope = impossibleAggregateError + regrSxx = impossibleAggregateError + regrSxy = impossibleAggregateError + regrSyy = impossibleAggregateError + stddev = impossibleAggregateError + stddevPop = impossibleAggregateError + stddevSamp = impossibleAggregateError + variance = impossibleAggregateError + varPop = impossibleAggregateError + varSamp = impossibleAggregateError + +-- | helper function for our errors above +impossibleAggregateError :: a +impossibleAggregateError = error "impossible; called aggregate function for Ungrouped even though the Aggregate instance has a type error constraint." + -- | escape hatch to define aggregate functions unsafeAggregate :: SOP.SListI xs diff --git a/src/Squeal/PostgreSQL/Expression/Parameter.hs b/src/Squeal/PostgreSQL/Expression/Parameter.hs --- a/src/Squeal/PostgreSQL/Expression/Parameter.hs +++ b/src/Squeal/PostgreSQL/Expression/Parameter.hs @@ -21,6 +21,7 @@ , RankNTypes , ScopedTypeVariables , TypeApplications + , TypeFamilies , TypeOperators , UndecidableInstances #-} @@ -31,6 +32,8 @@ , param ) where +import Data.Kind (Constraint) +import GHC.Exts (Any) import GHC.TypeLits import Squeal.PostgreSQL.Expression @@ -49,11 +52,11 @@ separately from the SQL command string, in which case `param`s are used to refer to the out-of-line data values. -} -class KnownNat n => HasParameter - (n :: Nat) +class KnownNat ix => HasParameter + (ix :: Nat) (params :: [NullType]) (ty :: NullType) - | n params -> ty where + | ix params -> ty where -- | `parameter` takes a `Nat` using type application and a `TypeExpression`. -- -- >>> printSQL (parameter @1 int4) @@ -62,12 +65,58 @@ :: TypeExpression db ty -> Expression grp lat with db params from ty parameter ty = UnsafeExpression $ parenthesized $ - "$" <> renderNat @n <+> "::" + "$" <> renderNat @ix <+> "::" <+> renderSQL ty -instance {-# OVERLAPPING #-} params ~ (x ': xs) => HasParameter 1 params x -instance {-# OVERLAPPABLE #-} - (KnownNat n, HasParameter (n-1) xs x, params ~ (y ': xs)) - => HasParameter n params x + +-- we could do the check for 0 in @HasParameter'@, but this way forces checking 'ix' before delegating, +-- which has the nice effect of ambiguous 'ix' errors mentioning 'HasParameter' instead of @HasParameter'@ +instance {-# OVERLAPS #-} (TypeError ('Text "Tried to get the param at index 0, but params are 1-indexed"), x ~ Any) => HasParameter 0 params x +instance {-# OVERLAPS #-} (KnownNat ix, HasParameter' ix params ix params x) => HasParameter ix params x + +-- | @HasParameter'@ is an implementation detail of 'HasParameter' allowing us to +-- include the full parameter list in our errors. Generally speaking it shouldn't leak to users +-- of the library +class KnownNat ix => HasParameter' + (originalIx :: Nat) + (allParams :: [NullType]) + (ix :: Nat) + (params :: [NullType]) + (ty :: NullType) + | ix params -> ty where +instance {-# OVERLAPS #-} + ( params ~ (y ': xs) + , y ~ x -- having a separate 'y' type variable is required for 'ParamTypeMismatchError' + , ParamOutOfBoundsError originalIx allParams params + , ParamTypeMismatchError originalIx allParams x y + ) => HasParameter' originalIx allParams 1 params x +instance {-# OVERLAPS #-} + ( KnownNat ix + , HasParameter' originalIx allParams (ix-1) xs x + , params ~ (y ': xs) + , ParamOutOfBoundsError originalIx allParams params + ) + => HasParameter' originalIx allParams ix params x + +-- | @ParamOutOfBoundsError@ reports a nicer error with more context when we try to do an out-of-bounds lookup successfully do a lookup but +-- find a different field than we expected, or when we find ourself out of bounds +type family ParamOutOfBoundsError (originalIx :: Nat) (allParams :: [NullType]) (params :: [NullType]) :: Constraint where + ParamOutOfBoundsError originalIx allParams '[] = TypeError + ('Text "Index " ':<>: 'ShowType originalIx ':<>: 'Text " is out of bounds in 1-indexed parameter list:" ':$$: 'ShowType allParams) + ParamOutOfBoundsError _ _ _ = () + +-- | @ParamTypeMismatchError@ reports a nicer error with more context when we successfully do a lookup but +-- find a different field than we expected, or when we find ourself out of bounds +type family ParamTypeMismatchError (originalIx :: Nat) (allParams :: [NullType]) (found :: NullType) (expected :: NullType) :: Constraint where + ParamTypeMismatchError _ _ found found = () + ParamTypeMismatchError originalIx allParams found expected = TypeError + ( 'Text "Type mismatch when looking up param at index " ':<>: 'ShowType originalIx + ':$$: 'Text "in 1-indexed parameter list:" + ':$$: 'Text " " ':<>: 'ShowType allParams + ':$$: 'Text "" + ':$$: 'Text "Expected: " ':<>: 'ShowType expected + ':$$: 'Text "But found: " ':<>: 'ShowType found + ':$$: 'Text "" + ) -- | `param` takes a `Nat` using type application and for basic types, -- infers a `TypeExpression`. diff --git a/src/Squeal/PostgreSQL/Type/Alias.hs b/src/Squeal/PostgreSQL/Type/Alias.hs --- a/src/Squeal/PostgreSQL/Type/Alias.hs +++ b/src/Squeal/PostgreSQL/Type/Alias.hs @@ -47,6 +47,11 @@ , HasErr , HasAll , HasIn + -- * Error reporting + , LookupFailedError + , PrettyPrintHaystack + , PrettyPrintInfo(..) + , MismatchError -- * Qualified Aliases , QualifiedAlias (..) , IsQualified (..) @@ -58,6 +63,7 @@ import Control.DeepSeq import Data.ByteString (ByteString) import Data.String (fromString) +import GHC.Exts (Any, Constraint) import GHC.OverloadedLabels import GHC.TypeLits @@ -184,20 +190,90 @@ -- | @Has alias fields field@ is a constraint that proves that -- @fields@ has a field of @alias ::: field@, inferring @field@ -- from @alias@ and @fields@. -type Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) - = HasErr fields alias fields field +class (KnownSymbol alias) => Has (alias :: Symbol) (fields :: [(Symbol, kind)]) (field :: kind) | alias fields -> field +-- having these instances forces 'Has' to inspect 'alias' and 'fields' and thereby fail before delegating to +-- 'HasErr', which means 'Has' shows up in error messages instead of 'HasErr' +instance {-# OVERLAPPING #-} (KnownSymbol alias, HasErr (alias ::: field0 ': fields) alias (alias ::: field0 ': fields) field1) + => Has alias (alias ::: field0 ': fields) field1 +instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr (field' ': fields) alias (field' ': fields) field) + => Has alias (field' ': fields) field +instance (KnownSymbol alias, HasErr '[] alias '[] field) + => Has alias '[] field -{- | `HasErr` is like `Has` except it also retains the original +{- | 'HasErr' is like `Has` except it also retains the original list of fields being searched, so that error messages are more useful. -} class KnownSymbol alias => - HasErr err (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) + HasErr (allFields :: [(Symbol, kind)]) (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) | alias fields -> field where -instance {-# OVERLAPPING #-} (KnownSymbol alias, field0 ~ field1) - => HasErr err alias (alias ::: field0 ': fields) field1 -instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr err alias fields field) - => HasErr err alias (field' ': fields) field +instance {-# OVERLAPPING #-} (KnownSymbol alias, field0 ~ field1, MismatchError alias allFields field0 field1) + => HasErr allFields alias (alias ::: field0 ': fields) field1 +instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr allFields alias fields field) + => HasErr allFields alias (field' ': fields) field +instance ( KnownSymbol alias + , LookupFailedError alias allFields -- report a nicer error + , field ~ Any -- required to satisfy the fundep + ) => HasErr allFields alias '[] field + +-- | @MismatchError@ reports a nicer error with more context when we successfully do a lookup but +-- find a different field than we expected +type MismatchError (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) + = MismatchError' (MismatchError' () (DefaultPrettyPrinter fields) alias fields found expected) (PrettyPrintHaystack fields) alias fields found expected + +-- | @MismatchError'@ is the workhorse behind @MismatchError@, but taking an additional type as the first argument. We can put another type error +-- in there which will only show if @MismatchError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance +-- is missing +type family MismatchError' (err :: Constraint) (ppInfo :: PrettyPrintInfo) (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where + MismatchError' _ _ _ _ found found = () + MismatchError' _ ('PrettyPrintInfo needleName haystackName _) alias fields found expected = TypeError + ( 'Text "Type mismatch when looking up " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType alias + ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":" + -- we don't use a pretty haystack because we want to show the values + ':$$: 'ShowType fields + ':$$: 'Text "" + ':$$: 'Text "Expected: " ':<>: 'ShowType expected + ':$$: 'Text "But found: " ':<>: 'ShowType found + ':$$: 'Text "" + ) + +-- | @LookupFailedError@ reports a nicer error when we fail to look up some @needle@ in some @haystack@ +type LookupFailedError needle haystack = LookupFailedError' (LookupFailedError' () (DefaultPrettyPrinter haystack) needle haystack) (PrettyPrintHaystack haystack) needle haystack + +-- | @LookupFailedError'@ is the workhorse behind @LookupFailedError@, but taking an additional type as the first argument. We can put another type error +-- in there which will only show if @LookupFailedError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance +-- is missing +type family LookupFailedError' (fallbackForUnknownKind :: Constraint) (prettyPrintInfo :: PrettyPrintInfo) (needle :: Symbol) (haystack :: [(Symbol, k)]) :: Constraint where + LookupFailedError' _ ('PrettyPrintInfo needleName haystackName prettyHaystack) needle rawHaystack = TypeError + ( 'Text "Could not find " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType needle + ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":" + ':$$: prettyHaystack + ':$$: 'Text "" + ':$$: 'Text "*Raw " ':<>: haystackName ':<>: 'Text "*:" + ':$$: 'ShowType rawHaystack + ':$$: 'Text "" + ) + +-- | @PrettyPrintInfo@ is a data type intended to be used at the type level +-- which describes how to pretty print a haystack in our custom errors. The general intention is we use @PrettyPrintHaystack@ +-- to define a more specific way of pretty printing our error information for each kind that we care about +data PrettyPrintInfo = PrettyPrintInfo + { _needleName :: ErrorMessage + , _haystackName :: ErrorMessage + , _haystackPrettyPrint :: ErrorMessage + } + +-- | 'PrettyPrintHaystack' allows us to use the kind of our haystack to come up +-- with nicer errors. It is implemented as an open type family for dependency reasons +type family PrettyPrintHaystack (haystack :: [(Symbol, k)]) :: PrettyPrintInfo + +-- | @DefaultPrettyPrinter@ provides a default we can use for kinds that don't provide an instance of @PrettyPrintInfo@, +-- although that should generally only be accidental +type family DefaultPrettyPrinter (haystack :: [(Symbol, k)]) :: PrettyPrintInfo where + DefaultPrettyPrinter (haystack :: [(Symbol, k)]) = 'PrettyPrintInfo + ('Text "some kind without a PrettyPrintHaystack instance (" ':<>: 'ShowType k ':<>: 'Text ")") + ('Text "associative list of that kind ([(Symbol, " ':<>: 'ShowType k ':<>: 'Text ")])") + ('ShowType (Sort (MapFst haystack))) {-| @HasIn fields (alias ::: field)@ is a constraint that proves that @fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to diff --git a/src/Squeal/PostgreSQL/Type/List.hs b/src/Squeal/PostgreSQL/Type/List.hs --- a/src/Squeal/PostgreSQL/Type/List.hs +++ b/src/Squeal/PostgreSQL/Type/List.hs @@ -41,6 +41,8 @@ , Elem , In , Length + , MapFst + , Sort , SubList , SubsetList ) where @@ -154,3 +156,44 @@ type family SubsetList (xs :: [k]) (ys :: [k]) :: Bool where SubsetList '[] ys = 'True SubsetList (x ': xs) ys = Elem x ys && SubsetList xs ys + +-- | 'Sort' sorts a type level list of 'Symbol's in ascending lexicographic order +type Sort ls = MergeSort (Twos ls) + +-- | 'MergeSort' is the workhorse behind 'Sort' +type family MergeSort (ls :: [[Symbol]]) :: [Symbol] where + MergeSort '[] = '[] + MergeSort '[x] = x + MergeSort ls = MergeSort (FoldMerge ls) + +-- | @Two@s splits a type-level list into a list of sorted lists of length 2 (with a singelton list potentially at the end) +-- It is required for implementing 'MergeSort' +type family Twos (ls :: [k]) :: [[k]] where + Twos (x ': y ': rs) = Merge '[x] '[y] ': Twos rs + Twos '[x] = '[ '[x]] + Twos '[] = '[] + +-- | 'Merge' two sorted lists into one list +type family Merge (ls :: [Symbol]) (rs :: [Symbol]) :: [Symbol] where + Merge '[] r = r + Merge l '[] = l + Merge (l ': ls) (r ': rs) = If (Leq l r) (l ': Merge ls (r ': rs)) (r ': Merge (l ': ls) rs) + +-- | 'FoldMerge' folds over a list of sorted lists, merging them into a single sorted list +type family FoldMerge (ls :: [[Symbol]]) :: [[Symbol]] where + FoldMerge (x ': y ': rs) = (Merge x y ': FoldMerge rs) + FoldMerge '[x] = '[x] + FoldMerge '[] = '[] + +type Leq l r = OrderingIsLeq (CmpSymbol l r) + +type family OrderingIsLeq (o :: Ordering) :: Bool where + OrderingIsLeq 'LT = 'True + OrderingIsLeq 'EQ = 'True + OrderingIsLeq 'GT = 'False + +-- | 'MapFst' takes the first value of each tuple of a type level list of tuples. Useful for getting +-- only the names in associatve lists +type family MapFst (ls :: [(j, k)]) :: [j] where + MapFst ('(j, _) ': rest) = j ': MapFst rest + MapFst '[] = '[] diff --git a/src/Squeal/PostgreSQL/Type/Schema.hs b/src/Squeal/PostgreSQL/Type/Schema.hs --- a/src/Squeal/PostgreSQL/Type/Schema.hs +++ b/src/Squeal/PostgreSQL/Type/Schema.hs @@ -49,7 +49,17 @@ , ReturnsType (..) , SchemaType , SchemasType + , PrettyPrintPartitionedSchema , Public + , PartitionedSchema(..) + , PartitionSchema + , SchemaFunctions + , SchemaIndexes + , SchemaProcedures + , SchemaTables + , SchemaTypes + , SchemaUnsafes + , SchemaViews -- * Database Subsets , SubDB , SubsetDB @@ -204,6 +214,9 @@ -- :} type ColumnsType = [(Symbol,ColumnType)] +type instance PrettyPrintHaystack (haystack :: ColumnsType) = + 'PrettyPrintInfo ('Text "column definition (ColumnType)") ('Text "table (ColumnsType)") ('ShowType (Sort (MapFst haystack))) + -- | `TableConstraint` encodes various forms of data constraints -- of columns in a table. -- `TableConstraint`s give you as much control over the data in your tables @@ -225,6 +238,9 @@ -} type TableConstraints = [(Symbol,TableConstraint)] +type instance PrettyPrintHaystack (haystack :: TableConstraints) = + 'PrettyPrintInfo ('Text "constraint (TableConstraint)") ('Text "table (TableConstraints)") ('ShowType (Sort (MapFst haystack))) + -- | A `ForeignKey` must reference columns that either are -- a `PrimaryKey` or form a `Unique` constraint. type family Uniquely @@ -261,12 +277,18 @@ -} type RowType = [(Symbol,NullType)] +type instance PrettyPrintHaystack (haystack :: RowType) = + 'PrettyPrintInfo ('Text "column (NullType)") ('Text "row (RowType)") ('ShowType (Sort (MapFst haystack))) + {- | `FromType` is a row of `RowType`s. It can be thought of as a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.From.FromClause`s and `Squeal.PostgreSQL.Query.Table.TableExpression`s. -} type FromType = [(Symbol,RowType)] +type instance PrettyPrintHaystack (haystack :: FromType) = + 'PrettyPrintInfo ('Text "row (RowType)") ('Text "from clause (FromType)") ('ShowType (Sort (MapFst haystack))) + -- | `ColumnsToRow` removes column constraints. type family ColumnsToRow (columns :: ColumnsType) :: RowType where ColumnsToRow (column ::: _ :=> ty ': columns) = @@ -571,6 +593,93 @@ -} type SchemaType = [(Symbol,SchemumType)] +-- | A @PartitionedSchema@ is a @SchemaType@ where each constructor of @SchemumType@ has +-- been separated into its own list +data PartitionedSchema = PartitionedSchema + { _tables :: [(Symbol, TableType)] + , _views :: [(Symbol, RowType)] + , _types :: [(Symbol, PGType)] + , _indexes :: [(Symbol, IndexType)] + , _functions :: [(Symbol, FunctionType)] + , _procedures :: [(Symbol, [NullType])] + , _unsafes :: [(Symbol, Symbol)] + } + +-- | @PartitionSchema@ partitions a @SchemaType@ into a @PartitionedSchema@ +type PartitionSchema schema = PartitionSchema' schema ('PartitionedSchema '[] '[] '[] '[] '[] '[] '[]) + +type family PartitionSchema' (remaining :: SchemaType) (acc :: PartitionedSchema) :: PartitionedSchema where + PartitionSchema' '[] ps = ps + PartitionSchema' ('(s, 'Table table) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema ('(s, table) ': tables) views types indexes functions procedures unsafe) + PartitionSchema' ('(s, 'View view) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables ('(s, view) ': views) types indexes functions procedures unsafe) + PartitionSchema' ('(s, 'Typedef typ) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views ('(s, typ) ': types) indexes functions procedures unsafe) + PartitionSchema' ('(s, 'Index ix) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types ('(s, ix) ': indexes) functions procedures unsafe) + PartitionSchema' ('(s, 'Function f) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types indexes ('(s, f) ': functions) procedures unsafe) + PartitionSchema' ('(s, 'Procedure p) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types indexes functions ('(s, p) ': procedures) unsafe) + PartitionSchema' ('(s, 'UnsafeSchemum u) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe) + = PartitionSchema' rest ('PartitionedSchema tables views types indexes functions procedures ('(s, u) ': unsafe)) + +-- | Get the tables from a @PartitionedSchema@ +type family SchemaTables (schema :: PartitionedSchema) :: [(Symbol, TableType)] where + SchemaTables ('PartitionedSchema tables _ _ _ _ _ _) = tables +-- | Get the views from a @PartitionedSchema@ +type family SchemaViews (schema :: PartitionedSchema) :: [(Symbol, RowType)] where + SchemaViews ('PartitionedSchema _ views _ _ _ _ _) = views +-- | Get the typedefs from a @PartitionedSchema@ +type family SchemaTypes (schema :: PartitionedSchema) :: [(Symbol, PGType)] where + SchemaTypes ('PartitionedSchema _ _ types _ _ _ _) = types +-- | Get the indexes from a @PartitionedSchema@ +type family SchemaIndexes (schema :: PartitionedSchema) :: [(Symbol, IndexType)] where + SchemaIndexes ('PartitionedSchema _ _ _ indexes _ _ _) = indexes +-- | Get the functions from a @PartitionedSchema@ +type family SchemaFunctions (schema :: PartitionedSchema) :: [(Symbol, FunctionType)] where + SchemaFunctions ('PartitionedSchema _ _ _ _ functions _ _) = functions +-- | Get the procedured from a @PartitionedSchema@ +type family SchemaProcedures (schema :: PartitionedSchema) :: [(Symbol, [NullType])] where + SchemaProcedures ('PartitionedSchema _ _ _ _ _ procedures _) = procedures +-- | Get the unsafe schema types from a @PartitionedSchema@ +type family SchemaUnsafes (schema :: PartitionedSchema) :: [(Symbol, Symbol)] where + SchemaUnsafes ('PartitionedSchema _ _ _ _ _ _ unsafes) = unsafes + +-- | @PrettyPrintPartitionedSchema@ makes a nice @ErrorMessage@ showing a @PartitionedSchema@, +-- only including the names of the things in it and not the values. Additionally, empty +-- fields are omitted +type family PrettyPrintPartitionedSchema (schema :: PartitionedSchema) :: ErrorMessage where + PrettyPrintPartitionedSchema schema = IntersperseNewlines (FilterNonEmpty + [ FieldIfNonEmpty "Tables" (SchemaTables schema) + , FieldIfNonEmpty "Views" (SchemaViews schema) + , FieldIfNonEmpty "Types" (SchemaTypes schema) + , FieldIfNonEmpty "Indexes" (SchemaIndexes schema) + , FieldIfNonEmpty "Functions" (SchemaFunctions schema) + , FieldIfNonEmpty "Procedures" (SchemaProcedures schema) + , FieldIfNonEmpty "Unsafe schema items" (SchemaUnsafes schema) + ]) + +type family FieldIfNonEmpty (fieldName :: Symbol) (value :: [(Symbol, k)]) :: ErrorMessage where + FieldIfNonEmpty _ '[] = 'Text "" + FieldIfNonEmpty n xs = 'Text " " ':<>: 'Text n ':<>: 'Text ":" ':$$: 'Text " " ':<>: 'ShowType (Sort (MapFst xs)) + +type family FilterNonEmpty (ls :: [ErrorMessage]) :: [ErrorMessage] where + FilterNonEmpty ('Text "" ': rest) = FilterNonEmpty rest + FilterNonEmpty (x ': rest) = x ': FilterNonEmpty rest + FilterNonEmpty '[] = '[] + +type family IntersperseNewlines (ls :: [ErrorMessage]) :: ErrorMessage where + IntersperseNewlines (x ': y ': '[]) = x ':$$: y + IntersperseNewlines (x ': xs) = x ':$$: IntersperseNewlines xs + IntersperseNewlines '[] = 'Text "" + +type instance PrettyPrintHaystack (haystack :: SchemaType) = + 'PrettyPrintInfo ('Text "table, view, typedef, index, function, or procedure (SchemumType)") ('Text "schema (SchemaType)") + ( PrettyPrintPartitionedSchema (PartitionSchema haystack) + ) + {- | A database contains one or more named schemas, which in turn contain tables. The same object name can be used in different schemas without conflict; @@ -587,6 +696,9 @@ so they do not collide with the names of other objects. -} type SchemasType = [(Symbol,SchemaType)] + +type instance PrettyPrintHaystack (haystack :: SchemasType) = + 'PrettyPrintInfo ('Text "schema (SchemaType)") ('Text "database (SchemasType)") ('Text " " ':<>: 'ShowType (Sort (MapFst haystack))) -- | A type family to use for a single schema database. type family Public (schema :: SchemaType) :: SchemasType