ribbit 0.4.1.0 → 1.0.0.0

raw patch · 11 files changed

+1047/−639 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ribbit.cabal +10/−2
• src/Database/Ribbit.hs +146/−529
• src/Database/Ribbit/Args.hs +114/−0
• src/Database/Ribbit/Conditions.hs +206/−0
• src/Database/Ribbit/Delete.hs +32/−0
• src/Database/Ribbit/Insert.hs +47/−0
• src/Database/Ribbit/PostgreSQL.hs +108/−108
• src/Database/Ribbit/Render.hs +17/−0
• src/Database/Ribbit/Select.hs +177/−0
• src/Database/Ribbit/Table.hs +123/−0
• src/Database/Ribbit/Update.hs +67/−0

@@ -1,6 +1,6 @@  name:                ribbit-version:             0.4.1.0+version:             1.0.0.0 synopsis:            Type-level Relational DB combinators. description:         Ribbit is yet another type safe relational database                      library for Haskell, heavily inspired by the@@ -24,7 +24,15 @@   exposed-modules:          Database.Ribbit     Database.Ribbit.PostgreSQL-  -- other-modules:       +  other-modules:       +    Database.Ribbit.Args+    Database.Ribbit.Conditions+    Database.Ribbit.Delete+    Database.Ribbit.Insert+    Database.Ribbit.Render+    Database.Ribbit.Select+    Database.Ribbit.Table+    Database.Ribbit.Update   -- other-extensions:       build-depends:     Only              >= 0.1     && < 0.2,

