packages feed

sqel (empty) → 0.0.1.0

raw patch · 98 files changed

+8599/−0 lines, 98 filesdep +aesondep +basedep +chronossetup-changed

Dependencies added: aeson, base, chronos, composition, containers, contravariant, exon, extra, first-class-families, generic-lens, generics-sop, hasql, hedgehog, incipit-base, invariant, microlens, path, path-io, prettyprinter, scientific, singletons, singletons-base, some, sqel, tasty, tasty-hedgehog, template-haskell, time, transformers, type-errors, uuid, vector

Files

+ LICENSE view
@@ -0,0 +1,34 @@+Copyright (c) 2023 Torsten Schmits++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met:++  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+  disclaimer.+  2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following+  disclaimer in the documentation and/or other materials provided with the distribution.++Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:++  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.++Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise.++DISCLAIMER++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lib/Sqel.hs view
@@ -0,0 +1,106 @@+module Sqel (+  module Sqel.Data.Dd,+  module Sqel.Data.Sel,+  module Sqel.Type,+  module Sqel.Merge,+  module Sqel.Prim,+  module Sqel.Product,+  module Sqel.Sum,+  module Sqel.Comp,+  module Sqel.Data.Uid,+  module Sqel.Uid,+  module Sqel.Names,+  module Sqel.Column,+  module Sqel.Data.Mods,+  module Sqel.Query.Combinators,+  module Sqel.Data.Order,+  module Sqel.Data.Migration,+  module Sqel.Migration.Table,+  module Sqel.Sql,+  module Sqel.Data.Codec,+  module Sqel.PgType,+  module Sqel.Query,+  module Sqel.Class.MatchView,+  module Sqel.Data.TableSchema,+  module Sqel.Data.Projection,+  module Sqel.Data.QuerySchema,+) where++import Sqel.Class.MatchView (HasField, HasPath)+import Sqel.Column (nullable, nullableAs, pgDefault, pk, tableName)+import Sqel.Comp (typePrefix)+import Sqel.Data.Codec (FullCodec)+import Sqel.Data.Dd (Dd (Dd), Sqel, Sqel', (:>) ((:>)))+import Sqel.Data.Migration (Migrations, migrate, noMigrations)+import Sqel.Data.Mods (+  ArrayColumn,+  EnumColumn,+  Ignore,+  Newtype,+  NoMods,+  Nullable,+  PgDefault,+  PrimaryKey,+  ReadShowColumn,+  SetTableName,+  Unique,+  )+import Sqel.Data.Order (Order (..))+import Sqel.Data.Projection (Projection)+import Sqel.Data.QuerySchema (QuerySchema, emptyQuerySchema)+import Sqel.Data.Sel (Sel (..), TSel (..))+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid), Uuid)+import Sqel.Merge (merge)+import Sqel.Migration.Table (migrateAuto)+import Sqel.Names (named, typeAs)+import Sqel.PgType (CheckedProjection, MkTableSchema (tableSchema), fullProjection, projection, toFullProjection)+import Sqel.Prim (+  IndexColumn,+  IndexColumnWith,+  array,+  column,+  enum,+  ignore,+  json,+  migrateDef,+  migrateDelete,+  migrateRename,+  migrateRenameType,+  mods,+  prim,+  primAs,+  primCoerce,+  primIndex,+  primMod,+  primMods,+  primNewtype,+  primNewtypes,+  primNullable,+  prims,+  readShow,+  )+import Sqel.Product (prod, prodAs, prodSel)+import Sqel.Query (CheckQuery (checkQuery), EmptyQuery, emptyQuery, primIdQuery)+import Sqel.Query.Combinators+import Sqel.Sql+import Sqel.Sum (con, con1, con1As, conAs, indexPrefix, mergeSum, sum, sumAs, sumWith)+import Sqel.Type (+  MSelect,+  Merge,+  Mod,+  Mods,+  ModsR,+  Name,+  Prim,+  PrimNewtype,+  PrimSel,+  PrimUnused,+  Prod,+  ProdPrims,+  ProdPrimsNewtype,+  TypeSel,+  type (*>),+  type (>),+  )+import Sqel.Uid (UidDd, uid, uidAs)
+ lib/Sqel/Class/MatchView.hs view
@@ -0,0 +1,143 @@+module Sqel.Class.MatchView where++import Type.Errors (ErrorMessage, IfStuck, Pure)++import Sqel.Data.Dd (DdK)+import Sqel.Data.FieldPath (FieldPath (FieldPath), FieldPaths, PathEq, ShowFields)+import Sqel.SOP.Error (JoinSym, QuotedError, QuotedType, Unlines)++type family CheckAvail (fields :: [FieldPath]) :: Type where+  CheckAvail ('FieldPath _ t : _) = t++type family AvailableColumns (fields :: [FieldPath]) :: ErrorMessage where+  AvailableColumns fields =+    "The specified table contains these fields:" %+    Unlines (ShowFields fields)++type NoViewMatch :: Symbol -> [FieldPath] -> FieldPath -> ErrorMessage+type family NoViewMatch viewType avail path where+  NoViewMatch viewType avail ('FieldPath path tpe) =+    "The " <> viewType <> " column " <> QuotedError (JoinSym "." path) <> " with type " <> QuotedType tpe <>+    " does not correspond to a table column." %+    AvailableColumns avail++type family UnknownMsg (viewType :: Symbol) (field :: FieldPath) :: ErrorMessage where+  UnknownMsg viewType ('FieldPath path tpe) =+    "This " <> viewType <> " cannot determine whether the column " <> QuotedError (JoinSym "." path) <> " with type " <>+    QuotedType tpe %+    "corresponds to a table column."++type family PathConstraint (path :: [Symbol]) :: ErrorMessage where+  PathConstraint '[field] = "HasField " <> 'ShowType field+  PathConstraint path = "HasPath " <> path++type family AvailStuckMsg (viewType :: Symbol) (table :: DdK) (field :: FieldPath) :: ErrorMessage where+  AvailStuckMsg viewType table ('FieldPath path tpe) =+    UnknownMsg viewType ('FieldPath path tpe) %+    "This is likely due to the structure type " <> QuotedType table <> " being polymorphic." %+    "Try adding the constraint:" %+    "  " <> QuotedError (PathConstraint path <> " " <> tpe <> " " <> table)++type MatchStuckMsg :: Symbol -> [FieldPath] -> FieldPath -> ErrorMessage+type family MatchStuckMsg viewType avail path where+  MatchStuckMsg viewType avail field =+    UnknownMsg viewType field %+    AvailableColumns avail++type family MatchStuck (viewType :: Symbol) (field :: FieldPath) (avail :: [FieldPath]) :: k where+  MatchStuck viewType field avail =+    TypeError (MatchStuckMsg viewType avail field)++type family AvailStuck (viewType :: Symbol) (table :: DdK) (field :: FieldPath) :: k where+  AvailStuck viewType table field =+    TypeError (AvailStuckMsg viewType table field)++type CheckMatch :: Symbol -> DdK -> FieldPath -> [FieldPath] -> Bool -> Bool+type family CheckMatch viewType table vfield avail match where+  CheckMatch viewType table vfield avail match =+    IfStuck match (IfStuck (CheckAvail avail) (AvailStuck viewType table vfield) (Pure (MatchStuck viewType vfield avail))) (Pure match)++type MatchPath :: FieldPath -> FieldPath -> Bool -> Constraint+class MatchPath view avail match | view avail -> match where++instance (+    match ~ PathEq view avail+  ) => MatchPath view avail match where++type CheckPathMatch :: FieldPath -> [FieldPath] -> Bool -> Bool -> Constraint+class CheckPathMatch view avail match finalMatch | view avail match -> finalMatch where++instance (+    MatchViewPath view avail match+  ) => CheckPathMatch view avail 'False match where++instance CheckPathMatch view avail 'True 'True where++type MatchViewPath :: FieldPath -> [FieldPath] -> Bool -> Constraint+class MatchViewPath view avail match | view avail -> match where++instance (+    MatchPath view tfield match,+    CheckPathMatch view tfields match finalMatch+  ) => MatchViewPath view (tfield : tfields) finalMatch where++instance MatchViewPath view '[] 'False where++-------------------------------------------------------------------------------------------------------++type CheckViewPathError :: Symbol -> DdK -> FieldPath -> [FieldPath] -> [FieldPath] -> Bool -> Maybe ErrorMessage -> Constraint+class CheckViewPathError viewType table vfield vfields avail match error | viewType table vfield vfields avail match -> error where++instance (+    MatchViewPaths viewType table vfields avail error+  ) => CheckViewPathError viewType table vfield vfields avail 'True error where++instance (+    err ~ NoViewMatch viewType avail vfield+  ) => CheckViewPathError viewType table vfield vfields avail 'False ('Just err) where++type MatchViewPaths :: Symbol -> DdK -> [FieldPath] -> [FieldPath] -> Maybe ErrorMessage -> Constraint+class MatchViewPaths viewType table view avail error | viewType table view avail -> error where++instance MatchViewPaths viewType table '[] avail 'Nothing where++instance (+    MatchViewPath vfield avail match,+    CheckViewPathError viewType table vfield vfields avail (CheckMatch viewType table vfield avail match) finalError+  ) => MatchViewPaths viewType table (vfield : vfields) avail finalError where++type family MaybeError (msg :: Maybe ErrorMessage) :: Maybe k where+  MaybeError 'Nothing = 'Nothing+  MaybeError ('Just msg) = 'Just (TypeError msg)++type MatchView :: Symbol -> DdK -> DdK -> Maybe Void -> Constraint+class MatchView viewType view avail error | viewType view avail -> error where++instance (+    MatchViewPaths viewType table (FieldPaths view) (FieldPaths table) msg,+    error ~ MaybeError msg+  ) => MatchView viewType view table error where++type MatchQuery view table error =+  MatchView "query" view table error++type MatchProjection view table error =+  MatchView "projection" view table error++-------------------------------------------------------------------------------------------------------++class (+    MatchViewPath ('FieldPath path t) (FieldPaths table) 'True+  ) => HasPath path t table where++instance (+    MatchViewPath ('FieldPath path t) (FieldPaths table) 'True+  ) => HasPath path t table where++class (+    MatchViewPath ('FieldPath '[path] t) (FieldPaths table) 'True+  ) => HasField path t table where++instance (+    MatchViewPath ('FieldPath '[path] t) (FieldPaths table) 'True+  ) => HasField path t table where
+ lib/Sqel/Class/MigrationEffect.hs view
@@ -0,0 +1,28 @@+module Sqel.Class.MigrationEffect where++import qualified Hasql.Session as Session+import Hasql.Session (Session)+import Hasql.Statement (Statement)++import Sqel.Migration.Statement (MigrationStatement, migrationSession)++class MigrationEffect m where+  runMigrationStatements :: [MigrationStatement] -> m ()+  runStatement_ :: q -> Statement q () -> m ()+  runStatement :: q -> Statement q [a] -> m [a]+  log :: Text -> m ()+  error :: Text -> m ()++instance MigrationEffect Session where+  runMigrationStatements = migrationSession+  runStatement_ = Session.statement+  runStatement = Session.statement+  log _ = unit+  error _ = unit++instance MigrationEffect (Const [MigrationStatement]) where+  runMigrationStatements = Const+  runStatement_ _ _ = Const []+  runStatement _ _ = Const []+  log _ = Const []+  error _ = Const []
+ lib/Sqel/Class/Mods.hs view
@@ -0,0 +1,199 @@+module Sqel.Class.Mods where++import Generics.SOP (I (I), NP (Nil, (:*)))+import Prelude hiding (Compose)++import Sqel.Data.Dd (Dd (Dd), DdK (DdK), (:>) ((:>)))+import Sqel.Data.Mods (Mods (Mods), unMods)++class SymNP p ps where+  symNP :: p -> NP I ps++instance {-# overlappable #-} (+    ps ~ '[p]+  ) => SymNP p ps where+  symNP p =+    I p :* Nil++instance (+    SymNP p1 ps+  ) => SymNP (p0 :> p1) (p0 : ps) where+  symNP (p0 :> p1) =+    I p0 :* symNP p1++instance SymNP (NP I ps) ps where+  symNP = id++symMods ::+  SymNP p ps =>+  p ->+  Mods ps+symMods p =+  Mods (symNP p)++class MapMod' p ps0 ps1 | p ps0 -> ps1 where+  mapMod' :: p -> (p -> p) -> Mods ps0 -> Mods ps1++instance MapMod' p (p : ps) (p : ps) where+  mapMod' _ f (Mods (I p :* ps)) =+    Mods (I (f p) :* ps)++instance {-# overlappable #-} (+    MapMod' p ps0 ps1+  ) => MapMod' p (a' : ps0) (a' : ps1) where+    mapMod' p f (Mods (a' :* ps)) =+      Mods (a' :* unMods (mapMod' p f (Mods ps)))++instance MapMod' p '[] '[p] where+  mapMod' p f (Mods Nil) =+    Mods (I (f p) :* Nil)++amendMod' ::+  MapMod' p ps0 ps1 =>+  p ->+  Mods ps0 ->+  Mods ps1+amendMod' p =+  mapMod' p id++setMod' ::+  MapMod' p ps0 ps1 =>+  p ->+  Mods ps0 ->+  Mods ps1+setMod' p =+  mapMod' p (const p)++-- TODO this could map over multiple matching mods+class OverMod' p ps where+  overMod' :: (p -> p) -> Mods ps -> Mods ps++instance OverMod' p (p : ps) where+  overMod' f (Mods (I p :* ps)) =+    Mods (I (f p) :* ps)++instance (+    OverMod' p ps+  ) => OverMod' p (a' : ps) where+    overMod' f (Mods (a' :* ps)) =+      Mods (a' :* unMods (overMod' f (Mods ps)))++instance OverMod' p '[] where+  overMod' _ (Mods Nil) =+    Mods Nil++class CMapMod' c p0 p p1 ps0 ps1 | ps0 p0 p1 -> p ps1 where+  cmapMod' :: p0 -> (c p p1 => p -> p1) -> Mods ps0 -> Mods ps1++instance (+    c p p1+  ) => CMapMod' c p0 p p1 (p : ps) (p1 : ps) where+  cmapMod' _ f (Mods (I p :* ps)) =+    Mods (I (f p) :* ps)++instance (+    CMapMod' c p0 p p1 ps0 ps1+  ) => CMapMod' c p0 p p1 (a' : ps0) (a' : ps1) where+    cmapMod' p f (Mods (a' :* ps)) =+      Mods (a' :* unMods (cmapMod' @c @p0 @p @p1 @ps0 @ps1 p f (Mods ps)))++instance CMapMod' c p0 p1 p1 '[] '[p0] where+  cmapMod' p _ (Mods Nil) =+    Mods (I p :* Nil)++type GetMod :: Constraint -> Type -> [Type] -> Constraint+class GetMod c p ps where+  getMod :: (c => p) -> Mods ps -> p++instance c => GetMod c p '[] where+  getMod f (Mods Nil) = f++instance GetMod c p (p : ps) where+  getMod _ (Mods (I p :* _)) = p++class AddMod p s0 s1 | p s0 -> s1 where+  addMod :: p -> Dd s0 -> Dd s1++instance AddMod p ('DdK sel ps a s) ('DdK sel (p : ps) a s) where+  addMod p (Dd sel (Mods ps) s) =+    Dd sel (Mods (I p :* ps)) s++instance {-# overlappable #-} (+    GetMod c p ps+  ) => GetMod c p (a' : ps) where+    getMod f (Mods (_ :* ps)) =+      getMod @c f (Mods ps)++class MapMod p s0 s1 | p s0 -> s1 where+  mapMod :: p -> (p -> p) -> Dd s0 -> Dd s1++instance (+    MapMod' p ps0 ps1+  ) => MapMod p ('DdK sel ps0 a s0) ('DdK sel ps1 a s0) where+    mapMod p f (Dd sel ps0 s) =+      Dd sel (mapMod' p f ps0) s++class OverMod p s where+  overMod :: (p -> p) -> Dd s -> Dd s++instance (+    OverMod' p ps+  ) => OverMod p ('DdK sel ps a s0) where+    overMod f (Dd sel ps s) =+      Dd sel (overMod' f ps) s++class CMapMod c p0 p p1 s0 s1 | s0 p0 p1 -> p s1 where+  cmapMod :: p0 -> (c p p1 => p -> p1) -> Dd s0 -> Dd s1++instance (+    CMapMod' c p0 p p1 ps0 ps1+  ) => CMapMod c p0 p p1 ('DdK sel ps0 a s0) ('DdK sel ps1 a s0) where+  cmapMod p0 f (Dd sel ps0 s) =+    Dd sel (cmapMod' @c @_ @_ @p1 p0 f ps0) s++-- TODO this appends the mod if it is missing, while it should prepend it to preserve the order of effects.+amendMod ::+  MapMod p s0 s1 =>+  p ->+  Dd s0 ->+  Dd s1+amendMod p =+  mapMod p id++setMod ::+  MapMod p s0 s1 =>+  p ->+  Dd s0 ->+  Dd s1+setMod p =+  mapMod p (const p)++type OptMod :: Type -> [Type] -> Type -> Constraint+class OptMod p ps res | ps p -> res where+  optMod :: Mods ps -> res++instance OptMod p '[] () where+  optMod (Mods Nil) = ()++instance OptMod p (p : ps) p where+  optMod (Mods (I p :* _)) = p++instance {-# overlappable #-} (+    OptMod p ps p1+  ) => OptMod p (p0 : ps) p1 where+    optMod (Mods (_ :* ps)) = optMod @p (Mods ps)++type MaybeMod :: Type -> [Type] -> Constraint+class MaybeMod p ps where+  maybeMod :: Mods ps -> Maybe p++instance MaybeMod p '[] where+  maybeMod (Mods Nil) = Nothing++instance MaybeMod p (p : ps) where+  maybeMod (Mods (I p :* _)) = Just p++instance {-# overlappable #-} (+    MaybeMod p ps+  ) => MaybeMod p (p0 : ps) where+    maybeMod (Mods (_ :* ps)) = maybeMod @p (Mods ps)
+ lib/Sqel/Codec.hs view
@@ -0,0 +1,105 @@+module Sqel.Codec where++import qualified Chronos as Chronos+import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)+import Data.UUID (UUID)+import qualified Hasql.Decoders as Hasql+import qualified Hasql.Decoders as Decoders+import Hasql.Decoders (Row, custom)+import qualified Hasql.Encoders as Encoders+import Hasql.Encoders (Params)+import Path (Path)++import qualified Sqel.Codec.PrimDecoder as PrimDecoder+import Sqel.Codec.PrimDecoder (PrimDecoder)+import qualified Sqel.Codec.PrimEncoder as PrimEncoder+import Sqel.Codec.PrimEncoder (PrimEncoder)+import Sqel.Codec.Sum (ignoreEncoder)+import qualified Sqel.Data.Codec as Codec+import Sqel.Data.Codec (Codec (Codec), Decoder (Decoder), Encoder (Encoder), FullCodec, ValueCodec)+import Sqel.Data.PgType (PgPrimName)+import Sqel.SOP.Error (Quoted, QuotedType)++ignoreDecoder :: Row (Maybe a)+ignoreDecoder =+  join <$> Hasql.column (Hasql.nullable (custom \ _ _ -> pure Nothing))++class ColumnEncoder f where+  columnEncoder :: f a -> Params a+  columnEncoderNullable :: f a -> Params (Maybe a)+  columnEncoderIgnore :: f a -> Params b++instance ColumnEncoder Encoders.Value where+  columnEncoder =+    Encoders.param . Encoders.nonNullable+  columnEncoderNullable =+    Encoders.param . Encoders.nullable+  columnEncoderIgnore =+    ignoreEncoder++class ColumnDecoder f where+  columnDecoder :: f a -> Row a+  columnDecoderNullable :: f a -> Row (Maybe a)++instance ColumnDecoder Decoders.Value where+  columnDecoder =+    Decoders.column . Decoders.nonNullable+  columnDecoderNullable =+    Decoders.column . Decoders.nullable++class PrimColumn a where+  primDecoder :: Decoders.Value a+  default primDecoder :: PrimDecoder a => Decoders.Value a+  primDecoder = PrimDecoder.primDecoder++  primEncoder :: Encoders.Value a+  default primEncoder :: PrimEncoder a => Encoders.Value a+  primEncoder = PrimEncoder.primEncoder++  pgType :: PgPrimName++instance {-# overlappable #-} (+    TypeError (+      "A column of type " <> QuotedType a <> " was declared as primitive," %+      "but there is no instance of " <> Quoted "PrimColumn" <> " for that type." %+      "If it is a newtype, ensure that it has " <> Quoted "Generic" <> " and use " <> Quoted "primNewtype" <> "."+    )+  ) => PrimColumn a where+    primDecoder = error "no instance for PrimColumn"+    primEncoder = error "no instance for PrimColumn"+    pgType = error "no instance for PrimColumn"++instance PrimColumn Bool where pgType = "boolean"+instance PrimColumn Int where pgType = "bigint"+instance PrimColumn Int64 where pgType = "bigint"+instance PrimColumn Double where pgType = "double precision"+instance PrimColumn Text where pgType = "text"+instance PrimColumn ByteString where pgType = "bytes"+instance PrimColumn UUID where pgType = "uuid"+instance PrimColumn Day where pgType = "date"+instance PrimColumn LocalTime where pgType = "timestamp without time zone"+instance PrimColumn UTCTime where pgType = "timestamp with time zone"+instance PrimColumn TimeOfDay where pgType = "time without time zone"+instance PrimColumn (TimeOfDay, TimeZone) where pgType = "time with time zone"+instance PrimColumn DiffTime where pgType = "interval"+instance PrimColumn Chronos.Date where pgType = "date"+instance PrimColumn Chronos.Time where pgType = "bigint"+instance PrimColumn Chronos.Datetime where pgType = "timestamp without time zone"+instance PrimDecoder (Path b t) => PrimColumn (Path b t) where pgType = "text"+instance PrimColumn () where pgType = "boolean"++fullPrimCodec ::+  Encoders.Value a ->+  Decoders.Value a ->+  FullCodec a+fullPrimCodec encoder decoder =+  Codec {+    encoder = Encoder (columnEncoder encoder) (columnEncoderIgnore encoder),+    decoder = Decoder (columnDecoder decoder) (void ignoreDecoder)+  }++toFullPrimCodec ::+  ValueCodec a ->+  FullCodec a+toFullPrimCodec (Codec encoder decoder) =+  fullPrimCodec encoder decoder
+ lib/Sqel/Codec/PrimDecoder.hs view
@@ -0,0 +1,204 @@+module Sqel.Codec.PrimDecoder where++import qualified Chronos as Chronos+import qualified Data.Map.Strict as Map+import Data.Scientific (Scientific)+import qualified Data.Set as Set+import Data.Time (Day, DiffTime, LocalTime (LocalTime), TimeOfDay (TimeOfDay), TimeZone, UTCTime, toModifiedJulianDay)+import Data.UUID (UUID)+import Data.Vector (Vector)+import Hasql.Decoders (+  Value,+  bool,+  bytea,+  char,+  custom,+  date,+  enum,+  float4,+  float8,+  int2,+  int4,+  int8,+  interval,+  listArray,+  nonNullable,+  numeric,+  refine,+  text,+  time,+  timestamp,+  timestamptz,+  timetz,+  uuid,+  vectorArray,+  )+import Path (Abs, Dir, File, Path, Rel, parseAbsDir, parseAbsFile, parseRelDir, parseRelFile)+import Prelude hiding (Enum, bool)++import Sqel.SOP.Enum (EnumTable (enumTable))++class PrimDecoder a where+  primDecoder :: Value a++instance PrimDecoder () where+  primDecoder =+    void bool++instance PrimDecoder Bool where+  primDecoder =+    bool++instance PrimDecoder Int16 where+  primDecoder =+    int2++instance PrimDecoder Int32 where+  primDecoder =+    int4++instance PrimDecoder Int64 where+  primDecoder =+    int8++instance PrimDecoder Int where+  primDecoder =+    fromIntegral <$> int8++instance PrimDecoder Float where+  primDecoder =+    float4++instance PrimDecoder Double where+  primDecoder =+    float8++instance PrimDecoder Scientific where+  primDecoder =+    numeric++instance PrimDecoder Char where+  primDecoder =+    char++instance PrimDecoder Text where+  primDecoder =+    text++instance PrimDecoder ByteString where+  primDecoder =+    bytea++instance PrimDecoder Day where+  primDecoder =+    date++instance PrimDecoder LocalTime where+  primDecoder =+    timestamp++instance PrimDecoder UTCTime where+  primDecoder =+    timestamptz++instance PrimDecoder TimeOfDay where+  primDecoder =+    time++instance PrimDecoder (TimeOfDay, TimeZone) where+  primDecoder =+    timetz++instance PrimDecoder DiffTime where+  primDecoder =+    interval++instance PrimDecoder UUID where+  primDecoder =+    uuid++decodePath ::+  Show e =>+  (String -> Either e (Path b t)) ->+  Bool ->+  ByteString ->+  Either Text (Path b t)+decodePath parse _ =+  first show . parse . decodeUtf8++instance PrimDecoder (Path Abs File) where+  primDecoder =+    custom (decodePath parseAbsFile)++instance PrimDecoder (Path Abs Dir) where+  primDecoder =+    custom (decodePath parseAbsDir)++instance PrimDecoder (Path Rel File) where+  primDecoder =+    custom (decodePath parseRelFile)++instance PrimDecoder (Path Rel Dir) where+  primDecoder =+    custom (decodePath parseRelDir)++dayToChronos :: Day -> Chronos.Date+dayToChronos =+  Chronos.dayToDate . Chronos.Day . fromIntegral . toModifiedJulianDay++instance PrimDecoder Chronos.Date where+  primDecoder =+    dayToChronos <$> date++instance PrimDecoder Chronos.Time where+  primDecoder =+    Chronos.Time <$> int8++chronosToTimeOfDay :: TimeOfDay -> Chronos.TimeOfDay+chronosToTimeOfDay (TimeOfDay h m ns) =+  Chronos.TimeOfDay h m (round (ns * 1000000000))++localTimeToDatetime :: LocalTime -> Chronos.Datetime+localTimeToDatetime (LocalTime d t) =+  Chronos.Datetime (dayToChronos d) (chronosToTimeOfDay t)++instance PrimDecoder Chronos.Datetime where+  primDecoder =+    localTimeToDatetime <$> primDecoder++class ArrayDecoder f a where+  arrayDecoder :: Value a -> Value (f a)++instance ArrayDecoder [] a where+  arrayDecoder =+    listArray . nonNullable++instance ArrayDecoder NonEmpty a where+  arrayDecoder =+    refine (maybeToRight "no elements in NonEmpty field" . nonEmpty) .+    listArray .+    nonNullable++instance ArrayDecoder Vector a where+  arrayDecoder =+    vectorArray . nonNullable++instance (+    Ord a+  ) => ArrayDecoder Set a where+  arrayDecoder =+    refine (Right . Set.fromList) .+    listArray .+    nonNullable++enumDecoder ::+  EnumTable a =>+  Value a+enumDecoder =+  enum (`Map.lookup` enumTable)++readDecoder ::+  Read a =>+  Value a+readDecoder =+  enum (readMaybe . fromText)
+ lib/Sqel/Codec/PrimEncoder.hs view
@@ -0,0 +1,149 @@+module Sqel.Codec.PrimEncoder where++import qualified Chronos as Chronos+import Data.Scientific (Scientific)+import Data.Time (Day (ModifiedJulianDay), DiffTime, LocalTime (LocalTime), TimeOfDay (TimeOfDay), TimeZone, UTCTime)+import Data.UUID (UUID)+import Hasql.Encoders (+  Value,+  array,+  bool,+  bytea,+  char,+  date,+  dimension,+  element,+  float4,+  float8,+  int2,+  int4,+  int8,+  interval,+  nonNullable,+  numeric,+  text,+  time,+  timestamp,+  timestamptz,+  timetz,+  uuid,+  )+import Path (Path, toFilePath)+import Prelude hiding (bool)++class PrimEncoder d where+  primEncoder :: Value d++instance PrimEncoder () where+  primEncoder =+    True >$ bool++instance PrimEncoder Bool where+  primEncoder =+    bool++instance PrimEncoder Int16 where+  primEncoder =+    int2++instance PrimEncoder Int32 where+  primEncoder =+    int4++instance PrimEncoder Int64 where+  primEncoder =+    int8++instance PrimEncoder Int where+  primEncoder =+    contramap fromIntegral int8++instance PrimEncoder Float where+  primEncoder =+    float4++instance PrimEncoder Double where+  primEncoder =+    float8++instance PrimEncoder Scientific where+  primEncoder =+    numeric++instance PrimEncoder Char where+  primEncoder =+    char++instance PrimEncoder Text where+  primEncoder =+    text++instance PrimEncoder ByteString where+  primEncoder =+    bytea++instance PrimEncoder Day where+  primEncoder =+    date++instance PrimEncoder LocalTime where+  primEncoder =+    timestamp++instance PrimEncoder UTCTime where+  primEncoder =+    timestamptz++instance PrimEncoder TimeOfDay where+  primEncoder =+    time++instance PrimEncoder (TimeOfDay, TimeZone) where+  primEncoder =+    timetz++instance PrimEncoder DiffTime where+  primEncoder =+    interval++instance PrimEncoder UUID where+  primEncoder =+    uuid++instance PrimEncoder (Path b t) where+  primEncoder =+    (toText . toFilePath) >$< text++chronosToDay :: Chronos.Date -> Day+chronosToDay =+  ModifiedJulianDay . fromIntegral . Chronos.getDay . Chronos.dateToDay++instance PrimEncoder Chronos.Date where+  primEncoder =+    chronosToDay >$< date++instance PrimEncoder Chronos.Time where+  primEncoder =+    Chronos.getTime >$< int8++chronosToTimeOfDay :: Chronos.TimeOfDay -> TimeOfDay+chronosToTimeOfDay (Chronos.TimeOfDay h m ns) =+  TimeOfDay h m (fromMaybe 0 (realToFrac ns / 1000000000))++datetimeToLocalTime :: Chronos.Datetime -> LocalTime+datetimeToLocalTime (Chronos.Datetime d t) =+  LocalTime (chronosToDay d) (chronosToTimeOfDay t)++instance PrimEncoder Chronos.Datetime where+  primEncoder =+     datetimeToLocalTime >$< primEncoder++arrayEncoder ::+  Foldable f =>+  Value a ->+  Value (f a)+arrayEncoder =+  array .+  dimension foldl' .+  element .+  nonNullable
+ lib/Sqel/Codec/Product.hs view
@@ -0,0 +1,103 @@+module Sqel.Codec.Product where++import Generics.SOP (+  All,+  I,+  K (K),+  NP,+  NS (Z),+  Projection,+  SOP (SOP),+  Top,+  hcmap,+  hcollapse,+  hsequence,+  hzipWith,+  projections,+  unI,+  unSOP,+  unZ,+  type  (-.->) (Fn),+  )+import Generics.SOP.GGP (gfrom, gto)+import Lens.Micro.Extras (view)++import qualified Sqel.Data.Codec as Codec+import Sqel.Data.Codec (Codec (Codec), Decoder, Encoder, FullCodec)+import Sqel.SOP.Constraint (ConstructProd, ReifyProd)++prodParams ::+  ∀ as b .+  Contravariant b =>+  (∀ x . Monoid (b x)) =>+  All Top as =>+  NP b as ->+  b (NP I as)+prodParams np =+  mconcat (hcollapse qps)+  where+    qps :: NP (K (b (NP I as))) as+    qps =+      hzipWith qp np (projections :: NP (Projection I as) as)+    {-# inline qps #-}+    qp :: ∀ a . b a -> Projection I as a -> K (b (NP I as)) a+    qp par (Fn proj) =+      K (contramap (unI . proj . K) par)+    {-# inline qp #-}+{-# inline prodParams #-}++type GetEncoder :: (Type -> Type) -> Type -> Constraint+class GetEncoder b a where+  getEncoder :: b a -> Encoder a++instance GetEncoder FullCodec a where+  getEncoder = view #encoder++instance GetEncoder Encoder a where+  getEncoder = id++type GetDecoder :: (Type -> Type) -> Type -> Constraint+class GetDecoder b a where+  getDecoder :: b a -> Decoder a++instance GetDecoder FullCodec a where+  getDecoder = view #decoder++type ProdEncoder :: (Type -> Type) -> Type -> [Type] -> Constraint+class ProdEncoder b a as | a -> as where+  prodEncoder :: NP b as -> Encoder a++instance (+    ConstructProd a as,+    All (GetEncoder b) as+  ) => ProdEncoder b a as where+    prodEncoder np = unZ . unSOP . gfrom >$< prodParams (hcmap (Proxy @(GetEncoder b)) getEncoder np)++type ProdDecoder :: (Type -> Type) -> Type -> [Type] -> Constraint+class ProdDecoder b a as | a -> as where+  prodDecoder :: NP b as -> Decoder a++instance (+    ReifyProd a as,+    All (GetDecoder b) as+  ) => ProdDecoder b a as where+    prodDecoder np = gto . SOP . Z <$> hsequence (hcmap (Proxy @(GetDecoder b)) getDecoder np)++type ProdCodec :: (Type -> Type) -> Type -> [Type] -> Constraint+class ProdCodec b a as | a -> as where+  prodCodec :: NP b as -> b a++instance (+    ProdDecoder FullCodec a as,+    ProdEncoder FullCodec a as+  ) => ProdCodec FullCodec a as where+    prodCodec np =+      Codec {+        decoder = prodDecoder np,+        encoder = prodEncoder np+      }++instance (+    ProdEncoder Encoder a as+  ) => ProdCodec Encoder a as where+    prodCodec = prodEncoder
+ lib/Sqel/Codec/Sum.hs view
@@ -0,0 +1,174 @@+module Sqel.Codec.Sum where++import Data.Functor.Contravariant.Divisible (choose)+import Data.Functor.Invariant (Invariant (invmap))+import Exon (exon)+import Generics.SOP (+  All2,+  HIndex (hindex),+  I,+  NP (Nil, (:*)),+  NS (S, Z),+  SListI,+  SListI2,+  SOP (SOP),+  Top,+  hcfoldMap,+  hctraverse_,+  hmap,+  hsequence,+  unSOP,+  )+import Generics.SOP.GGP (gfrom, gto)+import Hasql.Decoders (Row)+import qualified Hasql.Encoders as Encoders+import qualified Hasql.Encoders as Encoder+import Hasql.Encoders (Params)+import Lens.Micro ((^.))+import Lens.Micro.Extras (view)+import qualified Sqel.Data.Codec as Codec+import Sqel.Data.Codec (Codec (Codec), Decoder (Decoder), Encoder (Encoder), FullCodec)+import Sqel.Data.Dd (ConCol (ConCol, unConCol))+import Sqel.SOP.Constraint (ConstructSOP, ReifySOP)++import Sqel.Codec.Product (prodParams)++unconsNS ::+  NS (NP I) (ds : dss) ->+  Either (NP I ds) (NS (NP I) dss)+unconsNS = \case+  Z x -> Left x+  S x -> Right x++newtype ConB b as =+  ConB { unConB :: b (NP I as) }++readNull ::+  ∀ as .+  Decoder (NP I as) ->+  Row ()+readNull rs =+  rs ^. #decodeNulls++readNulls ::+  ∀ ass .+  SListI2 ass =>+  NP (ConB Decoder) ass ->+  Row ()+readNulls cons =+  hctraverse_ (Proxy @SListI) (readNull . unConB) cons++sumRows ::+  All2 Top ass =>+  NP (ConB Decoder) ass ->+  Int64 ->+  Row (NS (NP I) ass)+sumRows (ConB con :* cons) 0 =+  Z <$> (con ^. #decodeValue) <* readNulls cons+sumRows (ConB con :* cons) index = do+  readNull con+  S <$> sumRows cons (index - 1)+sumRows Nil index =+  fail [exon|invalid index into sum type in database: #{show index}|]++ignoreEncoder :: Encoder.Value a -> Params b+ignoreEncoder v =+  const Nothing >$< Encoders.param (Encoders.nullable v)++writeNull ::+  ∀ a as .+  ConB Encoder as ->+  Params a+writeNull (ConB enc) =+  contramap unit (enc ^. #encodeNulls)++writeNulls ::+  ∀ a ass .+  SListI2 ass =>+  NP (ConB Encoder) ass ->+  Params a+writeNulls =+  hcfoldMap (Proxy @SListI) writeNull++sumParams ::+  All2 Top ass =>+  NP (ConB Encoder) ass ->+  Params (NS (NP I) ass)+sumParams = \case+  con :* cons ->+    choose unconsNS inhabited uninhabited+    where+      inhabited = (unConB con) ^. #encodeValue <> writeNulls cons+      uninhabited = writeNull con <> sumParams cons+  Nil ->+    mempty++type WrapConB :: (Type -> Type) -> [[Type]] -> [Type] -> Constraint+class WrapConB b ass as where+  wrapConB :: NP b as -> NP (ConB b) ass++instance WrapConB b '[] '[] where+  wrapConB Nil = Nil++instance (+    Invariant b,+    WrapConB b ass as+  ) => WrapConB b (as' : ass) (ConCol name record fields as' : as) where+    wrapConB (b :* bs) =+      ConB (invmap unConCol ConCol b) :* wrapConB bs++encodeValue ::+  ConstructSOP a ass =>+  Encoder Int64 ->+  NP (ConB Encoder) ass ->+  Params a+encodeValue (Encoder indexParams _) wrapped =+  unSOP . gfrom >$< (indexEncoder <> sumParams wrapped)+  where+    indexEncoder = (fromIntegral . hindex) >$< indexParams++type SumCodec :: (Type -> Type) -> Type -> [Type] -> Constraint+class SumCodec b a as where+  sumCodec :: NP b as -> b a++-- TODO add null builders+instance (+    ReifySOP a ass,+    ConstructSOP a ass,+    WrapConB FullCodec ass as+  ) => SumCodec FullCodec a (Int64 : as) where+    sumCodec (Codec index (Decoder indexRow _) :* conCodecs) =+      Codec {+        decoder = Decoder decodeValue unit,+        encoder = Encoder (encodeValue index (hmap (ConB . view #encoder . unConB) wrapped)) mempty+      }+      where+        decodeValue =+          gto . SOP <$> (sumRows decs =<< indexRow)+        decs =+          hmap (ConB . view #decoder . unConB) wrapped+        wrapped =+          wrapConB conCodecs++instance (+    ConstructSOP a ass,+    WrapConB Encoder ass as+  ) => SumCodec Encoder a (Int64 : as) where+    sumCodec (index :* conCodecs) =+      Encoder (encodeValue index wrapped) mempty+      where+        wrapped = wrapConB conCodecs++type ConCodec :: (Type -> Type) -> [Type] -> Constraint+class ConCodec b as where+  conCodec :: NP b as -> b (ConCol name record fields as)++instance SListI as => ConCodec FullCodec as where+  conCodec np =+    Codec {+      decoder = ConCol <$> hsequence (hmap (view #decoder) np),+      encoder = unConCol >$< prodParams (hmap (view #encoder) np)+    }++instance SListI as => ConCodec Encoder as where+    conCodec np = unConCol >$< prodParams np
+ lib/Sqel/Column.hs view
@@ -0,0 +1,59 @@+module Sqel.Column where++import Sqel.Class.Mods (AddMod (addMod), MapMod, amendMod)+import Sqel.Data.Dd (Dd (Dd), DdK (DdK), Struct (Prim))+import Sqel.Data.Mods (Nullable (Nullable), PgDefault (PgDefault), PrimaryKey (PrimaryKey), SetTableName (SetTableName))+import Sqel.Data.PgTypeName (PgTableName)+import Sqel.Data.Sql (Sql)+import Sqel.Names.Rename (Rename, rename)+import Sqel.Names.Set (SetName)++pk ::+  AddMod PrimaryKey s0 s1 =>+  Dd s0 ->+  Dd s1+pk =+  addMod PrimaryKey++class MkNullable s0 s1 | s0 -> s1 where+  mkNullable :: Dd s0 -> Dd s1++instance MkNullable ('DdK sel p a 'Prim) ('DdK sel p (Maybe a) 'Prim) where+  mkNullable (Dd sel p s) = Dd sel p s++nullable ::+  ∀ s0 s1 s2 .+  AddMod Nullable s0 s1 =>+  MkNullable s1 s2 =>+  Dd s0 ->+  Dd s2+nullable =+  mkNullable .+  addMod Nullable++nullableAs ::+  ∀ name s0 s1 s2 .+  AddMod Nullable s0 s1 =>+  MkNullable s1 s2 =>+  Rename s2 (SetName s2 name) =>+  Dd s0 ->+  Dd (SetName s2 name)+nullableAs =+  rename . nullable++tableName ::+  ∀ s0 s1 .+  MapMod SetTableName s0 s1 =>+  PgTableName ->+  Dd s0 ->+  Dd s1+tableName name =+  amendMod (SetTableName name)++pgDefault ::+  AddMod PgDefault s0 s1 =>+  Sql ->+  Dd s0 ->+  Dd s1+pgDefault v =+  addMod (PgDefault v)
+ lib/Sqel/ColumnConstraints.hs view
@@ -0,0 +1,74 @@+module Sqel.ColumnConstraints where++import Generics.SOP (I (I), NP (Nil, (:*)))+import Lens.Micro ((%~), (.~))+import Sqel.Data.Mods (+  Mods (Mods),+  Nullable (Nullable),+  PgDefault (PgDefault),+  PrimaryKey (PrimaryKey),+  Unique (Unique),+  )+import Sqel.Data.Sql (Sql, sql)++data Constraints =+  Constraints {+    unique :: Bool,+    nullable :: Bool,+    extra :: [Sql]+  }+  deriving stock (Eq, Show, Generic)++class ColumnConstraint mod where+  columnConstraint :: mod -> Constraints -> Constraints++instance {-# overlappable #-} ColumnConstraint mod where+  columnConstraint _ = id++instance ColumnConstraint Nullable where+  columnConstraint Nullable =+    #nullable .~ True++instance ColumnConstraint PrimaryKey where+  columnConstraint PrimaryKey Constraints {..} =+    Constraints {+      unique = True,+      extra = "primary key" : extra,+      ..+    }++instance ColumnConstraint PgDefault where+  columnConstraint (PgDefault val) =+    #extra %~ ([sql|default ##{val}|] :)++instance ColumnConstraint Unique where+  columnConstraint Unique Constraints {..} =+    Constraints {+      unique = True,+      extra = "unique" : extra,+      ..+    }++class ColumnConstraints mods where+  collectConstraints :: NP I mods -> Constraints++instance ColumnConstraints '[] where+  collectConstraints Nil = Constraints False False []++instance (+    ColumnConstraint mod,+    ColumnConstraints mods+  ) => ColumnConstraints (mod : mods) where+  collectConstraints (I h :* t) =+    columnConstraint h (collectConstraints t)++columnConstraints ::+  ColumnConstraints mods =>+  Mods mods ->+  (Bool, [Sql])+columnConstraints (Mods mods) =+  (unique, notNull <> extra)+  where+    notNull | nullable = []+            | otherwise = ["not null"]+    Constraints {..} = collectConstraints mods
+ lib/Sqel/Comp.hs view
@@ -0,0 +1,242 @@+module Sqel.Comp where++import Fcf (Length, type (@@))+import Generics.SOP (NP (Nil, (:*)))+import Generics.SOP.GGP (GDatatypeInfoOf)+import Generics.SOP.Type.Metadata (ConstructorInfo (Record), DatatypeInfo (ADT), FieldInfo (FieldInfo))+import Sqel.Data.Dd (+  CompInc (Merge, Nest),+  Dd (Dd),+  DdK (DdK),+  DdStruct (DdComp),+  ProductField (ProductField),+  Struct (Comp, Prim),+  type (:>) ((:>)),+  )+import Sqel.Data.Sel (+  MkTSel (mkTSel),+  Sel (SelAuto, SelSymbol, SelUnused),+  SelPrefix (DefaultPrefix, SelPrefix),+  TSel (TSel),+  TSelW (TSelW),+  TypeName,+  )+import Sqel.Data.Uid (Uid)+import Sqel.Names.Data (NatSymbol)+import Sqel.Names.Error (CountMismatch)+import Sqel.Names.Rename (Rename (rename))+import Sqel.Prim (Prims (Prims))+import Sqel.SOP.Error (Quoted, QuotedType)+import Type.Errors (DelayError, ErrorMessage)++-- TODO reimplement for new class structure+-- -- TODO this recurses through the entire subtree.+-- -- can we replace this with a check for the index column? i.e. ($1 != 2 or foo = $2)+-- -- TODO this has to be moved to the post builder+-- class GuardSumPrim s where+--   guardSumPrim :: Dd s -> Dd s++-- instance (+--     OverMod SelectAtom ('DdK sel p a 'Prim)+--   ) => GuardSumPrim ('DdK sel p a 'Prim) where+--   guardSumPrim =+--     overMod \case+--       SelectAtom Where code ->+--         SelectAtom Where (\ s i -> [sql|(#{dollar i} is null or #{code s i})|])+--       m -> m++-- instance (+--     All GuardSumPrim sub+--   ) => GuardSumPrim ('DdK sel param a ('Comp tsel ('Prod 'Reg) 'Nest sub)) where+--     guardSumPrim (Dd sel p (DdComp tsel DdProd DdNest sub)) =+--       Dd sel p (DdComp tsel DdProd DdNest (hcmap (Proxy @GuardSumPrim) guardSumPrim sub))++type CompName :: Type -> TSel -> Constraint+class CompName a sel | a -> sel where+  compName :: TSelW sel++type CompNameData :: Type -> DatatypeInfo -> Symbol+type family CompNameData a info where+  CompNameData _ ('ADT _ name _ _) = name+  CompNameData a _ = TypeError ("The type " <> a <> " is not an ADT.")++instance {-# overlappable #-} (+    name ~ CompNameData a (GDatatypeInfoOf a),+    sel ~ 'TSel 'DefaultPrefix name,+    MkTSel sel+  ) => CompName a sel where+    compName = mkTSel++instance CompName a sel => CompName (Uid i a) sel where+  compName = compName @a++type family RecordFields (fields :: [FieldInfo]) (ass :: [Type]) :: [ProductField] where+  RecordFields '[] '[] = '[]+  RecordFields ('FieldInfo name : fields) (a : as) = 'ProductField name a : RecordFields fields as++type family ConstructorFields (name :: Symbol) (index :: Nat) (ass :: [Type]) :: [ProductField] where+  ConstructorFields _ _ '[] = '[]+  ConstructorFields name n (a : as) = 'ProductField (AppendSymbol name (NatSymbol n)) a : ConstructorFields name (n + 1) as++type family ProductFields (info :: DatatypeInfo) (ass :: [[Type]]) :: [ProductField] where+  ProductFields ('ADT _ _ '[ 'Record _ fields] _) '[ass] = RecordFields fields ass++-- TODO check if the sel cases can be refactored into another class that does the rename/id distinction+-- First add an error test case for the higher-order constraint of Column+--+-- Maybe add a class layer before this that separates Dd and others, so that Column is the one in the error when Dd+-- is able to be inferred and the other one has a custom error+type Column :: Type -> Symbol -> DdK -> DdK -> Constraint+class Column a fieldName s0 s | a fieldName s0 -> s where+  compItem :: Dd s0 -> Dd s++instance (+    a ~ b,+    KnownSymbol name+  ) => Column a name ('DdK 'SelAuto mods b 'Prim) ('DdK ('SelSymbol name) mods a 'Prim) where+  compItem = rename++instance (+    a ~ b+  ) => Column a fname ('DdK ('SelSymbol name) mods b 'Prim) ('DdK ('SelSymbol name) mods a 'Prim) where+  compItem = id++instance (+    a ~ b+  ) => Column a name ('DdK 'SelUnused mods b 'Prim) ('DdK 'SelUnused mods a 'Prim) where+  compItem = id++instance (+    a ~ b,+    KnownSymbol name+  ) => Column a name ('DdK 'SelAuto mods b ('Comp tsel c 'Nest s)) ('DdK ('SelSymbol name) mods a ('Comp tsel c 'Nest s)) where+  compItem = rename++instance (+    a ~ b+  ) => Column a fname ('DdK ('SelSymbol name) mods b ('Comp tsel c 'Nest s)) ('DdK ('SelSymbol name) mods a ('Comp tsel c 'Nest s)) where+  compItem = id++instance (+    a ~ b+  ) => Column a name ('DdK 'SelAuto mods b ('Comp tsel c 'Merge s)) ('DdK 'SelAuto mods a ('Comp tsel c 'Merge s)) where+  compItem = id++data CompMeta =+  CompMeta {+    desc :: Symbol,+    name :: ErrorMessage,+    combinator :: Symbol,+    index :: Nat+  }+  deriving stock (Generic)++type InvalidElem :: Symbol -> Nat -> Type -> Void+type InvalidElem name i arg =+  DelayError (+    "Element number " <> i <> " in the call to " <> Quoted name <> " has type " <> QuotedType arg <> "." %+    "Columns should only be constructed with combinators like " <> Quoted "prim" <> ", " <> Quoted "prod" <> "," %+    Quoted "column" <> " that return the proper type, " <> Quoted "Dd" <> "." %+    "Consult the module " <> Quoted "Sqel.Combinators" <> " for the full API."+  )++type CompItemOrError :: Void -> ProductField -> Type -> DdK -> Constraint+class CompItemOrError err field arg s | field arg -> s where+  compItemOrError :: Proxy err -> arg -> Dd s++instance (+    Column a fieldName s0 s1+  ) => CompItemOrError err ('ProductField fieldName a) (Dd s0) s1 where+    compItemOrError Proxy = compItem @a @fieldName++type CheckCompItem :: CompMeta -> ProductField -> Type -> DdK -> Constraint+class CheckCompItem meta field arg s | field arg -> s where+  checkCompItem :: arg -> Dd s++instance (+    meta ~ 'CompMeta desc name combinator index,+    error ~ InvalidElem combinator index arg,+    CompItemOrError error field arg s1+  ) => CheckCompItem meta field arg s1 where+    checkCompItem = compItemOrError @error @field Proxy++type family MetaNext (meta :: CompMeta) :: CompMeta where+  MetaNext ('CompMeta desc name combinator index) = 'CompMeta desc name combinator (index + 1)++type family MetaFor (desc :: Symbol) (name :: ErrorMessage) (combinator :: Symbol) :: CompMeta where+  MetaFor desc name combinator = 'CompMeta desc name combinator 1++data SpecType = SpecNP | SpecDsl | SpecPrims++type family CheckFields (meta :: CompMeta) (len :: Nat) (fieldLen :: Nat) (t :: SpecType) :: Either Void SpecType where+  CheckFields _ n n t = 'Right t+  CheckFields ('CompMeta desc name _ _) arg f _ = 'Left (DelayError (CountMismatch desc name arg f))++type family DslSize (arg :: Type) :: Nat where+  DslSize (_ :> as) = 1 + DslSize as+  DslSize _ = 1++type family TriageComp (meta :: CompMeta) (arg :: Type) (fields :: [ProductField]) :: Either Void SpecType where+  TriageComp _ (Prims _ _) _ = 'Right 'SpecPrims+  TriageComp meta (NP _ s) fs = CheckFields meta (Length @@ s) (Length @@ fs) 'SpecNP+  TriageComp meta args fs = CheckFields meta (DslSize args) (Length @@ fs) 'SpecDsl++type CompColumn' :: CompMeta -> Either Void SpecType -> [ProductField] -> Type -> Type -> [DdK] -> Constraint+class CompColumn' meta spec fields a arg s | fields arg -> s where+  compColumn' :: arg -> NP Dd s++instance CompColumn' meta ('Right 'SpecNP) '[] a (NP f '[]) '[] where+  compColumn' Nil = Nil++instance (+    CheckCompItem meta field (f arg0) s0,+    CompColumn' (MetaNext meta) ('Right 'SpecNP) fields a (NP f args) s1+  ) => CompColumn' meta ('Right 'SpecNP) (field : fields) a (NP f (arg0 : args)) (s0 : s1) where+    compColumn' (arg0 :* args) =+      checkCompItem @meta @field arg0 :* compColumn' @(MetaNext meta) @('Right 'SpecNP) @fields @a args++instance (+    CheckCompItem meta field arg0 s0,+    CompColumn' (MetaNext meta) ('Right 'SpecDsl) fields a args s1+  ) => CompColumn' meta ('Right 'SpecDsl) (field : fields) a (arg0 :> args) (s0 : s1) where+  compColumn' (arg0 :> args) =+    checkCompItem @meta @field arg0 :* compColumn' @(MetaNext meta) @('Right 'SpecDsl) @fields @a args++instance (+    CheckCompItem meta field arg s+  ) => CompColumn' meta ('Right 'SpecDsl) '[ field] a arg '[s] where+    compColumn' arg = checkCompItem @meta @field arg :* Nil++instance (+    a ~ b,+    CompColumn' meta ('Right 'SpecNP) fields a (NP Dd s0) s1+  ) => CompColumn' meta ('Right 'SpecPrims) fields a (Prims b s0) s1 where+  compColumn' (Prims np) = compColumn' @meta @('Right 'SpecNP) @fields @a np++type CompColumn :: CompMeta -> [ProductField] -> Type -> Type -> [DdK] -> Constraint+class CompColumn meta fields a arg s | fields arg -> s where+  compColumn :: arg -> NP Dd s++instance (+    spec ~ TriageComp meta arg fields,+    CompColumn' meta spec fields a arg s+  ) => CompColumn meta fields a arg s where+    compColumn = compColumn' @meta @spec @fields @a++type SetTypePrefix :: Symbol -> DdK -> DdK -> Constraint+class SetTypePrefix prefix s0 s1 | prefix s0 -> s1 where+  setTypePrefix :: Dd s0 -> Dd s1++instance (+    TypeName ('SelPrefix prefix) tpe tname+  ) => SetTypePrefix prefix ('DdK sel mods a ('Comp ('TSel oldPrefix tpe) c i s)) ('DdK sel mods a ('Comp ('TSel ('SelPrefix prefix) tpe) c i s)) where+    setTypePrefix (Dd sel mods (DdComp _ c i s)) =+      Dd sel mods (DdComp (TSelW Proxy) c i s)++typePrefix ::+  ∀ prefix s0 s1 .+  SetTypePrefix prefix s0 s1 =>+  Dd s0 ->+  Dd s1+typePrefix =+  setTypePrefix @prefix
+ lib/Sqel/Data/Codec.hs view
@@ -0,0 +1,84 @@+module Sqel.Data.Codec where++import Data.Functor.Invariant (Invariant (invmap), invmapContravariant)+import qualified Hasql.Decoders as Decoders+import Hasql.Decoders (Row)+import qualified Hasql.Encoders as Encoders+import Hasql.Encoders (Params)++import Sqel.SOP.Constraint (symbolText)++data Encoder a =+  Encoder {+    encodeValue :: Params a,+    encodeNulls :: Params ()+  }+  deriving stock (Generic)++instance Semigroup (Encoder a) where+  Encoder vl nl <> Encoder vr nr =+    Encoder (vl <> vr) (nl <> nr)++instance Monoid (Encoder a) where+  mempty =+    Encoder mempty mempty++instance Contravariant Encoder where+  contramap f Encoder {..} =+    Encoder (f >$< encodeValue) encodeNulls++instance Invariant Encoder where+  invmap = invmapContravariant++data Decoder a =+  Decoder {+    decodeValue :: Row a,+    decodeNulls :: Row ()+  }+  deriving stock (Generic)++instance Functor Decoder where+  fmap f Decoder {..} =+    Decoder (f <$> decodeValue) decodeNulls++instance Applicative Decoder where+  pure a =+    Decoder (pure a) (pure ())++  liftA2 f (Decoder vl nl) (Decoder vr nr) =+    Decoder (liftA2 f vl vr) (nl *> nr)++data Codec e d a =+  Codec {+    encoder :: e a,+    decoder :: d a+  }+  deriving stock (Generic)++type ValueCodec =+  Codec Encoders.Value Decoders.Value++instance (+    Contravariant e,+    Functor d+  ) => Invariant (Codec e d) where+    invmap f c Codec {..} =+      Codec {+        encoder = c >$< encoder,+        decoder = f <$> decoder+      }++type FullCodec =+  Codec Encoder Decoder++newtype ColumnName =+  ColumnName { unColumnName :: Text }+  deriving stock (Eq, Show)+  deriving newtype (IsString, Ord)++symbolColumnName ::+  ∀ (name :: Symbol) .+  KnownSymbol name =>+  ColumnName+symbolColumnName =+  ColumnName (symbolText @name)
+ lib/Sqel/Data/Dd.hs view
@@ -0,0 +1,163 @@+module Sqel.Data.Dd where++import Generics.SOP (I, NP (Nil, (:*)))+import Prettyprinter (Doc, Pretty (pretty), brackets, nest, parens, vsep, (<+>))++import Sqel.Data.Mods (Mods)+import Sqel.Data.Sel (Sel (SelSymbol), SelW, TSel, TSelW, showSelW, showTSelW)++data ProductField =+  ProductField {+    name :: Symbol,+    tpe :: Type+  }++newtype ConCol (name :: Symbol) (record :: Bool) (fields :: [ProductField]) as =+  ConCol { unConCol :: NP I as }++data ProdType = Reg | Con [Type]++data Comp = Prod ProdType | Sum++data CompInc = Merge | Nest++data Struct =+  Prim+  |+  Comp {+    typeName :: TSel,+    compKind :: Comp,+    compInc :: CompInc,+    sub :: [DdK]+  }++data DdK =+  DdK {+    columnName :: Sel,+    mods :: [Type],+    hsType :: Type,+    struct :: Struct+  }++type DdSort :: Comp -> Type+data DdSort c where+  DdProd :: DdSort ('Prod 'Reg)+  DdCon :: DdSort ('Prod ('Con as))+  DdSum :: DdSort 'Sum++type MkDdSort :: Comp -> Constraint+class MkDdSort c where ddSort :: DdSort c++instance MkDdSort ('Prod 'Reg) where ddSort = DdProd+instance MkDdSort ('Prod ('Con as)) where ddSort = DdCon+instance MkDdSort 'Sum where ddSort = DdSum++type DdInc :: CompInc -> Type+data DdInc c where+  DdMerge :: DdInc 'Merge+  DdNest :: DdInc 'Nest++type MkDdInc :: CompInc -> Constraint+class MkDdInc c where ddInc :: DdInc c++instance MkDdInc 'Merge where ddInc = DdMerge+instance MkDdInc 'Nest where ddInc = DdNest++type DdStruct :: Struct -> Type+data DdStruct s where+  DdPrim :: DdStruct 'Prim+  DdComp :: TSelW sel -> DdSort c -> DdInc i -> NP Dd sub -> DdStruct ('Comp sel c i sub)++-- TODO maybe this could be a data family so that after using the dsl, the index is changed so that all Sels are present+-- also to stuff different metadata in there, like DdlColumn?+type Dd :: DdK -> Type+data Dd s where+  Dd :: SelW sel -> Mods mods -> DdStruct s -> Dd ('DdK sel mods a s)++data QOp =+  QAnd+  |+  QOr+  deriving stock (Eq, Show, Generic)++type DdType :: DdK -> Type+type family DdType s where+  DdType ('DdK _ _ a _) = a++type DdTypes :: [DdK] -> [Type]+type family DdTypes s where+  DdTypes '[] = '[]+  DdTypes (s : ss) = DdType s : DdTypes ss++type DdSel :: DdK -> Sel+type family DdSel s where+  DdSel ('DdK sel _ _ _) = sel++type family DdName (s :: DdK) :: Symbol where+  DdName ('DdK ('SelSymbol name) _ _ _) = name+  DdName ('DdK _ _ a _) = TypeError ("This Dd for type " <> a <> " has no name")++type DdTypeSel :: DdK -> TSel+type family DdTypeSel s where+  DdTypeSel ('DdK _ _ _ ('Comp sel _ _ _)) = sel++sel :: Dd s -> SelW (DdSel s)+sel (Dd s _ _) = s++typeSel :: Dd ('DdK sel p a ('Comp tsel c i sub)) -> TSelW tsel+typeSel (Dd _ _ (DdComp s _ _ _)) = s++showSel :: Dd s -> Text+showSel =+  showSelW . sel++showTypeSel :: Dd ('DdK sel p a ('Comp tsel c i sub)) -> Text+showTypeSel =+  showTSelW . typeSel++data a :> b = a :> b+infixr 3 :>++class PrettyNP s where+  prettyNP :: NP Dd s -> [Doc ann]++instance PrettyNP '[] where+  prettyNP Nil = mempty++instance (+    Pretty (Dd s),+    PrettyNP ss+  ) => PrettyNP (s : ss) where+  prettyNP (dd :* dds) =+    pretty dd : prettyNP dds++instance Pretty (DdStruct 'Prim) where+  pretty DdPrim = "prim"++instance (+    PrettyNP sub+  ) => Pretty (Dd ('DdK sel p a ('Comp tsel c i sub))) where+  pretty (Dd s _ (DdComp ts c i sub)) =+    nest 2 (vsep ((var <> brackets (pretty (showTSelW ts)) <+> pretty (showSelW s) <+> parens inc) : prettyNP sub))+    where+      var = case c of+        DdProd -> "prod"+        DdSum -> "sum"+        DdCon -> "con"+      inc = case i of+        DdNest -> "nest"+        DdMerge -> "merge"++instance (+    Pretty (Mods p)+  ) => Pretty (Dd ('DdK sel p a 'Prim)) where+  pretty (Dd s p DdPrim) =+    "prim" <+> pretty (showSelW s) <+> pretty p++type Sqel' :: Sel -> [Type] -> Type -> Struct -> Type+type family Sqel' sel mods a s = r | r -> sel mods a s where+  Sqel' sel mods a s = Dd ('DdK sel mods a s)++type Sqel :: Type -> (Sel, [Type], Struct) -> Type+type family Sqel a p = r | r -> p a where+  Sqel a '(sel, mods, s) = Dd ('DdK sel mods a s)
+ lib/Sqel/Data/FieldPath.hs view
@@ -0,0 +1,71 @@+module Sqel.Data.FieldPath where++import Sqel.Kind (type (++))+import Sqel.SOP.Error (JoinSep, QuotedType, Unlines)+import Type.Errors (ErrorMessage)++import Sqel.Data.Dd (Comp (Sum), CompInc (Merge), Dd, DdK (DdK), Struct (Comp, Prim))+import Sqel.Data.Sel (Sel (SelAuto, SelIndex, SelPath, SelSymbol, SelUnused))++data FieldPath =+  FieldPath {+    path :: [Symbol],+    tpe :: Type+  }++type FieldPathPrim :: [Symbol] -> Sel -> Type -> [FieldPath]+type family FieldPathPrim prefix sel t where+  FieldPathPrim prefix ('SelSymbol name) t = '[ 'FieldPath (prefix ++ '[name]) t]+  FieldPathPrim _ ('SelPath path) t = '[ 'FieldPath path t]+  FieldPathPrim _ 'SelUnused _ = '[]+  FieldPathPrim _ ('SelIndex _ _) _ = '[]+  FieldPathPrim _ 'SelAuto t =+    TypeError ("Internal error: A field with type " <> t <> " was not automatically renamed.")++type FieldPathsComp :: [Symbol] -> Sel -> Comp -> CompInc -> Type -> [DdK] -> [FieldPath]+type family FieldPathsComp prefix name c i t sub where+  FieldPathsComp prefix _ _ 'Merge _ sub = FieldPathsProd prefix sub+  FieldPathsComp prefix ('SelSymbol name) 'Sum _ _ (_ : sub) = FieldPathsProd (prefix ++ '[name]) sub+  FieldPathsComp prefix ('SelSymbol name) _ _ _ sub = FieldPathsProd (prefix ++ '[name]) sub+  FieldPathsComp _ 'SelAuto _ _ t _ =+    TypeError ("Internal error: A composite column with type " <> QuotedType t <> " was not automatically renamed.")++type FieldPathsSub :: [Symbol] -> DdK -> [FieldPath]+type family FieldPathsSub prefix s where+  FieldPathsSub prefix ('DdK sel _ t 'Prim) = FieldPathPrim prefix sel t+  FieldPathsSub prefix ('DdK sel _ t ('Comp _ c i d)) = FieldPathsComp prefix sel c i t d+  FieldPathsSub _ s = TypeError ("FieldPathsSub: " <> s)++type FieldPathsProd :: [Symbol] -> [DdK] -> [FieldPath]+type family FieldPathsProd prefix s where+  FieldPathsProd _ '[] = '[]+  FieldPathsProd prefix (s : ss) = FieldPathsSub prefix s ++ FieldPathsProd prefix ss+  FieldPathsProd _ s = TypeError ("FieldPathsProd: " <> s)++type FieldPaths :: DdK -> [FieldPath]+type family FieldPaths s where+  FieldPaths ('DdK ('SelSymbol name) _ t 'Prim) = '[ 'FieldPath '[name] t]+  FieldPaths ('DdK _ _ _ ('Comp _ _ _ sub)) = FieldPathsProd '[] sub+  FieldPaths s = TypeError ("FieldPaths: " <> s)++-------------------------------------------------------------------------------------------------------++type family PathEq (f1 :: FieldPath) (f2 :: FieldPath) :: Bool where+  PathEq ('FieldPath path _) ('FieldPath path _) = 'True+  PathEq _ _ = 'False++type family ShowField (field :: FieldPath) :: ErrorMessage where+  ShowField ('FieldPath path tpe) = "  " <> JoinSep "." path <> " [" <> tpe <> "]"++type family ShowFields (fields :: [FieldPath]) :: [ErrorMessage] where+  ShowFields '[] = '[]+  ShowFields (field : fields) =+    ShowField field : ShowFields fields++class PrintFields (s :: DdK) where+  printFields :: Dd s -> ()+  printFields _ = ()++instance (+    TypeError (Unlines (ShowFields (FieldPaths s)) % s)+  ) => PrintFields s where
+ lib/Sqel/Data/FragType.hs view
@@ -0,0 +1,36 @@+module Sqel.Data.FragType where++import Sqel.Data.Order (Order)+import Sqel.Data.Sql (Sql, sql)++data FragType =+  Where+  |+  Offset+  |+  Limit+  |+  Order Order+  |+  Custom Int Text+  deriving stock (Eq, Show, Generic)++renderWithFragKeyword :: Sql -> FragType -> Sql+renderWithFragKeyword param = \case+  Where -> [sql|where #{param}|]+  Offset -> [sql|offset #{param}|]+  Limit -> [sql|limit #{param}|]+  Order dir -> [sql|order by #{param} ##{dir}|]+  Custom _ kw -> [sql|##{kw} #{param}|]++sfragOrdinal :: FragType -> Int+sfragOrdinal = \case+  Where -> 0+  Order _ -> 1+  Limit -> 2+  Offset -> 3+  Custom i _ -> i++instance Ord FragType where+  compare =+    comparing sfragOrdinal
+ lib/Sqel/Data/Migration.hs view
@@ -0,0 +1,149 @@+module Sqel.Data.Migration where++import Exon (exon)+import Generics.SOP (NP (Nil, (:*)))+import Hasql.Encoders (Params)++import Sqel.Data.Dd ((:>) ((:>)))+import Sqel.Data.PgType (ColumnType, PgColumnName, PgColumns, PgTable)+import Sqel.Data.PgTypeName (PgCompName, PgTableName, PgTypeName)++data ColumnAction where+  AddColumn :: PgColumnName -> ColumnType -> Maybe (a, Params a) -> ColumnAction+  RemoveColumn :: PgColumnName -> ColumnType -> ColumnAction+  RenameColumn :: PgColumnName -> PgColumnName -> ColumnAction+  RenameColumnType :: PgColumnName -> PgCompName -> ColumnAction++instance Show ColumnAction where+  showsPrec d =+    showParen (d > 10) . \case+      AddColumn name tpe _ ->+        [exon|AddColumn #{showsPrec 11 name} #{showsPrec 11 tpe}|]+      RemoveColumn name tpe ->+        [exon|RemoveColumn #{showsPrec 11 name} #{showsPrec 11 tpe}|]+      RenameColumn old new ->+        [exon|RenameColumn #{showsPrec 11 old} #{showsPrec 11 new}|]+      RenameColumnType name new ->+        [exon|RenameColumnType #{showsPrec 11 name} #{showsPrec 11 new}|]++data TypeAction (table :: Bool) where+  ModifyAction :: PgTypeName table -> [ColumnAction] -> TypeAction table+  RenameAction :: PgCompName -> [ColumnAction] -> TypeAction 'False+  AddAction :: PgColumns -> TypeAction 'False++type TableAction = TypeAction 'True+type CompAction = TypeAction 'False++data MigrationActions ext =+  AutoActions {+    table :: TableAction,+    types :: Map PgCompName CompAction+  }+  |+  CustomActions ext+  deriving stock (Generic)++data Mig =+  Mig {+    from :: Type,+    to :: Type,+    effect :: Type -> Type,+    ext :: Type+  }++type Migration :: Mig -> Type+data Migration t where+  Migration :: {+    tableFrom :: PgTable from,+    tableTo :: PgTable to,+    actions :: MigrationActions ext+  } -> Migration ('Mig from to m ext)++type family MigFrom (mig :: Mig) :: Type where+  MigFrom ('Mig from _ _ _) = from++type family MigTo (mig :: Mig) :: Type where+  MigTo ('Mig _ to _ _) = to++type family MigEff (mig :: Mig) :: Type -> Type where+  MigEff ('Mig _ _ m _) = m++type family MigExt (mig :: Mig) :: Type where+  MigExt ('Mig _ _ _ ext) = ext++type UniMigList :: (Type -> Type) -> Type -> [Type] -> [Mig]+type family UniMigList m ext as where+  UniMigList _ _ '[] = '[]+  UniMigList m ext [new, old] = '[ 'Mig old new m ext]+  UniMigList m ext (new : old : as) = 'Mig old new m ext : UniMigList m ext (old : as)++type UniMigs :: (Type -> Type) -> Type -> [Type] -> Type -> [Mig]+type family UniMigs m ext old cur where+  UniMigs _ _ '[] _ = '[]+  UniMigs m ext '[o] cur = '[ 'Mig o cur m ext]+  UniMigs m ext (o : os) cur = 'Mig o cur m ext : UniMigList m ext (o : os)++type Migrations :: (Type -> Type) -> [Mig] -> Type+newtype Migrations m migs =+  Migrations { unMigrations :: NP Migration migs }++type UniMigrations m ext old cur =+  Migrations m (UniMigs m ext old cur)++type AutoMigrations m old cur =+  UniMigrations m Void old cur++class MkMigrations arg migs | arg -> migs, migs -> arg where+  mkMigrations :: arg -> NP Migration migs++instance (+    MkMigrations old (mig1 : migs)+  ) => MkMigrations (Migration ('Mig from to m ext) :> old) ('Mig from to m ext : mig1 : migs) where+    mkMigrations (next :> old) =+      next :* mkMigrations old++instance MkMigrations (Migration ('Mig from to m ext)) '[ 'Mig from to m ext] where+  mkMigrations next =+    next :* Nil++migrate ::+  MkMigrations arg migs =>+  arg ->+  Migrations m migs+migrate =+  Migrations . mkMigrations++noMigrations :: Migrations m '[]+noMigrations =+  Migrations Nil++class CustomMigration m mig where+  customTypeKeys :: MigExt mig -> m (Set (PgCompName, Bool))+  customMigration :: PgTableName -> Set PgCompName -> MigExt mig -> m ()++instance CustomMigration m ('Mig from to m Void) where+  customTypeKeys = \case+  customMigration _ _ = \case++class HoistMigration m n ext ext' | m n ext -> ext' where+  hoistMigration :: (∀ x . m x -> n x) -> ext -> ext'++instance HoistMigration m n Void Void where+  hoistMigration _ = \case++class HoistMigrations m n migs migs' | m n migs -> migs' where+  hoistMigrations :: (∀ x . m x -> n x) -> Migrations m migs -> Migrations n migs'++instance HoistMigrations m n '[] '[] where+  hoistMigrations _ Migrations {..} = Migrations {..}++instance (+    HoistMigration m n ext ext',+    HoistMigrations m n migs migs'+  ) => HoistMigrations m n ('Mig from to m ext : migs) ('Mig from to n ext' : migs') where+  hoistMigrations f (Migrations (Migration {..} :* migs)) =+    Migrations (Migration {actions = hoistAction actions, ..} :* unMigrations (hoistMigrations f (Migrations migs)))+    where+      hoistAction = \case+        CustomActions ext -> CustomActions (hoistMigration f ext)+        AutoActions {..} -> AutoActions {..}
+ lib/Sqel/Data/MigrationParams.hs view
@@ -0,0 +1,34 @@+module Sqel.Data.MigrationParams where++newtype MigrationDefault a =+  MigrationDefault { unMigrationDefault :: a }+  deriving stock (Eq, Show, Generic)++type MigrationRename :: Symbol -> Type+data MigrationRename name =+  MigrationRename+  deriving stock (Eq, Show, Generic)++type family MigrationRenameK (ps :: [Type]) :: Maybe Symbol where+  MigrationRenameK '[] = 'Nothing+  MigrationRenameK (MigrationRename name : _) = 'Just name+  MigrationRenameK (_ : ps) = MigrationRenameK ps++type MigrationRenameType :: Symbol -> Type+data MigrationRenameType name =+  MigrationRenameType+  deriving stock (Eq, Show, Generic)++type family MigrationRenameTypeK (ps :: [Type]) :: Maybe Symbol where+  MigrationRenameTypeK '[] = 'Nothing+  MigrationRenameTypeK (MigrationRenameType name : _) = 'Just name+  MigrationRenameTypeK (_ : ps) = MigrationRenameTypeK ps++data MigrationDelete =+  MigrationDelete+  deriving stock (Eq, Show, Generic)++type family MigrationDeleteK (ps :: [Type]) :: Bool where+  MigrationDeleteK '[] = 'False+  MigrationDeleteK (MigrationDelete : _) = 'True+  MigrationDeleteK (_ : ps) = MigrationDeleteK ps
+ lib/Sqel/Data/Mods.hs view
@@ -0,0 +1,68 @@+module Sqel.Data.Mods where++import Exon (exon)+import Generics.SOP (All, Compose, I, K (K), NP (Nil), hcmap, hcollapse)+import Prelude hiding (Compose)+import Prettyprinter (Pretty (pretty), hsep, viaShow)+import qualified Text.Show as Show++import Sqel.Data.PgTypeName (PgTableName)+import Sqel.Data.Sql (Sql)++newtype Mods ps = Mods { unMods :: NP I ps }++type NoMods = '[]++pattern NoMods :: () => (ps ~ '[]) => Mods ps+pattern NoMods = Mods Nil++instance (+    All (Compose Show I) ps+  ) => Show (Mods ps) where+  showsPrec d (Mods ps) =+    showParen (d > 10) [exon|Mods #{showsPrec 11 ps}|]++instance All Show ps => Pretty (Mods ps) where+  pretty (Mods ps) =+    hsep (hcollapse (hcmap (Proxy @Show) (K . viaShow) ps))++data Nullable = Nullable+  deriving stock (Show)++data Unique = Unique+  deriving stock (Show)++data PrimaryKey = PrimaryKey+  deriving stock (Show)++data PgDefault = PgDefault Sql+  deriving stock (Show)++data EnumColumn = EnumColumn+  deriving stock (Eq, Show, Generic)++data ReadShowColumn = ReadShowColumn+  deriving stock (Eq, Show, Generic)++type ArrayColumn :: (Type -> Type) -> Type+data ArrayColumn f = ArrayColumn+  deriving stock (Eq, Show, Generic)++newtype SetTableName =+  SetTableName { unSetTableName :: PgTableName }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++data Newtype a w =+  Newtype {+    unwrap :: a -> w,+    wrap :: w -> a+  }+  deriving stock (Generic)++instance Show (Newtype a w) where+  show _ =+    "Newtype"++data Ignore = Ignore+  deriving stock (Eq, Show, Generic)
+ lib/Sqel/Data/Order.hs view
@@ -0,0 +1,17 @@+module Sqel.Data.Order where++import Sqel.Data.Sql (ToSql (toSql), sql)++data Order =+  Asc+  |+  Desc+  |+  Using Text+  deriving stock (Eq, Show, Generic)++instance ToSql Order where+  toSql = \case+    Asc -> "asc"+    Desc -> "desc"+    Using expr -> [sql|using ##{expr}|]
+ lib/Sqel/Data/PgType.hs view
@@ -0,0 +1,229 @@+module Sqel.Data.PgType where++import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Map.Strict as Map+import qualified Exon+import Lens.Micro.Extras (view)+import Prettyprinter (Pretty (pretty), nest, sep, vsep, (<+>))+import Sqel.SOP.Constraint (symbolText)+import Sqel.Text.DbIdentifier (dbIdentifierT, dbSymbol)++import Sqel.Data.PgTypeName (PgCompName, PgTableName, pattern PgTypeName)+import Sqel.Data.Selector (Selector (unSelector), assign, nameSelector)+import Sqel.Data.Sql (Sql, ToSql (toSql), sql, sqlQuote)+import Sqel.Data.SqlFragment (+  CommaSep (CommaSep),+  Create (Create),+  Delete (Delete),+  From (From),+  Insert (Insert),+  Into (Into),+  Returning (Returning),+  Select (Select),+  Update (Update),+  )++newtype PgPrimName =+  PgPrimName { unPgPrimName :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord, Semigroup, Monoid, ToJSON, FromJSON)++instance Pretty PgPrimName where+  pretty (PgPrimName n) = pretty n++pgPrimName ::+  ∀ name .+  KnownSymbol name =>+  PgPrimName+pgPrimName =+  PgPrimName (dbSymbol @name)++newtype PgProdName =+  PgProdName { unPgProdName :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++newtype PgColumnName =+  PgColumnName { unPgColumnName :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (Ord, ToJSON, FromJSON)++instance Pretty PgColumnName where+  pretty (PgColumnName n) = pretty n++instance ToSql PgColumnName where+  toSql =+    sqlQuote . unPgColumnName++pgColumnName ::+  Text ->+  PgColumnName+pgColumnName n =+  PgColumnName (dbIdentifierT n)++instance IsString PgColumnName where+  fromString = pgColumnName . fromString++newtype PgTypeRef =+  PgTypeRef { unPgTypeRef :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord, ToJSON, FromJSON)++instance Pretty PgTypeRef where+  pretty (PgTypeRef n) = pretty n++instance ToSql PgTypeRef where+  toSql = sqlQuote . unPgTypeRef++pgTypeRef ::+  Text ->+  PgTypeRef+pgTypeRef n =+  PgTypeRef (dbIdentifierT n)++pgCompRef :: PgCompName -> PgTypeRef+pgCompRef (PgTypeName n) =+  PgTypeRef n++pgTypeRefSym ::+  ∀ tname .+  KnownSymbol tname =>+  PgTypeRef+pgTypeRefSym =+  pgTypeRef (symbolText @tname)++data ColumnType =+  ColumnPrim { name :: PgPrimName, unique :: Bool, constraints :: [Sql] }+  |+  ColumnComp { pgType :: PgTypeRef, unique :: Bool, constraints :: [Sql] }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (ToJSON, FromJSON)++data PgColumn =+  PgColumn {+    name :: PgColumnName,+    pgType :: ColumnType+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++instance Pretty PgColumn where+  pretty = \case+    PgColumn n (ColumnPrim t _ opt) -> "*" <+> pretty n <+> pretty t <+> sep (pretty <$> opt)+    PgColumn n (ColumnComp t _ opt) -> "+" <+> pretty n <+> pretty t <+> sep (pretty <$> opt)++instance ToSql (Create PgColumn) where+  toSql (Create PgColumn {..}) =+    case pgType of+      ColumnPrim (PgPrimName tpe) _ (Exon.intercalate " " -> params) ->+        [sql|##{name} ##{tpe} #{params}|]+      ColumnComp (PgTypeRef tpe) _ (Exon.intercalate " " -> params) ->+        [sql|##{name} ##{tpe} #{params}|]++newtype PgColumns =+  PgColumns { unPgColumns :: [PgColumn] }+  deriving stock (Eq, Show)+  deriving newtype (FromJSON, ToJSON)++data StructureType =+  StructurePrim { name :: PgPrimName, unique :: Bool, constraints :: [Sql] }+  |+  StructureComp { compName :: PgCompName, struct :: PgStructure, unique :: Bool, constraints :: [Sql] }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++structureToColumn :: StructureType -> ColumnType+structureToColumn = \case+  StructurePrim {..} -> ColumnPrim {..}+  StructureComp (PgTypeName ref) _ unique constr -> ColumnComp (PgTypeRef ref) unique constr++instance Pretty PgColumns where+  pretty (PgColumns cs) =+    vsep (pretty <$> cs)++instance ToSql (CommaSep PgColumns) where+  toSql (CommaSep (PgColumns cols)) =+    toSql (CommaSep (view #name <$> cols))++instance ToSql (Create PgColumns) where+  toSql (Create (PgColumns cols)) =+    [sql|(##{CommaSep (Create <$> cols)})|]++newtype PgStructure =+  PgStructure { unPgColumns :: [(PgColumnName, StructureType)] }+  deriving stock (Eq, Show)+  deriving newtype (FromJSON, ToJSON)++structureToColumns :: PgStructure -> PgColumns+structureToColumns (PgStructure cols) =+  PgColumns (uncurry PgColumn . second structureToColumn <$> cols)++data PgComposite =+  PgComposite {+    name :: PgCompName,+    columns :: PgColumns+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++instance Pretty PgComposite where+  pretty PgComposite {..} =+    nest 2 (vsep ["type" <+> pretty name, pretty columns])++newtype TableSelectors =+  TableSelectors { unTableSelectors :: [Selector] }+  deriving stock (Eq, Show, Generic)++instance ToSql (CommaSep TableSelectors) where+  toSql (CommaSep (TableSelectors s)) =+    toSql (CommaSep (unSelector <$> s))++instance ToSql (Select TableSelectors) where+  toSql (Select s) =+    "select " <> toSql (CommaSep s)++newtype TableValues =+  TableValues { unTableValues :: [Sql] }+  deriving stock (Eq, Show, Generic)++data PgTable a =+  PgTable {+    name :: PgTableName,+    columns :: PgColumns,+    types :: Map PgTypeRef PgComposite,+    selectors :: TableSelectors,+    values :: TableValues,+    structure :: PgStructure+  }+  deriving stock (Show, Generic)++instance Pretty (PgTable a) where+  pretty PgTable {..} =+    nest 2 (vsep (("table" <+> pretty name) : pretty columns : (pretty <$> Map.elems types)))++instance ToSql (Create (PgTable a)) where+  toSql (Create PgTable {name, columns}) =+    [sql|create table ##{name} ##{Create columns}|]++instance ToSql (Select (PgTable a)) where+  toSql (Select PgTable {name, selectors}) =+    [sql|##{Select selectors} ##{From name}|]++instance ToSql (Update (PgTable a)) where+  toSql (Update PgTable {columns = PgColumns columns, values = TableValues values}) =+    [sql|update set ##{CommaSep assigns}|]+    where+      assigns = zipWith assign colNames values+      colNames = columns <&> \ (PgColumn (PgColumnName name) _) -> nameSelector name++instance ToSql (Returning (PgTable a)) where+  toSql (Returning (PgTable {selectors})) =+    [sql|returning ##{CommaSep selectors}|]++instance ToSql (Insert (PgTable a)) where+  toSql (Insert PgTable {name, columns, values = TableValues values}) =+    [sql|insert ##{Into name} (##{CommaSep columns}) values (##{CommaSep values})|]++instance ToSql (Delete (PgTable a)) where+  toSql (Delete PgTable {name}) =+    [sql|delete ##{From name}|]
+ lib/Sqel/Data/PgTypeName.hs view
@@ -0,0 +1,124 @@+module Sqel.Data.PgTypeName where++import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON))+import Data.GADT.Show (GShow (gshowsPrec))+import Exon (exon)+import Prettyprinter (Pretty (pretty))++import Sqel.Data.Sel (SelPrefix (DefaultPrefix), TypeName)+import Sqel.Data.Sql (ToSql (toSql), sql, sqlQuote)+import Sqel.Data.SqlFragment (From (From), Into (Into))+import Sqel.SOP.Constraint (symbolText)+import Sqel.Text.DbIdentifier (dbIdentifierT)++type PgTypeName :: Bool -> Type+data PgTypeName table where+  UnsafePgTableName :: Text -> PgTypeName 'True+  UnsafePgCompName :: Text -> PgTypeName 'False++instance GShow PgTypeName where gshowsPrec = showsPrec++type PgTableName =+  PgTypeName 'True++type PgCompName =+  PgTypeName 'False++getPgTypeName :: PgTypeName table -> Text+getPgTypeName = \case+  UnsafePgTableName n -> n+  UnsafePgCompName n -> n++pattern PgTypeName :: Text -> PgTypeName table+pattern PgTypeName name <- (getPgTypeName -> name)+{-# complete PgTypeName #-}++pattern PgTableName :: Text -> PgTypeName table+pattern PgTableName name <- (UnsafePgTableName name)++pattern PgCompName :: Text -> PgTypeName table+pattern PgCompName name <- (UnsafePgCompName name)++{-# complete PgTableName, PgCompName #-}++pattern PgOnlyTableName :: Text -> PgTypeName 'True+pattern PgOnlyTableName name <- (UnsafePgTableName name)++{-# complete PgOnlyTableName #-}++pattern PgOnlyCompName :: Text -> PgTypeName 'False+pattern PgOnlyCompName name <- (UnsafePgCompName name)++{-# complete PgOnlyCompName #-}++instance Eq (PgTypeName table) where+  UnsafePgTableName l == UnsafePgTableName r = l == r+  UnsafePgCompName l == UnsafePgCompName r = l == r++instance Show (PgTypeName table) where+  showsPrec d =+    showParen (d > 10) . \case+      UnsafePgTableName n -> [exon|UnsafePgTableName #{showsPrec 11 n}|]+      UnsafePgCompName n -> [exon|UnsafePgCompName #{showsPrec 11 n}|]++instance Pretty (PgTypeName table) where+  pretty (UnsafePgCompName n) = pretty n+  pretty (UnsafePgTableName n) = pretty n++instance ToSql (PgTypeName table) where+  toSql (PgTypeName n) =+    sqlQuote n++instance ToSql (From PgTableName) where+  toSql (From n) =+    [sql|from ##{n}|]++instance ToSql (Into PgTableName) where+  toSql (Into n) =+    [sql|into ##{n}|]++instance FromJSON PgTableName where+  parseJSON v = UnsafePgTableName <$> parseJSON v++instance FromJSON PgCompName where+  parseJSON v = UnsafePgCompName <$> parseJSON v++instance ToJSON (PgTypeName t) where+  toJSON = toJSON . getPgTypeName++pgTableName ::+  Text ->+  PgTypeName 'True+pgTableName =+  UnsafePgTableName . dbIdentifierT++pgCompName ::+  Text ->+  PgTypeName 'False+pgCompName name =+  UnsafePgCompName (dbIdentifierT name)++instance IsString PgTableName where+  fromString =+    pgTableName . fromString++instance IsString PgCompName where+  fromString =+    pgCompName . fromString++instance Ord (PgTypeName table) where+  compare = comparing getPgTypeName++type MkPgTypeName :: SelPrefix -> Symbol -> Bool -> Symbol -> Constraint+class KnownSymbol tname => MkPgTypeName prefix name table tname | prefix name table -> tname where+  pgTypeName :: PgTypeName table++instance (+    KnownSymbol name+  ) => MkPgTypeName 'DefaultPrefix name 'True name where+    pgTypeName = pgTableName (symbolText @name)++instance (+    TypeName prefix name tname+  ) => MkPgTypeName prefix name 'False tname where+    pgTypeName = pgCompName (symbolText @tname)
+ lib/Sqel/Data/Projection.hs view
@@ -0,0 +1,31 @@+module Sqel.Data.Projection where++import Exon (exon)+import Hasql.Decoders (Row)+import Hasql.Encoders (Params)++import qualified Sqel.Data.PgType as PgType+import Sqel.Data.PgType (PgTable (PgTable))+import Sqel.Data.ProjectionWitness (ProjectionWitness)+import Sqel.Data.Sql (ToSql (toSql), sql)+import Sqel.Data.SqlFragment (From (From), Select (Select))+import qualified Sqel.Data.TableSchema as TableSchema+import Sqel.Data.TableSchema (TableSchema (TableSchema))++data Projection proj table =+  Projection {+    pg :: PgTable proj,+    decoder :: Row proj,+    encoder :: Params proj,+    table :: TableSchema table,+    witness :: ProjectionWitness proj table+  }+  deriving stock (Generic)++instance Show (Projection proj table) where+  showsPrec d Projection {pg} =+    showParen (d > 10) [exon|Projection #{showsPrec 11 pg}|]++instance ToSql (Select (Projection proj table)) where+  toSql (Select Projection {pg = PgTable {selectors}, table = TableSchema {pg = PgTable {name}}}) =+    [sql|##{Select selectors} ##{From name}|]
+ lib/Sqel/Data/ProjectionWitness.hs view
@@ -0,0 +1,4 @@+module Sqel.Data.ProjectionWitness where++data ProjectionWitness proj table =+  ProjectionWitness
+ lib/Sqel/Data/QuerySchema.hs view
@@ -0,0 +1,21 @@+module Sqel.Data.QuerySchema where++import Sqel.Data.Codec (Encoder)+import Sqel.Data.SelectExpr (SelectFragment)+import Sqel.Data.Sql (ToSql (toSql))+import Sqel.Data.SqlFragment (SelectQuery (SelectQuery))++data QuerySchema q a =+  QuerySchema {+    frags :: [SelectFragment],+    encoder :: Encoder q+  }+  deriving stock (Generic)++emptyQuerySchema :: QuerySchema () a+emptyQuerySchema =+  QuerySchema mempty mempty++instance ToSql (SelectQuery (QuerySchema q a)) where+  toSql (SelectQuery (QuerySchema frags _)) =+    toSql frags
+ lib/Sqel/Data/Sel.hs view
@@ -0,0 +1,133 @@+module Sqel.Data.Sel where++import Exon (exon)++import Sqel.SOP.Constraint (symbolText, symbolString)++data SelPrefix =+  DefaultPrefix+  |+  NoPrefix+  |+  SelPrefix Symbol++type family IndexPrefixed (spec :: SelPrefix) (name :: Symbol) :: Symbol where+  IndexPrefixed 'DefaultPrefix name = AppendSymbol "sqel_sum_index__" name+  IndexPrefixed 'NoPrefix name = name+  IndexPrefixed ('SelPrefix spec) name = AppendSymbol spec name++type IndexName :: SelPrefix -> Symbol -> Symbol -> Constraint+class KnownSymbol name => IndexName prefix tpe name | prefix tpe -> name where++instance (+    name ~ IndexPrefixed prefixSpec tpe,+    KnownSymbol name+  ) => IndexName prefixSpec tpe name where++type family TypePrefixed (spec :: SelPrefix) (name :: Symbol) :: Symbol where+  TypePrefixed 'DefaultPrefix name = AppendSymbol "sqel_type__" name+  TypePrefixed 'NoPrefix name = name+  TypePrefixed ('SelPrefix spec) name = AppendSymbol spec name++type TypeName :: SelPrefix -> Symbol -> Symbol -> Constraint+class (+    KnownSymbol name,+    KnownSymbol tpe+  ) => TypeName prefix tpe name | prefix tpe -> name where++instance (+    name ~ TypePrefixed prefixSpec tpe,+    KnownSymbol name,+    KnownSymbol tpe+  ) => TypeName prefixSpec tpe name where++data Sel =+  SelSymbol Symbol+  |+  SelPath [Symbol]+  |+  SelAuto+  |+  SelUnused+  |+  SelIndex SelPrefix Symbol++type SelW :: Sel -> Type+data SelW sel where+  SelWSymbol :: KnownSymbol name => Proxy name -> SelW ('SelSymbol name)+  SelWPath :: SelW ('SelPath path)+  SelWAuto :: SelW 'SelAuto+  SelWUnused :: SelW 'SelUnused+  SelWIndex :: IndexName prefix tpe name => Proxy name -> SelW ('SelIndex prefix tpe)++type MkSel :: Sel -> Constraint+class MkSel sel where+  mkSel :: SelW sel++instance (+    KnownSymbol sel+  ) => MkSel ('SelSymbol sel) where+  mkSel = SelWSymbol Proxy++instance MkSel 'SelAuto where+  mkSel = SelWAuto++instance MkSel 'SelUnused where+  mkSel = SelWUnused++instance MkSel ('SelPath p) where+  mkSel = SelWPath++-- TODO path: store witness+showSelW :: SelW s -> Text+showSelW = \case+  SelWAuto -> "<auto>"+  SelWPath -> "<path>"+  SelWUnused -> "<unused>"+  SelWSymbol (Proxy :: Proxy sel) -> symbolText @sel+  SelWIndex (Proxy :: Proxy sel) -> [exon|<index for #{symbolText @sel}>|]++type ReifySel :: Sel -> Symbol -> Constraint+class KnownSymbol name => ReifySel sel name | sel -> name where+  reifySel :: SelW sel -> Text++instance KnownSymbol name => ReifySel ('SelSymbol name) name where+  reifySel (SelWSymbol Proxy) = symbolText @name++instance (+    IndexName prefixSpec sel name+  ) => ReifySel ('SelIndex prefixSpec sel) name where+  reifySel (SelWIndex Proxy) = symbolText @name++data TSel =+  TSel SelPrefix Symbol++type TSelW :: TSel -> Type+data TSelW sel where+  TSelW :: TypeName prefix tpe name => Proxy '(tpe, name) -> TSelW ('TSel prefix tpe)++showTSelW :: TSelW s -> Text+showTSelW (TSelW (Proxy :: Proxy '(tpe, name))) =+  [exon|<type name for #{symbolText @name}>|]++instance Show (TSelW s) where+  showsPrec d (TSelW (Proxy :: Proxy '(tpe, name))) =+    showParen (d > 10) [exon|TSelW #{showString (symbolString @name)}|]++type ReifyTSel :: TSel -> Symbol -> Constraint+class KnownSymbol name => ReifyTSel sel name | sel -> name where+  reifyTSel :: TSelW sel -> Text++instance (+    TypeName prefixSpec sel name+  ) => ReifyTSel ('TSel prefixSpec sel) name where+  reifyTSel (TSelW Proxy) = symbolText @name++type MkTSel :: TSel -> Constraint+class MkTSel sel where+  mkTSel :: TSelW sel++instance (+    TypeName prefix tpe name+  ) => MkTSel ('TSel prefix tpe) where+  mkTSel = TSelW Proxy
+ lib/Sqel/Data/SelectExpr.hs view
@@ -0,0 +1,40 @@+module Sqel.Data.SelectExpr where++import qualified Exon++import Sqel.Data.Dd (QOp)+import Sqel.Data.FragType (FragType, renderWithFragKeyword)+import Sqel.Data.Selector (Selector)+import Sqel.Data.Sql (Sql, ToSql (toSql))++data SelectAtom =+  SelectAtom {+    type_ :: FragType,+    code :: Selector -> Int -> Sql+  }+  deriving stock (Generic)++data SelectFragment =+  SelectFragment {+     type_ :: FragType,+     content :: Sql+  }+  deriving stock (Show, Eq, Generic, Ord)++renderSelectFragment :: SelectFragment -> Sql+renderSelectFragment SelectFragment {..} =+  renderWithFragKeyword content type_++instance ToSql [SelectFragment] where+  toSql = Exon.intercalate " " . fmap renderSelectFragment . sort++data SelectExpr =+  SelectExprAtom FragType (Int -> Sql)+  |+  SelectExprList QOp [SelectExpr]+  |+  SelectExprSum [SelectExpr]+  |+  SelectExprNot SelectExpr+  |+  SelectExprIgnore
+ lib/Sqel/Data/Selector.hs view
@@ -0,0 +1,24 @@+module Sqel.Data.Selector where++import Sqel.Data.Sql (Sql (Sql), ToSql (toSql), sql)+import Sqel.Text.Quote (dquote)++newtype Selector =+  Selector { unSelector :: Sql }+  deriving stock (Eq, Show, Generic, Ord)+  deriving newtype (IsString, Semigroup, Monoid)++textSelector :: Text -> Selector+textSelector =+  Selector . Sql++nameSelector :: Text -> Selector+nameSelector =+  textSelector . dquote++assign :: Selector -> Sql -> Sql+assign (Selector name) value =+  [sql|#{name} = #{value}|]++instance ToSql Selector where+  toSql = unSelector
+ lib/Sqel/Data/Sql.hs view
@@ -0,0 +1,63 @@+module Sqel.Data.Sql where++import Data.Aeson (FromJSON, ToJSON)+import Data.Generics.Labels ()+import qualified Data.Text as Text+import qualified Data.Text.Lazy.Builder as Text+import Exon (+  ExonAppend (exonAppend, exonConcat),+  ExonExpression (exonExpression),+  Result (Empty, Result),+  SkipWs (SkipWs),+  ToSegment (toSegment),+  exonWith,+  skipWs,+  )+import Language.Haskell.TH.Quote (QuasiQuoter)+import Prettyprinter (Pretty (pretty))+import Sqel.Text.Quote (dquote)++newtype Sql = Sql { unSql :: Text }+  deriving stock (Eq, Show, Generic, Ord)+  deriving newtype (IsString, Semigroup, Monoid, ToJSON, FromJSON)++instance ConvertUtf8 Text bs => ConvertUtf8 Sql bs where+  encodeUtf8 = encodeUtf8 . unSql++  decodeUtf8 = Sql . decodeUtf8++  decodeUtf8Strict = fmap Sql . decodeUtf8Strict++instance Pretty Sql where+  pretty (Sql s) = pretty s++sql :: QuasiQuoter+sql = exonWith (Just ([e|SkipWs|], [e|skipWs|])) True False++class ToSql a where+  toSql :: a -> Sql++instance ToSql Sql where+  toSql = id++instance {-# incoherent #-} ToSql a => ToSegment a Sql where+  toSegment = toSql++instance ExonExpression (SkipWs Sql) Text builder where+  exonExpression builder expr+    | Text.null expr = Empty+    | otherwise = Result (builder expr)++instance ExonAppend (SkipWs Sql) Text.Builder where+  exonConcat (h :| t) =+    go h t+    where+      go Empty (seg : segs) = go seg segs+      go z (Empty : Empty : segs) = go z (Empty : segs)+      go z [Empty] = z+      go z (Empty : segs) = go z (Result " " : segs)+      go (Result z) (Result seg : segs) = go (exonAppend @Sql z seg) segs+      go z [] = z++sqlQuote :: Text -> Sql+sqlQuote = Sql . dquote
+ lib/Sqel/Data/SqlFragment.hs view
@@ -0,0 +1,49 @@+module Sqel.Data.SqlFragment where++import qualified Exon++import Sqel.Data.Sql (ToSql (toSql))++newtype CommaSep a =+  CommaSep { unCommaSep :: a }+  deriving stock (Eq, Show, Generic)++instance ToSql a => ToSql (CommaSep [a]) where+  toSql (CommaSep a) =+    Exon.intercalate ", " (toSql <$> a)++newtype Delete a =+  Delete { unDelete :: a }+  deriving stock (Eq, Show, Generic)++newtype From a =+  From { unFrom :: a }+  deriving stock (Eq, Show, Generic)++newtype Insert a =+  Insert { unInsert :: a }+  deriving stock (Eq, Show, Generic)++newtype Into a =+  Into { unInto :: a }+  deriving stock (Eq, Show, Generic)++newtype Returning a =+  Returning { unReturning :: a }+  deriving stock (Eq, Show, Generic)++newtype Select a =+  Select { unSelect :: a }+  deriving stock (Eq, Show, Generic)++newtype SelectQuery a =+  SelectQuery { unSelectQuery :: a }+  deriving stock (Eq, Show, Generic)++newtype Update a =+  Update { unUpdate :: a }+  deriving stock (Eq, Show, Generic)++newtype Create a =+  Create { unSelect :: a }+  deriving stock (Eq, Show, Generic)
+ lib/Sqel/Data/TableSchema.hs view
@@ -0,0 +1,30 @@+module Sqel.Data.TableSchema where++import Exon (exon)+import Hasql.Decoders (Row)+import Hasql.Encoders (Params)+import Lens.Micro ((^.))++import Sqel.Data.PgType (PgTable)+import Sqel.Data.Sql (ToSql (toSql))+import Sqel.Data.SqlFragment (Create (Create), Select (Select))++data TableSchema a =+  TableSchema {+    pg :: PgTable a,+    decoder :: Row a,+    encoder :: Params a+  }+  deriving stock (Generic)++instance Show (TableSchema a) where+  showsPrec d TableSchema {pg} =+    showParen (d > 10) [exon|TableSchema #{showsPrec 11 pg}|]++instance ToSql (Select (TableSchema a)) where+  toSql (Select ts) =+    toSql (Select (ts ^. #pg))++instance ToSql (Create (TableSchema a)) where+  toSql (Create ts) =+    toSql (Create (ts ^. #pg))
+ lib/Sqel/Data/Term.hs view
@@ -0,0 +1,52 @@+module Sqel.Data.Term where++import Sqel.Data.Dd (DdInc (DdMerge, DdNest), DdSort (DdCon, DdProd, DdSum))+import Sqel.Data.PgType (PgColumnName, PgPrimName)+import Sqel.Data.PgTypeName (PgTableName)+import Sqel.Data.Sql (Sql)++data ProdType =+  Reg+  |+  Con+  deriving stock (Eq, Show, Generic)++data Comp =+  Prod ProdType+  |+  Sum+  deriving stock (Eq, Show, Generic)++data CompInc =+  Merge+  |+  Nest+  deriving stock (Eq, Show, Generic)++data Struct =+  Prim PgPrimName+  |+  Comp Text Comp CompInc [DdTerm]+  deriving stock (Eq, Show, Generic)++-- TODO would be nice to have a separate type wrapping the root for the table name+data DdTerm =+  DdTerm {+    name :: PgColumnName,+    tableName :: Maybe PgTableName,+    unique :: Bool,+    constraints :: [Sql],+    struct :: Struct+  }+  deriving stock (Eq, Show, Generic)++demoteComp :: DdSort c -> Comp+demoteComp = \case+  DdProd -> Prod Reg+  DdCon -> Prod Con+  DdSum -> Sum++demoteInc :: DdInc i -> CompInc+demoteInc = \case+  DdMerge -> Merge+  DdNest -> Nest
+ lib/Sqel/Data/Uid.hs view
@@ -0,0 +1,38 @@+module Sqel.Data.Uid where++import qualified Data.Aeson as Aeson+import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, object, withObject, (.:), (.=))+import qualified Data.UUID as UUID+import Data.UUID (UUID)++data Uid i a =+  Uid {+    id :: i,+    payload :: a+  }+  deriving stock (Eq, Show, Generic, Functor)++instance (FromJSON a, FromJSON i) => FromJSON (Uid i a) where+  parseJSON v =+    withObject "Uid" parseFlat v <|> genericParseJSON Aeson.defaultOptions v+    where+      parseFlat o =+        Uid <$> o .: "id" <*> parseJSON v++instance (ToJSON a, ToJSON i) => ToJSON (Uid i a) where+  toJSON (Uid id' a) =+    object ["id" .= toJSON id', "payload" .= a]++type Uuid =+  Uid UUID++intUUID :: Int -> UUID+intUUID int =+  UUID.fromWords i' i' i' i'+  where+    i' =+      fromIntegral int++intUuid :: Int -> a -> Uuid a+intUuid i' =+  Uid (intUUID i')
+ lib/Sqel/Ext.hs view
@@ -0,0 +1,56 @@+module Sqel.Ext (+  module Sqel.Data.Dd,+  module Sqel.Names,+  module Sqel.Product,+  module Sqel.Sum,+  module Sqel.Uid,+  module Sqel.Comp,+  module Sqel.Data.Sel,+  module Sqel.Data.Mods,+  module Sqel.Class.Mods,+  module Sqel.Data.SelectExpr,+  module Sqel.Data.FragType,+  module Sqel.Data.Migration,+  module Sqel.Codec,+  module Sqel.ReifyCodec,+  module Sqel.ReifyDd,+) where++import Sqel.Class.Mods (+  AddMod (addMod),+  CMapMod (cmapMod),+  MapMod (mapMod),+  MaybeMod (maybeMod),+  OptMod (optMod),+  OverMod (overMod),+  amendMod,+  setMod,+  )+import Sqel.Codec (PrimColumn (..))+import Sqel.Comp (Column, CompName (compName))+import Sqel.Data.Dd+import Sqel.Data.FragType (FragType (..))+import Sqel.Data.Migration+import Sqel.Data.Mods (+  ArrayColumn (..),+  EnumColumn (..),+  Ignore (..),+  Mods,+  Newtype (Newtype),+  pattern NoMods,+  NoMods,+  Nullable (..),+  PgDefault (..),+  PrimaryKey (..),+  ReadShowColumn (..),+  SetTableName (..),+  Unique (..),+  )+import Sqel.Data.Sel (IndexName, MkSel (..), MkTSel (..), ReifySel (..), ReifyTSel (..), SelPrefix (..), TypeName)+import Sqel.Data.SelectExpr (SelectAtom (SelectAtom))+import Sqel.Names+import Sqel.Product+import Sqel.ReifyCodec (ReifyCodec)+import Sqel.ReifyDd (ReifyDd)+import Sqel.Sum (Con1AsColumn (..), Con1Column (..), ConColumn (..), SetIndexPrefix (..), Sum (..), SumWith (..))+import Sqel.Uid (UidColumn (..))
+ lib/Sqel/Kind.hs view
@@ -0,0 +1,9 @@+-- | Description: Type functions+module Sqel.Kind where++-- | Append two type lists.+type family (++) l r where+  (a : l) ++ r = a : (l ++ r)+  '[] ++ r = r++infixr 5 ++
+ lib/Sqel/Merge.hs view
@@ -0,0 +1,11 @@+module Sqel.Merge where++import Sqel.Data.Dd (Dd (Dd), DdInc (DdMerge), DdStruct (DdComp, DdPrim))+import Sqel.Type (Merge)++merge :: Dd s -> Dd (Merge s)+merge = \case+  Dd sel mods (DdComp tsel c _ sub) ->+    Dd sel mods (DdComp tsel c DdMerge sub)+  Dd sel mods DdPrim ->+    Dd sel mods DdPrim
+ lib/Sqel/Migration/Column.hs view
@@ -0,0 +1,194 @@+module Sqel.Migration.Column where++import Generics.SOP (NP (Nil, (:*)), hd, tl)+import qualified Hasql.Encoders as Encoders+import Sqel.Class.Mods (OptMod (optMod))+import Sqel.Codec (PrimColumn (primEncoder))+import Sqel.Data.Migration (ColumnAction (AddColumn, RemoveColumn, RenameColumn))+import Sqel.Data.MigrationParams (MigrationDefault (MigrationDefault))+import Sqel.Data.PgType (ColumnType, PgColumnName, pgColumnName)+import Sqel.Kind (type (++))+import Sqel.SOP.Constraint (symbolText)++import Sqel.Migration.Data.Ddl (DdlColumn (DdlColumn), DdlColumnK (DdlColumnK))++data OldK =+  OldK {+    name :: Symbol,+    comp :: Maybe Symbol,+    delete :: Bool+  }++data NewK =+  NewK {+    index :: Nat,+    name :: Symbol,+    comp :: Maybe Symbol,+    rename :: Maybe Symbol,+    renameType :: Maybe Symbol+  }++data ModK =+  KeepK+  |+  AddK+  |+  RenameK++data ActionK =+  ActionK {+    mod :: ModK,+    index :: Nat+  }+  |+  RemoveK++type family OldKs (index :: Nat) (cols :: [DdlColumnK]) :: [OldK] where+  OldKs _ '[] = '[]+  OldKs index ('DdlColumnK name comp _ _ _ delete _ : cols) =+    'OldK name comp delete : OldKs (index + 1) cols++type family NewKs (index :: Nat) (cols :: [DdlColumnK]) :: [NewK] where+  NewKs _ '[] = '[]+  NewKs index ('DdlColumnK name comp _ rename renameType _ _ : cols) =+    'NewK index name comp rename renameType : NewKs (index + 1) cols++-- TODO this reverses the other list every time+type family MkMigrationAction (old :: OldK) (check :: [NewK]) (other :: [NewK]) :: (ActionK, [NewK]) where+  MkMigrationAction ('OldK _ _ 'True) '[] other =+    '( 'RemoveK, other)+  MkMigrationAction ('OldK name comp 'False) ('NewK index name comp 'Nothing 'Nothing : news) other =+    '( 'ActionK 'KeepK index, news ++ other)+  MkMigrationAction ('OldK oldName comp 'False) ('NewK index _ comp ('Just oldName) 'Nothing : news) other =+    '( 'ActionK 'RenameK index, news ++ other)+  MkMigrationAction ('OldK oldName ('Just oldComp) 'False) ('NewK index newName _ rename ('Just oldComp) : news) other =+    MkMigrationAction ('OldK oldName ('Just oldComp) 'False) ('NewK index newName ('Just oldComp) rename 'Nothing : news) other+  MkMigrationAction old (new : news) other =+    MkMigrationAction old news (new : other)+  MkMigrationAction old '[] other =+    TypeError ("MkMigrationAction:" % old % other)++type family NewMigrationActions (cols :: [NewK]) :: [ActionK] where+  NewMigrationActions '[] = '[]+  NewMigrationActions ('NewK index _ _ 'Nothing 'Nothing : news) =+    'ActionK 'AddK index : NewMigrationActions news+  NewMigrationActions cols = TypeError ("NewMigrationActions:" % cols)++type family MigrationActionsCont (cur :: (ActionK, [NewK])) (old :: [OldK]) :: [ActionK] where+  MigrationActionsCont '(cur, new) old = cur : MigrationActions old new++-- TODO removing could be done implicitly, given that only renaming really _necessitates_ explicit marking.+-- The only reason to not do that is to avoid mistakes, but that seems exaggerated since we use unit tests for checking+-- consistency anyway, and integration tests to ensure the tables work+type family MigrationActions (old :: [OldK]) (new :: [NewK]) :: [ActionK] where+  MigrationActions '[] rest =+    NewMigrationActions rest+  MigrationActions (old : olds) new =+    MigrationActionsCont (MkMigrationAction old new '[]) olds++class ColumnAddition (comp :: Maybe Symbol) (def :: Type) where+  columnAddition :: def -> PgColumnName -> ColumnType -> [ColumnAction]++instance ColumnAddition ('Just tname) () where+  columnAddition () n t = [AddColumn n t Nothing]++instance ColumnAddition 'Nothing () where+  columnAddition () n t = [AddColumn n t Nothing]++-- TODO error message when no migration default was specified for new column+-- TODO this encoder should be taken from the builder derivation+instance (+    PrimColumn a+  ) => ColumnAddition 'Nothing (MigrationDefault a) where+  columnAddition (MigrationDefault a) n t =+    [AddColumn n t md]+    where+      md = Just (a, Encoders.param (Encoders.nonNullable (primEncoder @a)))++class ColIndex index cols col | index cols -> col where+  colIndex :: NP f cols -> f col++instance ColIndex 0 (col : cols) col where+  colIndex = hd++instance {-# overlappable #-} (+    ColIndex (n - 1) cols col+  ) => ColIndex n (c : cols) col where+  colIndex = colIndex @(n - 1) . tl++type ReifyModAction :: ModK -> DdlColumnK -> DdlColumnK -> Constraint+class ReifyModAction action old new where+  reifyModAction :: DdlColumn old -> DdlColumn new -> [ColumnAction]++instance ReifyModAction 'KeepK old new where+  reifyModAction _ _ = []++instance ReifyModAction 'RenameK ('DdlColumnK name compOld modsOld renameOld renameTOld deleteOld typeOld) ('DdlColumnK nameNew compNew modsNew ('Just name) renameTNew delNew typeNew) where+  reifyModAction (DdlColumn Proxy _ _) (DdlColumn Proxy _ _) =+    [RenameColumn (pgColumnName (symbolText @name)) (pgColumnName (symbolText @nameNew))]++type ReifyOldAction :: ActionK -> DdlColumnK -> [DdlColumnK] -> Constraint+class ReifyOldAction action old new where+  reifyOldAction :: DdlColumn old -> NP DdlColumn new -> [ColumnAction]++instance (+    ColIndex index news new,+    ReifyModAction mod old new+  ) => ReifyOldAction ('ActionK mod index) old news where+  reifyOldAction old news =+    reifyModAction @mod old new+    where+      new = colIndex @index news++instance ReifyOldAction 'RemoveK old new where+  reifyOldAction (DdlColumn (Proxy :: Proxy name) t _) _ =+    [RemoveColumn (pgColumnName (symbolText @name)) t]++-- -- TODO this has to check that new columns in composite types are+-- -- a) at the end of the list+-- -- b) Maybe+type ReifyNewAction :: ActionK -> [DdlColumnK] -> Constraint+class ReifyNewAction action new where+  reifyNewAction :: NP DdlColumn new -> [ColumnAction]++instance (+    ColIndex index news ('DdlColumnK name comp mods rename renameT delete tpe),+    OptMod (MigrationDefault tpe) mods def,+    ColumnAddition comp def+  ) => ReifyNewAction ('ActionK 'AddK index) news where+  reifyNewAction news =+    case colIndex @index news of+      DdlColumn (Proxy :: Proxy name) t mods ->+        columnAddition @comp @def (optMod @(MigrationDefault tpe) mods) (pgColumnName (symbolText @name)) t++type ReifyActions :: [ActionK] -> [DdlColumnK] -> [DdlColumnK] -> Constraint+class ReifyActions actions old new where+  reifyActions :: NP DdlColumn old -> NP DdlColumn new -> [ColumnAction]++instance ReifyActions '[] '[] new where+  reifyActions _ _ =+    mempty++instance (+    ReifyNewAction action new,+    ReifyActions actions '[] new+  ) => ReifyActions (action : actions) '[] new where+    reifyActions Nil new =+      reifyNewAction @action new <> reifyActions @actions Nil new++instance (+    ReifyOldAction action o new,+    ReifyActions actions old new+  ) => ReifyActions (action : actions) (o : old) new where+    reifyActions (o :* old) new =+      reifyOldAction @action o new <> reifyActions @actions old new++type ColumnsChanges :: [DdlColumnK] -> [DdlColumnK] -> Constraint+class ColumnsChanges old new where+  columnsChanges :: NP DdlColumn old -> NP DdlColumn new -> [ColumnAction]++instance (+    actions ~ MigrationActions (OldKs 0 old) (NewKs 0 new),+    ReifyActions actions old new+  ) => ColumnsChanges old new where+      columnsChanges = reifyActions @actions
+ lib/Sqel/Migration/Consistency.hs view
@@ -0,0 +1,244 @@+module Sqel.Migration.Consistency where++import qualified Control.Exception as Base+import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT, throwE, withExceptT)+import qualified Data.Aeson as Aeson+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LByteString+import Data.List.Extra (zipWithLongest)+import qualified Data.Map.Strict as Map+import Exon (exon)+import Generics.SOP (NP (Nil, (:*)))+import Lens.Micro ((.~), (^.))+import Path (Abs, Dir, File, Path, parseRelFile, toFilePath, (</>))+import Path.IO (createDirIfMissing, doesFileExist)+import qualified Sqel.Data.Migration as Migration+import Sqel.Data.Migration (Migration (Migration), Migrations (Migrations))+import qualified Sqel.Data.PgType as PgType+import Sqel.Data.PgType (+  ColumnType (ColumnComp, ColumnPrim),+  PgColumn (PgColumn),+  PgColumns (PgColumns),+  PgComposite (PgComposite),+  PgPrimName (PgPrimName),+  PgTable (PgTable),+  PgTypeRef (PgTypeRef),+  )+import Sqel.Data.PgTypeName (PgTableName, pattern PgTypeName)+import Sqel.Data.Sql (Sql)+import qualified Sqel.Sql.Type as Sql+import Sqel.Text.Quote (squote)+import System.IO.Error (IOError)++import Sqel.Migration.Statement (migrationStatementSql, migrationStatements)++tryIO :: MonadIO m => IO a -> m (Either Text a)+tryIO =+  liftIO . fmap (first show) . Base.try @IOError++data MigrationMetadata =+  MigrationMetadata {+    name :: PgTableName,+    table :: PgColumns,+    types :: [PgComposite],+    statementsTable :: [Sql],+    statementsMigration :: [Sql]+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (ToJSON, FromJSON)++tableStatements :: PgTable a -> [Sql]+tableStatements table =+  Sql.createTable table : (Sql.createProdType <$> types)+  where+    types = snd <$> Map.toAscList (table ^. #types)++tableMetadata :: PgTable a -> MigrationMetadata+tableMetadata table =+  MigrationMetadata {+    name = table ^. #name,+    table = table ^. #columns,+    types,+    statementsTable = tableStatements table,+    statementsMigration = []+  }+  where+    types = snd <$> Map.toAscList (table ^. #types)++migrationMetadata :: Migration mig -> MigrationMetadata+migrationMetadata Migration {tableFrom, actions} =+  tableMetadata tableFrom & #statementsMigration .~+  (migrationStatementSql <$> migrationStatements (tableFrom ^. #name) actions)++currentMetadata :: Migration mig -> MigrationMetadata+currentMetadata Migration {tableTo} =+  tableMetadata tableTo++migrationMetadatas :: NP Migration migs -> [MigrationMetadata]+migrationMetadatas = \case+  Nil -> []+  m :* ms -> migrationMetadata m : migrationMetadatas ms++headMigrationMetadata :: NP Migration migs -> Maybe MigrationMetadata+headMigrationMetadata = \case+  Nil -> Nothing+  mig :* _ -> Just (currentMetadata mig)++migrationsMetadata :: Migrations m migs -> [MigrationMetadata]+migrationsMetadata (Migrations migs) =+  reverse (maybeToList (headMigrationMetadata migs) <> migrationMetadatas migs)++jsonFile :: PgTable a -> String+jsonFile PgTable {name = PgTypeName name} =+  [exon|##{name}.json|]++jsonPath ::+  Monad m =>+  Path Abs Dir ->+  PgTable a ->+  ExceptT Text m (Path Abs File)+jsonPath dir table = do+  name <- ExceptT (pure (first pathError (parseRelFile (jsonFile table))))+  pure (dir </> name)+  where+    pathError _ = [exon|Table name couldn't be converted to a path: #{toText tname}|]+    tname = jsonFile table++writeMigrationMetadata ::+  MonadIO m =>+  Path Abs Dir ->+  Migrations m migs ->+  ExceptT Text m ()+writeMigrationMetadata dir migs@(Migrations (Migration {tableFrom} :* _)) = do+  path <- jsonPath dir tableFrom+  let+    write = LByteString.writeFile (toFilePath path) (Aeson.encode (migrationsMetadata migs))+    writeError e = [exon|Couldn't write migration metadata to '#{show path}': #{e}|]+  ExceptT (first writeError <$> tryIO (createDirIfMissing True dir))+  ExceptT (first writeError <$> tryIO write)+writeMigrationMetadata _ (Migrations Nil) =+  unit++readError :: Path Abs File -> Text -> Text+readError path e =+  [exon|Couldn't read migration metadata from #{show path}: #{e}|]++decodeError :: Path Abs File -> String -> Text+decodeError path e =+  [exon|Migration metadata in '#{show path}' has invalid json format: ##{e}|]++readMigrationMetadata ::+  MonadIO m =>+  Path Abs Dir ->+  Migrations m migs ->+  ExceptT Text m (Maybe [MigrationMetadata])+readMigrationMetadata dir (Migrations (Migration {tableFrom} :* _)) = do+  path <- jsonPath dir tableFrom+  liftIO (fromRight False <$> tryIO (doesFileExist path)) >>= \case+    False ->+      pure Nothing+    True -> do+      j <- ExceptT (first (readError path) <$> tryIO (ByteString.readFile (toFilePath path)))+      ExceptT (pure (first (decodeError path) (Aeson.eitherDecodeStrict' j)))+readMigrationMetadata _ (Migrations Nil) =+  throwE "Cannot test empty migrations"++indent ::+  Functor t =>+  t Text ->+  t Text+indent =+  fmap (" • " <>)++showType :: ColumnType -> Text+showType =+  squote . \case+    ColumnPrim {name = PgPrimName name} -> name+    ColumnComp { pgType = PgTypeRef name } -> name++columnMismatch :: Maybe PgColumn -> Maybe PgColumn -> Text+columnMismatch Nothing (Just (PgColumn name tpe)) =+  [exon|A column '##{name}' with type #{showType tpe} was added.|]+columnMismatch (Just (PgColumn name tpe)) Nothing =+  [exon|The column '##{name}' with type #{showType tpe} was removed.|]+columnMismatch (Just (PgColumn gname gtpe)) (Just (PgColumn cname ctpe))+  | gname == cname =+    [exon|The type of the column '##{gname}' was changed from #{showType gtpe} to #{showType ctpe}.|]+  | otherwise =+    [exon|The column '##{gname}' with type #{showType gtpe} was replaced with the column '##{cname}' with type #{showType ctpe}.|]+columnMismatch Nothing Nothing =+  "Internal error"++compareType :: Text -> PgColumns -> PgColumns -> Maybe (NonEmpty Text)+compareType desc (PgColumns golden) (PgColumns current) =+  mismatches <$> nonEmpty (filter (uncurry (/=)) (zipWithLongest (,) golden current))+  where+    mismatches cols = [exon|#{desc} has mismatched columns:|] :| (indent (uncurry columnMismatch <$> toList cols))++compareComp :: Maybe PgComposite -> Maybe PgComposite -> Maybe (NonEmpty Text)+compareComp Nothing Nothing =+  Nothing+compareComp Nothing (Just (PgComposite (PgTypeName name) _)) =+  Just [[exon|The type '#{name}' was added.|]]+compareComp (Just (PgComposite (PgTypeName name) _)) Nothing =+  Just [[exon|The type '#{name}' was removed.|]]+compareComp (Just (PgComposite (PgTypeName gname) gcols)) (Just (PgComposite (PgTypeName cname) ccols))+  | gname == cname =+    compareType [exon|The composite type '#{gname}'|] gcols ccols+  | otherwise =+    Just [[exon|The type '#{gname}' was replaced with a type named '#{cname}'.|]]++compareStep :: MigrationMetadata -> MigrationMetadata -> Maybe (NonEmpty Text)+compareStep golden current =+  join <$> nonEmpty (catMaybes mismatches)+  where+    mismatches =+      compareType [exon|The migration table '#{name}'|] (golden ^. #table) (current ^. #table) :+      zipWithLongest (compareComp) (golden ^. #types) (current ^. #types)+    PgTypeName name = golden ^. #name++checkStep :: Maybe MigrationMetadata -> Maybe MigrationMetadata -> Maybe (NonEmpty Text)+checkStep Nothing _ =+  Nothing+checkStep (Just golden) Nothing =+  let (PgTypeName name) = golden ^. #name+  in Just (pure [exon|A migration for #{name} was removed.|])+checkStep (Just golden) (Just current) =+  compareStep golden current++checkMigrationConsistency :: [MigrationMetadata] -> [MigrationMetadata] -> Either (NonEmpty Text) ()+checkMigrationConsistency golden current =+  maybeToLeft () (join <$> (nonEmpty (catMaybes (zipWithLongest checkStep golden current))))++single ::+  Functor m =>+  ExceptT Text m a ->+  ExceptT (NonEmpty Text) m a+single =+  withExceptT pure++result ::+  Functor m =>+  ExceptT e m () ->+  m (Maybe e)+result =+  runExceptT >>> fmap \case+    Left e -> Just e+    Right () -> Nothing++migrationConsistency ::+  MonadIO m =>+  Path Abs Dir ->+  Migrations m migs ->+  Bool ->+  m (Maybe (NonEmpty Text))+migrationConsistency dir migs =+  result . \case+    True ->+      single (writeMigrationMetadata dir migs)+    False ->+      single (readMigrationMetadata dir migs) >>= \case+        Just golden ->+          ExceptT (pure (checkMigrationConsistency golden (migrationsMetadata migs)))+        Nothing -> single (writeMigrationMetadata dir migs)
+ lib/Sqel/Migration/Data/Ddl.hs view
@@ -0,0 +1,54 @@+module Sqel.Migration.Data.Ddl where++import Exon (exon)+import Generics.SOP (All, Compose, NP)+import Prelude hiding (Compose)++import Sqel.Data.Mods (Mods)+import Sqel.Data.PgType (ColumnType)+import Sqel.Data.PgTypeName (PgTypeName)+import Sqel.SOP.Constraint (symbolString)++data DdlColumnK =+  DdlColumnK {+    name :: Symbol,+    compName :: Maybe Symbol,+    params :: [Type],+    rename :: Maybe Symbol,+    renameType :: Maybe Symbol,+    delete :: Bool,+    tpe :: Type+  }++type DdlColumn :: DdlColumnK -> Type+data DdlColumn k where+  DdlColumn ::+    KnownSymbol name =>+    Proxy name ->+    ColumnType ->+    Mods p ->+    DdlColumn ('DdlColumnK name comp p rename renameType delete a)++instance (+    Show (Mods p)+  ) => Show (DdlColumn ('DdlColumnK name comp p rename renameType delete a)) where+  showsPrec d (DdlColumn Proxy ctype p) =+    showParen (d > 10) [exon|DdlColumn #{showsPrec 11 (symbolString @name)} #{showsPrec 11 ctype} #{showsPrec 11 p}|]++data DdlTypeK =+  DdlTypeK {+    table :: Bool,+    tname :: Symbol,+    rename :: Maybe Symbol,+    columns :: [DdlColumnK]+  }++type DdlType :: DdlTypeK -> Type+data DdlType s where+  DdlType :: KnownSymbol tname => PgTypeName table -> NP DdlColumn cols -> DdlType ('DdlTypeK table tname rename cols)++instance (+    All (Compose Show DdlColumn) cols+  ) => Show (DdlType ('DdlTypeK pgName tname rename cols)) where+  showsPrec d (DdlType name cols) =+    showParen (d > 10) [exon|DdlType #{showsPrec 11 name} #{showsPrec 11 cols}|]
+ lib/Sqel/Migration/Ddl.hs view
@@ -0,0 +1,95 @@+module Sqel.Migration.Ddl where++import Generics.SOP (NP (Nil, (:*)))+import Sqel.ColumnConstraints (ColumnConstraints, columnConstraints)+import Sqel.Data.Dd (CompInc (Merge, Nest), Dd (Dd), DdK (DdK), DdStruct (DdComp, DdPrim), Struct (Comp, Prim))+import Sqel.Data.MigrationParams (MigrationDeleteK, MigrationRenameK, MigrationRenameTypeK)+import Sqel.Data.Mods (Mods (Mods))+import Sqel.Data.PgType (ColumnType (ColumnComp, ColumnPrim), pgTypeRefSym)+import Sqel.Data.PgTypeName (MkPgTypeName (pgTypeName))+import Sqel.Data.Sel (ReifySel, Sel (SelSymbol), SelW (SelWSymbol), TSel (TSel), TSelW (TSelW), TypeName)+import Sqel.Kind (type (++))+import Sqel.ReifyDd (ReifyPrimName (reifyPrimName))++import Sqel.Migration.Data.Ddl (DdlColumn (DdlColumn), DdlColumnK (DdlColumnK), DdlType (DdlType), DdlTypeK (DdlTypeK))++appendNP :: NP f as -> NP f bs -> NP f (as ++ bs)+appendNP Nil bs =+  bs+appendNP (h :* t) bs =+  h :* appendNP t bs++type DdCols :: [DdK] -> [DdlColumnK] -> [DdlTypeK] -> Constraint+class DdCols s cols types | s -> cols types where+  ddCols :: NP Dd s -> (NP DdlColumn cols, NP DdlType types)++instance DdCols '[] '[] '[] where+  ddCols Nil = (Nil, Nil)++-- TODO the migration params could be extracted in OldColumnsChanges and passed to OldColumnChanges.+instance (+    ReifySel sel name,+    ReifyPrimName a mods,+    ColumnConstraints mods,+    DdCols ss cols types,+    rename ~ MigrationRenameK mods,+    renameType ~ MigrationRenameTypeK mods,+    delete ~ MigrationDeleteK mods+  ) => DdCols ('DdK sel mods a 'Prim : ss) ('DdlColumnK name 'Nothing mods rename renameType delete a : cols) types where+    ddCols (Dd _ m@(Mods mods) DdPrim :* t) =+      (DdlColumn Proxy (ColumnPrim (reifyPrimName @a mods) unique constr) m :* cols, types)+      where+        (unique, constr) = columnConstraints m+        (cols, types) = ddCols t++instance (+    ColumnConstraints mods,+    DdlTypes 'False ('DdK ('SelSymbol name) mods a ('Comp ('TSel tprefix tname) c 'Nest sub)) hTypes,+    DdCols ss cols types,+    allTypes ~ hTypes ++ types,+    rename ~ MigrationRenameK mods,+    renameType ~ MigrationRenameTypeK mods,+    delete ~ MigrationDeleteK mods,+    TypeName tprefix tname pgName+  ) => DdCols ('DdK ('SelSymbol name) mods a ('Comp ('TSel tprefix tname) c 'Nest sub) : ss) ('DdlColumnK name ('Just pgName) mods rename renameType delete a : cols) allTypes where+    ddCols (h@(Dd (SelWSymbol Proxy) mods (DdComp (TSelW Proxy) _ _ _)) :* t) =+      (DdlColumn Proxy (ColumnComp (pgTypeRefSym @pgName) unique constr) mods :* tailCols, appendNP subTypes tailTypes)+      where+        (unique, constr) = columnConstraints mods+        subTypes = ddTypes @'False @_ @hTypes h+        (tailCols, tailTypes) = ddCols t++instance (+    DdCols sub mergeCols subTypes,+    DdCols ss cols types,+    allCols ~ mergeCols ++ cols,+    allTypes ~ subTypes ++ types+  ) => DdCols ('DdK sel mods a ('Comp ('TSel tprefix tname) c 'Merge sub) : ss) allCols allTypes where+    ddCols (Dd _ _ (DdComp _ _ _ sub) :* t) =+      (appendNP subCols tailCols, appendNP subTypes tailTypes)+      where+        (subCols, subTypes) = ddCols sub+        (tailCols, tailTypes) = ddCols t++type DdlTypes :: Bool -> DdK -> [DdlTypeK] -> Constraint+class DdlTypes table s types | table s -> types where+  ddTypes :: Dd s -> NP DdlType types++instance (+    DdCols sub cols types,+    rename ~ MigrationRenameTypeK mods,+    MkPgTypeName tprefix tname table pgName+  ) => DdlTypes table ('DdK sel mods a ('Comp ('TSel tprefix tname) c i sub)) ('DdlTypeK table pgName rename cols : types) where+  ddTypes (Dd _ _ (DdComp (TSelW Proxy) _ _ sub)) =+    DdlType (pgTypeName @tprefix @tname) cols :* types+    where+      (cols, types) = ddCols sub++ddTable ::+  DdlTypes 'True s (table : types) =>+  Dd s ->+  (DdlType table, NP DdlType types)+ddTable dd =+  (table, types)+  where+    table :* types = ddTypes @'True dd
+ lib/Sqel/Migration/Init.hs view
@@ -0,0 +1,63 @@+module Sqel.Migration.Init where++import Exon (exon)+import Lens.Micro ((^.))+import qualified Sqel.Class.MigrationEffect as MigrationEffect+import Sqel.Class.MigrationEffect (MigrationEffect)+import Sqel.Data.PgType (+  PgColumnName (PgColumnName),+  PgComposite (PgComposite),+  PgStructure (PgStructure),+  PgTable,+  StructureType (StructureComp, StructurePrim),+  structureToColumns,+  )+import Sqel.Data.PgTypeName (PgCompName, getPgTypeName)+import qualified Sqel.Sql.Type as Sql+import Sqel.Statement (createTable, plain, typeColumnsSql)++import Sqel.Migration.Metadata (DbCols (DbCols), typeColumns)++initComp ::+  Monad m =>+  MigrationEffect m =>+  PgCompName ->+  PgStructure ->+  m ()+initComp tpe structure = do+  DbCols existing <- typeColumns typeColumnsSql tpe+  when (null existing) createType+  where+    createType = do+      initStructure structure+      MigrationEffect.runStatement_ () (plain (Sql.createProdType (PgComposite tpe (structureToColumns structure))))++initType ::+  Monad m =>+  MigrationEffect m =>+  PgColumnName ->+  StructureType ->+  m ()+initType (PgColumnName _) = \case+  StructurePrim _ _ _ ->+    unit+  StructureComp tpe columns _ _ ->+    initComp tpe columns++initStructure ::+  Monad m =>+  MigrationEffect m =>+  PgStructure ->+  m ()+initStructure (PgStructure cols) =+  traverse_ (uncurry initType) cols++initTable ::+  Monad m =>+  MigrationEffect m =>+  PgTable a ->+  m ()+initTable table = do+  MigrationEffect.log [exon|Initializing table '#{getPgTypeName (table ^. #name)}'|]+  initStructure (table ^. #structure)+  MigrationEffect.runStatement_ () (createTable table)
+ lib/Sqel/Migration/Metadata.hs view
@@ -0,0 +1,98 @@+module Sqel.Migration.Metadata where++import qualified Data.Map.Strict as Map+import Exon (exon)+import Prettyprinter (Pretty, pretty, vsep, (<+>))++import qualified Sqel.Class.MigrationEffect as MigrationEffect+import Sqel.Class.MigrationEffect (MigrationEffect)+import qualified Sqel.Data.PgType as PgType+import Sqel.Data.PgType (+  ColumnType,+  PgColumn (PgColumn),+  PgColumnName (PgColumnName),+  PgPrimName (PgPrimName),+  PgTypeRef (PgTypeRef),+  )+import Sqel.Data.PgTypeName (PgTableName, pattern PgTypeName, PgTypeName)+import Sqel.Data.Sql (Sql)+import qualified Sqel.Statement as Statement+import Sqel.Statement (tableColumnsSql)++newtype DbCols =+  DbCols { unDbCols :: Map PgColumnName (Either PgTypeRef PgPrimName) }+  deriving stock (Eq, Show, Generic)++newtype PrettyColMap =+  PrettyColMap { unPrettyColMap :: DbCols }+  deriving stock (Eq, Show, Generic)++instance Pretty PrettyColMap where+  pretty (PrettyColMap (DbCols cols)) =+    vsep (uncurry col <$> Map.toList cols)+    where+      col name = \case+        Right tpe -> "*" <+> pretty name <+> pretty tpe+        Left ref -> "+" <+> pretty name <+> pretty ref++typeColumns ::+  Monad m =>+  MigrationEffect m =>+  Sql ->+  PgTypeName table ->+  m DbCols+typeColumns code (PgTypeName name) = do+  cols <- traverse mktype =<< MigrationEffect.runStatement name (Statement.dbColumns code)+  pure (DbCols (Map.fromList cols))+  where+    mktype = \case+      (col, "USER-DEFINED", n, _) ->+        pure (PgColumnName col, Left (PgTypeRef n))+      (col, "ARRAY", _, Just n) ->+        pure (PgColumnName col, Right (PgPrimName [exon|#{n}[]|]))+      (col, n, _, Nothing) ->+        pure (PgColumnName col, Right (PgPrimName n))+      (col, n, _, Just e) -> do+        MigrationEffect.error [exon|Error: non-array column with element type: ##{n} | ##{e}|]+        pure (PgColumnName col, Right (PgPrimName n))++tableColumns ::+  Monad m =>+  MigrationEffect m =>+  PgTableName ->+  m DbCols+tableColumns =+  typeColumns tableColumnsSql++columnMap :: [PgColumn] -> Map PgColumnName ColumnType+columnMap =+  Map.fromList . fmap \ PgColumn {name, pgType} -> (name, pgType)++logType ::+  MigrationEffect m =>+  Text ->+  DbCols ->+  DbCols ->+  m ()+logType desc dbCols colsByName =+  MigrationEffect.log [exon|Trying #{desc} with:+#{show (pretty (PrettyColMap colsByName))}+for existing #{desc} with+#{show (pretty (PrettyColMap dbCols))}|]++data TypeStatus =+  Absent+  |+  Mismatch+  |+  Match+  deriving stock (Eq, Show, Generic)++typeStatus ::+  DbCols ->+  DbCols ->+  TypeStatus+typeStatus (DbCols dbCols) (DbCols colByName)+  | Map.null dbCols = Absent+  | dbCols == colByName = Match+  | otherwise = Mismatch
+ lib/Sqel/Migration/Run.hs view
@@ -0,0 +1,266 @@+module Sqel.Migration.Run where++import Control.Monad (foldM)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import Exon (exon)+import Generics.SOP (All, NP (Nil, (:*)))+import Lens.Micro ((^.))+import qualified Sqel.Class.MigrationEffect as MigrationEffect+import Sqel.Class.MigrationEffect (MigrationEffect (runMigrationStatements))+import Sqel.Data.Migration (+  CompAction,+  CustomMigration (customMigration, customTypeKeys),+  MigExt,+  Migration (Migration),+  MigrationActions (AutoActions, CustomActions),+  Migrations (Migrations),+  TypeAction (AddAction),+  )+import Sqel.Data.PgType (+  ColumnType (ColumnComp, ColumnPrim),+  PgColumns (PgColumns),+  PgComposite (PgComposite),+  PgTable (PgTable),+  )+import Sqel.Data.PgTypeName (+  PgCompName,+  pattern PgOnlyTableName,+  PgTableName,+  pattern PgTableName,+  pattern PgTypeName,+  PgTypeName,+  getPgTypeName,+  )+import Sqel.Data.Sql (Sql)+import Sqel.Statement (tableColumnsSql, typeColumnsSql)++import Sqel.Migration.Init (initTable)+import Sqel.Migration.Metadata (+  DbCols (DbCols),+  TypeStatus (Absent, Match, Mismatch),+  columnMap,+  logType,+  typeColumns,+  typeStatus,+  )+import Sqel.Migration.Statement (typeStatements)++typeMatchWith ::+  Monad m =>+  MigrationEffect m =>+  Text ->+  PgTypeName table ->+  PgColumns ->+  Sql ->+  m TypeStatus+typeMatchWith desc name (PgColumns cols) code = do+  dbCols <- typeColumns code name+  logType desc dbCols colsByName+  pure (typeStatus dbCols colsByName)+  where+    colsByName = DbCols $ columnMap cols <&> \case+      ColumnPrim n _ _ -> Right n+      ColumnComp n _ _ -> Left n++typeMatch ::+  Monad m =>+  MigrationEffect m =>+  PgComposite ->+  m TypeStatus+typeMatch (PgComposite name cols) =+  typeMatchWith "type" name cols typeColumnsSql++tableMatch ::+  Monad m =>+  MigrationEffect m =>+  TypeStatus ->+  PgTable a ->+  m TypeStatus+tableMatch Absent _ =+  pure Absent+tableMatch _ (PgTable name cols _ _ _ _) =+  typeMatchWith "table" name cols tableColumnsSql++matches ::+  Monad m =>+  MigrationEffect m =>+  TypeStatus ->+  PgTable from ->+  m (TypeStatus, Set PgCompName)+matches initialStatus table = do+  tbm <- tableMatch initialStatus table+  tym <- foldM folder Set.empty (table ^. #types)+  pure (tbm, tym)+  where+    folder acc t =+      typeMatch t <&> \case+        Match -> Set.insert (t ^. #name) acc+        _ -> acc++runAction ::+  MigrationEffect m =>+  PgTypeName table ->+  TypeAction table ->+  m ()+runAction typeName action =+  runMigrationStatements (typeStatements typeName action)++-- TODO topo sort the types+runTypesMigration ::+  Monad m =>+  MigrationEffect m =>+  Set PgCompName ->+  Map PgCompName CompAction ->+  m ()+runTypesMigration eligible actions =+  for_ (Map.toList (Map.restrictKeys actions eligible)) \ (name, tpe) ->+    runAction name tpe++runMigration ::+  ∀ mig m .+  Monad m =>+  MigrationEffect m =>+  CustomMigration m mig =>+  TypeStatus ->+  PgTableName ->+  Set PgCompName ->+  MigrationActions (MigExt mig) ->+  m ()+runMigration status tableName eligible = \case+  AutoActions tableAction typeActions -> do+    MigrationEffect.log [exon|Starting migration for #{getPgTypeName tableName}|]+    runTypesMigration eligible typeActions+    when (status == Match) (runAction tableName tableAction)+  CustomActions actions ->+    customMigration @m @mig tableName eligible actions++tryRunMigration ::+  ∀ mig m .+  Monad m =>+  MigrationEffect m =>+  CustomMigration m mig =>+  TypeStatus ->+  PgTableName ->+  Set PgCompName ->+  MigrationActions (MigExt mig) ->+  m ()+tryRunMigration Mismatch (PgTableName name) _ _ =+  MigrationEffect.error [exon|No migration fits the current table layout for #{name}|]+tryRunMigration status tableName eligible actions =+  runMigration @mig status tableName eligible actions++autoKeys ::+  Map PgCompName CompAction ->+  Set (PgCompName, Bool)+autoKeys typeActions =+  Set.fromList (Map.elems (Map.mapWithKey keyAndAddition typeActions))+  where+    keyAndAddition k = \case+      AddAction _ -> (k, True)+      _ -> (k, False)++typeKeys ::+  ∀ mig m .+  Applicative m =>+  CustomMigration m mig =>+  MigrationActions (MigExt mig) ->+  m (Set (PgCompName, Bool))+typeKeys = \case+  AutoActions _ typeActions ->+    pure (autoKeys typeActions)+  CustomActions actions ->+    customTypeKeys @m @mig actions++collectDirectMatches :: Set (PgCompName, Bool) -> Set PgCompName -> Set PgCompName+collectDirectMatches actions curMatches =+  Set.fromList (fst <$> filter (uncurry matchAction) (Set.toList actions))+  where+    matchAction name = \case+      True -> not (Set.member name curMatches)+      False -> Set.member name curMatches++matchMessage :: PgTypeName table -> TypeStatus -> Set PgCompName -> Set PgCompName -> Set PgCompName -> Text+matchMessage (PgTypeName tableName) status currentMatches directMatches allMatches =+  [exon|Table #{tableName}: #{show status}+Matching types: #{showNames currentMatches}+Direct action matches: #{showNames directMatches}+All action matches: #{showNames allMatches}+|]+  where+    showNames =+      Text.intercalate ", " .+      fmap (\ (PgTypeName name) -> name) .+      Set.toList++runMigrationSteps ::+  ∀ m migs a .+  Monad m =>+  MigrationEffect m =>+  All (CustomMigration m) migs =>+  TypeStatus ->+  Set PgCompName ->+  PgTable a ->+  NP Migration migs ->+  m (TypeStatus, Set PgCompName)+runMigrationSteps initialStatus _ _ Nil =+  pure (initialStatus, mempty)+runMigrationSteps initialStatus laterMatches table ((Migration currentTable _ actions :: Migration mig) :* t) = do+  -- types that are identical in the database and the current migration's from-table+  (status, currentTypeMatches) <- matches initialStatus currentTable+  actionNamesAndAdditions <- typeKeys @mig @m actions+  let+    actionNames = Set.fromList (fst <$> Set.toList actionNamesAndAdditions)+    mismatchHere = status == Mismatch+    -- actions whose types match the database before any migrations are executed.+    -- these cannot be additions, since they are absent from the database if they are applicable.+    -- check whether additions need special treatment, i.e. execute if absent.+    directMatches = collectDirectMatches actionNamesAndAdditions currentTypeMatches+    -- actions whose types either match this migration's from-table or that of a later migration.+    allMatches = Set.union directMatches laterMatches+  MigrationEffect.log (matchMessage (currentTable ^. #name) status currentTypeMatches directMatches allMatches)+  (newStatus, eligible) <-+    -- if actionNames is a subset of allMatches, all actions can be executed either here or in a later migration.+    -- therefore we don't need to check earlier migrations and just execute the direct matches here and relay the rest+    -- to later migrations.+    -- if the current migration's table doesn't match the existing table, we still have to run earlier migrations,+    -- but those don't have to run any type actions.+    -- if the table is absent, earlier migrations don't have to be run, just like a match.+    if not mismatchHere && Set.isSubsetOf actionNames allMatches+    then pure (status, directMatches)+    else do+      -- if the table matched in an earlier migration, it will match here as well since the earlier migration+      -- executed.+      -- same for types, so add earlier matches to the direct matches.+      (earlierStatus, earlierMatches) <- runMigrationSteps status allMatches table t+      pure (earlierStatus, Set.union earlierMatches directMatches)+  runMigration @mig newStatus (table ^. #name) eligible actions+  pure (newStatus, eligible)++createAbsent ::+  Monad m =>+  MigrationEffect m =>+  PgTable a ->+  TypeStatus ->+  m ()+createAbsent table = \case+  Absent -> initTable table+  _ -> unit++runMigrations ::+  ∀ m migs a .+  Monad m =>+  MigrationEffect m =>+  All (CustomMigration m) migs =>+  PgTable a ->+  Migrations m migs ->+  m ()+runMigrations table (Migrations steps) = do+  MigrationEffect.log [exon|Checking migrations for '#{name}'|]+  initialStatus <- tableMatch Mismatch table+  (status, _) <- runMigrationSteps initialStatus mempty table steps+  MigrationEffect.log [exon|Migrations for '#{name}' concluded with #{show status}|]+  createAbsent table status+  where+    PgOnlyTableName name = table ^. #name
+ lib/Sqel/Migration/Statement.hs view
@@ -0,0 +1,114 @@+module Sqel.Migration.Statement where++import qualified Control.Monad.Trans.Writer.Strict as Mtl+import qualified Data.Map.Strict as Map+import qualified Exon+import Hasql.Encoders (Params)+import qualified Hasql.Session as Session+import Hasql.Session (Session)+import qualified Sqel.Data.Migration as Migration+import Sqel.Data.Migration (+  ColumnAction (AddColumn, RemoveColumn, RenameColumn, RenameColumnType),+  MigrationActions (AutoActions, CustomActions),+  TypeAction (AddAction, ModifyAction, RenameAction),+  )+import Sqel.Data.PgType (+  ColumnType (ColumnComp, ColumnPrim),+  PgColumnName (PgColumnName),+  PgComposite (PgComposite),+  PgPrimName (PgPrimName),+  PgTypeRef (PgTypeRef),+  )+import Sqel.Data.PgTypeName (+  pattern PgCompName,+  PgTableName,+  pattern PgTableName,+  pattern PgTypeName,+  PgTypeName,+  pgTableName,+  )+import Sqel.Data.Sql (Sql (Sql), sql)+import qualified Sqel.Sql.Type as Sql+import Sqel.Statement (unprepared)+import qualified Text.Show as Show++data MigrationStatement where+  MigrationStatement :: p -> Params p -> Sql -> MigrationStatement++instance Show MigrationStatement where+  show (MigrationStatement _ _ s) = show s++migrationStatementSql :: MigrationStatement -> Sql+migrationStatementSql (MigrationStatement _ _ s) =+  s++alterStatement ::+  PgTypeName table ->+  p ->+  Params p ->+  (Sql -> Sql -> Sql) ->+  Mtl.Writer [MigrationStatement] ()+alterStatement typeName p enc f =+  Mtl.tell [MigrationStatement p enc (f [sql|alter #{entity} ##{pgTableName name}|] attr)]+  where+    (entity, attr, name) = case typeName of+      PgTableName n -> ("table", "column", n)+      PgCompName n -> ("type", "attribute", n)++-- TODO maybe the default value can be null and the encoder Maybe, to unify the cases+columnStatements' ::+  PgTypeName table ->+  ColumnAction ->+  Mtl.Writer [MigrationStatement] ()+columnStatements' typeName = \case+  AddColumn (PgColumnName colName) tpe md -> do+    alter_ \ alter attr -> [sql|#{alter} add #{attr} ##{colName} #{colTypeName}|]+    case typeName of+      PgTableName _ -> do+        for_ md \ (defVal, enc) -> do+          alterStatement typeName defVal enc \ _ _ -> [sql|update ##{comp} set ##{colName} = $1|]+        for_ (nonEmpty optFrag) \ opt ->+          alter_ \ alter attr ->+            [sql|#{alter} alter #{attr} ##{colName} set #{Exon.intercalate " " opt}|]+      PgCompName _ -> unit+    where+      (optFrag, colTypeName) = case tpe of+        ColumnPrim (PgPrimName n) _ opt -> (opt, Sql n)+        ColumnComp (PgTypeRef n) _ opt -> (opt, Sql n)+  RemoveColumn (PgColumnName name) _ ->+    alter_ \ alter attr -> [sql|#{alter} drop #{attr} ##{name}|]+  RenameColumn (PgColumnName old) (PgColumnName new) ->+    alter_ \ alter attr -> [sql|#{alter} rename #{attr} ##{old} to ##{new}|]+  RenameColumnType (PgColumnName old) (PgTypeName new) ->+    alter_ \ alter attr -> [sql|#{alter} alter #{attr} ##{old} set data type ##{new}|]+  where+    alter_ = alterStatement typeName () mempty+    PgTypeName comp = typeName++typeActionStatements :: PgTypeName table -> TypeAction table -> Mtl.Writer [MigrationStatement] ()+typeActionStatements typeName = \case+  ModifyAction _ cols ->+    traverse_ (columnStatements' typeName) cols+  RenameAction newName@(PgTypeName new) cols -> do+    alterStatement typeName () mempty \ alter _ -> [sql|#{alter} rename to ##{new}|]+    traverse_ (columnStatements' newName) cols+  AddAction cols ->+    Mtl.tell [MigrationStatement () mempty (Sql.createProdType (PgComposite typeName cols))]++typeStatements :: PgTypeName table -> TypeAction table -> [MigrationStatement]+typeStatements name =+  snd .+  runIdentity .+  Mtl.runWriterT .+  typeActionStatements name++migrationStatements :: PgTableName -> MigrationActions ext -> [MigrationStatement]+migrationStatements tableName = \case+  AutoActions {..} ->+    typeStatements tableName table <> (Map.toList types >>= \ (name, actions) -> typeStatements name actions)+  CustomActions _ ->+    []++migrationSession :: [MigrationStatement] -> Session ()+migrationSession =+  traverse_ \ (MigrationStatement p enc stmt) -> Session.statement p (unprepared @() stmt unit enc)
+ lib/Sqel/Migration/Table.hs view
@@ -0,0 +1,62 @@+module Sqel.Migration.Table where++import qualified Data.Map as Map++import Sqel.Data.Dd (Dd, DdType)+import qualified Sqel.Data.Migration as Migration+import Sqel.Data.Migration (Mig (Mig), Migration (Migration), MigrationActions (AutoActions))+import Sqel.Migration.Ddl (DdlTypes, ddTable)+import Sqel.Migration.Type (TableChange (tableChange), TypeChanges (typeChanges))+import Sqel.PgType (pgTable)+import Sqel.ReifyDd (ReifyDd)++class TableChanges old new where+  tableChanges :: Dd old -> Dd new -> MigrationActions ext++instance (+    DdlTypes 'True old (oldTable : oldTypes),+    DdlTypes 'True new (newTable : newTypes),+    TypeChanges oldTypes newTypes,+    TableChange oldTable newTable+  ) => TableChanges old new where+    tableChanges old new =+      AutoActions {+        table = tableChange oldTable newTable,+        types = Map.fromList (typeChanges oldTypes newTypes)+      }+      where+        (oldTable, oldTypes) = ddTable old+        (newTable, newTypes) = ddTable new++class MigrationTables m old new where+  withMigrationTables ::+    MigrationActions ext ->+    Dd old ->+    Dd new ->+    Migration ('Mig (DdType old) (DdType new) m ext)++instance (+    ReifyDd old,+    ReifyDd new+  ) => MigrationTables m old new where+    withMigrationTables actions old new =+      Migration (pgTable old) (pgTable new) actions++class AutoMigration old new where+  autoMigration :: Dd old -> Dd new -> Migration ('Mig (DdType old) (DdType new) m Void)++instance (+    TableChanges old new,+    ReifyDd old,+    ReifyDd new+  ) => AutoMigration old new where+    autoMigration old new =+      withMigrationTables (tableChanges old new) old new++migrateAuto ::+  AutoMigration old new =>+  Dd old ->+  Dd new ->+  Migration ('Mig (DdType old) (DdType new) m Void)+migrateAuto =+  autoMigration
+ lib/Sqel/Migration/Transform.hs view
@@ -0,0 +1,98 @@+module Sqel.Migration.Transform where++import qualified Data.Map as Map+import Hasql.Statement (Statement)+import Lens.Micro ((^.))+import Sqel (MkTableSchema (tableSchema))+import Sqel.Class.MigrationEffect (MigrationEffect (runStatement, runStatement_))+import Sqel.Data.Dd (Dd, DdType)+import qualified Sqel.Data.Migration as Migration+import Sqel.Data.Migration (+  CompAction,+  CustomMigration (customMigration),+  Mig (Mig),+  Migration,+  MigrationActions (CustomActions),+  )+import Sqel.Data.PgTypeName (PgCompName, pattern PgTypeName)+import Sqel.Data.Sql (sql, toSql)+import Sqel.Data.SqlFragment (Insert (Insert), Select (Select))+import Sqel.Data.TableSchema (TableSchema)+import Sqel.ReifyDd (ReifyDd)+import Sqel.Sql.Type (createTable)+import Sqel.Statement (plain, prepared, unprepared)++import Sqel.Migration.Ddl (DdlTypes, ddTable)+import Sqel.Migration.Run (autoKeys, runTypesMigration)+import Sqel.Migration.Table (MigrationTables (withMigrationTables))+import Sqel.Migration.Type (TypeChanges (typeChanges))++data MigrateTransform m old new =+  MigrateTransform {+    trans :: [old] -> m [new],+    types :: Map PgCompName CompAction,+    schemaOld :: TableSchema old,+    schemaNew :: TableSchema new+  }++class MkMigrateTransform m old new where+  migrateTransform ::+    Dd old ->+    Dd new ->+    ([DdType old] -> m [DdType new]) ->+    Migration ('Mig (DdType old) (DdType new) m (MigrateTransform m (DdType old) (DdType new)))++instance (+    DdlTypes 'True old (oldTable : oldTypes),+    DdlTypes 'True new (newTable : newTypes),+    TypeChanges oldTypes newTypes,+    MkTableSchema old,+    MkTableSchema new,+    ReifyDd old,+    ReifyDd new+  ) => MkMigrateTransform m old new where+    migrateTransform old new f =+      withMigrationTables (CustomActions actions) old new+      where+        actions =+          MigrateTransform {+            trans = f,+            types = Map.fromList (typeChanges oldTypes newTypes),+            ..+          }+        schemaOld = tableSchema old+        schemaNew = tableSchema new+        (_, oldTypes) = ddTable old+        (_, newTypes) = ddTable new++transformAndMigrate ::+  ∀ old new m .+  Monad m =>+  MigrationEffect m =>+  Set PgCompName ->+  MigrateTransform m old new ->+  m ()+transformAndMigrate eligible MigrateTransform {..} = do+  oldRows <- runStatement () fetchOld+  newRows <- trans oldRows+  runTypesMigration eligible types+  runPlain [sql|alter table ##{schemaOld ^. #pg . #name} rename to "##{oldName}-migration-temp"|]+  runPlain (createTable (schemaNew ^. #pg))+  for_ newRows \ row -> runStatement_ row insertNew+  where+    PgTypeName oldName = schemaOld ^. #pg . #name+    runPlain = runStatement_ () . plain+    fetchOld :: Statement () [old]+    fetchOld = unprepared [sql|##{Select schemaOld}|] (schemaOld ^. #decoder) mempty+    insertNew :: Statement new ()+    insertNew = prepared (toSql (Insert (schemaNew ^. #pg))) unit (schemaNew ^. #encoder)++instance (+    Monad m,+    MigrationEffect m+  ) => CustomMigration m ('Mig old new m (MigrateTransform m old new)) where+    customMigration _ =+      transformAndMigrate++    customTypeKeys MigrateTransform {types} =+      pure (autoKeys types)
+ lib/Sqel/Migration/Type.hs view
@@ -0,0 +1,191 @@+module Sqel.Migration.Type where++import Generics.SOP (NP (Nil, (:*)), SListI, Top, hcfoldMap)+import Sqel.Data.Migration (CompAction, TableAction, TypeAction (AddAction, ModifyAction, RenameAction))+import Sqel.Data.PgType (PgColumn (PgColumn), PgColumns (PgColumns), pgColumnName)+import Sqel.Data.PgTypeName (PgCompName)+import Sqel.Kind (type (++))+import Sqel.SOP.Constraint (symbolText)++import Sqel.Migration.Column (ColIndex (colIndex), ColumnsChanges (columnsChanges))+import Sqel.Migration.Data.Ddl (DdlColumn (DdlColumn), DdlColumnK, DdlType (DdlType), DdlTypeK (DdlTypeK))++data OldK =+  OldK {+    table :: Bool,+    name :: Symbol,+    cols :: [DdlColumnK]+  }++data NewK =+  NewK {+    index :: Nat,+    table :: Bool,+    name :: Symbol,+    rename :: Maybe Symbol,+    cols :: [DdlColumnK]+  }++data ModK =+  KeepK+  |+  AddK+  |+  RenameK++data ActionK =+  ActionK {+    mod :: ModK,+    index :: Nat+  }+  |+  UnusedK++type family OldKs (index :: Nat) (types :: [DdlTypeK]) :: [OldK] where+  OldKs _ '[] = '[]+  OldKs index ('DdlTypeK table name _ cols : types) =+    'OldK table name cols : OldKs (index + 1) types++type family NewKs (index :: Nat) (types :: [DdlTypeK]) :: [NewK] where+  NewKs _ '[] = '[]+  NewKs index ('DdlTypeK table name rename cols : types) =+    'NewK index table name rename cols : NewKs (index + 1) types++type family MkMigrationAction (old :: OldK) (check :: [NewK]) (other :: [NewK]) :: (ActionK, [NewK]) where+  MkMigrationAction _ '[] other =+    '( 'UnusedK, other)+  MkMigrationAction ('OldK table name _) ('NewK index table name 'Nothing _ : news) other =+    '( 'ActionK 'KeepK index, news ++ other)+  MkMigrationAction ('OldK table oldName _) ('NewK index table _ ('Just oldName) _ : news) other =+    '( 'ActionK 'RenameK index, news ++ other)+  MkMigrationAction old (new : news) other =+    MkMigrationAction old news (new : other)++type family NewMigrationActions (cols :: [NewK]) :: [ActionK] where+  NewMigrationActions '[] = '[]+  NewMigrationActions ('NewK index 'False _ 'Nothing _ : news) =+    'ActionK 'AddK index : NewMigrationActions news+  NewMigrationActions cols = TypeError ("type NewMigrationActions:" % cols)++type family MigrationActionsCont (cur :: (ActionK, [NewK])) (old :: [OldK]) :: [ActionK] where+  MigrationActionsCont '(cur, new) old = cur : MigrationActions old new++type family MigrationActions (old :: [OldK]) (new :: [NewK]) :: [ActionK] where+  MigrationActions '[] rest =+    NewMigrationActions rest+  MigrationActions (old : olds) new =+    MigrationActionsCont (MkMigrationAction old new '[]) olds++type ReifyKeepAction :: Bool -> DdlTypeK -> DdlTypeK -> Constraint+class ReifyKeepAction table old new where+  reifyKeepAction :: DdlType old -> DdlType new -> TypeAction table++instance (+    ColumnsChanges colsOld colsNew+  ) => ReifyKeepAction table ('DdlTypeK table tname renameOld colsOld) ('DdlTypeK table tname renameNew colsNew) where+    reifyKeepAction (DdlType name colsOld) (DdlType _ colsNew) =+      ModifyAction name (columnsChanges colsOld colsNew)++type family ReifyModResult (table :: Bool) :: Type where+  ReifyModResult 'False =+    [(PgCompName, CompAction)]+  ReifyModResult 'True =+    TypeAction 'True++type ReifyModAction :: Bool -> ModK -> DdlTypeK -> DdlTypeK -> Constraint+class ReifyModAction table action old new where+  reifyModAction :: DdlType old -> DdlType new -> ReifyModResult table++instance (+    ReifyKeepAction 'True old new+  ) => ReifyModAction 'True 'KeepK old new where+    reifyModAction old new =+      reifyKeepAction @'True old new++instance (+    ReifyKeepAction 'False ('DdlTypeK 'False tname renameOld colsOld) new+  ) => ReifyModAction 'False 'KeepK ('DdlTypeK 'False tname renameOld colsOld) new where+    reifyModAction old@(DdlType name _) new =+      [(name, reifyKeepAction @'False old new)]++instance (+    ColumnsChanges colsOld colsNew+  ) => ReifyModAction 'False 'RenameK ('DdlTypeK 'False name renameOld colsOld) ('DdlTypeK 'False nameNew ('Just name) colsNew) where+    reifyModAction (DdlType nameOld colsOld) (DdlType nameNew colsNew) =+      [(nameOld, RenameAction nameNew (columnsChanges colsOld colsNew))]++type ReifyOldAction :: Bool -> ActionK -> DdlTypeK -> [DdlTypeK] -> Constraint+class ReifyOldAction table action old new where+  reifyOldAction :: DdlType old -> NP DdlType new -> ReifyModResult table++instance (+    ColIndex index news new,+    ReifyModAction table mod old new+  ) => ReifyOldAction table ('ActionK mod index) old news where+  reifyOldAction old news =+    reifyModAction @table @mod old (colIndex @index news)++instance ReifyOldAction 'False 'UnusedK ('DdlTypeK 'False name renameOld colsOld) new where+  reifyOldAction _ _ = []++-- -- TODO this has to check that new columns in composite types are+-- -- a) at the end of the list+-- -- b) Maybe+type ReifyNewAction :: ActionK -> [DdlTypeK] -> Constraint+class ReifyNewAction action new where+  reifyNewAction :: NP DdlType new -> (PgCompName, CompAction)++instance (+    SListI cols,+    ColIndex index news ('DdlTypeK 'False name rename cols)+  ) => ReifyNewAction ('ActionK 'AddK index) news where+  reifyNewAction news =+    let+      DdlType name ddlCols = colIndex @index news+      cols = hcfoldMap (Proxy @Top) \ (DdlColumn (Proxy :: Proxy n) t _) ->+        [PgColumn (pgColumnName (symbolText @n)) t]+    in (name, AddAction (PgColumns (cols ddlCols)))++type ReifyActions :: [ActionK] -> [DdlTypeK] -> [DdlTypeK] -> Constraint+class ReifyActions actions old new where+  reifyActions :: NP DdlType old -> NP DdlType new -> [(PgCompName, CompAction)]++instance ReifyActions '[] '[] new where+  reifyActions _ _ =+    mempty++instance (+    ReifyNewAction action new,+    ReifyActions actions '[] new+  ) => ReifyActions (action : actions) '[] new where+    reifyActions Nil new =+      reifyNewAction @action new : reifyActions @actions Nil new++instance (+    ReifyOldAction 'False action o new,+    ReifyActions actions old new+  ) => ReifyActions (action : actions) (o : old) new where+    reifyActions (o :* old) new =+      reifyOldAction @'False @action o new <> reifyActions @actions old new++type TypeChanges :: [DdlTypeK] -> [DdlTypeK] -> Constraint+class TypeChanges old new where+  typeChanges :: NP DdlType old -> NP DdlType new -> [(PgCompName, CompAction)]++instance (+    actions ~ MigrationActions (OldKs 0 old) (NewKs 0 new),+    ReifyActions actions old new+  ) => TypeChanges old new where+    typeChanges = reifyActions @actions++type TableChange :: DdlTypeK -> DdlTypeK -> Constraint+class TableChange old new where+  tableChange :: DdlType old -> DdlType new -> TableAction++instance (+    '[oldk] ~ OldKs 0 '[old],+    '(action, '[]) ~ MkMigrationAction oldk (NewKs 0 '[new]) '[],+    ReifyOldAction 'True action old '[new]+  ) => TableChange old new where+    tableChange old new =+      reifyOldAction @'True @action old (new :* Nil)
+ lib/Sqel/Mods.hs view
@@ -0,0 +1,62 @@+module Sqel.Mods where++import qualified Data.Aeson as Aeson+import Data.Aeson (FromJSON, ToJSON)+import Generics.SOP (I (I), NP (Nil, (:*)))+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders+import Sqel.Data.Codec (Codec (Codec))+import Sqel.Data.Mods (+  EnumColumn (EnumColumn),+  Mods (Mods),+  ReadShowColumn (ReadShowColumn),+  SetTableName (SetTableName),+  )+import Sqel.Data.PgType (PgPrimName)+import Sqel.Data.PgTypeName (PgTableName)+import Text.Show (show)++jsonEncoder ::+  ToJSON a =>+  Encoders.Value a+jsonEncoder =+  toStrict . Aeson.encode >$< Encoders.jsonBytes++jsonDecoder ::+  FromJSON a =>+  Decoders.Value a+jsonDecoder =+  Decoders.jsonBytes (first toText . Aeson.eitherDecodeStrict')++data PrimCodec f a =+  PrimCodec (f a)++instance Show (PrimCodec f a) where+  show _ =+    "PrimCodec"++type PrimValueCodec a =+  PrimCodec (Codec Encoders.Value Decoders.Value) a++type PrimValueEncoder a =+  PrimCodec Encoders.Value a++primJsonMods ::+  ToJSON a =>+  FromJSON a =>+  Mods [PgPrimName, PrimValueCodec a]+primJsonMods =+  Mods (I "json" :* I (PrimCodec (Codec jsonEncoder jsonDecoder)) :* Nil)++-- TODO change to "enum", create the type just like other composites+primEnumMods :: Mods [PgPrimName, EnumColumn]+primEnumMods =+  Mods (I "text" :* I EnumColumn :* Nil)++primReadShowMods :: Mods [PgPrimName, ReadShowColumn]+primReadShowMods =+  Mods (I "text" :* I ReadShowColumn :* Nil)++tableNameMods :: PgTableName -> Mods '[SetTableName]+tableNameMods n =+  Mods (I (SetTableName n) :* Nil)
+ lib/Sqel/Names.hs view
@@ -0,0 +1,43 @@+module Sqel.Names (+  module Sqel.Names,+  module Sqel.Names.Rename,+  module Sqel.Names.Set,+) where++import Sqel.Data.Codec (ColumnName (ColumnName))+import Sqel.Data.Dd (Dd, DdK)+import Sqel.Data.Sel (Sel)+import Sqel.Names.Rename+import Sqel.Names.Set+import Sqel.Text.DbIdentifier (dbSymbol)++ddName ::+  ∀ n .+  KnownSymbol n =>+  ColumnName+ddName =+  ColumnName (dbSymbol @n)++selAs ::+  ∀ (sel :: Sel) (s0 :: DdK) .+  Rename s0 (SetSel s0 sel) =>+  Dd s0 ->+  Dd (SetSel s0 sel)+selAs =+  rename++named ::+  ∀ (name :: Symbol) (s0 :: DdK) .+  Rename s0 (SetName s0 name) =>+  Dd s0 ->+  Dd (SetName s0 name)+named =+  rename++typeAs ::+  ∀ (name :: Symbol) (s0 :: DdK) .+  Rename2 s0 (SetTypeName s0 name) =>+  Dd s0 ->+  Dd (SetTypeName s0 name)+typeAs =+  rename2
+ lib/Sqel/Names/Data.hs view
@@ -0,0 +1,73 @@+module Sqel.Names.Data where++import Generics.SOP.GGP (GCode, GDatatypeInfoOf)+import Generics.SOP.Type.Metadata (+  ConstructorInfo (Constructor, Infix, Record),+  DatatypeInfo (ADT, Newtype),+  FieldInfo (FieldInfo),+  )+import Type.Errors (ErrorMessage (Text))++type NatSymbol :: Nat -> Symbol+type family NatSymbol n where+  NatSymbol 0 = "0"+  NatSymbol 1 = "1"+  NatSymbol 2 = "2"+  NatSymbol 3 = "3"+  NatSymbol 4 = "4"+  NatSymbol 5 = "5"+  NatSymbol 6 = "6"+  NatSymbol 7 = "7"+  NatSymbol 8 = "8"+  NatSymbol 9 = "9"+  NatSymbol 10 = "10"+  NatSymbol 11 = "11"+  NatSymbol 12 = "12"+  NatSymbol 13 = "13"+  NatSymbol 14 = "14"+  NatSymbol 15 = "15"+  NatSymbol 16 = "16"+  NatSymbol 17 = "17"+  NatSymbol 18 = "18"+  NatSymbol 19 = "19"+  NatSymbol _ = TypeError ('Text "Constructors with more than 20 fields not supported")++type ConNsEnum :: Symbol -> Nat -> [Type] -> [Symbol]+type family ConNsEnum con n fs where+  ConNsEnum _ _ '[] = '[]+  ConNsEnum con n (_ : fs) = AppendSymbol con (NatSymbol n) : ConNsEnum con (n + 1) fs++type ConNs :: [FieldInfo] -> [Symbol]+type family ConNs fs where+  ConNs '[] = '[]+  ConNs ('FieldInfo n : fs) = n : ConNs fs++type AdtNs :: [[Type]] -> [ConstructorInfo] -> [(Symbol, Bool, [Symbol])]+type family AdtNs ass cons where+  AdtNs '[] '[] = '[]+  AdtNs (_ : ass) ('Record conName fs : cons) =+    '(conName, 'True, ConNs fs) : AdtNs ass cons+  AdtNs (as : ass) ('Constructor conName : cons) =+    '(conName, 'False, ConNsEnum conName 0 as) : AdtNs ass cons+  AdtNs _ ('Infix conName _ _ : _) =+    TypeError ("Infix constructor not supported: " <> conName)++type Ns :: [[Type]] -> DatatypeInfo -> [(Symbol, Bool, [Symbol])]+type family Ns ass info where+  Ns ass ('ADT _ _ cons _) =+    AdtNs ass cons+  Ns _ ('Newtype _ name _) =+    TypeError ("Newtype used for composite column: " <> name)++type SumConNames :: Type -> [(Symbol, Bool, [Symbol])]+type family SumConNames a where+  SumConNames a = Ns (GCode a) (GDatatypeInfoOf a)++type ProdNames' :: Type -> [(Symbol, Bool, [Symbol])] -> [Symbol]+type family ProdNames' a names :: [Symbol] where+  ProdNames' _ '[ '(_, _, names)] = names+  ProdNames' a '[] = TypeError ("Tried using empty type as a product: " <> a)+  ProdNames' a _ = TypeError ("Tried using sum type as a product: " <> a)++type family ProdNames (a :: Type) :: [Symbol] where+  ProdNames a = ProdNames' a (Ns (GCode a) (GDatatypeInfoOf a))
+ lib/Sqel/Names/Error.hs view
@@ -0,0 +1,14 @@+module Sqel.Names.Error where++import Sqel.SOP.Error (QuotedError)+import Type.Errors (ErrorMessage)++type CountMismatch :: Symbol -> ErrorMessage -> Nat -> Nat -> ErrorMessage+type family CountMismatch desc a spec actual where+  CountMismatch desc a spec actual =+    "The " <> desc <> " " <> QuotedError a <> " has " <> actual <> " fields, but the expression specifies " <>+    spec <> "."++type family NoPrimType (a :: Type) :: k where+  NoPrimType a =+    TypeError ("Can't set type name on primitive column of type " <> a)
+ lib/Sqel/Names/Rename.hs view
@@ -0,0 +1,94 @@+module Sqel.Names.Rename where++import qualified Generics.SOP as SOP+import Generics.SOP (AllZipN, HTrans (htrans), NP)++import Sqel.Data.Dd (CompInc (Merge), Dd (Dd), DdK (DdK), DdStruct (DdComp), Struct (Comp, Prim))+import Sqel.Data.Sel (+  Sel (SelAuto, SelSymbol, SelUnused),+  SelW (SelWAuto, SelWSymbol, SelWUnused),+  TSel (TSel),+  TSelW (TSelW),+  TypeName,+  )++type RenameSel :: Sel -> Sel -> Constraint+class RenameSel s0 s1 where+  renameSel :: SelW s0 -> SelW s1++instance {-# overlappable #-} (+    s0 ~ s1+  ) => RenameSel s0 s1 where+  renameSel = id++instance (+    KnownSymbol name+  ) => RenameSel s0 ('SelSymbol name) where+  renameSel _ = SelWSymbol Proxy++instance RenameSel s0 'SelUnused where+  renameSel _ = SelWUnused++instance RenameSel s0 'SelAuto where+  renameSel _ = SelWAuto++type RenameTSel :: TSel -> TSel -> Constraint+class RenameTSel s0 s1 where+  renameTSel :: TSelW s0 -> TSelW s1++instance {-# overlappable #-} (+    s0 ~ s1+  ) => RenameTSel s0 s1 where+  renameTSel = id++instance (+    TypeName prefix tpe name+  ) => RenameTSel s0 ('TSel prefix tpe) where+  renameTSel _ = TSelW Proxy++type Rename :: DdK -> DdK -> Constraint+class Rename s0 s1 where+  rename :: Dd s0 -> Dd s1++instance (+    RenameSel sel0 sel1+  ) => Rename ('DdK sel0 p t 'Prim) ('DdK sel1 p t 'Prim) where+  rename (Dd sel p s) =+    Dd (renameSel sel) p s++instance {-# overlappable #-} (+    RenameSel sel0 sel1,+    RenameTSel tsel0 tsel1+  ) => Rename ('DdK sel0 p t ('Comp tsel0 c i sub)) ('DdK sel1 p t ('Comp tsel1 c i sub)) where+    rename (Dd sel p (DdComp tsel c i s)) =+      Dd (renameSel sel) p (DdComp (renameTSel tsel) c i s)++instance Rename ('DdK sel p t ('Comp tsel c 'Merge sub)) ('DdK sel p t ('Comp tsel c 'Merge sub)) where+    rename (Dd sel p (DdComp tsel c i s)) =+      Dd sel p (DdComp tsel c i s)++type RenameN :: ((DdK -> Type) -> k -> Type) -> k -> k -> Constraint+class RenameN h s0 s1 where+  renameN :: h Dd s0 -> h Dd s1++instance (+    HTrans h h,+    AllZipN (SOP.Prod h) Rename s0 s1+  ) => RenameN h s0 s1 where+  renameN = htrans (Proxy @Rename) rename++type Rename2 :: DdK -> DdK -> Constraint+class Rename2 s0 s1 where+  rename2 :: Dd s0 -> Dd s1++instance (+    RenameSel sel0 sel1+  ) => Rename2 ('DdK sel0 p t 'Prim) ('DdK sel1 p t 'Prim) where+  rename2 (Dd sel p s) = Dd (renameSel sel) p s++instance (+    RenameSel sel0 sel1,+    RenameTSel tsel0 tsel1,+    RenameN NP s0 s1+  ) => Rename2 ('DdK sel0 p t ('Comp tsel0 c i s0)) ('DdK sel1 p t ('Comp tsel1 c i s1)) where+  rename2 (Dd sel p (DdComp tsel c i sub)) = Dd (renameSel sel) p (DdComp (renameTSel tsel) c i (renameN sub))
+ lib/Sqel/Names/Set.hs view
@@ -0,0 +1,46 @@+module Sqel.Names.Set where++import Fcf (Length, type (@@))+import Sqel.Data.Dd (DdK (DdK), Struct (Comp, Prim))+import Sqel.Data.Sel (Sel (SelIndex, SelSymbol), SelPrefix (DefaultPrefix), TSel (TSel))+import Type.Errors (ErrorMessage)++import Sqel.Names.Error (CountMismatch, NoPrimType)++type SetSel :: DdK -> Sel -> DdK+type family SetSel s sel where+  SetSel ('DdK _ p t s) sel = 'DdK sel p t s++type SetName :: DdK -> Symbol -> DdK+type family SetName s name where+  SetName ('DdK ('SelIndex pre _) p t s) n = 'DdK ('SelIndex pre n) p t s+  SetName s n = SetSel s ('SelSymbol n)++type SetNames :: ErrorMessage -> [DdK] -> [Symbol] -> [DdK]+type family SetNames error s0 names where+  SetNames _ '[] '[] = '[]+  SetNames error (s : ss) (n : names) = SetName s n : SetNames error ss names+  SetNames error _ _ = TypeError error++type SetNamesFor :: Symbol -> ErrorMessage -> [DdK] -> [Symbol] -> [DdK]+type family SetNamesFor desc a ss names where+  SetNamesFor desc a ss names =+    SetNames (CountMismatch desc a (Length @@ ss) (Length @@ names)) ss names++type SetTypeName :: DdK -> Symbol -> DdK+type family SetTypeName s name where+  SetTypeName ('DdK sel p t ('Comp _ c i sub)) n =+    'DdK sel p t ('Comp ('TSel 'DefaultPrefix n) c i sub)+  SetTypeName ('DdK _ _ t 'Prim) _ =+    NoPrimType t+  SetTypeName s _ =+    TypeError ("SetTypeName: " <> s)++type SetTypeSel :: DdK -> TSel -> DdK+type family SetTypeSel s sel where+  SetTypeSel ('DdK sel p t ('Comp _ c i sub)) new =+    'DdK sel p t ('Comp new c i sub)+  SetTypeSel ('DdK _ _ t 'Prim) _ =+    NoPrimType t+  SetTypeSel s sel =+    TypeError ("SetTypeSel:" % sel % s)
+ lib/Sqel/PgType.hs view
@@ -0,0 +1,196 @@+module Sqel.PgType where++import Data.List.NonEmpty ((<|))+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Exon+import Exon (exon)+import Lens.Micro (_1, _2, _3, _4, (^.))+import Lens.Micro.Extras (view)+import Sqel.Class.MatchView (MatchProjection)+import Sqel.Data.Codec (Codec (Codec), FullCodec)+import Sqel.Data.Dd (Dd, DdK, DdType)+import Sqel.Data.PgType (+  ColumnType (ColumnComp, ColumnPrim),+  PgColumn (PgColumn),+  PgColumnName (PgColumnName),+  PgColumns (PgColumns),+  PgComposite (PgComposite),+  PgStructure (PgStructure),+  PgTable (PgTable),+  PgTypeRef,+  StructureType (StructureComp, StructurePrim),+  TableSelectors (TableSelectors),+  TableValues (TableValues),+  pgCompRef,+  )+import Sqel.Data.PgTypeName (PgTableName, pgCompName, pgTableName)+import qualified Sqel.Data.Projection as Projection+import Sqel.Data.Projection (Projection (Projection))+import Sqel.Data.ProjectionWitness (ProjectionWitness (ProjectionWitness))+import Sqel.Data.Selector (Selector (Selector))+import Sqel.Data.Sql (Sql (Sql), sql)+import qualified Sqel.Data.TableSchema as TableSchema+import Sqel.Data.TableSchema (TableSchema (TableSchema))+import Sqel.Data.Term (Comp, CompInc (Merge), DdTerm (DdTerm), Struct (Comp, Prim))+import Sqel.ReifyCodec (ReifyCodec (reifyCodec))+import Sqel.ReifyDd (ReifyDd (reifyDd))+import Sqel.SOP.Error (Quoted)+import Sqel.Sql.Prepared (dollar)+import Sqel.Text.Quote (dquote)+import Type.Errors (ErrorMessage)++pgColumn ::+  DdTerm ->+  ([PgColumn], [(PgColumnName, StructureType)], Map PgTypeRef PgComposite, [NonEmpty PgColumnName])+pgColumn = \case+  DdTerm name _ unique constr (Prim t) ->+    ([PgColumn name (ColumnPrim t unique constr)], [(name, StructurePrim t unique constr)], mempty, [pure name])+  DdTerm name _ unique constr (Comp typeName c i sub) ->+    case comp typeName c i sub of+      (compType@(PgComposite cname _), struct, types, False, sels) ->+        (colType, structType, Map.insert ref compType types, (name <|) <$> sels)+        where+          colType = [PgColumn name (ColumnComp ref unique constr)]+          structType = [(name, StructureComp cname struct unique constr)]+          ref = pgCompRef cname+      (PgComposite _ (PgColumns columns), PgStructure struct, types, True, sels) ->+        (columns, struct, types, sels)++comp ::+  Text ->+  Comp ->+  CompInc ->+  [DdTerm] ->+  (PgComposite, PgStructure, Map PgTypeRef PgComposite, Bool, [NonEmpty PgColumnName])+comp typeName _ i sub =+  (compType, structType, Map.unions (view _3 <$> cols), i == Merge, view _4 =<< cols)+  where+    compType = PgComposite compName (PgColumns (view _1 =<< cols))+    structType = PgStructure (view _2 =<< cols)+    compName = pgCompName typeName+    cols = pgColumn <$> sub++-- TODO this used to dquote the @names@ as well but it appears to fail for the sum index field+mkSelector :: NonEmpty PgColumnName -> Selector+mkSelector =+  Selector . Sql . \case+    [PgColumnName name] -> dquote name+    root :| names -> [exon|(##{dquote root}).##{Text.intercalate "." (coerce names)}|]++-- TODO use CommaSep+mkValues :: PgStructure -> [Sql]+mkValues (PgStructure base) =+  snd (mapAccumL mkCol (1 :: Int) base)+  where+    mkCol (n :: Int) = \case+      (_, StructurePrim _ _ _) -> (n + 1, [sql|##{dollar n}|])+      (_, StructureComp _ (PgStructure cols) _ _) ->+        (newN, [sql|row(#{Exon.intercalate ", " sub})|])+        where+          (newN, sub) =+            mapAccumL mkCol n cols++mkTable ::+  PgColumnName ->+  Maybe PgTableName ->+  PgColumns ->+  Map PgTypeRef PgComposite ->+  [NonEmpty PgColumnName] ->+  PgStructure ->+  PgTable a+mkTable (PgColumnName name) tableName cols types selectors struct =+  PgTable (fromMaybe (pgTableName name) tableName) cols types (TableSelectors (mkSelector <$> selectors)) values struct+  where+    values = TableValues (mkValues struct)++toTable :: DdTerm -> PgTable a+toTable = \case+  DdTerm name tableName unique constr (Prim t) ->+    mkTable name tableName cols [] [pure name] struct+    where+      cols = PgColumns [PgColumn name (ColumnPrim t unique constr)]+      struct = PgStructure [(name, StructurePrim t unique constr)]+  DdTerm name tableName _ _ (Comp typeName c i sub) ->+    mkTable name tableName cols types paths struct+    where+      (PgComposite _ cols, struct, types, _, paths) = comp typeName c i sub++pgTable ::+  ∀ s .+  ReifyDd s =>+  Dd s ->+  PgTable (DdType s)+pgTable dd =+  toTable (reifyDd dd)++type MkTableSchema :: DdK -> Constraint+class MkTableSchema table where+  tableSchema :: Dd table -> TableSchema (DdType table)++instance (+    ReifyDd table,+    ReifyCodec FullCodec table (DdType table)+  ) => MkTableSchema table where+  tableSchema tab =+    TableSchema (pgTable tab) (row ^. #decodeValue) (params ^. #encodeValue)+    where+      Codec params row = reifyCodec @FullCodec tab++class CheckedProjection' (check :: Maybe Void) (s :: DdK) where+  checkedProjection' :: Dd s -> ProjectionWitness (DdType s) table++instance CheckedProjection' 'Nothing s where+  checkedProjection' _ = ProjectionWitness++class CheckedProjection (proj :: DdK) (table :: DdK) where+  checkedProjection :: Dd proj -> ProjectionWitness (DdType proj) (DdType table)++type CheckProjectionStuck :: ErrorMessage+type CheckProjectionStuck =+  "Could not validate projection fields since there is not enough type information available." %+  "You are most likely missing a constraint for " <> Quoted "CheckedProjection" <> "."++instance (+    MatchProjection proj table match,+    CheckedProjection' match proj+  ) => CheckedProjection proj table where+    checkedProjection = checkedProjection' @match++-- TODO check that the table name matches, otherwise a query using the projection will use the wrong name.+-- also possible to automatically set it, but that might be incompatible with the db view interpreter feature, since+-- the name there can't be propagated here. but it would be possible to check only there and do it automatically here.+projectionWitness ::+  ∀ proj table .+  CheckedProjection proj table =>+  Dd proj ->+  Dd table ->+  ProjectionWitness (DdType proj) (DdType table)+projectionWitness proj _ =+  checkedProjection @proj @table proj++projection ::+  MkTableSchema proj =>+  MkTableSchema table =>+  CheckedProjection proj table =>+  Dd proj ->+  Dd table ->+  Projection (DdType proj) (DdType table)+projection ddProj ddTable =+  Projection {..}+  where+    table = tableSchema ddTable+    TableSchema {..} = tableSchema ddProj+    witness = projectionWitness ddProj ddTable++fullProjection ::+  MkTableSchema table =>+  CheckedProjection table table =>+  Dd table ->+  Projection (DdType table) (DdType table)+fullProjection dd =+  projection dd dd++toFullProjection :: TableSchema table -> Projection table table+toFullProjection table@TableSchema {..} =+  Projection {table, witness = ProjectionWitness, ..}
+ lib/Sqel/Prim.hs view
@@ -0,0 +1,224 @@+module Sqel.Prim where++import Data.Aeson (FromJSON, ToJSON)+import Generics.SOP (I (I), NP (Nil, (:*)))+import Sqel.Class.Mods (MapMod, SymNP, setMod, symMods)+import Sqel.Column (nullable)+import Sqel.Data.Dd (ConCol, Dd (Dd), DdK (DdK), DdStruct (DdPrim), DdType, Struct (Prim))+import Sqel.Data.MigrationParams (+  MigrationDefault (MigrationDefault),+  MigrationDelete (MigrationDelete),+  MigrationRename (MigrationRename),+  MigrationRenameType (MigrationRenameType),+  )+import Sqel.Data.Mods (+  ArrayColumn (ArrayColumn),+  EnumColumn,+  Ignore (Ignore),+  Mods (Mods),+  Newtype (Newtype),+  pattern NoMods,+  type NoMods,+  Nullable,+  ReadShowColumn,+  )+import Sqel.Data.PgType (PgPrimName)+import Sqel.Data.Sel (+  IndexName,+  Sel (SelAuto, SelIndex, SelSymbol, SelUnused),+  SelPrefix (DefaultPrefix),+  SelW (SelWAuto, SelWIndex),+  )+import Sqel.Mods (PrimValueCodec, primEnumMods, primJsonMods, primReadShowMods)+import Sqel.Names (named, selAs)+import Sqel.SOP.Constraint (ProductGCode)+import Sqel.SOP.Error (Quoted)+import Sqel.SOP.Newtype (UnwrapNewtype (unwrapNewtype, wrapNewtype))++type IndexColumnWith prefix name =+  'DdK ('SelIndex prefix name) NoMods Int64 'Prim++type IndexColumn name =+  IndexColumnWith 'DefaultPrefix name++column :: Mods p -> Dd ('DdK 'SelAuto p a 'Prim)+column m =+  Dd SelWAuto m DdPrim++mods ::+  SymNP p ps =>+  p ->+  Mods ps+mods =+  symMods++primMod ::+  p ->+  Dd ('DdK 'SelAuto '[p] a 'Prim)+primMod p =+  column (Mods (I p :* Nil))++primMods ::+  SymNP p ps =>+  p ->+  Dd ('DdK 'SelAuto ps a 'Prim)+primMods p =+  column (mods p)++prim ::+  ∀ a .+  Dd ('DdK 'SelAuto NoMods a 'Prim)+prim =+  column NoMods++ignore ::+  ∀ a .+  Dd ('DdK 'SelUnused '[Ignore] a 'Prim)+ignore =+  selAs (primMod Ignore)++type NewtypeError =+  Quoted "primNewtype" <> " declares a column for a newtype using " <> Quoted "Generic" <> "."++primNewtype ::+  ∀ a w err .+  err ~ NewtypeError =>+  UnwrapNewtype err a w =>+  Dd ('DdK 'SelAuto '[Newtype a w] a 'Prim)+primNewtype =+  primMod (Newtype (unwrapNewtype @err) (wrapNewtype @err))++primCoerce ::+  ∀ a w .+  Coercible a w =>+  Dd ('DdK 'SelAuto '[Newtype a w] a 'Prim)+primCoerce =+  primMod (Newtype coerce coerce)++primIndex ::+  ∀ tpe name .+  IndexName 'DefaultPrefix tpe name =>+  Dd (IndexColumn tpe)+primIndex =+  Dd (SelWIndex Proxy) NoMods DdPrim++-- TODO move aeson to reify+json ::+  ∀ a .+  ToJSON a =>+  FromJSON a =>+  Dd ('DdK 'SelAuto [PgPrimName, PrimValueCodec a] a 'Prim)+json =+  column primJsonMods++enum ::+  ∀ a .+  Dd ('DdK 'SelAuto [PgPrimName, EnumColumn] a 'Prim)+enum =+  column primEnumMods++readShow ::+  ∀ a .+  Dd ('DdK 'SelAuto [PgPrimName, ReadShowColumn] a 'Prim)+readShow =+  column primReadShowMods++primNullable ::+  ∀ a .+  Dd ('DdK 'SelAuto '[Nullable] (Maybe a) 'Prim)+primNullable =+  nullable (prim @a)++primAs ::+  ∀ name a .+  KnownSymbol name =>+  Dd ('DdK ('SelSymbol name) '[] a 'Prim)+primAs =+  named @name (prim @a)++-- TODO are composite arrays legal?+array ::+  ∀ f a p sel .+  Dd ('DdK sel p a 'Prim) ->+  Dd ('DdK sel (ArrayColumn f : p) (f a) 'Prim)+array (Dd sel (Mods p) s) =+  Dd sel (Mods (I ArrayColumn :* p)) s++migrateDef ::+  ∀ s0 s1 .+  MapMod (MigrationDefault (DdType s0)) s0 s1 =>+  DdType s0 ->+  Dd s0 ->+  Dd s1+migrateDef a =+  setMod (MigrationDefault a)++migrateRename ::+  ∀ name s0 s1 .+  MapMod (MigrationRename name) s0 s1 =>+  Dd s0 ->+  Dd s1+migrateRename =+  setMod (MigrationRename @name)++migrateRenameType ::+  ∀ name s0 s1 .+  MapMod (MigrationRenameType name) s0 s1 =>+  Dd s0 ->+  Dd s1+migrateRenameType =+  setMod (MigrationRenameType @name)++migrateDelete ::+  ∀ s0 s1 .+  MapMod MigrationDelete s0 s1 =>+  Dd s0 ->+  Dd s1+migrateDelete =+  setMod MigrationDelete++newtype Prims a s =+  Prims { unPrims :: NP Dd s }+  deriving stock (Generic)++class MkPrims as s | as -> s where+  mkPrims :: NP Dd s++instance MkPrims '[] '[] where+  mkPrims = Nil++instance (+    MkPrims as s+  ) => MkPrims (a : as) ('DdK 'SelAuto '[] a 'Prim : s) where+    mkPrims = prim :* mkPrims @as @s++type family PrimProd (a :: Type) :: [Type] where+  PrimProd (ConCol _ _ _ as) = as+  PrimProd a = ProductGCode a++prims ::+  ∀ (a :: Type) (s :: [DdK]) .+  MkPrims (PrimProd a) s =>+  Prims a s+prims =+  Prims (mkPrims @(PrimProd a))++class MkPrimNewtypes as s | as -> s where+  mkPrimNewtypes :: NP Dd s++instance MkPrimNewtypes '[] '[] where+  mkPrimNewtypes = Nil++instance (+    MkPrimNewtypes as s,+    err ~ NewtypeError,+    UnwrapNewtype err a w+  ) => MkPrimNewtypes (a : as) ('DdK 'SelAuto '[Newtype a w] a 'Prim : s) where+    mkPrimNewtypes = primNewtype :* mkPrimNewtypes @as @s++primNewtypes ::+  ∀ (a :: Type) (s :: [DdK]) .+  MkPrimNewtypes (PrimProd a) s =>+  Prims a s+primNewtypes =+  Prims (mkPrimNewtypes @(PrimProd a))
+ lib/Sqel/Product.hs view
@@ -0,0 +1,51 @@+module Sqel.Product where++import Generics.SOP.GGP (GCode, GDatatypeInfoOf)+import Sqel.Comp (CompColumn (compColumn), CompName, MetaFor, ProductFields)+import Sqel.Data.Dd (+  Comp (Prod),+  CompInc (Nest),+  Dd (Dd),+  DdInc (DdNest),+  DdK (DdK),+  DdSort (DdProd),+  DdStruct (DdComp),+  DdType,+  ProdType (Reg),+  Struct (Comp),+  )+import Sqel.Data.Mods (pattern NoMods, NoMods)+import Sqel.Data.Sel (MkTSel (mkTSel), Sel (SelAuto), SelW (SelWAuto))+import Sqel.Names.Rename (Rename (rename))+import Sqel.Names.Set (SetName)++class DdType s ~ a => ProductSel sel a arg s | sel a arg -> s where+  prodSel :: arg -> Dd s++instance (+    MkTSel sel,+    fields ~ ProductFields (GDatatypeInfoOf a) (GCode a),+    meta ~ MetaFor "product type" ('ShowType a) "prod",+    CompColumn meta fields a arg s+  ) => ProductSel sel a arg ('DdK 'SelAuto NoMods a ('Comp sel ('Prod 'Reg) 'Nest s)) where+    prodSel arg =+      Dd SelWAuto NoMods (DdComp mkTSel DdProd DdNest (compColumn @meta @fields @a arg))++class DdType s ~ a => Product a arg s | a arg -> s where+  prod :: arg -> Dd s++instance (+    CompName a sel,+    ProductSel sel a arg s+  ) => Product a arg s where+    prod =+      prodSel @sel @a++prodAs ::+  ∀ (name :: Symbol) (a :: Type) (s :: DdK) (arg :: Type) .+  Product a arg s =>+  Rename s (SetName s name) =>+  arg ->+  Dd (SetName s name)+prodAs =+  rename . prod @_ @_ @s
+ lib/Sqel/Query.hs view
@@ -0,0 +1,118 @@+module Sqel.Query where++import qualified Data.Map.Strict as Map+import Generics.SOP (NP (Nil))+import Sqel.Class.MatchView (MatchQuery)+import Sqel.Data.Codec (Encoder)+import Sqel.Data.Dd (+  Comp (Prod),+  CompInc (Nest),+  Dd (Dd),+  DdInc (DdNest),+  DdK (DdK),+  DdSort (DdProd),+  DdStruct (DdComp),+  DdType,+  ProdType (Reg),+  Struct (Comp, Prim),+  )+import Sqel.Data.FragType (FragType)+import Sqel.Data.Mods (pattern NoMods, NoMods)+import Sqel.Data.QuerySchema (QuerySchema (QuerySchema))+import Sqel.Data.Sel (MkTSel (mkTSel), Sel (SelSymbol), SelPrefix (DefaultPrefix), SelW (SelWSymbol), TSel (TSel))+import Sqel.Data.SelectExpr (+  SelectExpr (SelectExprAtom, SelectExprIgnore, SelectExprList, SelectExprNot, SelectExprSum),+  SelectFragment (SelectFragment),+  )+import Sqel.Data.Sql (Sql)+import Sqel.Prim (primAs)+import Sqel.ReifyCodec (ReifyCodec (reifyCodec))+import Sqel.SOP.Error (Quoted)+import Type.Errors (ErrorMessage)++import Sqel.Query.Fragments (ColumnPrefix (NoPrefix), joinFrag, joinSum)+import Sqel.Query.SelectExpr (ToSelectExpr (toSelectExpr))++class SelectExprUnlessError (check :: Maybe k) (s :: DdK) where+  selectExprUnlessError :: Dd s -> SelectExpr++instance ToSelectExpr s => SelectExprUnlessError 'Nothing s where+  selectExprUnlessError = toSelectExpr NoPrefix++class CheckedQuery (qs :: DdK) (ts :: DdK) where+  checkedQ :: Dd qs -> SelectExpr++-- TODO remove or move to MatchView+type CheckQueryStuck :: ErrorMessage+type CheckQueryStuck =+  "Could not validate query fields since there is not enough type information available." %+  "You are most likely missing a constraint for " <> Quoted "CheckedQuery" <> "."++instance (+    MatchQuery query table match,+    SelectExprUnlessError match query+  ) => CheckedQuery query table where+    checkedQ = selectExprUnlessError @_ @match++compileSelectExpr ::+  SelectExpr ->+  [SelectFragment]+compileSelectExpr expr =+  Map.elems (Map.mapWithKey SelectFragment (snd (spin 1 expr)))+  where+    spin :: Int -> SelectExpr -> (Int, Map FragType Sql)+    spin i = \case+      SelectExprAtom tpe code -> (i + 1, [(tpe, code i)])+      SelectExprList op sub -> second (Map.mapWithKey (joinFrag op)) (prod i sub)+      SelectExprSum sub -> second (Map.mapWithKey (joinSum i)) (prod (i + 1) sub)+      -- TODO+      SelectExprNot _ -> undefined+      SelectExprIgnore -> (i, mempty)+    prod i sub =+      second (Map.unionsWith (<>) . fmap (fmap pure)) (mapAccumL spin i sub)++querySchemaWith ::+  ∀ q query a .+  ReifyCodec Encoder query q =>+  Dd query ->+  SelectExpr ->+  QuerySchema q a+querySchemaWith query expr =+  QuerySchema (compileSelectExpr expr) (reifyCodec @Encoder query)++unsafeQuerySchema ::+  ∀ q query a .+  ToSelectExpr query =>+  ReifyCodec Encoder query q =>+  Dd query ->+  QuerySchema q a+unsafeQuerySchema query =+  querySchemaWith query (toSelectExpr NoPrefix query)++-- TODO CheckFields should be generated by classes with fundeps so that they can be built incrementally and provided+-- separately+-- try this out with QueryPending in bodhi+type CheckQuery :: DdK -> DdK -> Constraint+class CheckQuery query table where+  checkQuery ::+    Dd query ->+    Dd table ->+    QuerySchema (DdType query) (DdType table)++instance (+    CheckedQuery query table,+    ReifyCodec Encoder query (DdType query)+  ) => CheckQuery query table where+  checkQuery query _ =+    querySchemaWith query (checkedQ @query @table query)++type EmptyQuery =+  'DdK ('SelSymbol "") NoMods () ('Comp ('TSel 'DefaultPrefix "") ('Prod 'Reg) 'Nest '[])++emptyQuery :: Dd EmptyQuery+emptyQuery =+  Dd (SelWSymbol Proxy) NoMods (DdComp mkTSel DdProd DdNest Nil)++primIdQuery :: Dd ('DdK ('SelSymbol "id") NoMods a 'Prim)+primIdQuery =+  primAs @"id"
+ lib/Sqel/Query/Combinators.hs view
@@ -0,0 +1,95 @@+module Sqel.Query.Combinators where++import Sqel.Class.Mods (MapMod, setMod)+import Sqel.Data.Dd (Dd (Dd), DdK (DdK), Struct (Prim))+import Sqel.Data.FragType (FragType (Limit, Offset, Order, Where))+import Sqel.Data.Order (Order)+import Sqel.Data.Sel (Sel (SelAuto, SelUnused), mkSel)+import Sqel.Data.SelectExpr (SelectAtom (SelectAtom))+import Sqel.Data.Selector (Selector (Selector))+import Sqel.Data.Sql (Sql, sql)+import Sqel.Prim (primMod)+import Sqel.Sql.Prepared (dollar)++whereOp :: Sql -> SelectAtom+whereOp op =+  SelectAtom Where (\ sel i -> [sql|##{sel} #{op} #{dollar i}|])++whereEq :: SelectAtom+whereEq =+  whereOp "="++whereGt :: SelectAtom+whereGt =+  whereOp ">"++whereGte :: SelectAtom+whereGte =+  whereOp ">="++whereLt :: SelectAtom+whereLt =+  whereOp "<"++whereLte :: SelectAtom+whereLte =+  whereOp "<="++whereLike :: SelectAtom+whereLike =+  whereOp "like"++greater ::+  MapMod SelectAtom s0 s1 =>+  Dd s0 ->+  Dd s1+greater =+  setMod whereGt++greaterEq ::+  MapMod SelectAtom s0 s1 =>+  Dd s0 ->+  Dd s1+greaterEq =+  setMod whereGte++less ::+  MapMod SelectAtom s0 s1 =>+  Dd s0 ->+  Dd s1+less =+  setMod whereLt++lessEq ::+  MapMod SelectAtom s0 s1 =>+  Dd s0 ->+  Dd s1+lessEq =+  setMod whereLte++like ::+  MapMod SelectAtom s0 s1 =>+  Dd s0 ->+  Dd s1+like =+  setMod whereLike++nocond :: Dd ('DdK sel p a s) -> Dd ('DdK 'SelUnused p a s)+nocond (Dd _ p s) =+  Dd mkSel p s++limit ::+  Dd ('DdK 'SelUnused '[SelectAtom] a 'Prim)+limit =+  nocond (primMod (SelectAtom Limit (const dollar)))++offset ::+  Dd ('DdK 'SelUnused '[SelectAtom] a 'Prim)+offset =+  nocond (primMod (SelectAtom Offset (const dollar)))++order ::+  Order ->+  Dd ('DdK 'SelAuto '[SelectAtom] a 'Prim)+order dir =+  primMod (SelectAtom (Order dir) (\ (Selector sel) _ -> sel))
+ lib/Sqel/Query/Fragments.hs view
@@ -0,0 +1,79 @@+module Sqel.Query.Fragments where++import Data.Composition ((.:))+import qualified Exon+import Exon (exon)++import Sqel.Data.Codec (ColumnName (ColumnName))+import Sqel.Data.Dd (QOp (QAnd, QOr))+import Sqel.Data.FragType (FragType (Where))+import Sqel.Data.Sel (Sel (SelAuto, SelSymbol, SelUnused), SelW (SelWSymbol))+import Sqel.Data.Sql (Sql, sql)+import Sqel.Names (ddName)+import Sqel.Sql.Prepared (dollar)+import Sqel.Text.DbIdentifier (quotedDbId)++parens :: Sql -> Sql+parens s =+  [sql|(#{s})|]++joinOp :: QOp -> [Sql] -> Sql+joinOp =+  parens .: Exon.intercalate . sep+  where+    sep = \case+      QAnd -> " and "+      QOr -> " or "++joinFrag :: QOp -> FragType -> [Sql] -> Sql+joinFrag op = \case+  Where ->+    joinOp op+  _ ->+    fold . head++guardCon :: Int -> Int -> Sql -> Sql+guardCon index con code =+  [exon|(#{dollar index} = #{show con} and #{code})|]++joinSum :: Int -> FragType -> [Sql] -> Sql+joinSum index Where =+  joinOp QOr . fmap (uncurry (guardCon index)) . zip [0..]+joinSum _  _ =+  fold . head++data ColumnPrefix =+  NoPrefix+  |+  BasePrefix Text+  |+  TypePrefix Text+  deriving stock (Eq, Show)++-- TODO this quotes the segments that seem to work fine, while the ones in PgTable don't.+addPrefix ::+  ColumnName ->+  ColumnPrefix ->+  ColumnPrefix+addPrefix (ColumnName segment) = \case+  NoPrefix -> BasePrefix (quotedDbId segment)+  BasePrefix name -> TypePrefix [exon|(#{name}).#{quotedDbId segment}|]+  TypePrefix prefix -> TypePrefix [exon|#{prefix}.#{quotedDbId segment}|]++prefixed :: Text -> ColumnPrefix -> Text+prefixed name = \case+  NoPrefix -> quotedDbId name+  BasePrefix prefix -> [exon|(#{prefix}).#{quotedDbId name}|]+  TypePrefix prefix -> [exon|#{prefix}.#{quotedDbId name}|]++class QFragmentPrefix sel where+  qfragmentPrefix :: SelW sel -> ColumnPrefix -> ColumnPrefix++instance QFragmentPrefix ('SelSymbol n) where+  qfragmentPrefix (SelWSymbol _) = addPrefix (ddName @n)++instance QFragmentPrefix 'SelAuto where+  qfragmentPrefix _ = id++instance QFragmentPrefix 'SelUnused where+  qfragmentPrefix _ = id
+ lib/Sqel/Query/SelectExpr.hs view
@@ -0,0 +1,107 @@+module Sqel.Query.SelectExpr where++import Generics.SOP (All, K (K), NP ((:*)), hcmap, hcollapse)++import Sqel.Class.Mods (GetMod (getMod), MaybeMod (maybeMod))+import Sqel.Data.Dd (+  Comp (Prod, Sum),+  CompInc (Merge, Nest),+  Dd (Dd),+  DdInc (DdMerge, DdNest),+  DdK (DdK),+  DdSort (DdSum),+  DdStruct (DdComp, DdPrim),+  QOp (QAnd),+  Struct (Comp, Prim),+  )+import Sqel.Data.FragType (FragType (Where))+import Sqel.Data.Mods (Ignore (Ignore))+import Sqel.Data.Sel (Sel (SelSymbol, SelUnused), SelW (SelWAuto))+import Sqel.Data.SelectExpr (+  SelectAtom (SelectAtom),+  SelectExpr (SelectExprAtom, SelectExprIgnore, SelectExprList, SelectExprSum),+  )+import Sqel.Data.Selector (Selector (Selector))+import Sqel.Data.Sql (Sql (Sql), sql)+import Sqel.Prim (IndexColumn)+import Sqel.Query.Combinators (whereEq)+import Sqel.Query.Fragments (ColumnPrefix, QFragmentPrefix (qfragmentPrefix), prefixed)+import Sqel.Sql.Prepared (dollar)+import Sqel.Text.DbIdentifier (dbSymbol)++guardSum :: SelectExpr -> SelectExpr+guardSum = \case+  SelectExprAtom Where code -> SelectExprAtom Where \ i -> [sql|(#{dollar i} is null or #{code i})|]+  SelectExprList op sub -> SelectExprList op (guardSum <$> sub)+  expr -> expr++class ToSelectExpr query where+  toSelectExpr :: ColumnPrefix -> Dd query -> SelectExpr++-- TODO this creates an invalid fragment, but it seems not to be used+instance (+    GetMod () SelectAtom ps,+    MaybeMod Ignore ps+  ) => ToSelectExpr ('DdK 'SelUnused ps q 'Prim) where+  toSelectExpr _ (Dd _ p DdPrim) =+    case maybeMod p of+      Just Ignore -> SelectExprIgnore+      Nothing -> SelectExprAtom type_ (code "")+    where+      SelectAtom type_ code = getMod @() whereEq p++instance (+    KnownSymbol n,+    GetMod () SelectAtom ps+  ) => ToSelectExpr ('DdK ('SelSymbol n) ps q 'Prim) where+  toSelectExpr pre (Dd _ p DdPrim) =+    SelectExprAtom type_ (code (Selector (Sql (prefixed (dbSymbol @n) pre))))+    where+      SelectAtom type_ code = getMod @() whereEq p++prodSelectExpr ::+  ∀ sel s .+  All ToSelectExpr s =>+  QFragmentPrefix sel =>+  SelW sel ->+  ColumnPrefix ->+  QOp ->+  NP Dd s ->+  SelectExpr+prodSelectExpr sel pre op =+  SelectExprList op . hcollapse . hcmap (Proxy @ToSelectExpr) (K . toSelectExpr (qfragmentPrefix sel pre))++sumSelectExpr ::+  ∀ sel s .+  All ToSelectExpr s =>+  QFragmentPrefix sel =>+  SelW sel ->+  ColumnPrefix ->+  NP Dd s ->+  SelectExpr+sumSelectExpr sel pre =+  SelectExprSum . hcollapse . hcmap (Proxy @ToSelectExpr) (K . toSelectExpr (qfragmentPrefix sel pre))++-- TODO add QOp param lookup+instance (+    All ToSelectExpr sub,+    QFragmentPrefix sel+  ) => ToSelectExpr ('DdK sel p q ('Comp tsel ('Prod con) 'Nest sub)) where+  toSelectExpr pre = \case+    Dd sel _ (DdComp _ _ DdNest sub) ->+      prodSelectExpr sel pre QAnd sub++instance (+    All ToSelectExpr sub+  ) => ToSelectExpr ('DdK sel p q ('Comp tsel ('Prod con) 'Merge sub)) where+  toSelectExpr pre = \case+    Dd _ _ (DdComp _ _ DdMerge sub) ->+      prodSelectExpr SelWAuto pre QAnd sub++instance (+    All ToSelectExpr sub,+    QFragmentPrefix sel+  ) => ToSelectExpr ('DdK sel p q ('Comp tsel 'Sum 'Nest (IndexColumn name : sub))) where+  toSelectExpr pre = \case+    Dd sel _ (DdComp _ DdSum DdNest (_ :* sub)) ->+      guardSum (sumSelectExpr sel pre sub)
+ lib/Sqel/ReifyCodec.hs view
@@ -0,0 +1,272 @@+module Sqel.ReifyCodec where++import Data.Functor.Invariant (Invariant, invmap)+import Generics.SOP (I (I), NP (Nil, (:*)))+import qualified Hasql.Encoders as Encoders++import Sqel.Codec (+  ColumnDecoder (columnDecoder, columnDecoderNullable),+  ColumnEncoder (columnEncoder, columnEncoderIgnore, columnEncoderNullable),+  PrimColumn (primDecoder, primEncoder),+  fullPrimCodec,+  ignoreDecoder,+  )+import Sqel.Codec.PrimDecoder (ArrayDecoder (arrayDecoder), enumDecoder, readDecoder)+import Sqel.Codec.PrimEncoder (arrayEncoder)+import Sqel.Codec.Product (ProdCodec (prodCodec))+import Sqel.Codec.Sum (ConCodec (conCodec), SumCodec (sumCodec), ignoreEncoder)+import qualified Sqel.Data.Codec as Codec+import Sqel.Data.Codec (Codec (Codec), Decoder (Decoder), Encoder (Encoder), FullCodec, ValueCodec)+import Sqel.Data.Dd (+  Comp (Prod, Sum),+  CompInc,+  ConCol,+  Dd (Dd),+  DdK (DdK),+  DdStruct (DdComp, DdPrim),+  ProdType (Con, Reg),+  Struct (Comp, Prim),+  )+import Sqel.Data.Mods (+  ArrayColumn (ArrayColumn),+  EnumColumn (EnumColumn),+  Ignore (Ignore),+  Mods (Mods),+  Newtype (Newtype),+  Nullable (Nullable),+  ReadShowColumn (ReadShowColumn),+  )+import Sqel.Mods (PrimCodec (PrimCodec), PrimValueCodec, PrimValueEncoder)+import Sqel.SOP.Enum (EnumTable)++type CompCodec :: Comp -> CompInc -> Type -> (Type -> Type) -> [Type] -> Constraint+class CompCodec c i a b as where+  compCodec :: NP b as -> b a++instance (+    ProdCodec b a as+  ) => CompCodec ('Prod 'Reg) i a b as where+    compCodec = prodCodec++instance (+    ConCodec b as+  ) => CompCodec ('Prod ('Con as)) i (ConCol name record fields as) b as where+    compCodec = conCodec++instance (+    SumCodec b a as+  ) => CompCodec 'Sum i a b as where+    compCodec = sumCodec++class DefaultPrimCodec b a where+  defaultPrimCodec :: b a++instance (+    PrimColumn a+  ) => DefaultPrimCodec FullCodec a where+    defaultPrimCodec =+      Codec {+        encoder = Encoder (columnEncoder encoder) (columnEncoderIgnore encoder),+        decoder = Decoder (columnDecoder decoder) (void ignoreDecoder)+      }+      where+        encoder = primEncoder+        decoder = primDecoder++instance (+    PrimColumn a+  ) => DefaultPrimCodec ValueCodec a where+    defaultPrimCodec =+      Codec {+        encoder = primEncoder,+        decoder = primDecoder+      }++instance (+    PrimColumn a+  ) => DefaultPrimCodec Encoder a where+    defaultPrimCodec =+      Encoder (columnEncoder encoder) (columnEncoderIgnore encoder)+      where+        encoder = primEncoder++instance (+    PrimColumn a+  ) => DefaultPrimCodec Encoders.Value a where+    defaultPrimCodec = primEncoder++type DefaultCompCodec :: Comp -> CompInc -> (Type -> Type) -> Type -> [Type] -> Constraint+class DefaultCompCodec c i b a as where+  defaultCompCodec :: NP b as -> b a++instance (+    CompCodec c i a FullCodec as+  ) => DefaultCompCodec c i FullCodec a as where+    defaultCompCodec = compCodec @c @i++instance (+    CompCodec c i a Encoder as+  ) => DefaultCompCodec c i Encoder a as where+    defaultCompCodec = compCodec @c @i++class ReifyPrimCodec b ps a where+  reifyPrimCodec :: NP I ps -> b a++instance {-# overlappable #-} (+    ReifyPrimCodec b ps a+  ) => ReifyPrimCodec b (p : ps) a where+  reifyPrimCodec (_ :* ps) =+    reifyPrimCodec ps++instance ReifyPrimCodec ValueCodec (PrimValueCodec a : ps) a where+  reifyPrimCodec (I (PrimCodec c) :* _) = c++instance ReifyPrimCodec FullCodec (PrimValueCodec a : ps) a where+  reifyPrimCodec (I (PrimCodec (Codec encoder decoder)) :* _) =+    Codec {+      encoder = Encoder (columnEncoder encoder) (columnEncoderIgnore encoder),+      decoder = Decoder (columnDecoder decoder) (void ignoreDecoder)+    }++instance (+    ReifyPrimCodec ValueCodec ps a+  ) => ReifyPrimCodec FullCodec (Nullable : ps) (Maybe a) where+    reifyPrimCodec (I Nullable :* ps) =+      Codec {+        encoder = Encoder (columnEncoderNullable encoder) (ignoreEncoder encoder),+        decoder = Decoder (columnDecoderNullable decoder) (void ignoreDecoder)+      }+      where+        Codec encoder decoder = reifyPrimCodec @ValueCodec ps++instance ReifyPrimCodec Encoders.Value (PrimValueEncoder a : ps) a where+  reifyPrimCodec (I (PrimCodec e) :* _) = e++instance ReifyPrimCodec Encoder (PrimValueEncoder a : ps) a where+  reifyPrimCodec (I (PrimCodec encoder) :* _) =+    Encoder (columnEncoder encoder) (columnEncoderIgnore encoder)++-- TODO this could also produce NullableOrNot+instance (+    ReifyPrimCodec Encoders.Value ps a+  ) => ReifyPrimCodec Encoder (Nullable : ps) (Maybe a) where+    reifyPrimCodec (I Nullable :* ps) =+      Encoder (columnEncoderNullable encoder) (ignoreEncoder encoder)+      where+        encoder = reifyPrimCodec @Encoders.Value ps++instance (+    Show a,+    EnumTable a+  ) => ReifyPrimCodec FullCodec (EnumColumn : ps) a where+  reifyPrimCodec (I EnumColumn :* _) =+    fullPrimCodec (Encoders.enum show) enumDecoder++instance (+    Show a,+    EnumTable a+  ) => ReifyPrimCodec ValueCodec (EnumColumn : ps) a where+  reifyPrimCodec (I EnumColumn :* _) =+    Codec (Encoders.enum show) enumDecoder++instance (+    Show a,+    Read a+  ) => ReifyPrimCodec FullCodec (ReadShowColumn : ps) a where+  reifyPrimCodec (I ReadShowColumn :* _) =+    fullPrimCodec (Encoders.enum show) readDecoder++instance (+    Show a,+    Read a+  ) => ReifyPrimCodec ValueCodec (ReadShowColumn : ps) a where+  reifyPrimCodec (I ReadShowColumn :* _) =+    Codec (Encoders.enum show) readDecoder++instance (+    ReifyPrimCodec ValueCodec ps a,+    Foldable f,+    ArrayDecoder f a+  ) => ReifyPrimCodec ValueCodec (ArrayColumn f : ps) (f a) where+  reifyPrimCodec (I ArrayColumn :* ps) =+    Codec (arrayEncoder encoder) (arrayDecoder decoder)+      where+        Codec encoder decoder = reifyPrimCodec @ValueCodec ps++instance (+    ReifyPrimCodec ValueCodec ps a,+    Foldable f,+    ArrayDecoder f a+  ) => ReifyPrimCodec FullCodec (ArrayColumn f : ps) (f a) where+  reifyPrimCodec (I ArrayColumn :* ps) =+    fullPrimCodec (arrayEncoder encoder) (arrayDecoder decoder)+      where+        Codec encoder decoder = reifyPrimCodec @ValueCodec ps++instance {-# overlappable #-} (+    ReifyPrimCodec c mods w,+    Invariant c+  ) => ReifyPrimCodec c (Newtype a w : mods) a where+  reifyPrimCodec (I (Newtype unwrap wrap) :* mods) =+    invmap wrap unwrap (reifyPrimCodec mods)++instance (+    ReifyPrimCodec Encoders.Value mods w+  ) => ReifyPrimCodec Encoders.Value (Newtype a w : mods) a where+  reifyPrimCodec (I (Newtype unwrap _) :* mods) =+    unwrap >$< (reifyPrimCodec mods)++instance ReifyPrimCodec FullCodec (Ignore : ps) a where+  reifyPrimCodec (I Ignore :* _) =+    Codec (Encoder mempty mempty) (Decoder (fail err) (fail err))+    where+      err = "ignored column was used"++instance ReifyPrimCodec Encoder (Ignore : ps) a where+  reifyPrimCodec (I Ignore :* _) =+    Encoder mempty mempty++instance (+    DefaultPrimCodec b a+  ) => ReifyPrimCodec b '[] a where+    reifyPrimCodec _ = defaultPrimCodec++class ReifyCompCodec b c i ps as a where+  reifyCompCodec :: NP I ps -> NP b as -> b a++instance (+    DefaultCompCodec c i b a as+  ) => ReifyCompCodec b c i ps as a where+    reifyCompCodec _ sub =+      defaultCompCodec @c @i sub++type ReifyCodec :: (Type -> Type) -> DdK -> Type -> Constraint+class ReifyCodec b s a | s -> a where+  reifyCodec :: Dd s -> b a++instance (+    ReifyPrimCodec b ps a+  ) => ReifyCodec b ('DdK sel ps a 'Prim) a where+    reifyCodec (Dd _ (Mods ps) DdPrim) =+      reifyPrimCodec @b ps++instance (+    ReifyCodecComp b sub as,+    ReifyCompCodec b c i ps as a+  ) => ReifyCodec b ('DdK sel ps a ('Comp tsel c i sub)) a where+    reifyCodec (Dd _ (Mods ps) (DdComp _ _ _ sub)) =+      reifyCompCodec @b @c @i @ps @as ps (reifyCodecComp @b @sub sub)++-- TODO this is probably only necessary because of a bug in GHC that's fixed in master+type ReifyCodecComp :: (Type -> Type) -> [DdK] -> [Type] -> Constraint+class ReifyCodecComp b s as | s -> as where+  reifyCodecComp :: NP Dd s -> NP b as++instance ReifyCodecComp b '[] '[] where+  reifyCodecComp Nil = Nil++instance (+    ReifyCodec b s a,+    ReifyCodecComp b ss as+  ) => ReifyCodecComp b (s : ss) (a : as) where+  reifyCodecComp (d :* ds) = reifyCodec d :* reifyCodecComp ds
+ lib/Sqel/ReifyDd.hs view
@@ -0,0 +1,95 @@+module Sqel.ReifyDd where++import Generics.SOP (I (I), NP (Nil, (:*)), tl)++import Sqel.Class.Mods (MaybeMod (maybeMod))+import Sqel.Codec (PrimColumn (pgType))+import Sqel.ColumnConstraints (ColumnConstraints, columnConstraints)+import Sqel.Data.Dd (Dd (Dd), DdK (DdK), DdStruct (DdComp, DdPrim), Struct (Comp, Prim))+import Sqel.Data.Mods (+  ArrayColumn (ArrayColumn),+  Mods (Mods),+  Newtype (Newtype),+  Nullable (Nullable),+  SetTableName,+  unSetTableName,+  )+import Sqel.Data.PgType (PgPrimName, pgColumnName)+import Sqel.Data.Sel (ReifySel (reifySel), SelW (SelWSymbol), TSelW (TSelW))+import qualified Sqel.Data.Term as Term+import Sqel.Data.Term (DdTerm (DdTerm), demoteComp, demoteInc)+import Sqel.SOP.Constraint (symbolText)++class ReifyPrimName a mods where+  reifyPrimName :: NP I mods -> PgPrimName++instance {-# overlappable #-} (+    ReifyPrimName a mods+  ) => ReifyPrimName a (p : mods) where+    reifyPrimName = reifyPrimName @a . tl++instance (+    PrimColumn a+  ) => ReifyPrimName a '[] where+    reifyPrimName Nil = pgType @a++instance (+    ReifyPrimName a mods+  ) => ReifyPrimName (Maybe a) (Nullable : mods) where+    reifyPrimName (I Nullable :* mods) = reifyPrimName @a mods++instance (+    ReifyPrimName a mods+  ) => ReifyPrimName (f a) (ArrayColumn f : mods) where+    reifyPrimName (I ArrayColumn :* mods) = reifyPrimName @a mods <> "[]"++instance (+    ReifyPrimName w mods+  ) => ReifyPrimName a (Newtype a w : mods) where+    reifyPrimName (I (Newtype _ _) :* mods) = reifyPrimName @w mods++instance ReifyPrimName a (PgPrimName : mods) where+  reifyPrimName (I t :* _) = t++class ReifyDd s where+  reifyDd :: Dd s -> DdTerm++instance (+    ColumnConstraints mods,+    MaybeMod SetTableName mods,+    ReifyPrimName a mods,+    ReifySel sel name+  ) => ReifyDd ('DdK sel mods a 'Prim) where+    reifyDd (Dd sel mods@(Mods ms) DdPrim) =+      DdTerm (pgColumnName name) (unSetTableName <$> maybeMod mods) unique constraints (Term.Prim (reifyPrimName @a ms))+      where+        (unique, constraints) = columnConstraints mods+        name = reifySel sel++instance (+    ColumnConstraints mods,+    MaybeMod SetTableName mods,+    ReifyDdComp sub+  ) => ReifyDd ('DdK sel mods a ('Comp tsel c i sub)) where+    reifyDd (Dd sel mods (DdComp (TSelW (Proxy :: Proxy '(tname, tpe))) c i sub)) =+      DdTerm (pgColumnName name) (unSetTableName <$> maybeMod mods) unique constraints struct+      where+        (unique, constraints) = columnConstraints mods+        struct = Term.Comp typeName (demoteComp c) (demoteInc i) (reifyDdComp sub)+        name = case sel of+          SelWSymbol (Proxy :: Proxy name) -> symbolText @name+          _ -> symbolText @tname+        typeName = symbolText @tpe++-- TODO this is probably only necessary because of a bug in GHC that's fixed in master+class ReifyDdComp s where+  reifyDdComp :: NP Dd s -> [DdTerm]++instance ReifyDdComp '[] where+  reifyDdComp Nil = []++instance (+    ReifyDd s,+    ReifyDdComp ss+  ) => ReifyDdComp (s : ss) where+    reifyDdComp (s :* ss) = reifyDd s : reifyDdComp ss
+ lib/Sqel/ResultShape.hs view
@@ -0,0 +1,27 @@+module Sqel.ResultShape where++import Data.Vector (Vector)+import Hasql.Decoders (Result, Row, noResult, rowList, rowMaybe, rowVector, singleRow)++class ResultShape d r | r -> d where+  resultShape :: Row d -> Result r++instance ResultShape d (Vector d) where+  resultShape =+    rowVector++instance ResultShape d [d] where+  resultShape =+    rowList++instance ResultShape d (Maybe d) where+  resultShape =+    rowMaybe++instance ResultShape () () where+  resultShape =+    const noResult++instance ResultShape a (Identity a) where+  resultShape =+    fmap Identity . singleRow
+ lib/Sqel/SOP/Constraint.hs view
@@ -0,0 +1,55 @@+module Sqel.SOP.Constraint where++import Data.Generics.Labels ()+import Generics.SOP (All, All2, Top)+import Generics.SOP.Constraint (Head)+import Generics.SOP.GGP (GCode, GDatatypeInfoOf, GFrom, GTo)+import Generics.SOP.Type.Metadata (DatatypeInfo (ADT, Newtype))++type Coded (d :: Type) (dss :: [[Type]]) =+  GCode d ~ dss++type ProductGCode d =+  Head (GCode d)++type ProductCoded (d :: Type) (ds :: [Type]) =+  Coded d '[ds]++type ReifySOP (d :: Type) (dss :: [[Type]]) =+  (Generic d, GTo d, GCode d ~ dss, All2 Top dss)++type ConstructSOP (d :: Type) (dss :: [[Type]]) =+  (Generic d, GFrom d, GCode d ~ dss, All2 Top dss)++type ReifyProd d ds =+  ReifySOP d '[ds]++type ConstructProd d ds =+  ConstructSOP d '[ds]++type IsNullary =+  (~) '[]++type IsEnum a =+  All IsNullary (GCode a)++type family DatatypeInfoName (dt :: DatatypeInfo) :: Symbol where+  DatatypeInfoName ('ADT _ name _ _) = name+  DatatypeInfoName ('Newtype _ name _) = name++type family DataName (d :: Type) :: Symbol where+  DataName d = DatatypeInfoName (GDatatypeInfoOf d)++symbolString ::+  ∀ (name :: Symbol) .+  KnownSymbol name =>+  String+symbolString =+  symbolVal (Proxy @name)++symbolText ::+  ∀ (name :: Symbol) .+  KnownSymbol name =>+  Text+symbolText =+  toText (symbolString @name)
+ lib/Sqel/SOP/Enum.hs view
@@ -0,0 +1,41 @@+module Sqel.SOP.Enum where++import qualified Data.Map.Strict as Map+import qualified Generics.SOP as SOP+import Generics.SOP (+  I,+  K (K),+  NP (Nil),+  NS,+  SOP (SOP),+  constructorName,+  hcollapse,+  hczipWith,+  injections,+  unK,+  type (-.->),+  )+import Generics.SOP.GGP (GCode, GDatatypeInfoOf, gto)+import qualified Generics.SOP.Type.Metadata as T++import Sqel.SOP.Constraint (IsEnum, IsNullary, ReifySOP)++class EnumTable a where+  enumTable :: Map Text a++instance (+    IsEnum a,+    ReifySOP a (GCode a),+    GDatatypeInfoOf a ~ 'T.ADT mod name ctors strictness,+    T.DemoteConstructorInfos ctors (GCode a)+  ) => EnumTable a where+    enumTable =+      Map.fromList (hcollapse cs)+      where+        cs =+          hczipWith (Proxy :: Proxy IsNullary) f ctors injections+        f :: SOP.ConstructorInfo fs -> (NP I -.-> K (NS (NP I) (GCode a))) '[] -> K (Text, a) '[]+        f ctor (SOP.Fn inject) =+          K (toText (constructorName ctor), gto (SOP (unK (inject Nil))))+        ctors =+          T.demoteConstructorInfos (Proxy @ctors)
+ lib/Sqel/SOP/Error.hs view
@@ -0,0 +1,43 @@+module Sqel.SOP.Error where++import Fcf (Eval, Exp, UnList, type (@@))+import Type.Errors (ErrorMessage (Text))++type family JoinSep (sep :: Symbol) (ss :: [Symbol]) :: Symbol where+  JoinSep _ '[] = "<empty>"+  JoinSep _ '[s] = s+  JoinSep sep (s : ss) = AppendSymbol (AppendSymbol s sep) (JoinSep sep ss)++type family JoinError (sep :: ErrorMessage) (ns :: [ErrorMessage]) :: ErrorMessage where+  JoinError _ '[] = 'Text "<empty>"+  JoinError sep (n : n1 : ns) = n <> sep <> JoinError sep (n1 : ns)+  JoinError _ '[n] = n++type family JoinComma (ns :: [ErrorMessage]) :: ErrorMessage where+  JoinComma ns = JoinError ('Text ", ") ns++type family JoinSym (sep :: Symbol) (ns :: [Symbol]) :: ErrorMessage where+  JoinSym sep (n : n1 : ns) = n <> sep <> JoinSym sep (n1 : ns)+  JoinSym _ '[n] = 'Text n++type family JoinCommaSym (ns :: [Symbol]) :: ErrorMessage where+  JoinCommaSym (n : n1 : ns) = 'Text n <> ", " <> JoinCommaSym (n1 : ns)+  JoinCommaSym '[n] = 'Text n++type family QuotedError (msg :: ErrorMessage) :: ErrorMessage where+  QuotedError err = "‘" <> err <> "’"++type family Quoted (s :: Symbol) :: ErrorMessage where+  Quoted s = QuotedError ('Text s)++type family QuotedType (t :: k) :: ErrorMessage where+  QuotedType t = QuotedError ('ShowType t)++data LineBreak :: ErrorMessage -> ErrorMessage -> Exp ErrorMessage+type instance Eval (LineBreak l r) = l % r++type family Unlines (fragments :: [ErrorMessage]) :: ErrorMessage where+  Unlines '[] =+    'Text ""+  Unlines (h : t) =+    UnList h LineBreak @@ t
+ lib/Sqel/SOP/HasGeneric.hs view
@@ -0,0 +1,36 @@+module Sqel.SOP.HasGeneric where++import Data.Bool.Singletons ()+import Data.Singletons (SingI, demote)+import Generics.SOP.GGP (GCode, GDatatypeInfoOf)+import Generics.SOP.Type.Metadata (DatatypeInfo (Newtype))++class GDatatypeInfoIsNewtype (dss :: [[Type]]) (info :: DatatypeInfo) (wrapped :: Maybe Type) | dss info -> wrapped+instance {-# incoherent #-} wrapped ~ 'Nothing => GDatatypeInfoIsNewtype dss info wrapped+instance wrapped ~ 'Just d => GDatatypeInfoIsNewtype '[ '[d]] ('Newtype m n c) wrapped++class IsNewtype d (wrapped :: Maybe Type) | d -> wrapped+instance GDatatypeInfoIsNewtype (GCode d) (GDatatypeInfoOf d) wrapped => IsNewtype d wrapped++class GCodeResolves (d :: [[Type]]) (flag :: Bool) | d -> flag+instance {-# incoherent #-} flag ~ 'False => GCodeResolves d flag+instance flag ~ 'True => GCodeResolves (d : ds) flag+instance flag ~ 'True => GCodeResolves '[] flag++class HasGeneric d (flag :: Bool) | d -> flag+instance GCodeResolves (GCode d) flag => HasGeneric d flag++class GCodeResolvesNot (d :: [[Type]]) (flag :: Bool) | d -> flag where+  gcodeResolvesNot :: Bool+instance {-# incoherent #-} flag ~ 'True => GCodeResolvesNot d flag where+  gcodeResolvesNot =+    True+instance flag ~ 'False => GCodeResolvesNot (d : ds) flag where+  gcodeResolvesNot =+    False++class HasNoGeneric d (flag :: Bool) | d -> flag where+  hasNoGeneric :: Bool++instance (SingI flag, GCodeResolvesNot (GCode d) flag) => HasNoGeneric d flag where+  hasNoGeneric = demote @flag
+ lib/Sqel/SOP/Newtype.hs view
@@ -0,0 +1,59 @@+module Sqel.SOP.Newtype where++import Generics.SOP.GGP (GCode, GDatatypeInfoOf)+import Generics.SOP.Type.Metadata (DatatypeInfo (Newtype))+import Type.Errors (DelayError, ErrorMessage)+import Unsafe.Coerce (unsafeCoerce)++import Sqel.SOP.Error (Quoted, QuotedType)+import Sqel.SOP.HasGeneric (HasGeneric)++type NoGenericError a =+  "The type " <> QuotedType a <> " does not have an instance of " <> Quoted "Generic" <> "." %+  "You can add it like this:" %+  Quoted "newtype MyType = MyType Text deriving Generic" %+  "If you want to use " <> Quoted "Coercible" <> " instead, use " <> Quoted "primCoerce" <> "."++type NotNewtypeError a =+  "The type " <> QuotedType a <> " is not a newtype."++type UN_CheckNewtype :: Void -> [[Type]] -> DatatypeInfo -> Type -> Type -> Constraint+class UN_CheckNewtype err ass info a w | ass info a -> w where+  un_checkNewtype_unwrap :: a -> w+  un_checkNewtype_wrap :: w -> a++instance UN_CheckNewtype err '[ '[w] ] ('Newtype mn dn ci) a w where+  un_checkNewtype_unwrap = unsafeCoerce+  un_checkNewtype_wrap = unsafeCoerce++type UN_CheckGeneric :: ErrorMessage -> Void -> [[Type]] -> DatatypeInfo -> Type -> Type -> Constraint+class UN_CheckGeneric errHead err ass info a w | ass info a -> w where+  un_checkGeneric_unwrap :: a -> w+  un_checkGeneric_wrap :: w -> a++instance (+    err ~ DelayError (errHead % NotNewtypeError a),+    UN_CheckNewtype err '[] info a w+  ) => UN_CheckGeneric errHead genErr '[] info a w where+    un_checkGeneric_unwrap = un_checkNewtype_unwrap @err @'[] @info+    un_checkGeneric_wrap = un_checkNewtype_wrap @err @'[] @info++instance (+    err ~ DelayError (errHead % NotNewtypeError a),+    UN_CheckNewtype err (x : xs) info a w+  ) => UN_CheckGeneric errHead genErr (x : xs) info a w where+    un_checkGeneric_unwrap = un_checkNewtype_unwrap @err @(x : xs) @info+    un_checkGeneric_wrap = un_checkNewtype_wrap @err @(x : xs) @info++type UnwrapNewtype :: ErrorMessage -> Type -> Type -> Constraint+class UnwrapNewtype errHead a w | a -> w where+  unwrapNewtype :: a -> w+  wrapNewtype :: w -> a++instance (+  HasGeneric a flag,+  err ~ DelayError (errHead % NoGenericError a),+  UN_CheckGeneric errHead err (GCode a) (GDatatypeInfoOf a) a w+  ) => UnwrapNewtype errHead a w where+    unwrapNewtype = un_checkGeneric_unwrap @errHead @err @(GCode a) @(GDatatypeInfoOf a)+    wrapNewtype = un_checkGeneric_wrap @errHead @err @(GCode a) @(GDatatypeInfoOf a)
+ lib/Sqel/Sql.hs view
@@ -0,0 +1,9 @@+module Sqel.Sql (+  module Sqel.Data.Sql,+  module Sqel.Data.SqlFragment,+  module Sqel.Sql.Prepared,+) where++import Sqel.Data.Sql+import Sqel.Data.SqlFragment+import Sqel.Sql.Prepared
+ lib/Sqel/Sql/Prepared.hs view
@@ -0,0 +1,7 @@+module Sqel.Sql.Prepared where++import Sqel.Data.Sql (Sql, sql)++dollar :: Int -> Sql+dollar i =+  [sql|$#{show i}|]
+ lib/Sqel/Sql/Select.hs view
@@ -0,0 +1,23 @@+module Sqel.Sql.Select where++import Sqel.Data.QuerySchema (QuerySchema (QuerySchema))+import Sqel.Data.Sql (Sql, ToSql, sql)+import Sqel.Data.SqlFragment (Select (Select))+import Sqel.Data.TableSchema (TableSchema (TableSchema))++selectWhere ::+  ∀ proj q table .+  QuerySchema q table ->+  TableSchema proj ->+  Sql+selectWhere (QuerySchema query _) (TableSchema proj _ _) =+  [sql|##{Select proj} ##{query}|]++selectWhereGen ::+  ∀ f proj q table .+  ToSql (Select (f proj table)) =>+  QuerySchema q table ->+  f proj table ->+  Sql+selectWhereGen (QuerySchema query _) proj =+  [sql|##{Select proj} ##{query}|]
+ lib/Sqel/Sql/Type.hs view
@@ -0,0 +1,61 @@+module Sqel.Sql.Type where++import qualified Exon++import qualified Sqel.Data.PgType as PgTable+import Sqel.Data.PgType (+  ColumnType (ColumnComp, ColumnPrim),+  PgColumn (PgColumn),+  PgColumnName (PgColumnName),+  PgColumns (PgColumns),+  PgComposite (PgComposite),+  PgPrimName (PgPrimName),+  PgTable (PgTable),+  PgTypeRef (PgTypeRef),+  )+import Sqel.Data.PgTypeName (PgTableName)+import Sqel.Data.Sql (Sql, sql)+import Sqel.Data.SqlFragment (CommaSep (CommaSep))+import Sqel.Text.Quote (dquote)++-- TODO why is unique not used?+columnSpec ::+  PgColumn ->+  Sql+columnSpec = \case+  PgColumn (PgColumnName name) (ColumnPrim (PgPrimName tpe) _ (Exon.intercalate " " -> params)) ->+    [sql|##{dquote name} ##{tpe} #{params}|]+  PgColumn (PgColumnName name) (ColumnComp (PgTypeRef tpe) _ (Exon.intercalate " " -> params)) ->+    [sql|##{dquote name} ##{tpe} #{params}|]++typeColumnSpec ::+  PgColumn ->+  Sql+typeColumnSpec = \case+  PgColumn (PgColumnName name) (ColumnPrim (PgPrimName tpe) _ _) ->+    [sql|##{dquote name} ##{tpe}|]+  PgColumn (PgColumnName name) (ColumnComp (PgTypeRef tpe) _ _) ->+    [sql|##{dquote name} ##{tpe}|]++createTable ::+  PgTable a ->+  Sql+createTable PgTable {name, columns = PgColumns cols} =+  [sql|create table ##{name} (##{CommaSep formattedColumns})|]+  where+    formattedColumns = toList (columnSpec <$> cols)++dropTable ::+  PgTableName ->+  Sql+dropTable name =+   [sql|drop table if exists ##{name}|]++-- TODO make PgTypeRef et al quote automatically by using @ToSegment@+createProdType ::+  PgComposite ->+  Sql+createProdType (PgComposite name (PgColumns cols)) =+  [sql|create type ##{name} as (##{CommaSep formattedColumns})|]+  where+    formattedColumns = toList (typeColumnSpec <$> cols)
+ lib/Sqel/Statement.hs view
@@ -0,0 +1,157 @@+module Sqel.Statement where++import qualified Hasql.Decoders as Decoders+import Hasql.Decoders (Row, noResult)+import qualified Hasql.Encoders as Encoders+import Hasql.Encoders (Params)+import Hasql.Statement (Statement (Statement))+import Lens.Micro ((^.))+import Sqel.Data.Codec (Encoder (Encoder))+import qualified Sqel.Data.PgType as PgTable+import Sqel.Data.PgType (+  ColumnType (ColumnPrim),+  PgColumn (PgColumn),+  PgColumnName (PgColumnName),+  PgColumns (PgColumns),+  PgTable (PgTable),+  )+import Sqel.Data.Projection (Projection)+import Sqel.Data.QuerySchema (QuerySchema (QuerySchema))+import Sqel.Data.Selector (Selector (Selector))+import Sqel.Data.Sql (Sql (Sql), sql)+import Sqel.Data.SqlFragment (+  CommaSep (CommaSep),+  Delete (Delete),+  Insert (Insert),+  Returning (Returning),+  Update (Update),+  )+import Sqel.Data.TableSchema (TableSchema (TableSchema))+import Sqel.ResultShape (ResultShape (resultShape))+import qualified Sqel.Sql.Select as Sql+import qualified Sqel.Sql.Type as Sql+import Sqel.Text.Quote (dquote)++statement ::+  ResultShape d result =>+  Bool ->+  Sql ->+  Row d ->+  Params p ->+  Statement p result+statement prep (Sql s) row params =+  Statement (encodeUtf8 s) params (resultShape row) prep++unprepared ::+  ∀ result d p .+  ResultShape d result =>+  Sql ->+  Row d ->+  Params p ->+  Statement p result+unprepared =+  statement False++prepared ::+  ResultShape d result =>+  Sql ->+  Row d ->+  Params p ->+  Statement p result+prepared =+  statement True++plain :: Sql -> Statement () ()+plain s =+  Statement (encodeUtf8 s) mempty noResult False++selectWhere ::+  ∀ result proj q table .+  ResultShape proj result =>+  QuerySchema q table ->+  Projection proj table ->+  Statement q result+selectWhere q@(QuerySchema _ (Encoder qp _)) t =+  prepared (Sql.selectWhereGen q t) (t ^. #decoder) qp++delete ::+  ResultShape a result =>+  QuerySchema q a ->+  TableSchema a ->+  Statement q result+delete (QuerySchema query (Encoder qp _)) (TableSchema col row _) =+  prepared [sql|##{Delete col} ##{query} ##{Returning col}|] row qp++insert ::+  TableSchema a ->+  Statement a ()+insert (TableSchema col _ params) =+  prepared [sql|##{Insert col}|] unit params++uniqueColumn :: PgColumn -> Maybe Selector+uniqueColumn = \case+  PgColumn (PgColumnName name) (ColumnPrim _ True _) ->+    Just (Selector (Sql (dquote name)))+  _ ->+    Nothing++pattern UniqueName :: Selector -> PgColumn+pattern UniqueName sel <- (uniqueColumn -> Just sel)++conflictFragment ::+  PgTable a ->+  Sql+conflictFragment table@PgTable {columns = PgColumns columns} =+  format uniques+  where+    format Nothing =+      ""+    format (Just cols) =+      [sql|on conflict (##{CommaSep (toList cols)}) do ##{Update table}|]+    uniques =+      nonEmpty [n | UniqueName (Selector n) <- columns]++upsertSql :: PgTable a -> Sql+upsertSql tab =+  [sql|##{Insert tab} #{conflict}|]+  where+    conflict = conflictFragment tab++upsert ::+  TableSchema a ->+  Statement a ()+upsert (TableSchema tab _ params) =+  prepared (upsertSql tab) unit params++dbColumns ::+  Sql ->+  Statement Text [(Text, Text, Text, Maybe Text)]+dbColumns code =+  prepared code decoder encoder+  where+    decoder =+      (,,,) <$> text' <*> text' <*> text' <*> Decoders.column (Decoders.nullable Decoders.text)+    text' =+      Decoders.column (Decoders.nonNullable Decoders.text)+    encoder =+      Encoders.param (Encoders.nonNullable Encoders.text)++columnsSql :: Sql -> Sql -> Sql -> Sql+columnsSql entity container namePrefix =+  [sql|select c.#{entity}_name, c.data_type, c.#{namePrefix}udt_name, e.data_type+       from information_schema.#{entity}s c left join information_schema.element_types e+       on ((c.#{container}_catalog, c.#{container}_schema, c.#{container}_name, 'TABLE', c.dtd_identifier)+       = (e.object_catalog, e.object_schema, e.object_name, e.object_type, e.collection_type_identifier))+       where c.#{container}_name = $1|]++tableColumnsSql :: Sql+tableColumnsSql =+  columnsSql "column" "table" ""++typeColumnsSql :: Sql+typeColumnsSql =+  columnsSql "attribute" "udt" "attribute_"++createTable :: PgTable a -> Statement () ()+createTable table =+  unprepared (Sql.createTable table) unit mempty
+ lib/Sqel/Sum.hs view
@@ -0,0 +1,171 @@+module Sqel.Sum where++import Generics.SOP (NP ((:*)))+import Generics.SOP.GGP (GCode, GDatatypeInfoOf)+import Generics.SOP.Type.Metadata (ConstructorInfo (Constructor, Infix, Record), DatatypeInfo (ADT))+import Prelude hiding (sum)+import Sqel.Comp (CompColumn (compColumn), CompName (compName), ConstructorFields, MetaFor, RecordFields)+import Sqel.Data.Dd (+  Comp (Prod, Sum),+  CompInc (Merge, Nest),+  ConCol,+  Dd (Dd),+  DdInc (DdMerge, DdNest),+  DdK (DdK),+  DdSort (DdCon, DdSum),+  DdStruct (DdComp, DdPrim),+  DdType,+  ProdType (Con),+  ProductField (ProductField),+  Struct (Comp, Prim),+  )+import Sqel.Data.Mods (pattern NoMods, NoMods)+import Sqel.Data.Sel (+  IndexName,+  MkTSel (mkTSel),+  Sel (SelAuto, SelIndex),+  SelPrefix (DefaultPrefix, SelPrefix),+  SelW (SelWAuto, SelWIndex),+  TSel (TSel),+  TypeName,+  )+import Sqel.Merge (merge)+import Sqel.Names.Rename (Rename (rename))+import Sqel.Names.Set (SetName)+import Sqel.Prim (IndexColumn, IndexColumnWith, primIndex)+import qualified Sqel.Type as T+import Type.Errors (ErrorMessage (Text))++type family SumFields' (fields :: [ConstructorInfo]) (ass :: [[Type]]) :: [ProductField] where+  SumFields' '[] '[] = '[]+  SumFields' ('Record name fields : cons) (as : ass) = 'ProductField name (ConCol name 'True (RecordFields fields as) as) : SumFields' cons ass+  SumFields' ('Constructor name : cons) (as : ass) = 'ProductField name (ConCol name 'False (ConstructorFields name 0 as) as) : SumFields' cons ass+  SumFields' ('Infix conName _ _ : _) _ =+    TypeError ("Infix constructor not supported: " <> conName)++type family SumFields (info :: DatatypeInfo) (ass :: [[Type]]) :: [ProductField] where+  SumFields ('ADT _ _ cons _) ass = SumFields' cons ass+  SumFields info _ =+    TypeError ("SumFields:" % info)++class DdType s ~ a => SumWith a isel imods arg s | a isel imods arg -> s where+  sumWith :: Dd ('DdK isel imods Int64 'Prim) -> arg -> Dd s++-- TODO b ~ a is not needed here, apparently, but it is for ConColumn. investigate and remove here+instance (+    b ~ a,+    CompName a ('TSel prefix name),+    fields ~ SumFields (GDatatypeInfoOf a) (GCode a),+    meta ~ MetaFor "sum type" ('ShowType a) "sum",+    CompColumn meta fields a arg s+  ) => SumWith b isel imods arg ('DdK 'SelAuto NoMods a ('Comp ('TSel prefix name) 'Sum 'Nest ('DdK isel imods Int64 'Prim : s))) where+  sumWith index arg =+    Dd SelWAuto NoMods (DdComp (compName @a) DdSum DdNest (index :* compColumn @meta @fields @a arg))++class DdType s ~ a => Sum a arg s | a arg -> s where+  sum :: arg -> Dd s++-- TODO b ~ a is not needed here, apparently, but it is for ConColumn. investigate and remove here+instance (+    b ~ a,+    CompName a ('TSel prefix name),+    IndexName 'DefaultPrefix name iname,+    fields ~ SumFields (GDatatypeInfoOf a) (GCode a),+    meta ~ MetaFor "sum type" ('ShowType a) "sum",+    CompColumn meta fields a arg s+  ) => Sum b arg ('DdK 'SelAuto NoMods a ('Comp ('TSel prefix name) 'Sum 'Nest (IndexColumn name : s))) where+  sum =+    sumWith primIndex++sumAs ::+  ∀ (name :: Symbol) (a :: Type) (s :: DdK) (arg :: Type) .+  Sum a arg s =>+  Rename s (SetName s name) =>+  arg ->+  Dd (SetName s name)+sumAs =+  rename . sum @a @_ @s++mergeSum ::+  ∀ (a :: Type) (s :: DdK) (arg :: Type) .+  Sum a arg s =>+  arg ->+  Dd (T.Merge s)+mergeSum =+  merge . sum @a @_ @s++class DdType s ~ a => ConColumn a arg s | a arg -> s where+  con :: arg -> Dd s++instance (+    a ~ ConCol name record fields as,+    MkTSel ('TSel 'DefaultPrefix name),+    meta ~ MetaFor "constructor" ('Text name) "con",+    CompColumn meta fields a arg s+  ) => ConColumn a arg ('DdK 'SelAuto NoMods (ConCol name record fields as) ('Comp ('TSel 'DefaultPrefix name) ('Prod ('Con as)) 'Nest s)) where+  con arg =+    Dd SelWAuto NoMods (DdComp mkTSel DdCon DdNest (compColumn @meta @fields @(ConCol name record fields as) arg))++conAs ::+  ∀ (name :: Symbol) (a :: Type) (s :: DdK) (arg :: Type) .+  ConColumn a arg s =>+  Rename s (SetName s name) =>+  arg ->+  Dd (SetName s name)+conAs =+  rename . con @a @_ @s++type family Con1Fields (con :: Type) :: [ProductField] where+  Con1Fields (ConCol _ 'True '[f] _) = '[f]+  Con1Fields (ConCol name 'False '[ 'ProductField _ a] _) = '[ 'ProductField name a]++class DdType s ~ a => Con1Column a arg s | a arg -> s where+  con1 :: arg -> Dd s++instance (+    a ~ ConCol name record fields as,+    TypeName 'DefaultPrefix name tname,+    meta ~ MetaFor "constructor" ('Text name) "con1",+    CompColumn meta (Con1Fields a) a arg s+  ) => Con1Column a arg ('DdK 'SelAuto NoMods (ConCol name record fields as) ('Comp ('TSel 'DefaultPrefix name) ('Prod ('Con as)) 'Merge s)) where+  con1 arg =+    Dd SelWAuto NoMods (DdComp mkTSel DdCon DdMerge (compColumn @meta @(Con1Fields a) @(ConCol name record fields as) arg))++type family RenameCon1 (name :: Symbol) (a :: Type) :: Type where+  RenameCon1 name (ConCol _ record '[ 'ProductField _ a] as) =+    ConCol name record '[ 'ProductField name a] as+  RenameCon1 _ a =+    TypeError ("RenameCon1:" % a)++class DdType s ~ a => Con1AsColumn name a arg s | name a arg -> s where+  con1As :: arg -> Dd s++instance (+    a ~ ConCol _name record _fields as,+    TypeName 'DefaultPrefix name tname,+    fields ~ Con1Fields (RenameCon1 name a),+    meta ~ MetaFor "constructor" ('Text name) "con1As",+    CompColumn meta fields a arg s+  ) => Con1AsColumn name a arg ('DdK 'SelAuto NoMods a ('Comp ('TSel 'DefaultPrefix name) ('Prod ('Con as)) 'Merge s)) where+  con1As arg =+    Dd SelWAuto NoMods (DdComp mkTSel DdCon DdMerge (compColumn @meta @fields @a arg))++type SetIndexPrefix :: Symbol -> DdK -> DdK -> Constraint+class SetIndexPrefix prefix s0 s1 | prefix s0 -> s1 where+  setIndexPrefix :: Dd s0 -> Dd s1++instance (+    IndexName ('SelPrefix prefix) tpe iname+  ) => SetIndexPrefix prefix ('DdK sel mods a ('Comp tsel 'Sum i ('DdK ('SelIndex oldPrefix tpe) NoMods Int64 'Prim : cons))) ('DdK sel mods a ('Comp tsel 'Sum i (IndexColumnWith ('SelPrefix prefix) tpe : cons))) where+    setIndexPrefix (Dd sel mods (DdComp tsel DdSum i (Dd (SelWIndex Proxy) NoMods DdPrim :* cons))) =+      Dd sel mods (DdComp tsel DdSum i (Dd (SelWIndex Proxy) NoMods DdPrim :* cons))+    setIndexPrefix _ =+      error "ghc bug?"++indexPrefix ::+  ∀ prefix s0 s1 .+  SetIndexPrefix prefix s0 s1 =>+  Dd s0 ->+  Dd s1+indexPrefix =+  setIndexPrefix @prefix
+ lib/Sqel/Text/Case.hs view
@@ -0,0 +1,25 @@+module Sqel.Text.Case where++import Data.Char (isLower, isUpper, toLower)+import Data.Composition ((.:))++unCamelCaseString :: Char -> String -> String+unCamelCaseString sep =+  fmap toLower . reverse . foldl f []+  where+    f [] c =+      [c]+    f (h1 : h2 : t) c | isLower c && isUpper h1 && isUpper h2 =+      c : h1 : sep : h2 : t+    f (h : t) c | isUpper c && isLower h =+      c : sep : h : t+    f z c =+      c : z++unCamelCase :: Char -> String -> Text+unCamelCase =+  toText .: unCamelCaseString++unCamelCaseText :: Char -> Text -> Text+unCamelCaseText sep =+  unCamelCase sep . toString
+ lib/Sqel/Text/DbIdentifier.hs view
@@ -0,0 +1,26 @@+module Sqel.Text.DbIdentifier where++import Data.List (dropWhileEnd)++import Sqel.SOP.Constraint (symbolString)+import Sqel.Text.Case (unCamelCase)+import Sqel.Text.Quote (dquote)++dbIdentifier :: String -> Text+dbIdentifier =+  unCamelCase '_' . dropWhile ('_' ==) . dropWhileEnd ('_' ==)++dbIdentifierT :: Text -> Text+dbIdentifierT =+  dbIdentifier . toString++quotedDbId :: Text -> Text+quotedDbId =+  dquote . dbIdentifierT++dbSymbol ::+  ∀ name .+  KnownSymbol name =>+  Text+dbSymbol =+  dbIdentifier (symbolString @name)
+ lib/Sqel/Text/Quote.hs view
@@ -0,0 +1,11 @@+module Sqel.Text.Quote where++import Exon (Exon, exon)++squote :: Exon a => a -> a+squote a =+  [exon|'#{a}'|]++dquote :: Exon a => a -> a+dquote a =+  [exon|"#{a}"|]
+ lib/Sqel/Type.hs view
@@ -0,0 +1,103 @@+module Sqel.Type where++import Generics.SOP.GGP (GCode, GDatatypeInfoOf)+import Generics.SOP.Type.Metadata (ConstructorInfo (Record), DatatypeInfo (ADT), FieldInfo (FieldInfo))+import Prelude hiding (Mod)+import qualified Sqel.Data.Dd as Kind+import Sqel.Data.Dd (DdK (DdK), Struct (Comp))+import Sqel.Data.Mods (Newtype, NoMods)+import Sqel.Data.Sel (Sel (SelAuto, SelSymbol, SelUnused), SelPrefix (DefaultPrefix), TSel (TSel))+import Sqel.Data.SelectExpr (SelectAtom)+import Sqel.Kind (type (++))+import Sqel.SOP.Constraint (DataName)+import Sqel.SOP.Error (QuotedType)++type family Prod (a :: Type) :: DdK where+  Prod a =+    'DdK 'SelAuto NoMods a ('Comp ('TSel 'DefaultPrefix (DataName a)) ('Kind.Prod 'Kind.Reg) 'Kind.Nest '[])++type family Merge (dd :: DdK) :: DdK where+  Merge ('DdK sel mods a ('Comp tsel c _ sub)) = 'DdK sel mods a ('Comp tsel c 'Kind.Merge sub)+  Merge s = s++-- TODO this could accept the type on the lhs and call Prod+type (*>) :: DdK -> k -> DdK+type family (*>) base sub++type instance ('DdK sel mods a ('Comp tsel c i '[])) *> (sub :: [DdK]) =+  'DdK sel mods a ('Comp tsel c i sub)++type instance ('DdK sel mods a ('Comp tsel c i '[])) *> (sub :: DdK) =+  'DdK sel mods a ('Comp tsel c i '[sub])++infix 4 *>++type (>) :: DdK -> k -> [DdK]+type family (>) a b+type instance a > (b :: [DdK]) = a : b+type instance a > (b :: DdK) = [a, b]++infixr 5 >++type family PrimSel (sel :: Sel) (a :: Type) :: DdK where+  PrimSel sel a = 'DdK sel NoMods a 'Kind.Prim++type family PrimUnused (a :: Type) :: DdK where+  PrimUnused a = PrimSel 'SelUnused a++type family Prim (name :: Symbol) (a :: Type) :: DdK where+  Prim name a = PrimSel ('SelSymbol name) a++type family NewtypeWrapped' (a :: Type) (ass :: [[Type]]) :: Type where+  NewtypeWrapped' _ '[ '[w]] = w+  NewtypeWrapped' a _ = TypeError (QuotedType a <> " is not a newtype.")++type family NewtypeWrapped (a :: Type) :: Type where+  NewtypeWrapped a = NewtypeWrapped' a (GCode a)++type family PrimNewtype (name :: Symbol) (a :: Type) :: DdK where+  PrimNewtype name a = Mod (Newtype a (NewtypeWrapped a)) (Prim name a)++type family Name (name :: Symbol) (dd :: DdK) :: DdK where+  Name name ('DdK _ mods a s) =+    'DdK ('SelSymbol name) mods a s++type family TypeSel (tsel :: TSel) (dd :: DdK) :: DdK where+  TypeSel tsel ('DdK sel mods a ('Comp _ c i sub)) =+    'DdK sel mods a ('Comp tsel c i sub)++type family ProdPrimFields (as :: [Type]) (fields :: [FieldInfo]) :: [DdK] where+  ProdPrimFields '[] '[] = '[]+  ProdPrimFields (a : as) ('FieldInfo name : fields) =+    Prim name a : ProdPrimFields as fields++type family ProdPrims' (a :: Type) (code :: [[Type]]) (info :: DatatypeInfo) :: DdK where+  ProdPrims' a '[as] ('ADT _ name '[ 'Record _ fields] _) =+    'DdK 'SelAuto NoMods a ('Comp ('TSel 'DefaultPrefix name) ('Kind.Prod 'Kind.Reg) 'Kind.Nest (ProdPrimFields as fields))++type family ProdPrims (a :: Type) :: DdK where+  ProdPrims a = ProdPrims' a (GCode a) (GDatatypeInfoOf a)++type family ProdPrimNewtypeFields (as :: [Type]) (fields :: [FieldInfo]) :: [DdK] where+  ProdPrimNewtypeFields '[] '[] = '[]+  ProdPrimNewtypeFields (a : as) ('FieldInfo name : fields) =+    PrimNewtype name a : ProdPrimNewtypeFields as fields++type family ProdPrimsNewtype' (a :: Type) (code :: [[Type]]) (info :: DatatypeInfo) :: DdK where+  ProdPrimsNewtype' a '[as] ('ADT _ name '[ 'Record _ fields] _) =+    'DdK 'SelAuto NoMods a ('Comp ('TSel 'DefaultPrefix name) ('Kind.Prod 'Kind.Reg) 'Kind.Nest (ProdPrimNewtypeFields as fields))++type family ProdPrimsNewtype (a :: Type) :: DdK where+  ProdPrimsNewtype a = ProdPrimsNewtype' a (GCode a) (GDatatypeInfoOf a)++type family Mods (mods :: [Type]) (dd :: DdK) :: DdK where+  Mods new ('DdK sel old a s) = 'DdK sel (new ++ old) a s++type family ModsR (mods :: [Type]) (dd :: DdK) :: DdK where+  ModsR new ('DdK sel old a s) = 'DdK sel (old ++ new) a s++type family Mod (mod :: Type) (dd :: DdK) :: DdK where+  Mod mod dd = Mods '[mod] dd++type family MSelect (dd :: DdK) :: DdK where+  MSelect dd = Mod SelectAtom dd
+ lib/Sqel/Uid.hs view
@@ -0,0 +1,48 @@+module Sqel.Uid where++import Sqel.Data.Dd (Dd, DdK, DdType, DdTypeSel, type (:>) ((:>)))+import Sqel.Data.Uid (Uid)+import Sqel.Merge (merge)+import Sqel.Names.Rename (Rename, rename)+import Sqel.Names.Set (SetTypeName)+import Sqel.Product (ProductSel (prodSel))+import qualified Sqel.Type as T+import Sqel.Type (type (*>), type (>))++type UidDd si sa =+  T.TypeSel (DdTypeSel sa) (T.Prod (Uid (DdType si) (DdType sa))) *> T.Name "id" si > T.Merge sa++type UidColumn :: Type -> Type -> DdK -> DdK -> DdK -> Constraint+class (+    DdType si ~ i,+    DdType sa ~ a+  ) => UidColumn i a si sa s | i a si sa -> s where+    uidColumn :: Dd si -> Dd sa -> Dd s++instance (+    DdType si ~ i,+    DdType sa ~ a,+    DdTypeSel sa ~ sel,+    ProductSel sel (Uid i a) (Dd si :> Dd (T.Merge sa)) s+  ) => UidColumn i a si sa s where+    uidColumn i a =+      prodSel @sel @(Uid i a) (i :> merge a)++uid ::+  ∀ (i :: Type) (a :: Type) (si :: DdK) (sa :: DdK) (s :: DdK) .+  UidColumn i a si sa s =>+  Dd si ->+  Dd sa ->+  Dd s+uid =+  uidColumn++uidAs ::+  ∀ (name :: Symbol) (i :: Type) (a :: Type) (si :: DdK) (sa :: DdK) (s :: DdK) .+  UidColumn i a si sa s =>+  Rename s (SetTypeName s name) =>+  Dd si ->+  Dd sa ->+  Dd (SetTypeName s name)+uidAs i a =+  rename (uidColumn i a)
+ sqel.cabal view
@@ -0,0 +1,306 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.35.0.+--+-- see: https://github.com/sol/hpack++name:           sqel+version:        0.0.1.0+synopsis:       Guided derivation for Hasql statements+description:    See https://hackage.haskell.org/package/sqel/docs/Sqel.html+category:       Database+homepage:       https://git.tryp.io/tek/sqel+bug-reports:    https://github.com/tek/sqel/issues+author:         Torsten Schmits+maintainer:     hackage@tryp.io+copyright:      2023 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple++source-repository head+  type: git+  location: https://git.tryp.io/tek/sqel++library+  exposed-modules:+      Sqel+      Sqel.Class.MatchView+      Sqel.Class.MigrationEffect+      Sqel.Class.Mods+      Sqel.Codec+      Sqel.Codec.PrimDecoder+      Sqel.Codec.PrimEncoder+      Sqel.Codec.Product+      Sqel.Codec.Sum+      Sqel.Column+      Sqel.ColumnConstraints+      Sqel.Comp+      Sqel.Data.Codec+      Sqel.Data.Dd+      Sqel.Data.FieldPath+      Sqel.Data.FragType+      Sqel.Data.Migration+      Sqel.Data.MigrationParams+      Sqel.Data.Mods+      Sqel.Data.Order+      Sqel.Data.PgType+      Sqel.Data.PgTypeName+      Sqel.Data.Projection+      Sqel.Data.ProjectionWitness+      Sqel.Data.QuerySchema+      Sqel.Data.Sel+      Sqel.Data.SelectExpr+      Sqel.Data.Selector+      Sqel.Data.Sql+      Sqel.Data.SqlFragment+      Sqel.Data.TableSchema+      Sqel.Data.Term+      Sqel.Data.Uid+      Sqel.Ext+      Sqel.Kind+      Sqel.Merge+      Sqel.Migration.Column+      Sqel.Migration.Consistency+      Sqel.Migration.Data.Ddl+      Sqel.Migration.Ddl+      Sqel.Migration.Init+      Sqel.Migration.Metadata+      Sqel.Migration.Run+      Sqel.Migration.Statement+      Sqel.Migration.Table+      Sqel.Migration.Transform+      Sqel.Migration.Type+      Sqel.Mods+      Sqel.Names+      Sqel.Names.Data+      Sqel.Names.Error+      Sqel.Names.Rename+      Sqel.Names.Set+      Sqel.PgType+      Sqel.Prim+      Sqel.Product+      Sqel.Query+      Sqel.Query.Combinators+      Sqel.Query.Fragments+      Sqel.Query.SelectExpr+      Sqel.ReifyCodec+      Sqel.ReifyDd+      Sqel.ResultShape+      Sqel.SOP.Constraint+      Sqel.SOP.Enum+      Sqel.SOP.Error+      Sqel.SOP.HasGeneric+      Sqel.SOP.Newtype+      Sqel.Sql+      Sqel.Sql.Prepared+      Sqel.Sql.Select+      Sqel.Sql.Type+      Sqel.Statement+      Sqel.Sum+      Sqel.Text.Case+      Sqel.Text.DbIdentifier+      Sqel.Text.Quote+      Sqel.Type+      Sqel.Uid+  hs-source-dirs:+      lib+  default-extensions:+      StandaloneKindSignatures+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyCase+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedLabels+      OverloadedLists+      OverloadedStrings+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages+  build-depends:+      aeson ==2.0.*+    , base >=4.12 && <5+    , chronos ==1.1.*+    , composition ==1.0.*+    , containers+    , contravariant ==1.5.*+    , exon ==1.4.*+    , extra ==1.7.*+    , first-class-families ==0.8.*+    , generic-lens ==2.2.*+    , generics-sop ==0.5.*+    , hasql ==1.6.*+    , incipit-base ==0.5.*+    , invariant ==0.6.*+    , microlens ==0.4.*+    , path ==0.9.*+    , path-io ==1.7.*+    , prettyprinter ==1.7.*+    , scientific ==0.3.*+    , singletons >=3 && <3.1+    , singletons-base ==3.1.*+    , some ==1.0.*+    , template-haskell+    , time+    , transformers+    , type-errors ==0.2.*+    , uuid ==1.3.*+    , vector ==0.12.*+  mixins:+      base hiding (Prelude)+    , incipit-base (IncipitBase as Prelude)+    , incipit-base hiding (IncipitBase)+  default-language: Haskell2010++test-suite sqel-unit+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Sqel.Test.Bug+      Sqel.Test.Error.CantInferCheckQuery+      Sqel.Test.Error.CompArgs+      Sqel.Test.Error.HigherOrderColumn+      Sqel.Test.Error.NewtypeNoGeneric+      Sqel.Test.Error.NewtypeNoNewtype+      Sqel.Test.Error.PolyHasField+      Sqel.Test.Error.QueryColumMismatch+      Sqel.Test.ErrorTest+      Sqel.Test.HasGeneric+      Sqel.Test.MigrationTest+      Sqel.Test.QueryProjectionTest+      Sqel.Test.SqlCodeTest+      Sqel.Test.StatementTest+      Test+  hs-source-dirs:+      test+  default-extensions:+      StandaloneKindSignatures+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyCase+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedLabels+      OverloadedLists+      OverloadedStrings+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.12 && <5+    , exon ==1.4.*+    , generics-sop ==0.5.*+    , hedgehog ==1.1.*+    , incipit-base ==0.5.*+    , microlens ==0.4.*+    , sqel+    , tasty ==1.4.*+    , tasty-hedgehog ==1.3.*+  mixins:+      base hiding (Prelude)+    , incipit-base (IncipitBase as Prelude)+    , incipit-base hiding (IncipitBase)+  default-language: Haskell2010
+ test/Main.hs view
@@ -0,0 +1,26 @@+module Main where++import Sqel.Test.ErrorTest (test_errors)+import Sqel.Test.HasGeneric (test_hasGeneric)+import Sqel.Test.MigrationTest (test_migration)+import Sqel.Test.QueryProjectionTest (test_queryProjection)+import Sqel.Test.SqlCodeTest (test_sqlCodeNoInterpolation)+import Sqel.Test.StatementTest (test_statement)+import Test (unitTest)+import Test.Tasty (TestTree, defaultMain, testGroup)++tests :: TestTree+tests =+  testGroup "all" [+    unitTest "migration" test_migration,+    test_errors,+    test_statement,+    unitTest "query with a projection" test_queryProjection,+    unitTest "sql quote without interpolation" test_sqlCodeNoInterpolation,+    unitTest "HasGeneric" test_hasGeneric,+    unitTest "migration" test_migration+  ]++main :: IO ()+main =+  defaultMain tests
+ test/Sqel/Test/Bug.hs view
@@ -0,0 +1,90 @@+{-# options_ghc -fconstraint-solver-iterations=10 #-}++module Sqel.Test.Bug where++import Sqel.Comp (Column)+import Sqel.Data.Codec (FullCodec)+import Sqel.Data.Dd (Dd, DdType, type (:>) ((:>)))+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Merge (merge)+import Sqel.Names (named)+import Sqel.Prim (prim, prims)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.ReifyCodec (reifyCodec)+import Sqel.Type (Merge, Prim, Prod, type (*>), type (>))++data Wrap a = Wrap { w :: a }+  deriving stock (Eq, Show, Generic)++data Wrap2 a = Wrap2 { id :: Text, w :: a }+  deriving stock (Eq, Show, Generic)++type DdWrap d s = Prod (Wrap d) *> Merge s++type DdWrap2 s = (Prod (Wrap2 (DdType s))) *> Prim "id" Text > Merge s++ddWrap2 ::+  ∀ d s merged .+  merged ~ Merge s =>+  Column d "w" merged merged =>+  Dd s ->+  Dd (DdWrap2 (DdWrap d s))+ddWrap2 w =+  prod (prim :> merge (prod (merge w)))++data Bug =+  Bug {+    a :: Int,+    b :: Int,+    c :: Int,+    d :: Int,+    e :: Int+  }+  deriving stock (Eq, Show, Generic)++type DdBug =+  Prod Bug *>+    Prim "a" Int >+    Prim "b" Int >+    Prim "c" Int >+    Prim "d" Int >+    Prim "e" Int++data WrapBug =+  WrapBug { w :: Bug }+  deriving stock (Eq, Show, Generic)++type DdWrapBug =+  Prod WrapBug *> Merge DdBug++type DdWrap2WrapBug =+  DdWrap2 DdWrapBug++ddBug :: Dd DdBug+ddBug =+  prod prims++ddWrapBug :: Dd DdWrapBug+ddWrapBug =+  prod (merge ddBug)++ddUidWrapBug :: Dd DdWrap2WrapBug+ddUidWrapBug =+  prod (prim :> merge ddWrapBug)++ddWrapWrapBug :: Dd (DdWrap2 (DdWrap WrapBug DdWrapBug))+ddWrapWrapBug =+  ddWrap2 ddWrapBug++schemaUidWrapBug :: FullCodec (Wrap2 WrapBug)+schemaUidWrapBug =+  reifyCodec ddUidWrapBug++schemaWrapWrapBug :: FullCodec (Wrap2 (Wrap WrapBug))+schemaWrapWrapBug =+  reifyCodec ddWrapWrapBug++queryUidWrapBug :: QuerySchema Int (Wrap2 WrapBug)+queryUidWrapBug =+  checkQuery (named @"a" prim) ddUidWrapBug
+ test/Sqel/Test/Error/CantInferCheckQuery.hs view
@@ -0,0 +1,39 @@+{-# options_ghc -fdefer-type-errors -Wno-deferred-type-errors -Wno-partial-type-signatures #-}++module Sqel.Test.Error.CantInferCheckQuery where++import Sqel.Data.Dd (Dd)+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.Sql (Sql, ToSql (toSql))+import Sqel.Data.SqlFragment (SelectQuery (SelectQuery))+import Sqel.Prim (prim)+import Sqel.Product (prod)+import Sqel.Query (CheckQuery (checkQuery))++data Dat =+  Dat {+    name :: Text+  }+  deriving stock (Eq, Show, Generic)++data Q =+  Q {+    name :: Text+  }+  deriving stock (Eq, Show, Generic)++dd :: Dd (_ _ Dat _)+dd =+  undefined++ddq :: Dd (_ _ Q _)+ddq =+  prod prim++qs :: QuerySchema Q Dat+qs =+  checkQuery ddq dd++cantInferCheckQuery :: Sql+cantInferCheckQuery =+  toSql (SelectQuery qs)
+ test/Sqel/Test/Error/CompArgs.hs view
@@ -0,0 +1,66 @@+{-# options_ghc -Wno-partial-type-signatures -fdefer-type-errors -Wno-deferred-type-errors #-}++module Sqel.Test.Error.CompArgs where++import Generics.SOP (NP (Nil, (:*)))++import Sqel.Column (nullable)+import Sqel.Data.Dd (Dd (Dd), DdK (DdK), DdStruct (DdComp), (:>) ((:>)))+import Sqel.Prim (prim)+import Sqel.Product (prod)++data Pr =+  Pr {+    pr1 :: Text,+    pr2 :: Int,+    pr3 :: Text+  }+  deriving stock (Eq, Show, Generic)++data Dat =+  Dat {+    name :: Maybe Text,+    p :: Pr+  }+  deriving stock (Eq, Show, Generic)++ddTooFew :: Dd ('DdK _ _ Dat _)+ddTooFew =+  prod (+    nullable prim :>+    prod prim+  )++prodTooFew :: ()+prodTooFew =+  case ddTooFew of+    Dd _ _ (DdComp _ _ _ (_ :* (Dd _ _ (DdComp _ _ _ (Dd _ _ _ :* _))) :* Nil)) ->+      ()+    Dd _ _ (DdComp _ _ _ (_ :* (Dd _ _ (DdComp _ _ _ _)) :* Nil)) ->+      ()++ddTooMany :: Dd ('DdK _ _ Dat _)+ddTooMany =+  prod (+    nullable prim :>+    prod (prim :> prim :> prim :> prim :> prim)+  )++prodTooMany :: ()+prodTooMany =+  case ddTooMany of+    Dd _ _ (DdComp _ _ _ (_ :* (Dd _ _ (DdComp _ _ _ (Dd _ _ _ :* _))) :* Nil)) ->+      ()++ddBadType :: Dd ('DdK _ _ Dat _)+ddBadType =+  prod (+    nullable prim :>+    prod (prim :> False :> prim)+  )++prodBadType :: ()+prodBadType =+  case ddBadType of+    Dd _ _ (DdComp _ _ _ (_ :* (Dd _ _ (DdComp _ _ _ (_ :* (Dd _ _ _) :* _ :* Nil))) :* Nil)) ->+      ()
+ test/Sqel/Test/Error/HigherOrderColumn.hs view
@@ -0,0 +1,50 @@+{-# options_ghc -Wno-partial-type-signatures -fdefer-type-errors -Wno-deferred-type-errors #-}++module Sqel.Test.Error.HigherOrderColumn where++import Generics.SOP (NP (Nil, (:*)))++import Sqel.Data.Dd (Dd (Dd), DdK (DdK), DdStruct (DdComp), (:>) ((:>)), DdTypeSel, DdType)+import Sqel.Prim (prim, prims)+import Sqel.Product (prod, prodSel)+import Sqel.Type (Prim, Merge, type (>), TypeSel, Prod, type (*>))+import Sqel.Data.Sel (MkTSel)+import Sqel.Merge (merge)++data Pr =+  Pr {+    pr1 :: Text,+    pr2 :: Int,+    pr3 :: Text+  }+  deriving stock (Eq, Show, Generic)++data Wrap a =+  Wrap { wrapped :: a, length :: Int64 }+  deriving stock (Eq, Show, Generic)++type WrapDd sa =+  TypeSel (DdTypeSel sa) (Prod (Wrap (DdType sa))) *> (+    Merge sa >+    Prim "length" Int64+  )++ddHO ::+  ∀ s merged .+  merged ~ Merge s =>+  MkTSel (DdTypeSel s) =>+  -- Column (DdType s) "wrapped" merged merged =>+  Dd s ->+  Dd (WrapDd s)+ddHO wrapped =+  prodSel @(DdTypeSel s) (merge wrapped :> prim)++ddHOCol :: Dd ('DdK _ _ (Wrap Pr) _)+ddHOCol =+  ddHO (prod prims)++higherOrderColumn :: ()+higherOrderColumn =+  case ddHOCol of+    Dd _ _ (DdComp _ _ _ ((Dd _ _ (DdComp _ _ _ (_ :* (Dd _ _ _) :* _ :* Nil))) :* _ :* Nil)) ->+      ()
+ test/Sqel/Test/Error/NewtypeNoGeneric.hs view
@@ -0,0 +1,37 @@+{-# options_ghc -fdefer-type-errors -Wno-deferred-type-errors -Wno-partial-type-signatures #-}++module Sqel.Test.Error.NewtypeNoGeneric where++import Generics.SOP (I (I), NP (Nil, (:*)))++import Sqel.Data.Dd (Dd (Dd), DdStruct (DdComp), type (:>) ((:>)))+import Sqel.Data.Mods (Mods (Mods), Newtype (Newtype))+import Sqel.Prim (prim, primNewtype)+import Sqel.Product (prod)++newtype TextNt = TextNt { unTextNt :: Text }+  deriving stock (Eq, Show)++data Dat =+  Dat {+    name :: Text,+    po :: TextNt+  }+  deriving stock (Eq, Show, Generic)++dd :: Dd (_ _ Dat _)+dd =+  prod (+    prim :>+    primNewtype+  )++useMod :: Text+useMod =+  case dd of+    Dd _ _ (DdComp _ _ _ (_ :* Dd _ (Mods (I (Newtype unwrap _) :* Nil)) _ :* Nil)) ->+      unwrap (TextNt "asdf")++newtypeNoGeneric :: Text+newtypeNoGeneric =+  useMod
+ test/Sqel/Test/Error/NewtypeNoNewtype.hs view
@@ -0,0 +1,37 @@+{-# options_ghc -fdefer-type-errors -Wno-deferred-type-errors -Wno-partial-type-signatures #-}++module Sqel.Test.Error.NewtypeNoNewtype where++import Generics.SOP (I (I), NP (Nil, (:*)))++import Sqel.Data.Dd+import Sqel.Data.Mods (Mods (Mods), Newtype (Newtype))+import Sqel.Prim (prim, primNewtype)+import Sqel.Product (prod)++data TextNt = TextNt { unTextNt :: Text }+  deriving stock (Eq, Show, Generic)++data Dat =+  Dat {+    name :: Text,+    po :: TextNt+  }+  deriving stock (Eq, Show, Generic)++dd :: Dd (_ _ Dat _)+dd =+  prod (+    prim :>+    primNewtype+  )++useMod :: Text+useMod =+  case dd of+    Dd _ _ (DdComp _ _ _ (_ :* Dd _ (Mods (I (Newtype unwrap _) :* Nil)) _ :* Nil)) ->+      unwrap (TextNt "asdf")++newtypeNoNewtype :: Text+newtypeNoNewtype =+  useMod
+ test/Sqel/Test/Error/PolyHasField.hs view
@@ -0,0 +1,55 @@+{-# options_ghc -fdefer-type-errors -Wno-deferred-type-errors #-}++module Sqel.Test.Error.PolyHasField where++import Prelude hiding (sum)++import Sqel.Class.MatchView (HasField)+import Sqel.Data.Dd (Dd)+import Sqel.Data.Sql (Sql)+import Sqel.PgType (CheckedProjection, MkTableSchema, projection)+import Sqel.Prim (prims)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Sql.Select (selectWhereGen)+import Sqel.Type (ProdPrims)++data Q =+  Q {+    f1 :: Text,+    f2 :: Int+  }+  deriving stock (Eq, Show, Generic)++ddQ :: Dd (ProdPrims Q)+ddQ =+  prod prims++data Dat =+  Dat {+    f1 :: Text,+    f2 :: Int,+    f3 :: Double+  }+  deriving stock (Eq, Show, Generic)++ddDat :: Dd (ProdPrims Dat)+ddDat =+  prod prims++mkSql ::+  ∀ s .+  HasField "f1" Text s =>+  CheckedProjection s s =>+  MkTableSchema s =>+  Dd s ->+  Sql+mkSql table =+  selectWhereGen qs ps+  where+    qs = checkQuery query table+    ps = projection table table+    query = ddQ++polyHasField :: Sql+polyHasField = mkSql ddDat
+ test/Sqel/Test/Error/QueryColumMismatch.hs view
@@ -0,0 +1,45 @@+{-# options_ghc -fdefer-type-errors -Wno-deferred-type-errors #-}++module Sqel.Test.Error.QueryColumMismatch where++import Generics.SOP (NP (Nil, (:*)))+import Prelude hiding (sum)++import Sqel.Data.QuerySchema (QuerySchema (QuerySchema))+import Sqel.Data.SelectExpr (SelectFragment)+import Sqel.Data.Uid (Uid)+import Sqel.Prim (prim, primAs)+import Sqel.Product (prod, prodAs)+import Sqel.Query (checkQuery)+import Sqel.Uid (uid)++data Pord =+  Pord {+    p1 :: Int,+    p2 :: Text+  }+  deriving stock (Eq, Show, Generic)++data Q =+  Q {+    n :: Text,+    pr :: Pord+  }+  deriving stock (Eq, Show, Generic)++data Dat =+  Dat {+    name :: Text,+    po :: Pord+  }+  deriving stock (Eq, Show, Generic)++queryColumnMismatch :: [SelectFragment]+queryColumnMismatch =+  frags+  where+    QuerySchema !frags _ = checkQuery qd td :: QuerySchema Q (Uid Int64 Dat)+    qd =+      prod (primAs @"name" :* (prodAs @"pog" (prim :* prim :* Nil)) :* Nil)+    td =+      uid prim (prod (prim :* (prod (prim :* prim :* Nil)) :* Nil))
+ test/Sqel/Test/ErrorTest.hs view
@@ -0,0 +1,114 @@+module Sqel.Test.ErrorTest where++import qualified Control.Exception as Base+import Control.Exception (evaluate)+import qualified Data.Text as Text+import Hedgehog (TestT, (===))+import Test (unitTest)+import Test.Tasty (TestTree, testGroup)++import Sqel.Test.Error.CompArgs (prodBadType, prodTooFew, prodTooMany)+import Sqel.Test.Error.HigherOrderColumn (higherOrderColumn)+import Sqel.Test.Error.NewtypeNoGeneric (newtypeNoGeneric)+import Sqel.Test.Error.NewtypeNoNewtype (newtypeNoNewtype)+import Sqel.Test.Error.QueryColumMismatch (queryColumnMismatch)++typeError ::+  Show a =>+  [Text] ->+  a ->+  TestT IO ()+typeError msg t =+  withFrozenCallStack do+    e <- liftIO $ Base.try @SomeException do+      !a <- show @Text <$> evaluate t+      pure a+    case e of+      Right _ -> fail "Test did not produce an error."+      Left err -> msg === trunc (drop 1 (lines (show err)))+  where+    trunc =+      if null msg+      then id+      else fmap Text.strip . take (length msg)++queryColumnMismatchMessage :: [Text]+queryColumnMismatchMessage =+    [+      "\8226 The query column \8216pog.p1\8217 with type \8216Int\8217 does not correspond to a table column.",+        "The specified table contains these fields:",+        "name [Text]",+        "po.p1 [Int]",+        "po.p2 [Text]",+        "id [Int64]"+    ]++prodTooFewMessage :: [Text]+prodTooFewMessage =+  [+    "\8226 The product type \8216Pr\8217 has 3 fields, but the expression specifies 1."+  ]++prodTooManyMessage :: [Text]+prodTooManyMessage =+  [+    "\8226 The product type \8216Pr\8217 has 3 fields, but the expression specifies 5."+  ]++prodBadTypeMessage :: [Text]+prodBadTypeMessage =+  [+    "\8226 Element number 2 in the call to \8216prod\8217 has type \8216Bool\8217.",+    "Columns should only be constructed with combinators like \8216prim\8217, \8216prod\8217,",+    "\8216column\8217 that return the proper type, \8216Dd\8217.",+    "Consult the module \8216Sqel.Combinators\8217 for the full API."+  ]++higherOrderColumnMessage :: [Text]+higherOrderColumnMessage =+  [+    "\8226 Could not deduce (Sqel.Comp.Column",+    "(DdType s) \"wrapped\" merged merged)"+  ]++newtypeNoGenericMessage :: [Text]+newtypeNoGenericMessage =+  [+    "\8226 \8216primNewtype\8217 declares a column for a newtype using \8216Generic\8217.",+    "The type \8216TextNt\8217 does not have an instance of \8216Generic\8217.",+    "You can add it like this:",+    "\8216newtype MyType = MyType Text deriving Generic\8217",+    "If you want to use \8216Coercible\8217 instead, use \8216primCoerce\8217."+  ]++newtypeNoNewtypeMessage :: [Text]+newtypeNoNewtypeMessage =+  [+    "\8226 \8216primNewtype\8217 declares a column for a newtype using \8216Generic\8217.",+    "The type \8216TextNt\8217 is not a newtype."+  ]++polyHasFieldMessage :: [Text]+polyHasFieldMessage =+  [+  ]++cantInferCheckQueryMessage :: [Text]+cantInferCheckQueryMessage =+  [+  ]++test_errors :: TestTree+test_errors =+  testGroup "type errors" [+    unitTest "query column mismatch" (typeError queryColumnMismatchMessage queryColumnMismatch),+    unitTest "too few product fields" (typeError prodTooFewMessage prodTooFew),+    unitTest "too many product fields" (typeError prodTooManyMessage prodTooMany),+    unitTest "bad type for product field" (typeError prodBadTypeMessage prodBadType),+    unitTest "higher-order column constraint" (typeError higherOrderColumnMessage higherOrderColumn),+    unitTest "primNewtype without Generic" (typeError newtypeNoGenericMessage newtypeNoGeneric),+    unitTest "primNewtype with ADT" (typeError newtypeNoNewtypeMessage newtypeNoNewtype)+    -- TODO these aren't triggered with deferred errors+    -- unitTest "missing HasField with polymorphic DdK" (typeError polyHasFieldMessage polyHasField)+    -- unitTest "can't infer CheckQuery" (typeError cantInferCheckQueryMessage cantInferCheckQuery)+  ]
+ test/Sqel/Test/HasGeneric.hs view
@@ -0,0 +1,17 @@+module Sqel.Test.HasGeneric where++import Generics.SOP.GGP (GCode)+import Hedgehog (TestT, (===))++import Sqel.SOP.HasGeneric (gcodeResolvesNot, hasNoGeneric)++data Dat =+  Dat { int :: Int }+  deriving stock (Eq, Show, Generic)++test_hasGeneric :: TestT IO ()+test_hasGeneric = do+  True === gcodeResolvesNot @(GCode Int)+  False === gcodeResolvesNot @(GCode Dat)+  True === hasNoGeneric @Int+  False === hasNoGeneric @Dat
+ test/Sqel/Test/MigrationTest.hs view
@@ -0,0 +1,108 @@+{-# options_ghc -Wno-partial-type-signatures #-}++module Sqel.Test.MigrationTest where++import Exon (exon)+import Generics.SOP (Top, hcfoldMap)+import Hedgehog (TestT, (===))+import Lens.Micro ((^.))+import Prelude hiding (sum)+import Sqel.Data.Dd (Dd, DdK (DdK), type (:>) ((:>)))+import qualified Sqel.Data.Migration as Migration+import Sqel.Data.Migration (AutoMigrations, Migration (Migration), Migrations (Migrations), migrate, tableFrom)+import Sqel.Data.Sql (Sql)+import Sqel.Merge (merge)+import Sqel.Migration.Consistency (tableStatements)+import Sqel.Migration.Statement (MigrationStatement, migrationStatementSql, migrationStatements)+import Sqel.Migration.Table (migrateAuto)+import Sqel.Names (typeAs)+import Sqel.Prim (migrateRename, prim, primIndex, primNullable, prims)+import Sqel.Product (prod)+import Sqel.Sum (con, indexPrefix, sum, sumWith)++data Thing =+  Thing1 { x :: Int, y :: Int }+  |+  Thing2 { z :: Int, a :: Int }+  deriving stock (Eq, Show, Generic)++data Dat0 =+  Dat0 {+    name :: Text+  }+  deriving stock (Eq, Show, Generic)++data Dat1 =+  Dat1 {+    num :: Maybe Int,+    name :: Text,+    thing :: Thing+  }+  deriving stock (Eq, Show, Generic)++data Dat =+  Dat {+    num :: Maybe Int,+    name :: Text,+    thing :: Thing+  }+  deriving stock (Eq, Show, Generic)++dd_Dat0 :: Dd ('DdK _ _ Dat0 _)+dd_Dat0 =+  typeAs @"Dat" (prod prims)++dd_Dat1 :: Dd ('DdK _ _ Dat1 _)+dd_Dat1 =+  typeAs @"Dat" (prod (primNullable :> prim :> indexPrefix @"ph_sum_index__" (merge (sum (con prims :> con prims)))))++-- TODO add combi @migrateRenameIndex@+dd_Dat :: Dd ('DdK _ _ Dat _)+dd_Dat =+  prod (primNullable :> prim :> merge (sumWith (migrateRename @"ph_sum_index__Thing" (primIndex @"Thing")) (con prims :> con prims)))++migrations :: AutoMigrations Identity [Dat1, Dat0] Dat+migrations =+  migrate (+    migrateAuto dd_Dat1 dd_Dat :>+    migrateAuto dd_Dat0 dd_Dat1+  )++stmts :: [MigrationStatement]+stmts =+  let Migrations migs = migrations+  in hcfoldMap (Proxy @Top) (\ Migration {tableFrom, actions} -> migrationStatements (tableFrom ^. #name) actions) migs++tableStmts :: [Sql]+tableStmts =+  let Migrations migs = migrations+  in hcfoldMap (Proxy @Top) (\ Migration {tableFrom} -> tableStatements tableFrom) migs++stmtsTarget :: [Sql]+stmtsTarget =+  [+    [exon|alter table "dat" rename column ph_sum_index__thing to sqel_sum_index__thing|],+    [exon|alter table "dat" add column ph_sum_index__thing bigint|],+    [exon|alter table "dat" alter column ph_sum_index__thing set not null|],+    [exon|alter table "dat" add column thing1 sqel_type__thing1|],+    [exon|alter table "dat" alter column thing1 set not null|],+    [exon|alter table "dat" add column thing2 sqel_type__thing2|],+    [exon|alter table "dat" alter column thing2 set not null|],+    [exon|alter table "dat" add column num bigint|],+    [exon|create type "sqel_type__thing1" as ("x" bigint, "y" bigint)|],+    [exon|create type "sqel_type__thing2" as ("z" bigint, "a" bigint)|]+  ]++tableStmtsTarget :: [Sql]+tableStmtsTarget =+  [+    [exon|create table "dat" ("num" bigint, "name" text not null, "ph_sum_index__thing" bigint not null, "thing1" sqel_type__thing1 not null, "thing2" sqel_type__thing2 not null)|],+    [exon|create type "sqel_type__thing1" as ("x" bigint, "y" bigint)|],+    [exon|create type "sqel_type__thing2" as ("z" bigint, "a" bigint)|],+    [exon|create table "dat" ("name" text not null)|]+  ]++test_migration :: TestT IO ()+test_migration = do+  stmtsTarget === (migrationStatementSql <$> stmts)+  tableStmtsTarget === tableStmts
+ test/Sqel/Test/QueryProjectionTest.hs view
@@ -0,0 +1,166 @@+{-# options_ghc -Wno-partial-type-signatures #-}++module Sqel.Test.QueryProjectionTest where++import Hedgehog (TestT, (===))+import Prelude hiding (sum)++import Sqel.Class.MatchView (HasPath, HasField)+import Sqel.Column (pk)+import Sqel.Data.Dd (Dd, DdType, Sqel, type (:>) ((:>)))+import Sqel.Data.Order (Order (Desc))+import Sqel.Data.Sql (Sql, sql)+import Sqel.Data.Uid (Uid)+import Sqel.Merge (merge)+import Sqel.Names (named)+import Sqel.PgType (CheckedProjection, MkTableSchema, projection)+import Sqel.Prim (prim, prims)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import qualified Sqel.Query.Combinators as Q+import Sqel.Sql.Select (selectWhereGen)+import Sqel.Sum (con, con1, sum)+import Sqel.Type (MSelect, Merge, Name, Prim, PrimUnused, Prod, type (*>), type (>))+import Sqel.Uid (uid)++data Thing =+  Thing {+    t_a :: Int,+    t_b :: Text,+    t_c :: Double+  }+  deriving stock (Eq, Show, Generic)++type DdThing =+  Prod Thing *>+    Prim "t_a" Int >+    Prim "t_b" Text >+    Prim "t_c" Double++ddThing :: Dd DdThing+ddThing =+  prod prims++data Something =+  Something {+    st_a :: Int,+    thing :: Thing+  }+  deriving stock (Eq, Show, Generic)++ddSomething :: Sqel (Uid Int64 Something) _+ddSomething =+  uid (pk prim) (prod (prim :> merge ddThing))++data SomethingNest =+  SomeThingNest { thing :: Thing }+  |+  NotAThingNest { nat_a :: Int, nat_b :: Text }+  deriving stock (Eq, Show, Generic)++ddSomethingNest :: Sqel (Uid Int64 SomethingNest) _+ddSomethingNest =+  uid (pk prim) (sum (con1 ddThing :> con prims))++data QThing (a :: Type) =+  QThing {+    t_b :: Text,+    t_c :: Double+  }+  deriving stock (Eq, Show, Generic)++-- TODO think of something better for @order@+data QThingI d =+  QThingI {+    qt :: QThing d,+    limit :: Int64,+    order :: ()+  }+  deriving stock (Eq, Show, Generic)++type QThingDd d =+  Prod (QThing d) *>+    Prim "t_b" Text >+    Prim "t_c" Double++data ThingWrap a =+  ThingWrap { thing :: a }+  deriving stock (Eq, Show, Generic)++type DdThingWrap d =+  Prod (ThingWrap (DdType d)) *> Name "thing" d++data ThingFor d =+  ThingFor { thing :: Thing }+  deriving stock (Eq, Show, Generic)++type DdThingForNest d =+  Prod (ThingFor d) *> Name "thing" DdThing++ddThingNest :: Dd (DdThingForNest d)+ddThingNest =+  prod ddThing++-- TODO also here, the order field must be renamed to @thing@ because that's what it orders on+type DdQThingI d =+  Prod (QThingI d) *>+    Merge (+      Prod (QThing d) *>+        Prim "t_b" Text >+        Prim "t_c" Double+    ) >+    MSelect (PrimUnused Int64) >+    MSelect (Prim "t_c" ())++type DdQThingINest d =+  Prod (ThingWrap (QThingI d)) *>+  Name "thing" (DdQThingI d)++ddDdQThingI :: Dd (DdQThingI d)+ddDdQThingI =+  prod (merge (prod prims) :> Q.limit :> named @"t_c" (Q.order Desc))++qthingSql ::+  ∀ s .+  HasField "t_b" Text s =>+  HasField "t_c" Double s =>+  HasField "t_c" () s =>+  CheckedProjection DdThing s =>+  MkTableSchema s =>+  Dd s ->+  Sql+qthingSql table =+  selectWhereGen qs ps+  where+    qs = checkQuery query table+    ps = projection ddThing table+    query = ddDdQThingI++qthingNestSql ::+  ∀ s .+  HasPath ["thing", "t_b"] Text s =>+  HasPath ["thing", "t_c"] Double s =>+  HasPath ["thing", "t_c"] () s =>+  MkTableSchema s =>+  CheckedProjection (DdThingForNest (DdType s)) s =>+  Dd s ->+  Sql+qthingNestSql table =+  selectWhereGen qs ps+  where+    qs = checkQuery query table+    ps = projection (ddThingNest @(DdType s)) table+    query = prod @(ThingWrap _) ddDdQThingI++targetThing :: Sql+targetThing =+  [sql|select "t_a", "t_b", "t_c" from "something" where (("t_b" = $1 and "t_c" = $2)) order by "t_c" desc limit $3|]++targetThingNest :: Sql+targetThingNest =+  [sql|select ("thing").t_a, ("thing").t_b, ("thing").t_c from "something_nest" where (((("thing")."t_b" = $1 and ("thing")."t_c" = $2))) order by ("thing")."t_c" desc limit $3|]++test_queryProjection :: TestT IO ()+test_queryProjection = do+  targetThing === qthingSql ddSomething+  targetThingNest === qthingNestSql ddSomethingNest
+ test/Sqel/Test/SqlCodeTest.hs view
@@ -0,0 +1,9 @@+module Sqel.Test.SqlCodeTest where++import Hedgehog ((===), TestT)++import Sqel.Data.Sql (Sql, sql)++test_sqlCodeNoInterpolation :: TestT IO ()+test_sqlCodeNoInterpolation =+  "foo bar" === ([sql|foo bar|] :: Sql)
+ test/Sqel/Test/StatementTest.hs view
@@ -0,0 +1,313 @@+{-# options_ghc -Wno-partial-type-signatures -fconstraint-solver-iterations=10 #-}++module Sqel.Test.StatementTest where++import Data.Type.Equality ((:~:) (Refl))+import Generics.SOP (NP (..))+import Hedgehog (TestT, (===))+import Prelude hiding (sum)+import Test (unitTest)+import Test.Tasty (TestTree, testGroup)++import Sqel.Class.MatchView (HasPath)+import Sqel.Comp (Column, CompName (compName))+import Sqel.Data.Codec (FullCodec)+import Sqel.Data.Dd (+  Dd (Dd),+  DdInc (DdNest),+  DdK (DdK),+  DdSort (DdProd),+  DdStruct (DdComp),+  DdType,+  DdTypeSel,+  type (:>) ((:>)),+  )+import Sqel.Data.Mods (pattern NoMods)+import Sqel.Data.Order (Order (Desc))+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.Sel (MkTSel (mkTSel), Sel (SelAuto), SelW (SelWAuto))+import Sqel.Data.Sql (Sql, sql, toSql)+import Sqel.Data.SqlFragment (Create (Create), Select (Select))+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid)+import Sqel.Merge (merge)+import Sqel.PgType (MkTableSchema, tableSchema)+import Sqel.Prim (prim, primAs, primNewtypes, prims)+import Sqel.Product (prod, prodSel)+import Sqel.Query (checkQuery)+import Sqel.Query.Combinators (order)+import Sqel.ReifyCodec (ReifyCodec)+import Sqel.ReifyDd (ReifyDd)+import qualified Sqel.Sql.Select as Sql+import Sqel.Sum (ConColumn (con), con1, sum)+import Sqel.Test.Bug ()+import qualified Sqel.Type as T+import Sqel.Type (Prim, PrimNewtype, Prod, ProdPrimsNewtype, TypeSel, type (*>), type (>))+import Sqel.Uid (UidDd, uid)++newtype IntNt =+  IntNt { unIntNt :: Int }+  deriving stock (Eq, Show, Generic)++data Three =+  Three {+    a :: IntNt,+    b :: IntNt,+    c :: IntNt+  }+  deriving stock (Eq, Show, Generic)++type ThreeTableGen =+  ProdPrimsNewtype Three++type ThreeTable =+  Prod Three *> PrimNewtype "a" IntNt > PrimNewtype "b" IntNt > PrimNewtype "c" IntNt++test_prodGen :: TestT IO ()+test_prodGen =+  case Refl :: ThreeTable :~: ThreeTableGen of+    Refl -> unit++ddThree :: Dd ThreeTableGen+ddThree =+  prod primNewtypes++data Pro =+  Pro {+    num :: Int64,+    name :: Text+  }+  deriving stock (Eq, Show, Generic)++data Dat =+  Dat {+    num :: Int+  }+  deriving stock (Eq, Show, Generic)++data Q =+  Q {+    num :: ()+  }+  deriving stock (Eq, Show, Generic)++type ProdTable =+  Prod Pro *> (Prim "num" Int64 > Prim "name" Text)++ddPro :: Dd ProdTable+ddPro =+  prod prims++target_order :: Sql+target_order =+  [sql|select "num" from "dat" order by "num" desc|]++test_statement_order :: TestT IO ()+test_statement_order =+  target_order === Sql.selectWhere qs ts+  where+    ts :: TableSchema Dat+    ts = tableSchema (prod prim)+    qs :: QuerySchema Q Dat+    qs = checkQuery (prod (order Desc)) (prod prim)++target_mergeSum :: Sql+target_mergeSum =+  [sql|select "id", "sqel_sum_index__merge_sum", ("merge_sum1").num1, ("merge_sum1").name1, ("merge_sum2").num2,+       ("merge_sum2").name2 from "merge_sum"|]++target_create_mergeSum :: Sql+target_create_mergeSum =+  [sql|create table "merge_sum"+  ("id" bigint not null,+    "sqel_sum_index__merge_sum" bigint not null,+    "merge_sum1" sqel_type__merge_sum1 not null,+    "merge_sum2" sqel_type__merge_sum2 not null)+  |]++data MergeSum =+  MergeSum1 { num1 :: Int, name1 :: Text }+  |+  MergeSum2 { num2 :: Int, name2 :: Text }+  deriving stock (Eq, Show, Generic)++dd_uid_merge_sum_manual :: Dd ('DdK _ _ (Uid Int64 MergeSum) _)+dd_uid_merge_sum_manual =+  prod (prim :> merge (sum (con prims :> con prims)))++dd_uid_merge_sum :: Dd ('DdK _ _ (Uid Int64 MergeSum) _)+dd_uid_merge_sum =+  uid prim (sum (con prims :> con prims))++test_statement_merge_sum :: TestT IO ()+test_statement_merge_sum = do+  target_mergeSum === toSql (Select (tableSchema dd_uid_merge_sum))+  target_mergeSum === toSql (Select (tableSchema dd_uid_merge_sum_manual))+  target_create_mergeSum === toSql (Create (tableSchema dd_uid_merge_sum_manual))++data MergeProd =+  MergeProd { count :: Int, b :: Pro }+  deriving stock (Eq, Show, Generic)++dd_merge_prod :: Dd ('DdK _ _ MergeProd _)+dd_merge_prod =+  prod (prim :> merge (prod prims))++target_merge_prod :: Sql+target_merge_prod =+  [sql|select "count", "num", "name" from "merge_prod"|]++test_statement_merge_prod :: TestT IO ()+test_statement_merge_prod =+  target_merge_prod === toSql (Select (tableSchema dd_merge_prod))++data Wrap a =+  Wrap { wrapped :: a, length :: Int64 }+  deriving stock (Eq, Show, Generic)++instance CompName a name => CompName (Wrap a) name where+  compName = compName @a++type WrapDd sa =+  TypeSel (DdTypeSel sa) (Prod (Wrap (DdType sa))) *> (+    T.Merge sa >+    Prim "length" Int64+  )++schema_higherOrder ::+  ∀ s0 table a sel mods s .+  s0 ~ 'DdK sel mods a s =>+  table ~ WrapDd s0 =>+  MkTSel (DdTypeSel s0) =>+  MkTableSchema table =>+  Dd s0 ->+  TableSchema (Wrap a)+schema_higherOrder wrapped =+  tableSchema dd+  where+    dd :: Dd table+    dd = Dd SelWAuto NoMods (DdComp mkTSel DdProd DdNest fields)+    fields = merge wrapped :* primAs @"length" :* Nil++target_higherOrder :: Sql+target_higherOrder =+  [sql|select "num", "name", "length" from "pro"|]++test_statement_higherOrder :: TestT IO ()+test_statement_higherOrder =+  target_higherOrder === toSql (Select (schema_higherOrder ddPro))++data Merge1 =+  One { one :: Pro }+  |+  Two { two :: Pro }+  deriving stock (Eq, Show, Generic)++data QHo = QHo { name :: Text }+  deriving stock (Eq, Show, Generic)++data QWrap = QWrap { two :: QHo }+  deriving stock (Eq, Show, Generic)++statement_query_higherOrder ::+  ∀ a s0 table mods s .+  s0 ~ 'DdK 'SelAuto mods a s =>+  MkTSel (DdTypeSel s0) =>+  table ~ UidDd (Prim "id" Int64) (WrapDd s0) =>+  MkTableSchema table =>+  HasPath ["two", "name"] Text table =>+  Dd s0 ->+  Sql+statement_query_higherOrder wrapped =+  Sql.selectWhere qs ts+  where+    ts :: TableSchema (Uid Int64 (Wrap a))+    ts = tableSchema dd+    qs :: QuerySchema QWrap (Uid Int64 (Wrap a))+    qs = checkQuery q dd+    q = prod (prod prim)+    dd :: Dd table+    dd = uid prim pro+    pro = Dd SelWAuto NoMods (DdComp mkTSel DdProd DdNest fields)+    fields = merge wrapped :* primAs @"length" :* Nil++ddMerge1 :: Dd ('DdK _ _ Merge1 _)+ddMerge1 = sum (con1 ddPro :> con1 ddPro)++target_merge_query_higherOrder :: Sql+target_merge_query_higherOrder =+  [sql|select "id", "sqel_sum_index__merge1", ("one").num, ("one").name, ("two").num, ("two").name, "length"+       from "merge1" where ((("two")."name" = $1))|]++test_statement_merge_query_higherOrder :: TestT IO ()+test_statement_merge_query_higherOrder =+  target_merge_query_higherOrder === statement_query_higherOrder ddMerge1++ddHigherOrder2 ::+  ∀ s merged .+  merged ~ T.Merge s =>+  MkTSel (DdTypeSel s) =>+  Column (DdType s) "wrapped" merged merged =>+  Dd s ->+  Dd (UidDd (Prim "id" Int64) (WrapDd s))+ddHigherOrder2 wrapped =+  uid prim (prodSel @(DdTypeSel s) (merge wrapped :> prim))++ddUidWrapPro :: Dd (UidDd (Prim "id" Int64) (WrapDd ProdTable))+ddUidWrapPro =+  ddHigherOrder2 ddPro++higherOrder2 ::+  ∀ a s merged .+  merged ~ T.Merge s =>+  MkTSel (DdTypeSel s) =>+  Column a "wrapped" merged merged =>+  ReifyDd merged =>+  ReifyCodec FullCodec merged a =>+  Dd s ->+  Sql+higherOrder2 wrapped =+  toSql (Select ts)+  where+    ts :: TableSchema (Wrap a)+    ts = tableSchema dd+    dd = prodSel @(DdTypeSel s) (merge wrapped :> prim)++test_higherOrder2 :: TestT IO ()+test_higherOrder2 =+  [sql|select "num", "name", "length" from "pro"|] === higherOrder2 ddPro++data NaNu =+  Na { name :: Text }+  |+  Nu Int64+  deriving stock (Eq, Show, Generic)++ddNaNu :: Dd ('DdK _ _ NaNu _)+ddNaNu =+  sum (con1 prim :> con1 prim)++statement_con1 :: Sql+statement_con1 =+  toSql (Select (tableSchema ddNaNu))++test_statement_con1 :: TestT IO ()+test_statement_con1 =+  [sql|select "sqel_sum_index__na_nu", "name", "nu" from "na_nu"|] === statement_con1++newtype TextNt =+  TextNt { unTextNt :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++test_statement :: TestTree+test_statement =+  testGroup "statement" [+    unitTest "order" test_statement_order,+    unitTest "merge sum" test_statement_merge_sum,+    unitTest "merge prod" test_statement_merge_prod,+    unitTest "higher-order merge statement" test_statement_higherOrder,+    unitTest "higher-order double merge query" test_statement_merge_query_higherOrder,+    unitTest "higher-order with new product class" test_higherOrder2,+    unitTest "unary con with record and positional fields" test_statement_con1+  ]
+ test/Test.hs view
@@ -0,0 +1,13 @@+module Test where++import Hedgehog (TestT, property, test, withTests)++import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty)++unitTest ::+  TestName ->+  TestT IO () ->+  TestTree+unitTest desc =+  testProperty desc . withTests 1 . property . test