@@ -54,62 +54,162 @@   -- $update    -- * Schema Definition Types-  (:>)(..),   Table(..),   Field,+  (:>)(..),    -- * SQL Statement Constructors   -- ** Query Constructors+  {- |+    Types in the section are used to construct SELECT queries.++    e.g.++    List all employees who have quit, for all companies. (Left Joined+    version, which shows companies that have had no employees quit.)++    > Select '["c.name", "e.name", "e.quit_date"]+    > `From`+    >   Company `As` "c"+    >   `LeftJoin`  Employee `As` "e" `On` "c.id" `Equals` "e.company_id"+    > `Where`+    >   NotNull "e.quit_date"++    List all employees who have quit, for all companies. (Inner join+    version, which omits companies from which no employee has quit.)++    > Select '["c.name", "e.name", "e.quit_date"]+    > `From` '[Company `As` "c", Employee `As` "e"]+    > `Where`+    >   "c.id" `Equals` "e.company_id"+    >   `And` NotNull "e.quit_date"+  -}   Select,   From,   As,+  On,+  LeftJoin,    -- ** Insert Constructors+  {- |+    Construct insert statements.++    e.g.++    Insert one row into the Employee Table.++    > InsertInto Employee '["id", "company_id", "name"]++    The values which are inserted into the specified fields are provided+    as query parameters.+  -}   InsertInto,-  +   -- ** Delete Constructors+  {- |+    Construct delete statements.++    e.g.++    Delete all rows from the Company table:+    +    > type Statement = DeleteFrom Company++    Delete a specific row from the Company table:++    > type Statement = DeleteFrom Company `Where` "id" `Equals` (?)+  -}   DeleteFrom,    -- ** Update Constructors+  {- |+    Construct update statements++    e.g.++    Update a specific employee's salary:++    > type Statement =+    >   Update Employee '["salary"]+    >   `Where`+    >     "company_id" `Equals` (?)+    >     `And` "id" `Equals` (?)++    The values which are inserted into the specified fields are provided+    as query parameters.++    e.g.++    > execute+    >   conn+    >   Statement+    >   (Only newSalary :> Only companyId :> Only employeeId)+  -}   Update, -  -- ** Condition Conbinators+  -- ** Condition Constructors+  {- | Use these types to construct a @WHERE@ clause. -}+   Where,-  And,-  Or,   Equals,   NotEquals,-  Gt,-  Gte,   Lt,   Lte,+  Gt,+  Gte,+  And,+  Or,   Not,--  -- ** Statement Parameters+  IsNull,+  NotNull,   type (?),    -- * Transformations on Statement Types+  {- |+    These type families are useful for transforming the query types in various+    ways, or extracting certain information from them.++    e.g.++    Given the query:++    > type Query = Select '["name"] `From` Company `Where` "id" `Equals` (?)++    Render the query as a 'String' value (using 'GHC.TypeLits.symbolVal'):++    > symbolVal (Proxy :: Proxy (Render Query)) == "SELECT name FROM companies WHERE id = ?"++    Produce the Haskell type corresponding to the query parameters for a select+    statement:++    > ArgsType Query ~ Only Int -- Our statement has only one parameter, which is an int.++    Produce the Haskell type corresponding to the rows produced by the query:++    > ResultType Query ~ Only Text -- Our query procudes only one column, a text.++  -}   ArgsType,   ResultType,-  ValidField,-  ProjectionType,+  Render,+  -- ValidField,+  -- ProjectionType, -  -- * Statement Rendering-  Render(..)+  -- -- * Statement Rendering+  -- Render,  ) where  -import Data.Proxy (Proxy(Proxy))-import Data.String (IsString, fromString)-import Data.Text (Text)-import Data.Tuple.Only (Only)-import Data.Type.Bool (If, type (||))-import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage((:<>:),-  (:$$:), ShowType), AppendSymbol, Symbol)-import qualified Data.Text as T-import qualified GHC.TypeLits as Lit-+import Database.Ribbit.Args (ArgsType, ResultType)+import Database.Ribbit.Conditions (Where, Equals, NotEquals, Lt, Lte,+  Gt, Gte, And, Or, Not, IsNull, NotNull, type (?))+import Database.Ribbit.Delete (DeleteFrom)+import Database.Ribbit.Insert (InsertInto)+import Database.Ribbit.Render (Render)+import Database.Ribbit.Select (Select, From, As, On, LeftJoin)+import Database.Ribbit.Table (Table(Name, DBSchema), Field, (:>)((:>)))+import Database.Ribbit.Update (Update)  -- $definetable -- To define a table you need a type:@@ -125,9 +225,7 @@ -- And you need a type class instance 'Table': --  -- > instance Table Company where--- > -- >   type Name Company = "companies"--- > -- >   type DBSchema Company = -- >     Field "id" Int -- >     :> Field "name" Text@@ -150,16 +248,14 @@ -- in the following examples: -- -- > data Employee--- > -- > instance Table Employee where--- > -- >   type Name Employee = "employees"--- > -- >   type DBSchema Employee =--- >     Field "id" Int--- >     :> Field "company_id" Int+-- >     Field "company_id" Int+-- >     :> Field "id" Int -- >     :> Field "name" Text -- >     :> Field "salary" (Maybe Int)+-- >     :> Field "quit_date" (Maybe Day) -- >     :> Field "birth_date" Day  -- $query@@ -203,12 +299,13 @@ -- The "Database.Ribbit.PostgreSQL" module provides a -- 'Database.Ribbit.PostgreSQL.query' function: -- --- > query :: (--- >     MonadIO m,--- >     Render query,--- >     ToRow (ArgsType query),--- >     FromRow (ResultType query)--- >   )+-- > query ::+-- >      forall m query.+-- >      ( MonadIO m+-- >      , KnownSymbol (Render query)+-- >      , ToRow (ArgsType query)+-- >      , FromRow (ResultType query)+-- >      ) -- >   => Connection -- >   -> Proxy query -- >   -> ArgsType query@@ -227,7 +324,7 @@ --  -- > sequence_ -- >   [--- >     putStrLn (show name <> " - " <> show sallary)+-- >     putStrLn (show name <> " - " <> show salary) -- >     | (Only name :> Only salary) <- results -- >   ] @@ -283,7 +380,9 @@ -- > type DeleteAllEmployees = DeleteFrom Employee -- > type DeleteEmployeeById = -- >   DeleteFrom Employee--- >   `Where` "id" `Equals` (?)+-- >   `Where`+-- >     "company_id" `Equals` (?)+-- >     `And` "id" `Equals` (?) --  -- Then just execute the query, providing the appropriate query params. -- @@ -309,509 +408,27 @@ -- -- > {- Update an employee's salary (hopefully a raise!). -} -- > type UpdateSalary =--- >   Update--- >     '[--- >       "salary"--- >     ]+-- >   Update '[ "salary" ] -- >   `Where` +-- >     "company_id" `Equals` (?) -- >     "id" `Equals` (?) -- >  -- > ... -- >  -- > let -- >   newSalary :: Int--- >   newSalary = ...+-- >   newSalary = 2 -- > +-- >   targetCompany :: Int+-- >   targetCompany = 1+-- >  -- >   targetEmployee :: Int--- >   targetEmployee = ...+-- >   targetEmployee = 1+-- >  -- > in -- >   execute -- >     conn -- >     (Proxy :: Proxy UpdateSalary)--- >     (Only newSalary :> Only targetEmployee)---{- | "SELECT" constructor, used for starting a @SELECT@ statement. -}-data Select fields---{- |-  "FROM" constructor, used for attaching a SELECT projection to a relation-  in the database.--}-data From proj relation-infixl 6 `From`---{- | "WHERE" constructor, used for attaching conditions to a query. -}-data Where query conditions-infixl 6 `Where`---{- | "=" constructor for conditions. -}-data Equals l r-infix 9 `Equals`---{- | "!=" constructor for conditions. -}-data NotEquals l r-infix 9 `NotEquals`---{- | "<" constructor for conditions. -}-data Lt l r-infix 9 `Lt`---{- | "<=" constructor for conditions. -}-data Lte l r-infix 9 `Lte`---{- | ">" constructor for conditions. -}-data Gt l r-infix 9 `Gt`---{- | ">=" constructor for conditions. -}-data Gte l r-infix 9 `Gte`---{- | "AND" constructor for conditions. -}-data And l r-infixr 8 `And`---{- | "OR" constructor for conditions. -}-data Or l r-infixr 7 `Or`---{- | "AS" constructor, used for attaching a name to a table in a FROM clause. -}-data As relation name-infix 8 `As`---{- | NOT conditional constructor. -}-data Not a---{- | "?" constructor, used to indicate the presence of a query parameter. -}-data (?)---{- |-  Define a field in a database schema, where:--  - @name@: is the name of the database column, expressed as a type-level-    string literal, and--  - @typ@: is the Haskell type whose values get stored in the column.--  E.g:--  - @'Field' "company_name" 'Text'@-  - @'Field' "expiration_date" ('Maybe' 'Data.Time.Day')@---}-data Field name typ---{- |-  String two types together. 'Int' ':>' 'Int' ':>' 'Int' is similar in-  principal to the nested tuple ('Int', ('Int', 'Int')), but looks a-  whole lot nicer when the number of elements becomes large.--  This is how you build up a schema from a collection of 'Field' types.--  E.g.:--  > Field "foo" Int-  > :> Field "bar" Text-  > :> Field "baz" (Maybe Text)--  It also the mechanism by which this library builds up the Haskell-  types for query parameters and resulting rows that get returned. So-  if you have a query that accepts three text query parameters, that-  type represented in Haskell is going to be @('Only' 'Text' ':>' 'Only'-  'Text' ':>' 'Only' 'Text')@.--  If that query returns rows that contain a Text, an Int, and a Text,-  then the type of the rows will be @('Only' 'Text' ':>' 'Only' 'Int'-  ':>' 'Only' 'Text')@.---}-data a :> b = a :> b-  deriving (Eq, Ord, Show)-infixr 5 :>---data Expr a---type family ProjectionType proj schema where-  ProjectionType '[name] schema =-    LookupType name schema schema-  ProjectionType (name:more) schema =-    LookupType name schema schema-    :> ProjectionType more schema--type family LookupType name schema context where-  LookupType name (Field name typ) _ = Only typ-  LookupType name (Field name typ :> _) _ = Only typ-  LookupType name (Field _ typ) context = NotInSchema name context-  LookupType name (_ :> more) context = LookupType name more context-  LookupType name a context = NotInSchema name context---{- |-  Type class for defining your own tables. The primary way for you to-  introduce a new schema is to instantiate this type class for one of-  your types.--  E.g.:--  > data MyTable-  > instance Table MyTable where-  >   type Name MyTable = "my_table"-  >   type DBSchema MyTable =-  >     Field "id" Int-  >     :> Field "my_non_nullable_text_field" Text-  >     :> Field "my_nullable_int_field" (Maybe Int)-    --}-class Table relation where-  type Name relation :: Symbol-  type DBSchema relation--{- | Cross product -}-instance-    (Table table, KnownSymbol name)-  =>-    Table ((table `As` name) : moreTables)-  where-    type DBSchema ((table `As` name) : moreTables) =-      CrossProductSchema ((table `As` name) : moreTables)-    type Name ((table `As` name) : moreTables) =-      CrossProductName ((table `As` name) : moreTables)---{- | Produce the schema of a cross product. -}-type family CrossProductSchema cp where-  CrossProductSchema '[table `as` name] =-    Flatten (-      AliasAs name (DBSchema table)-    )-  CrossProductSchema ((table `As` name) : moreTables) =-    Flatten (-      AliasAs name (DBSchema table)-      :> CrossProductSchema moreTables-    )---{- | Product the renderable "name" of a cross product. -}-type family CrossProductName cp where-  CrossProductName '[table `As` name] = -    Name table-    `AppendSymbol` " as "-    `AppendSymbol` name-  CrossProductName ((table `As` name) : moreTables) = -    Name table-    `AppendSymbol` " as "-    `AppendSymbol` name-    `AppendSymbol` ", "-    `AppendSymbol` CrossProductName moreTables---{- |-  Rename the fields in a given schema to reflect an applied table-  alias. For instance, data Foo--}-type family AliasAs prefix schema where-  AliasAs prefix (Field name typ) =-    Field-      (prefix `AppendSymbol` "." `AppendSymbol` name)-      typ-  AliasAs prefix (Field name typ :> more) =-    Field-      (prefix `AppendSymbol` "." `AppendSymbol` name)-      typ-    :> AliasAs prefix more---{- | Produce the type of rows return by a query. -}-type family ResultType query where-  ResultType (Select fields `From` relation) =-    ProjectionType fields (DBSchema relation)-  ResultType (query `Where` conditions) = ResultType query-  ResultType query =-    TypeError ('Lit.Text "Malformed Query" ':$$: 'ShowType query)---{- |-  Produce the type represeting the placeholder ("?") values in a-  paramaterized query.--}-type family ArgsType query where-  ArgsType (_ `From` relation `Where` conditions) =-    ArgsType (DBSchema relation, conditions)-  ArgsType (DeleteFrom relation `Where` conditions) =-    ArgsType (DBSchema relation, conditions)-  ArgsType (InsertInto relation '[]) =-    TypeError ('Lit.Text "Insert statement must specify at least one column.")-  ArgsType (InsertInto relation fields) =-    ProjectionType fields (DBSchema relation)-  ArgsType (Update relation fields) =-    ProjectionType fields (DBSchema relation)-  ArgsType (Update relation fields `Where` conditions) =-    ProjectionType fields (DBSchema relation)-    :> ArgsType (DBSchema relation, conditions)---  ArgsType (schema, And a b) =-    StripUnit (Flatten (ArgsType (schema, a) :> ArgsType (schema, b)))-  ArgsType (schema, Or a b) =-    StripUnit (Flatten (ArgsType (schema, a) :> ArgsType (schema, b)))-  ArgsType (schema, Condition field (?)) =-    ProjectionType '[field] schema-  ArgsType (schema, Condition (?) field) =-    ProjectionType '[field] schema-  ArgsType (schema, Condition l r) =-    If-      (ValidField r schema)-      (If (ValidField l schema) () (NotInSchema l schema))-      (NotInSchema r schema)-  ArgsType (schema, Equals l r) = ArgsType (schema, Condition l r)-  ArgsType (schema, NotEquals l r) = ArgsType (schema, Condition l r)-  ArgsType (schema, Lt l r) = ArgsType (schema, Condition l r)-  ArgsType (schema, Lte l r) = ArgsType (schema, Condition l r)-  ArgsType (schema, Gt l r) = ArgsType (schema, Condition l r)-  ArgsType (schema, Gte l r) = ArgsType (schema, Condition l r)-  ArgsType (schema, Not a) = ArgsType (schema, a)-  ArgsType _ = ()---{- |-  Helper for 'ArgsType'. Reduces the number of equations required, because-  'ArgsType' doesn't actually care about which conditionl operator it-  is inspecting.--}-data Condition l r---type family NotInSchema field schema where-  NotInSchema field schema =-    TypeError (-      'Lit.Text "name ("-      ':<>: 'ShowType field-      ':<>: 'Lit.Text ") not found in schema: "-      ':<>: 'ShowType schema-    )---{- | Type level check to see if the field is actually contained in the schema -}-type family ValidField field schema where-  ValidField name (Field name typ) = 'True-  ValidField name (Field _ typ) = 'False-  ValidField name (a :> b) = ValidField name a || ValidField name b---{- |-  Normalize nested type strings to be right associative. Mainly used to-  help simplify the implementation of other type families.--}-type family Flatten a where-  Flatten ((a :> b) :> c) = Flatten (a :> b :> c)-  Flatten (a :> b) = a :> Flatten b-  Flatten a = a---{- |-  Strip redundant unit types out of a string of types. This is used-  mainly to help simplify the implementation of 'ArgsType'.--}-type family StripUnit a where-  StripUnit (() :> a) = StripUnit a-  StripUnit (a :> ()) = StripUnit a-  StripUnit (a :> b) = a :> StripUnit b-  StripUnit a = a---{- | Like 'Lit.symbolVal', but produce any kind of string-like thing. -}-symbolVal :: (KnownSymbol n, IsString a) => proxy n -> a-symbolVal = fromString . Lit.symbolVal---{- | Render a type-level query as text. -}-class Render query where-  render :: proxy query -> Text--{- SELECT -}-instance (Render fields) => Render (Select fields) where-  render _proxy =-    "SELECT "-    <> render (Proxy @fields)--{- Field list -}-instance (KnownSymbol field, ReflectFields (field:more)) => Render (field:more) where-  render _proxy = T.intercalate "," (reflectFields (Proxy @(field:more)))--{- FROM -}-instance (KnownSymbol (Name relation), Render proj, Table relation) => Render (From proj relation) where-  render _proxy =-    render (Proxy @proj)-    <> " FROM "-    <> symbolVal (Proxy @(Name relation))--{- WHERE -}-instance (Render query, Render conditions) => Render (Where query conditions) where-  render _proxy =-    render (Proxy @query)-    <> " WHERE "-    <> render (Proxy @conditions)--{- Equals -}-instance (Render (Expr l), Render (Expr r)) => Render (Equals l r) where-  render _proxy =-    render (Proxy @(Expr l))-    <> " = "-    <> render (Proxy @(Expr r))--{- Not Equals -}-instance (Render (Expr l), Render (Expr r)) => Render (NotEquals l r) where-  render _proxy =-    render (Proxy @(Expr l))-    <> " != "-    <> render (Proxy @(Expr r))--{- Not -}-instance (Render a) => Render (Not a) where-  render _proxy =-    "not ("-    <> render (Proxy @a)-    <> ")"--{- Gt -}-instance (Render (Expr l), Render (Expr r)) => Render (Gt l r) where-  render _proxy =-    render (Proxy @(Expr l))-    <> " > "-    <> render (Proxy @(Expr r))--{- Gte -}-instance (Render (Expr l), Render (Expr r)) => Render (Gte l r) where-  render _proxy =-    render (Proxy @(Expr l))-    <> " >= "-    <> render (Proxy @(Expr r))--{- Lt -}-instance (Render (Expr l), Render (Expr r)) => Render (Lt l r) where-  render _proxy =-    render (Proxy @(Expr l))-    <> " < "-    <> render (Proxy @(Expr r))--{- Lte -}-instance (Render (Expr l), Render (Expr r)) => Render (Lte l r) where-  render _proxy =-    render (Proxy @(Expr l))-    <> " <= "-    <> render (Proxy @(Expr r))--{- AND -}-instance (Render l, Render r) => Render (And l r) where-  render _proxy =-    "( "-    <> render (Proxy @l)-    <> " AND "-    <> render (Proxy @r)-    <> " )"--{- OR -}-instance (Render l, Render r) => Render (Or l r) where-  render _proxy =-    "( "-    <> render (Proxy @l)-    <> " AND "-    <> render (Proxy @r)-    <> " )"--{- Expr -}-instance Render (Expr (?)) where-  render _proxy = "?"-instance (KnownSymbol a) => Render (Expr a) where-  render _proxy = symbolVal (Proxy @a)--{- (?) -}-instance Render (?) where-  render _proxy = "?"--{- INSERT -}-instance-    (ReflectFields fields, KnownSymbol (Name table))-  =>-    Render (InsertInto table fields)-  where-    render _proxy =-      let-        fields :: [Text]-        fields = reflectFields (Proxy @fields)-      in-        "insert into " <> symbolVal (Proxy @(Name table))-        <> " (" <> T.intercalate ", " fields <> ")"-        <> " values (" <> T.intercalate ", " (const "?" <$> fields) <> ");"--{- DELETE -}-instance (KnownSymbol (Name table)) => Render (DeleteFrom table) where-  render _proxy =-    "delete from " <> symbolVal (Proxy @(Name table))--{- UPDATE -}-instance (KnownSymbol (Name table), RenderUpdates updates)-  =>-    Render (Update table updates)-  where-    render _proxy =-      "UPDATE "-      <> symbolVal (Proxy @(Name table))-      <> " SET "-      <> renderUpdates (Proxy @updates)---{- | Render the updates to a table. -}-class RenderUpdates a where-  renderUpdates :: proxy a -> Text-instance (KnownSymbol field) => RenderUpdates '[field] where-  renderUpdates _ = symbolVal (Proxy @field) <> " = ?"-instance (KnownSymbol field, RenderUpdates (m:ore))-  =>-    RenderUpdates (field : (m:ore))-  where-    renderUpdates _ =-      symbolVal (Proxy @field) <> " = ?, "-      <> renderUpdates (Proxy @(m:ore))---{- | Insert statement. -}-data InsertInto table fields---{- | Convert a type-level list of strings into a value. -}-class ReflectFields a where-  reflectFields :: proxy a -> [Text]-instance ReflectFields '[] where-  reflectFields _proxy = []-instance (KnownSymbol a, ReflectFields more) => ReflectFields (a:more) where-  reflectFields _proxy = symbolVal (Proxy @a) : reflectFields (Proxy @more)---{- | Delete statement. -}-data DeleteFrom table---{- | Update rows in a table. -}-data Update table fields+-- >     (Only newSalary :> Only targetCompany :> Only targetEmployee)  

@@ -0,0 +1,114 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Translate statement parameters into Haskell types. -}+module Database.Ribbit.Args (+  ArgsType,+  ResultType,+) where+++import Data.Tuple.Only (Only)+import Data.Type.Bool (If)+import Database.Ribbit.Conditions (Where, Equals, NotEquals, Lt, Lte,+  Gt, Gte, Not, And, Or, type (?))+import Database.Ribbit.Delete (DeleteFrom)+import Database.Ribbit.Insert (InsertInto)+import Database.Ribbit.Select (From, Select)+import Database.Ribbit.Table (DBSchema, Flatten, (:>), Field, ValidField,+  NotInSchema)+import Database.Ribbit.Update (Update)+import GHC.TypeLits (TypeError, ErrorMessage(ShowType, (:$$:)))+import qualified GHC.TypeLits as Lit+++{- |+  Produce the type represeting the placeholder ("?") values in a+  paramaterized query.+-}+type family ArgsType query where+  ArgsType (_ `From` relation `Where` conditions) =+    ArgsType (DBSchema relation, conditions)++  ArgsType (InsertInto relation fields) =+    ProjectionType fields (DBSchema relation)++  ArgsType (DeleteFrom relation `Where` conditions) =+    ArgsType (DBSchema relation, conditions)++  ArgsType (Update relation fields) =+    ProjectionType fields (DBSchema relation)+  ArgsType (Update relation fields `Where` conditions) =+    ProjectionType fields (DBSchema relation)+    :> ArgsType (DBSchema relation, conditions)++  ArgsType (schema, And a b) =+    StripUnit (Flatten (ArgsType (schema, a) :> ArgsType (schema, b)))+  ArgsType (schema, Or a b) =+    StripUnit (Flatten (ArgsType (schema, a) :> ArgsType (schema, b)))+  ArgsType (schema, Condition field (?)) =+    ProjectionType '[field] schema+  ArgsType (schema, Condition (?) field) =+    ProjectionType '[field] schema+  ArgsType (schema, Condition l r) =+    If+      (ValidField r schema)+      (If (ValidField l schema) () (NotInSchema l schema))+      (NotInSchema r schema)+  ArgsType (schema, Equals l r) = ArgsType (schema, Condition l r)+  ArgsType (schema, NotEquals l r) = ArgsType (schema, Condition l r)+  ArgsType (schema, Lt l r) = ArgsType (schema, Condition l r)+  ArgsType (schema, Lte l r) = ArgsType (schema, Condition l r)+  ArgsType (schema, Gt l r) = ArgsType (schema, Condition l r)+  ArgsType (schema, Gte l r) = ArgsType (schema, Condition l r)+  ArgsType (schema, Not a) = ArgsType (schema, a)+  ArgsType _ = ()+++{- |+  Helper for 'ArgsType'. Reduces the number of equations required, because+  'ArgsType' doesn't actually care about which conditionl operator it+  is inspecting.+-}+data Condition l r+++{- |+  Strip redundant unit types out of a string of types. This is used+  mainly to help simplify the implementation of 'ArgsType'.+-}+type family StripUnit a where+  StripUnit (() :> a) = StripUnit a+  StripUnit (a :> ()) = StripUnit a+  StripUnit (a :> b) = a :> StripUnit b+  StripUnit a = a+++type family ProjectionType proj schema where+  ProjectionType '[name] schema =+    LookupType name schema schema+  ProjectionType (name:more) schema =+    LookupType name schema schema+    :> ProjectionType more schema+++{- | Produce the type of rows return by a query. -}+type family ResultType query where+  ResultType (Select fields `From` relation) =+    ProjectionType fields (DBSchema relation)+  ResultType (query `Where` conditions) = ResultType query+  ResultType query =+    TypeError ('Lit.Text "Malformed Query" ':$$: 'ShowType query)+++type family LookupType name schema context where+  LookupType name (Field name typ) _ = Only typ+  LookupType name (Field name typ :> _) _ = Only typ+  LookupType name (Field _ typ) context = NotInSchema name context+  LookupType name (_ :> more) context = LookupType name more context+  LookupType name a context = NotInSchema name context++

@@ -0,0 +1,206 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- | SQL statement conditions. -}+module Database.Ribbit.Conditions (+  Where,+  Equals,+  NotEquals,+  Lt,+  Lte,+  Gt,+  Gte,+  And,+  Or,+  Not,+  IsNull,+  NotNull,+  type (?),++  RenderConditions,+  RenderJoinConditions,+) where+++import Database.Ribbit.Table (Validate)+import GHC.TypeLits (Symbol, AppendSymbol, TypeError, ErrorMessage((:<>:),+  ShowType))+import qualified GHC.TypeLits as Lit+++{- | "WHERE" constructor, used for attaching conditions to a query. -}+data Where query conditions+infixl 6 `Where`+++{- | "=" constructor for conditions. -}+data Equals (l :: k1) (r :: k2)+infix 9 `Equals`+++{- | "!=" constructor for conditions. -}+data NotEquals l r+infix 9 `NotEquals`+++{- | "<" constructor for conditions. -}+data Lt l r+infix 9 `Lt`+++{- | "<=" constructor for conditions. -}+data Lte l r+infix 9 `Lte`+++{- | ">" constructor for conditions. -}+data Gt l r+infix 9 `Gt`+++{- | ">=" constructor for conditions. -}+data Gte l r+infix 9 `Gte`+++{- | "AND" constructor for conditions. -}+data And l r+infixr 8 `And`+++{- | "OR" constructor for conditions. -}+data Or (l :: k1) (r :: k2)+infixr 7 `Or`+++{- | NOT conditional constructor. -}+data Not a+++{- | Is a field null? -}+data IsNull (field :: Symbol)+++{- | Is a field not null? -}+data NotNull (field :: Symbol)+++type family RenderConditions a schema where+  RenderConditions (Or l r) schema =+    "( "+    `AppendSymbol` RenderConditions l schema+    `AppendSymbol` " ) OR ("+    `AppendSymbol` RenderConditions r schema+    `AppendSymbol` " )"++  RenderConditions (And l r) schema =+    "( "+    `AppendSymbol` RenderConditions l schema+    `AppendSymbol` " ) AND ( "+    `AppendSymbol` RenderConditions r schema+    `AppendSymbol` " )"++  RenderConditions condition schema = RenderCondition condition schema+++type family RenderCondition condition schema where+  RenderCondition (Equals l r) schema = SimpleCondition schema (Expr l) "=" (Expr r)+  RenderCondition (NotEquals l r) schema = SimpleCondition schema (Expr l) "!=" (Expr r)+  RenderCondition (Lt l r) schema = SimpleCondition schema (Expr l) "<" (Expr r)+  RenderCondition (Lte l r) schema = SimpleCondition schema (Expr l) "<=" (Expr r)+  RenderCondition (Gt l r) schema = SimpleCondition schema (Expr l) ">" (Expr r)+  RenderCondition (Gte l r) schema = SimpleCondition schema (Expr l) ">=" (Expr r)+  RenderCondition (IsNull field) schema = Validate field schema (+      field `AppendSymbol` " IS NULL"+    )+  RenderCondition (NotNull field) schema = Validate field schema (+      field `AppendSymbol` " IS NOT NULL"+    )+  RenderCondition a _ = TypeError ('Lit.Text "Invalid condition: " ':<>: 'ShowType a)+++type family SimpleCondition schema l op r where+  SimpleCondition schema (Expr (?)) op (Expr r) =+    Validate r schema (+      "? "+      `AppendSymbol` op+      `AppendSymbol` " "+      `AppendSymbol` r+    )+  SimpleCondition schema (Expr l) op (Expr (?)) =+    Validate l schema (+      l+      `AppendSymbol` " "+      `AppendSymbol` op+      `AppendSymbol` " ?"+    )+  SimpleCondition schema (Expr l) op (Expr r) =+    Validate l schema (+      Validate r schema (+        l+        `AppendSymbol` " "+        `AppendSymbol` op+        `AppendSymbol` " "+        `AppendSymbol` r+      )+    )+++data Expr (a :: k)+++type family RenderJoinConditions a schema where+  RenderJoinConditions (Or l r) schema =+    "( "+    `AppendSymbol` RenderJoinConditions l schema+    `AppendSymbol` " ) OR ("+    `AppendSymbol` RenderJoinConditions r schema+    `AppendSymbol` " )"++  RenderJoinConditions (And l r) schema =+    "( "+    `AppendSymbol` RenderJoinConditions l schema+    `AppendSymbol` " ) AND ( "+    `AppendSymbol` RenderJoinConditions r schema+    `AppendSymbol` " )"++  RenderJoinConditions condition schema = RenderJoinCondition condition schema+++type family RenderJoinCondition condition schema where+  RenderJoinCondition (Equals l r) schema = ClosedCondition schema (Expr l) "=" (Expr r)+  RenderJoinCondition (NotEquals l r) schema = ClosedCondition schema (Expr l) "!=" (Expr r)+  RenderJoinCondition (Lt l r) schema = ClosedCondition schema (Expr l) "<" (Expr r)+  RenderJoinCondition (Lte l r) schema = ClosedCondition schema (Expr l) "<=" (Expr r)+  RenderJoinCondition (Gt l r) schema = ClosedCondition schema (Expr l) ">" (Expr r)+  RenderJoinCondition (Gte l r) schema = ClosedCondition schema (Expr l) ">=" (Expr r)+  RenderJoinCondition (IsNull field) schema = Validate field schema (+      field `AppendSymbol` " IS NULL"+    )+  RenderJoinCondition (NotNull field) schema = Validate field schema (+      field `AppendSymbol` " IS NOT NULL"+    )+  RenderJoinCondition a _ = TypeError ('Lit.Text "Invalid condition: " ':<>: 'ShowType a)+++{- | A closed condition is one that does not allow query parameters. -}+type family ClosedCondition schema l op r where+  ClosedCondition schema (Expr l) op (Expr r) =+    Validate l schema (+      Validate r schema (+        l+        `AppendSymbol` " "+        `AppendSymbol` op+        `AppendSymbol` " "+        `AppendSymbol` r+      )+    )+++{- | "?" constructor, used to indicate the presence of a query parameter. -}+data (?)++

@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+++{- | Delete statements. -}+module Database.Ribbit.Delete (+  DeleteFrom,+) where+++import Database.Ribbit.Conditions (RenderConditions, Where)+import Database.Ribbit.Render (Render)+import Database.Ribbit.Table (Name, DBSchema)+import GHC.TypeLits (AppendSymbol)+++{- | Delete statement. -}+data DeleteFrom table+++type instance Render (DeleteFrom table) =+  "DELETE FROM "+  `AppendSymbol` Name table++type instance Render (DeleteFrom table `Where` conditions) =+  Render (DeleteFrom table)+  `AppendSymbol` " WHERE "+  `AppendSymbol` RenderConditions conditions (DBSchema table)++

@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Ribbit.Insert (+  InsertInto,+) where+++import Database.Ribbit.Render (Render)+import Database.Ribbit.Table (Name)+import GHC.TypeLits (AppendSymbol)+++{- | Insert statement. -}+data InsertInto table fields+++type instance Render (InsertInto table fields) =+  "insert into "+  `AppendSymbol` Name table+  `AppendSymbol` " ("+  `AppendSymbol` RendFieldList fields+  `AppendSymbol`") values ("+  `AppendSymbol` RendPlaceholderList fields+  `AppendSymbol` ");"+++type family RendFieldList a where+  RendFieldList '[field] = field+  RendFieldList (f1:f2:more) =+    f1+    `AppendSymbol` ", "+    `AppendSymbol` RendFieldList (f2:more)++type family RendPlaceholderList a where+  RendPlaceholderList '[field] = "?"+  RendPlaceholderList (f1:f2:more) =+    "?"+    `AppendSymbol` ", "+    `AppendSymbol` RendPlaceholderList (f2:more)++

@@ -1,15 +1,15 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}  {- | "postgresql-simple"-backed query ribbit implementation. -} module Database.Ribbit.PostgreSQL (@@ -18,8 +18,8 @@   PsqlType(..),    -- * Performing queries.-  query,   execute,+  query,    -- * Creating tables.   createTable,@@ -42,17 +42,19 @@ import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Int (Int64)-import Data.Proxy (Proxy(Proxy))+import Data.Proxy (Proxy (Proxy)) import Data.String (fromString, IsString) import Data.Text (Text) import Data.Time (Day)-import Data.Tuple.Only (Only(Only))+import Data.Tuple.Only (Only (Only)) import Data.Type.Bool (If) import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple.FromField (FromField) import Database.PostgreSQL.Simple.ToField (Action, ToField)-import Database.Ribbit (Render, render, ArgsType, ResultType, (:>)((:>)),-  Name, Field, DBSchema, ValidField)+import Database.Ribbit.Args (ArgsType, ResultType)+import Database.Ribbit.Render (Render)+import Database.Ribbit.Table ((:>)((:>)), Name, DBSchema, Field,+  ValidField) import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage((:<>:),   ShowType)) import qualified Data.Text as T@@ -62,43 +64,56 @@ import qualified GHC.TypeLits as Lit  -{- | Execute a query against a PostgreSQL database connection. -}-query :: (-    MonadIO m,-    Render query,-    ToRow (ArgsType query),-    FromRow (ResultType query)-  )-  => Connection-  -> Proxy query-  -> ArgsType query-  -> m [ResultType query]-query conn theQuery args =-  liftIO . (fmap . fmap) unWrap $-    PG.query-      conn -      ((fromString . T.unpack . render) theQuery)-      (Wrap args)-- {- | Execute a statement. -}-execute :: (-    MonadIO m,-    ToRow (ArgsType query),-    Render query-  )+execute ::+     forall m query.+     (MonadIO m, ToRow (ArgsType query), KnownSymbol (Render query))   => Connection   -> Proxy query   -> ArgsType query   -> m Int64-execute conn theQuery args =+execute conn _theQuery args =   liftIO $     PG.execute       conn-      ((fromString . T.unpack . render) theQuery)+      (fromString (symbolVal (Proxy @(Render query))))       (Wrap args)  ++{- | Like 'PGT.ToRow', but defined here to avoid orphan instances. -}+class ToRow a where+  toRow :: a -> [Action]+instance (ToRow a, ToRow b) => ToRow (a :> b) where+  toRow (a :> b) = toRow a ++ toRow b+instance (ToField a) => ToRow (Only a) where+  toRow = PGT.toRow+instance ToRow () where+  toRow = PGT.toRow+  ++{- | Like 'PGF.FromRow', but defined here so we can avoid orphaned instances. -}+class FromRow a where+  fromRow :: PGF.RowParser a+instance (FromRow a, FromRow b) => FromRow (a :> b) where+  fromRow = +    (:>)+      <$> fromRow+      <*> fromRow+instance (FromField a) => FromRow (Only a) where+  fromRow = Only <$> PGF.field+++{- | Wrapper that helps us avoid orphan instances. -}+newtype Wrap a = Wrap {+    unWrap :: a+  }+instance (FromRow a) => PGF.FromRow (Wrap a) where+  fromRow = Wrap <$> fromRow+instance (ToRow a) => PGT.ToRow (Wrap a) where+  toRow = toRow . unWrap++ {- |   Create the indicated table in the database. @@ -188,20 +203,6 @@     tableName = Proxy  -class HasFields a where-  fields :: proxy a -> [Text]-instance (KnownSymbol name) => HasFields (Field name typ) where-  fields _proxy = [symbolVal (Proxy @name)]-instance (KnownSymbol name, HasFields more) =>-    HasFields (Field name typ :> more)-  where-    fields _proxy = symbolVal (Proxy @name) : fields (Proxy @more)-instance HasFields '[] where-  fields _proxy = []-instance (KnownSymbol name, HasFields more) => HasFields (name:more) where-  fields _proxy = symbolVal (Proxy @name) : fields (Proxy @more)-- class HasPsqlTypes a where   psqlTypes :: proxy a -> [Text] instance (HasIsNullable typ, HasPsqlType typ) => HasPsqlTypes (Field name typ) where@@ -233,6 +234,39 @@   psqlType _proxy = "date"  +{- | Make sure the fields in the list are actually part of the schema. -}+type family IsSubset fields schema where+  IsSubset '[] schema = 'True+  IsSubset (field:more) schema =+    If+      (ValidField field schema)+      (IsSubset more schema)+      (+        TypeError (+          'Lit.Text "field "+          ':<>: 'ShowType field+          ':<>: 'Lit.Text " is not part of the schema, so it cannot be\+                          \ used as a component of the primary key."+        )+      )+++{- | Produce a list of field names from a schema. -}+class HasFields a where+  fields :: proxy a -> [Text]+instance (KnownSymbol name) => HasFields (Field name typ) where+  fields _proxy = [symbolVal (Proxy @name)]+instance (KnownSymbol name, HasFields more) =>+    HasFields (Field name typ :> more)+  where+    fields _proxy = symbolVal (Proxy @name) : fields (Proxy @more)+instance HasFields '[] where+  fields _proxy = []+instance (KnownSymbol name, HasFields more) => HasFields (name:more) where+  fields _proxy = symbolVal (Proxy @name) : fields (Proxy @more)+++{- | Figure out if a Haskell type is "nullable" in sql. -} class HasIsNullable a where   isNullable :: proxy a -> Bool instance HasIsNullable (Maybe a) where@@ -256,60 +290,26 @@   deriving newtype (IsString)  -{- | Like 'PGF.FromRow', but defined here so we can avoid orphaned instances. -}-class FromRow a where-  fromRow :: PGF.RowParser a-instance (FromRow a, FromRow b) => FromRow (a :> b) where-  fromRow = -    (:>)-      <$> fromRow-      <*> fromRow-instance (FromField a) => FromRow (Only a) where-  fromRow = Only <$> PGF.field---{- | Like 'PGT.ToRow', but defined here to avoid orphan instances. -}-class ToRow a where-  toRow :: a -> [Action]-instance (ToRow a, ToRow b) => ToRow (a :> b) where-  toRow (a :> b) = toRow a ++ toRow b-instance (ToField a) => ToRow (Only a) where-  toRow = PGT.toRow-instance ToRow () where-  toRow = PGT.toRow-  ---{- | Wrapper that helps us avoid orphan instances. -}-newtype Wrap a = Wrap {-    unWrap :: a-  }-instance (FromRow a) => PGF.FromRow (Wrap a) where-  fromRow = Wrap <$> fromRow-instance (ToRow a) => PGT.ToRow (Wrap a) where-  toRow = toRow . unWrap-- {- | Like 'Lit.symbolVal', but produce any kind of string-like thing. -} symbolVal :: (KnownSymbol n, IsString a) => proxy n -> a symbolVal = fromString . Lit.symbolVal  -{- | Make sure the fields in the list are actually part of the schema. -}-type family IsSubset fields schema where-  IsSubset '[] schema = 'True-  IsSubset (field:more) schema =-    If-      (ValidField field schema)-      (IsSubset more schema)-      (-        TypeError (-          'Lit.Text "field "-          ':<>: 'ShowType field-          ':<>: 'Lit.Text " is not part of the schema, so it cannot be\-                          \ used as a component of the primary key."-        )-      )---+{- | Execute a query against a PostgreSQL database connection. -}+query ::+     forall m query.+     ( MonadIO m+     , KnownSymbol (Render query)+     , ToRow (ArgsType query)+     , FromRow (ResultType query)+     )+  => Connection+  -> Proxy query+  -> ArgsType query+  -> m [ResultType query]+query conn _theQuery args =+  liftIO . (fmap . fmap) unWrap $+    PG.query+      conn +      (fromString (symbolVal (Proxy @(Render query))))+      (Wrap args)

@@ -0,0 +1,17 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+++{- | Render queries. -}+module Database.Ribbit.Render (+  Render+) where+++import GHC.TypeLits (Symbol)+++{- | Render a query. -}+type family Render a :: Symbol++

@@ -0,0 +1,177 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Ribbit.Select (+  -- * Query Structure+  Select,+  From,+  As,+  On,+  LeftJoin,++  -- * Type families+  RenderFieldList,+  RenderField,+  Expr,+) where+++import Database.Ribbit.Conditions (RenderJoinConditions, Where, RenderConditions)+import Database.Ribbit.Render (Render)+import Database.Ribbit.Table (Name, DBSchema, Field, (:>), Table, Flatten,+  Validate)+import GHC.TypeLits (AppendSymbol, Symbol)+++{- | "SELECT" constructor, used for starting a @SELECT@ statement. -}+data Select fields+++{- |+  "FROM" constructor, used for attaching a SELECT projection to a relation+  in the database.+-}+data From proj relation+infixl 6 `From`+++{- | "AS" constructor, used for attaching a name to a table in a FROM clause. -}+data As relation (name :: Symbol)+infix 9 `As`++{- | Cross Product -}+instance (Table table) => Table ((table `As` alias) : more) where+  type Name ((table `As` alias):more) =+    CrossProductName ((table `As` alias) : more)++  type DBSchema ((table `As` alias) : more) =+    CrossProductSchema ((table `As` alias) : more)+++{- | Product the renderable "name" of a cross product. -}+type family CrossProductName cp where+  CrossProductName '[table `As` name] = +    Name table+    `AppendSymbol` " AS "+    `AppendSymbol` name+  CrossProductName ((table `As` name) : moreTables) = +    Name table+    `AppendSymbol` " AS "+    `AppendSymbol` name+    `AppendSymbol` ", "+    `AppendSymbol` CrossProductName moreTables++{- | Produce the schema of a cross product. -}+type family CrossProductSchema cp where+  CrossProductSchema '[table `as` name] =+    Flatten (+      AliasAs name (DBSchema table)+    )+  CrossProductSchema ((table `As` name) : moreTables) =+    Flatten (+      AliasAs name (DBSchema table)+      :> CrossProductSchema moreTables+    )++{- |+  Rename the fields in a given schema to reflect an applied table+  alias. For instance, data Foo+-}+type family AliasAs prefix schema where+  AliasAs prefix (Field name typ) =+    Field+      (prefix `AppendSymbol` "." `AppendSymbol` name)+      typ+  AliasAs prefix (Field name typ :> more) =+    Field+      (prefix `AppendSymbol` "." `AppendSymbol` name)+      typ+    :> AliasAs prefix more+++{- | "ON" keyword, for joins.  -}+data On join (conditions :: *)+infix 7 `On`+++{- | Left Joins. -}+data LeftJoin left right+infix 8 `LeftJoin`+++type instance Render (From (Select proj) table) =+  "SELECT "+  `AppendSymbol` RenderFieldList proj (DBSchema table)+  `AppendSymbol` " FROM "+  `AppendSymbol` Name table++type family RenderFieldList fields schema where+  RenderFieldList '[field] schema =+    RenderField field schema++  RenderFieldList (f1:f2:more) schema =+    RenderField f1 schema+    `AppendSymbol` ", "+    `AppendSymbol` RenderFieldList (f2:more) schema++type family RenderField field schema where+  RenderField field schema =+    Validate field schema field+++data Expr (a :: k)++instance Table (((l `As` lname) `LeftJoin` (r `As` rname)) `On` conditions) where+  type Name (((l `As` lname) `LeftJoin` (r `As` rname)) `On` conditions) =+    Name l+    `AppendSymbol` " AS "+    `AppendSymbol` lname+    `AppendSymbol` " LEFT JOIN "+    `AppendSymbol` Name r+    `AppendSymbol` " AS "+    `AppendSymbol` rname+    `AppendSymbol` " ON "+    `AppendSymbol`+      RenderJoinConditions+        conditions+        (+          LeftJoinSchema+            (AliasAs lname (DBSchema l))+            (AliasAs rname (DBSchema r))+        )++  type DBSchema (((l `As` lname) `LeftJoin` (r `As` rname)) `On` conditions) =+    LeftJoinSchema+      (AliasAs lname (DBSchema l))+      (AliasAs rname (DBSchema r))+++{- | Produce the schema for a left join. -}+type family LeftJoinSchema l r where+  LeftJoinSchema l r =+    Flatten (l :> Nullable r)+++{- | Make all the fields of a schema nullable. -}+type family Nullable schema where+  Nullable (Field name (Maybe typ)) =+    Field name (Maybe typ)++  Nullable (Field name typ) =+    Field name (Maybe typ)++  Nullable (a :> b) =+    Flatten (Nullable a :> Nullable b)+++type instance Render (proj `From` table `Where` conditions) =+  Render (proj `From` table)+  `AppendSymbol` " WHERE "+  `AppendSymbol` RenderConditions conditions (DBSchema table)++

@@ -0,0 +1,123 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Ribbit.Table (+  Table(..),+  Field,+  (:>)(..),++  Flatten,+  ValidField,+  Validate,+  NotInSchema,+) where+++import Data.Type.Bool (type (||), If)+import GHC.TypeLits (Symbol, TypeError, ErrorMessage(ShowType, (:<>:)))+import qualified GHC.TypeLits as Lit+++{- |+  Type class for defining your own tables. The primary way for you to+  introduce a new schema is to instantiate this type class for one of+  your types.++  E.g.:++  > data MyTable+  > instance Table MyTable where+  >   type Name MyTable = "my_table"+  >   type DBSchema MyTable =+  >     Field "id" Int+  >     :> Field "my_non_nullable_text_field" Text+  >     :> Field "my_nullable_int_field" (Maybe Int)+    +-}+class Table relation where+  type Name relation :: Symbol+  type DBSchema relation+++{- |+  Define a field in a database schema, where:++  - @name@: is the name of the database column, expressed as a type-level+    string literal, and++  - @typ@: is the Haskell type whose values get stored in the column.++  E.g:++  - @'Field' "company_name" 'Text'@+  - @'Field' "expiration_date" ('Maybe' 'Data.Time.Day')@++-}+data Field name typ+++{- |+  String two types together. 'Int' ':>' 'Int' ':>' 'Int' is similar in+  principal to the nested tuple ('Int', ('Int', 'Int')), but looks a+  whole lot nicer when the number of elements becomes large.++  This is how you build up a schema from a collection of 'Field' types.++  E.g.:++  > Field "foo" Int+  > :> Field "bar" Text+  > :> Field "baz" (Maybe Text)++  It also the mechanism by which this library builds up the Haskell+  types for query parameters and resulting rows that get returned. So+  if you have a query that accepts three text query parameters, that+  type represented in Haskell is going to be @('Only' 'Text' ':>' 'Only'+  'Text' ':>' 'Only' 'Text')@.++  If that query returns rows that contain a Text, an Int, and a Text,+  then the type of the rows will be @('Only' 'Text' ':>' 'Only' 'Int'+  ':>' 'Only' 'Text')@.++-}+data a :> b = a :> b+  deriving (Eq, Ord, Show)+infixr 5 :>++{- |+  Normalize nested type strings to be right associative. Mainly used to+  help simplify the implementation of other type families.+-}+type family Flatten a where+  Flatten ((a :> b) :> c) = Flatten (a :> b :> c)+  Flatten (a :> b) = a :> Flatten b+  Flatten a = a+++{- | Type level check to see if the field is actually contained in the schema -}+type family ValidField field schema where+  ValidField name (Field name typ) = 'True+  ValidField name (Field _ typ) = 'False+  ValidField name (a :> b) = ValidField name a || ValidField name b+++type Validate field schema result =+  If (ValidField field schema)+    result+    (NotInSchema field schema)+++type family NotInSchema field schema where+  NotInSchema field schema =+    TypeError (+      'Lit.Text "name ("+      ':<>: 'ShowType field+      ':<>: 'Lit.Text ") not found in schema: "+      ':<>: 'ShowType schema+    )+

@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+++{- | Update statements. -}+module Database.Ribbit.Update (+  Update,+) where+++import Database.Ribbit.Conditions (RenderConditions, Where)+import Database.Ribbit.Render (Render)+import Database.Ribbit.Table (Name, DBSchema)+import GHC.TypeLits (AppendSymbol, Symbol)+++{- | Update statement. -}+data Update table (fields :: [Symbol])+++type instance Render (Update table fields) =+  "UPDATE "+  `AppendSymbol` Name table+  `AppendSymbol` " SET "+  `AppendSymbol` RenderUpdateFields fields++type instance Render (Update table fields `Where` conditions) =+  Render (Update table fields)+  `AppendSymbol` " WHERE "+  `AppendSymbol` RenderConditions conditions (DBSchema table)+++type family RenderUpdateFields fields where+  RenderUpdateFields '[field] =+    field `AppendSymbol` " = ?"+  RenderUpdateFields (field:more) =+    field+    `AppendSymbol` " = ?, "+    `AppendSymbol` RenderUpdateFields more++-- {- UPDATE -}+-- instance (KnownSymbol (Name table), RenderUpdates updates)+--   =>+--     Render (Update table updates)+--   where+--     render _proxy =+--       "UPDATE "+--       <> symbolVal (Proxy @(Name table))+--       <> " SET "+--       <> renderUpdates (Proxy @updates)+-- +-- +-- {- | Render the updates to a table. -}+-- class RenderUpdates a where+--   renderUpdates :: proxy a -> Text+-- instance (KnownSymbol field) => RenderUpdates '[field] where+--   renderUpdates _ = symbolVal (Proxy @field) <> " = ?"+-- instance (KnownSymbol field, RenderUpdates (m:ore))+--   =>+--     RenderUpdates (field : (m:ore))+--   where+--     renderUpdates _ =+--       symbolVal (Proxy @field) <> " = ?, "+--       <> renderUpdates (Proxy @(m:ore))