data-basic (empty) → 0.2.0.0

raw patch · 28 files changed

+3167/−0 lines, 28 filesdep +aesondep +basedep +basicsetup-changed

Dependencies added: aeson, base, basic, binary, bytestring, cases, containers, hssqlppp, lens, lens-aeson, mtl, overload, postgresql-simple, simple-effects, string-conv, template-haskell, text, time

Files

• LICENSE +19/−0
• Setup.hs +2/−0
• data-basic.cabal +85/−0
• src/Data/Basic.hs +20/−0
• src/Data/Basic/Example.hs +206/−0
• src/Internal/Control/Effects/Basic.hs +95/−0
• src/Internal/Data/Basic.hs +9/−0
• src/Internal/Data/Basic/Common.hs +155/−0
• src/Internal/Data/Basic/Compare.hs +34/−0
• src/Internal/Data/Basic/Compiler.hs +136/−0
• src/Internal/Data/Basic/Foreign.hs +92/−0
• src/Internal/Data/Basic/Lens.hs +102/−0
• src/Internal/Data/Basic/Replace.hs +69/−0
• src/Internal/Data/Basic/Sql/Types.hs +179/−0
• src/Internal/Data/Basic/SqlToHsTypes.hs +26/−0
• src/Internal/Data/Basic/TH.hs +73/−0
• src/Internal/Data/Basic/TH/Compiler.hs +137/−0
• src/Internal/Data/Basic/TH/Generator.hs +327/−0
• src/Internal/Data/Basic/TH/Helper.hs +121/−0
• src/Internal/Data/Basic/TH/SqlToHsTypes.hs +72/−0
• src/Internal/Data/Basic/TH/Types.hs +117/−0
• src/Internal/Data/Basic/Tutorial.hs +232/−0
• src/Internal/Data/Basic/TypeLevel.hs +92/−0
• src/Internal/Data/Basic/Types.hs +581/−0
• src/Internal/Data/Basic/Virtual.hs +81/−0
• src/Internal/Interlude.hs +59/−0
• test/Model.hs +7/−0
• test/Spec.hs +39/−0

@@ -0,0 +1,19 @@+Copyright (c) 2016-2017 Luka Horvat, Nikola Henezi++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

@@ -0,0 +1,85 @@+name: data-basic+version: 0.2.0.0+cabal-version: >=1.10+build-type: Simple+license: MIT+license-file: LICENSE+maintainer: nikola@henezi.com, luka.horvat9@gmail.com+homepage: https://gitlab.com/haskell-hr/basic+synopsis: A database library with a focus on ease of use, type safety and useful error messages+description:+    Please see README.md+category: Database+author: Nikola Henezi, Luka Horvat++source-repository head+    type: git+    location: https://gitlab.com/haskell-hr/basic.git++library+    exposed-modules:+        Internal.Data.Basic.TH+        Internal.Data.Basic+        Internal.Control.Effects.Basic+        Internal.Data.Basic.Types+        Internal.Data.Basic.Lens+        Internal.Data.Basic.TH.Types+        Internal.Data.Basic.TH.Compiler+        Internal.Data.Basic.TH.SqlToHsTypes+        Internal.Data.Basic.TH.Helper+        Internal.Data.Basic.TH.Generator+        Internal.Data.Basic.Sql.Types+        Internal.Data.Basic.Compiler+        Internal.Data.Basic.Replace+        Internal.Data.Basic.Common+        Internal.Data.Basic.Virtual+        Internal.Data.Basic.Compare+        Internal.Data.Basic.Foreign+        Internal.Data.Basic.TypeLevel+        Internal.Data.Basic.SqlToHsTypes+        Internal.Data.Basic.Tutorial+        Data.Basic.Example+        Data.Basic+    build-depends:+        base >=4.7 && <5,+        simple-effects >=0.8.0.2,+        lens >=4.15.1,+        postgresql-simple >=0.5.2.1,+        text >=1.2.2.1,+        hssqlppp >=0.6.0,+        template-haskell >=2.11.1.0,+        cases >=0.1.3.2,+        containers >=0.5.7.1,+        time >=1.6.0.1,+        bytestring >=0.10.8.1,+        overload >=0.1.0.3,+        aeson >=1.0.2.1,+        lens-aeson >=1.0.0.5,+        binary >=0.8.3.0,+        string-conv >=0.1.2,+        mtl >=2.2.1+    default-language: Haskell2010+    default-extensions: NoImplicitPrelude OverloadedStrings+                        DuplicateRecordFields MultiParamTypeClasses DataKinds+                        TemplateHaskell FlexibleContexts FlexibleInstances TypeFamilies+                        ScopedTypeVariables ConstraintKinds NoMonomorphismRestriction+                        TypeOperators TypeApplications PolyKinds DeriveGeneric+    hs-source-dirs: src+    other-modules:+        Internal.Interlude+    ghc-options: -Wall++test-suite basic-test+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    build-depends:+        base >=4.9.1.0,+        basic -any,+        postgresql-simple >=0.5.2.1,+        time >=1.6.0.1,+        lens >=4.15.1+    default-language: Haskell2010+    hs-source-dirs: test+    other-modules:+        Model+    ghc-options: -threaded -rtsopts -with-rtsopts=-N

@@ -0,0 +1,20 @@+module Data.Basic+    ( Key, Point(..), Table(..), TableField(..), UniqueConstraint(..), PrimaryKeyConstraint+    , ForeignKeyConstraint(..), MissingField(..), FieldConstraint(..), AllRows, Entity(..)+    , EntityKind(..), VirtualTable, virtualTableLens, Getter', FieldOpticProxy, fieldOptic+    , ForeignKeyLensProxy, foreignKeyLens+    , MonadEffectBasic, allRows+    , ddelete, dupdate, insert, dfilter, save, dtake, djoin, dsortOn, dfoldMap, dfoldMapInner, dmap+    , dgroupOn+    , (<.), (>.), (==.), (/=.), (<=.), (>=.)+    , ConditionExp(In), Avg(..), Count(..), Min(..), Max(..), Sum(..)+    , handleBasicPsql, handleBasic, connectPostgreSQL+    , mkFromFile, mkFromFiles, printToFile )+    where++import Internal.Data.Basic.Types+import Internal.Data.Basic+import Internal.Data.Basic.TH+import Internal.Control.Effects.Basic+import Internal.Data.Basic.SqlToHsTypes+import Database.PostgreSQL.Simple

@@ -0,0 +1,206 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Data.Basic.Example where++import Internal.Interlude hiding (filter)++import Database.PostgreSQL.Simple hiding (In)+import Database.PostgreSQL.Simple.FromRow++import Data.Basic+import Language.Haskell.TH hiding (location)++import Unsafe.Coerce++data User = User { _userId   :: {-# UNPACK #-} !Key+                 , _userName :: {-# UNPACK #-} !Text+                 , _userLocation :: Point } deriving (Eq, Ord, Read, Show)++makeLenses ''User++instance Table User where+    type TableName User = "blog_user"+    type TableFields User = ["id", "name", "location"]+    type TableConstraints User = '[ 'Unique "blog_user_pkey"]+    type TablePrimaryKey User = 'Just "blog_user_pkey"+    type TableRequiredFields User = ['Required "id", 'Required "name"]+    newEntity = Entity (User (unsafeCoerce ()) (unsafeCoerce ()) (Point 0 0))++instance UniqueConstraint "blog_user_pkey" where+    type UniqueTable "blog_user_pkey" = User+    type UniqueFields "blog_user_pkey" = '["id"]++instance PrimaryKeyConstraint "blog_user_pkey"++instance TableField User "id" where+    type TableFieldType User "id" = Key+    tableFieldLens = userId++instance TableField User "name" where+    type TableFieldType User "name" = Text+    tableFieldLens = userName++instance TableField User "location" where+    type TableFieldType User "location" = Point+    tableFieldLens = userLocation++instance FromRow User where+    fromRow = User <$> field <*> field <*> field++data Post = Post { _postId     :: Key+                 , _postName   :: Text+                 , _postUserId :: Key } deriving (Eq, Ord, Read, Show)++makeLenses ''Post++instance Table Post where+    type TableName Post = "blog_post"+    type TableFields Post = ["id", "name", "author"]+    type TableConstraints Post = '[ 'ForeignKey "blog_post_author_fkey"]+    type TablePrimaryKey Post = 'Just "blog_post_pkey"+    type TableRequiredFields Post = ['Required "id", 'Required "name", 'Required "author"]+    newEntity = Entity (Post (unsafeCoerce ()) (unsafeCoerce ()) (unsafeCoerce ()))++instance UniqueConstraint "blog_post_pkey" where+    type UniqueTable "blog_post_pkey" = Post+    type UniqueFields "blog_post_pkey" = '["id"]++instance PrimaryKeyConstraint "blog_post_pkey"++instance FromRow Post where+    fromRow = Post <$> field <*> field <*> field++instance TableField Post "id" where+    type TableFieldType Post "id" = Key+    tableFieldLens = postId++instance TableField Post "name" where+    type TableFieldType Post "name" = Text+    tableFieldLens = postName++instance TableField Post "author" where+    type TableFieldType Post "author" = Key+    tableFieldLens = postUserId++instance ForeignKeyConstraint "blog_post_author_fkey" where+    type ForeignKeyFrom "blog_post_author_fkey" = Post+    type ForeignKeyFromFields "blog_post_author_fkey" = '["author"]+    type ForeignKeyTo "blog_post_author_fkey" = User+    type ForeignKeyToFields "blog_post_author_fkey" = '["id"]++allUsers :: AllRows User res => res+allUsers = allRows @"blog_user"++allPosts :: AllRows Post res => res+allPosts = allRows @"blog_post"++newUser :: Entity ('Fresh ['Required "id", 'Required "name", 'Required "location"]) User+newUser = Entity (User 0 "" (Point 0 0))++newPost :: Entity ('Fresh ['Required "id", 'Required "name", 'Required "author"]) Post+newPost = Entity (Post 0 "" 1)++posts :: VirtualTable "blog_post_author_fkey" res+      => Getter' (Entity ('FromDb c) (ForeignKeyTo "blog_post_author_fkey")) res+posts = virtualTableLens @"blog_post_author_fkey"++id :: FieldOpticProxy (Proxy "id" -> o) => o+id = fieldOptic @"id"++name :: FieldOpticProxy (Proxy "name" -> o) => o+name = fieldOptic @"name"++location :: FieldOpticProxy (Proxy "location" -> o) => o+location = fieldOptic @"location"++authorId :: FieldOpticProxy (Proxy "author" -> o) => o+authorId = fieldOptic @"author"++author :: ForeignKeyLensProxy (Proxy "blog_post_author_fkey" -> o) => o+author = foreignKeyLens @"blog_post_author_fkey"++test1 :: (MonadIO m, MonadEffectBasic m) => m ()+test1 = do+    void $ ddelete allPosts+    void $ ddelete allUsers+    let user = newUser & name .~ "Luka"+                       & id .~ 1+                       & location .~ Point 5 6+    user' <- insert user+    let post = newPost & id .~ 1+                       & name .~ "New post"+                       & author .~ user'+    post' <- insert post+    void $ dfilter (\u -> In (u ^. id) [1, 3, 4]) allUsers+    void $ dfilter (\u -> u ^. id <. (2 :: Key)) allUsers++    auth <- post' ^. author+    void $ save (auth & name .~ "Luka H")++    let user2 = newUser & name .~ "Ivan"+                        & id .~ 2+                        & location .~ Point 6 7+    void $ insert user2++    us <- dtake 1 $ dsortOn (\u -> Down (u ^. id)) allUsers+    print us++    void $ dupdate (\u' -> u' & location .~ Point 7 8) allUsers++    usersPosts <- allUsers `djoin` allPosts+    print usersPosts++    -- Folding/grouping test+    void $ ddelete allPosts+    void $ ddelete allUsers+    void $ insert $+        newUser+            & name .~ "A"+            & id .~ 1+            & location .~ Point 0 0++    void $ insert $+        newUser+            & name .~ "A"+            & id .~ 2+            & location .~ Point 0 0++    void $ insert $+        newUser+            & name .~ "B"+            & id .~ 3+            & location .~ Point 0 0++    void $ insert $+        newUser+            & name .~ "B"+            & id .~ 4+            & location .~ Point 0 0++    print =<< dfoldMap (\u -> (Min (u ^. id), Max (u ^. id))) allUsers+    print =<< dmap (\u -> u ^. name) allUsers+    allUsers+        & dgroupOn (view name)+        & dmap (\(_, g) ->+            (dfoldMap ((,) <$> Min . view id <*> Max . view id) g)+            )+        & (>>= print)+    allUsers+        & dgroupOn (view name)+        & dfoldMapInner ((,) <$> Min . view id <*> Max . view id)+        & (>>= print)++test :: IO ()+test = do+    conn <- connectPostgreSQL "host=localhost port=5432 user=postgres dbname=postgres password=admin connect_timeout=10"+    handleBasicPsql conn test1++-- Two very useful functions.+-- And these are just good for printing out code.++putQ :: Show a => Q a -> IO ()+putQ xQ = do x <- runQ xQ+             print x++putQLn :: Show a => Q a -> IO ()+putQLn xQ = do putQ xQ+               putText ""

@@ -0,0 +1,95 @@+{-# LANGUAGE RankNTypes, ConstraintKinds, FlexibleContexts, TypeFamilies, ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications, TypeOperators, DataKinds, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE TypeFamilyDependencies #-}+module Internal.Control.Effects.Basic where++import Internal.Interlude++import Control.Effects+import Database.PostgreSQL.Simple+import qualified Database.PostgreSQL.Simple.Types as PSQL++import Internal.Data.Basic.Types+import Internal.Data.Basic.Sql.Types+import Internal.Data.Basic.Compiler++data Basic++newtype SqlRequest a = SqlRequest { getSqlRequest :: SqlExp } deriving Show++type instance EffectMsg1 Basic = SqlRequest+type instance EffectRes1 Basic = []+type instance EffectCon1 Basic a = FromRow a++handleBasic :: (forall b. FromRow b => SqlRequest b -> m [b])+            -> EffectHandler1 Basic m a -> m a+handleBasic = handleEffect1++-- | Handles SQL by querying a PostgreSQL database.+handleBasicPsql :: MonadIO m => Connection -> EffectHandler1 Basic m a -> m a+handleBasicPsql conn = handleBasic+    (liftIO . runQuerySegment . sqlExpToQuery . getSqlRequest)+  where+    runQuerySegment :: FromRow b => QuerySegment -> IO [b]+    runQuerySegment (QuerySegment q as) = query conn q as++type family AllTables tables where+    AllTables '[x] = x+    AllTables (x ': xs) = x :. AllTables xs++class (FromRow (AllTables ts)) => AllHaveFromRowInstance ts where+    compositeToTuple :: proxy ts -> AllTables ts -> DbResult ts++instance (FromRow a) => AllHaveFromRowInstance '[a] where+    compositeToTuple _ = Entity++instance (FromRow a, FromRow b) => AllHaveFromRowInstance '[a, b] where+    compositeToTuple _ (a :. b) = (Entity a, Entity b)++instance (FromRow a, FromRow b, FromRow c) => AllHaveFromRowInstance '[a, b, c] where+    compositeToTuple _ (a :. b :. c) = (Entity a, Entity b, Entity c)++runDbStatement :: forall ts m f.+            (AllHaveFromRowInstance ts, MonadEffect1 Basic m)+         => DbStatement f ts -> m [DbResult ts]+runDbStatement = fmap (map (compositeToTuple (Proxy @ts)))+         . effect1 (Proxy :: Proxy Basic)+         . SqlRequest+         . compileToSql++runAggregateStatement ::+    forall aggr m.+    ( MonadEffect1 Basic m+    , FromRow (AggregationResult aggr))+    => AggregateStatement aggr 'AM -> m (AggregationResult aggr)+runAggregateStatement =+      fmap unsafeHead+    . effect1 (Proxy :: Proxy Basic)+    . SqlRequest+    . aggregateStatementToSql++type family WithoutOnly a where+    WithoutOnly (PSQL.Only a) = a+    WithoutOnly a = a+class NoOnly a where+    noOnly :: a -> WithoutOnly a+instance NoOnly (PSQL.Only a) where+    noOnly (PSQL.Only a) = a+instance {-# OVERLAPPABLE #-}+    WithoutOnly a ~ a+    => NoOnly a where+    noOnly = identity++runMapStatement ::+    forall res m f.+    ( MonadEffect1 Basic m+    , FromRow res+    , NoOnly res )+    => DbStatement f '[res] -> m [WithoutOnly res]+runMapStatement =+      fmap (fmap (noOnly @res))+    . effect1 (Proxy :: Proxy Basic)+    . SqlRequest+    . compileToSql++type MonadEffectBasic m = MonadEffect1 Basic m

@@ -0,0 +1,9 @@+module Internal.Data.Basic+    ( module X ) where++import Internal.Data.Basic.Common  as X+import Internal.Data.Basic.Replace as X+import Internal.Data.Basic.Compare as X+import Internal.Data.Basic.Virtual as X+import Internal.Data.Basic.Lens    as X+import Internal.Data.Basic.Foreign as X

@@ -0,0 +1,155 @@+{-# LANGUAGE MultiParamTypeClasses, DataKinds, FlexibleInstances, TypeFamilies+           , FlexibleContexts, ScopedTypeVariables, ConstraintKinds+           , NoMonomorphismRestriction, TypeOperators, UndecidableSuperClasses, TypeApplications+           , AllowAmbiguousTypes, UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans -Wno-redundant-constraints #-}+-- {-# OPTIONS_GHC -ddump-splices #-}+module Internal.Data.Basic.Common (module Internal.Data.Basic.Common) where++import Internal.Interlude hiding (filter)++import Database.PostgreSQL.Simple (FromRow)+import Database.PostgreSQL.Simple.ToRow (ToRow)++import Overload++import Internal.Data.Basic.Types+import Internal.Control.Effects.Basic++class LiftedStatement fs t res where+    liftDbExp :: DbStatement fs t -> res+instance (DbStatement fs ~ dbs, ts1 ~ ts2) => LiftedStatement fs ts1 (dbs (ts2 :: [*])) where+    liftDbExp = identity+instance ( res ~ [DbResult ts]+         , AllHaveFromRowInstance ts, MonadEffectBasic m )+         => LiftedStatement fs ts (m (res :: *)) where+    liftDbExp = runDbStatement++djoin :: LiftedStatement 'Unfiltered (tables1 ++ tables2) res+      => DbStatement 'Unfiltered tables1+      -> DbStatement 'Unfiltered tables2 -> res+djoin l r = liftDbExp (Join l r)++dfilter :: ( LiftedStatement 'Filtered tables res+           , TableSetVars 'Filtering tables+           , Selection f )+        => (Variables 'Filtering tables -> ConditionExp) -> DbStatement f tables -> res+dfilter f t = liftDbExp (Filter f t)++ddelete :: (LiftedStatement 'Deleted '[table] res, Selection f, Table table)+        => DbStatement f '[table] -> res+ddelete = liftDbExp . Delete++type AllRows table res = (Table table, LiftedStatement 'Unfiltered '[table] res)++allRows :: forall tableName table res.+        (TableName table ~ tableName, AllRows table res)+        => res+allRows = liftDbExp (Table (Proxy @tableName))++allRowsProxy ::+    forall table res proxy.+    (Table table, LiftedStatement 'Unfiltered '[table] res)+    => proxy table -> res+allRowsProxy _ = allRows @(TableName table)++rawQuery :: forall a r m. (MonadEffectBasic m, FromRow a, ToRow r)+         => Text -> r -> m [Entity ('FromDb 'Live) a]+rawQuery q r = runDbStatement (Raw q r :: DbStatement f '[a])++insert :: (CanInsert entKind table, MonadEffectBasic m, FromRow table)+       => Entity entKind table -> m (Entity ('FromDb 'Live) table)+insert = fmap unsafeHead . runDbStatement . Insert++dupdate :: (MonadEffectBasic m, FromRow table, Selection f)+        => (Var 'Updating table -> UpdateExp fields table) -> DbStatement f '[table]+        -> m [Entity ('FromDb 'Live) table]+dupdate f e = runDbStatement (Update f e)++dsortOn :: ( LiftedStatement 'Sorted tables res+           , TableSetVars 'Sorting tables+           , Sortable ord+           , Selection f )+        => (Variables 'Sorting tables -> ord) -> DbStatement f tables -> res+dsortOn f t = liftDbExp (SortOn f t)++dtake :: ( LiftedStatement 'Limited tables res+         , SelectionOrSortedSelection f )+      => Int -> DbStatement f tables -> res+dtake n t = liftDbExp (Take n t)++dgroupOn ::+    ( Groupable group+    , TableSetVars 'Grouping tables+    , Internal.Data.Basic.Types.Selection f )+    => (Variables 'Grouping tables -> group) -> DbStatement f tables -> GroupStatement group tables+dgroupOn = GroupOn++dmapAll ::+    (Mappable map, CanMap f, TableSetVars 'Mapping tables)+    => (Variables 'Mapping tables -> map) -> DbStatement f tables+    -> DbStatement 'Mapped '[MapResult map]+dmapAll = Map++dgroupMap ::+    (GroupMappable map, InterpretAsGroupMap map ~ 'True)+    => ((AsAggregate group, DbStatement 'Grouped tables) -> map)+    -> GroupStatement group tables+    -> DbStatement 'Folded '[GroupMapResult map]+dgroupMap = GroupMap++overload "dmap'" ['dmapAll, 'dgroupMap]++class LiftedMapStatement fs t res where+    liftMapStatement :: DbStatement fs '[t] -> res+instance (DbStatement fs ~ dbs, '[ts1] ~ ts2) => LiftedMapStatement fs ts1 (dbs (ts2 :: [*])) where+    liftMapStatement = identity+instance+    ( res ~ [WithoutOnly ts]+    , MonadEffectBasic m+    , FromRow ts+    , NoOnly ts )+    => LiftedMapStatement fs ts (m (res :: *)) where+    liftMapStatement = runMapStatement++dmap :: forall f res a b m (ts :: [*]) t.+    (Dmap' ((a -> b) -> m ts -> DbStatement f '[t]), LiftedMapStatement f t res)+    => (a -> b) -> m ts -> res+dmap f as = liftMapStatement @f @t @res (dmap' f as)++class+    interpretAsGroupMap ~ InterpretAsGroupMap res+    => LiftedAggregation (interpretAsGroupMap :: Bool) aggr res where+    liftAggregation :: AggregateStatement aggr 'AM -> res+instance {-# INCOHERENT #-}+    ( GroupMappableThing (AggregationResult aggr) 'AM ~ aggStat, Aggregatable aggr+    , InterpretAsGroupMap aggStat ~ 'True )+    => LiftedAggregation 'True aggr aggStat where+    liftAggregation = GroupMappableAggr+instance {-# INCOHERENT #-}+    ( GroupMappableThing (AggregationResult aggr) ~ aggStat, m ~ 'AM, Aggregatable aggr+    , InterpretAsGroupMap (aggStat m) ~ i )+    => LiftedAggregation i aggr (aggStat (m :: AM)) where+    liftAggregation = GroupMappableAggr+instance {-# INCOHERENT #-}+    ( res ~ AggregationResult aggr, MonadEffectBasic m, FromRow res+    , InterpretAsGroupMap (m res) ~ i )+    => LiftedAggregation i aggr (m (res :: *)) where+    liftAggregation = runAggregateStatement++dfoldMap :: forall tables aggr f res.+    ( Aggregatable aggr+    , CanAggregate f+    , TableSetVars 'Folding tables+    , LiftedAggregation (InterpretAsGroupMap res) aggr res )+    => (Variables 'Folding tables -> aggr) -> DbStatement f tables+    -> res+dfoldMap f s = liftAggregation (Aggregate f s)++dfoldMapInner ::+    ( AsAggregate group ~ GroupMappableThing t 'AM+    , LiftedMapStatement 'Folded (ListToSimpleTuple (TupleToList t ++ TupleToList (AggregationResult aggr))) res+    , Aggregatable aggr+    , TableSetVars 'Folding tables )+    => (Variables 'Folding tables -> aggr) -> GroupStatement group tables -> res+dfoldMapInner f s = liftMapStatement (dgroupMap (\(g, t) -> (g, GroupMappableAggr (Aggregate f t))) s)

@@ -0,0 +1,34 @@+{-# LANGUAGE UndecidableInstances #-}+module Internal.Data.Basic.Compare where++import Internal.Interlude++import Internal.Data.Basic.Types+import Internal.Data.Basic.Sql.Types++class ComparableInDbExp (a :: *) (b :: *) where+    compareInDbExp :: Comparison -> a -> b -> ConditionExp+instance {-# INCOHERENT #-} (ValueAsDbExp b a, Ord a)+    => ComparableInDbExp (DbExp k a) b where+    compareInDbExp comp a b = Compare comp a (valueAsDbExp b)+instance {-# INCOHERENT #-} (ValueAsDbExp a b, Ord b)+    => ComparableInDbExp a (DbExp k b) where+    compareInDbExp comp a = Compare comp (valueAsDbExp a)++infix 4 ==.+infix 4 >.+infix 4 /=.+infix 4 <.+infix 4 <=.+infix 4 >=.++(>.), (==.), (/=.), (<.), (<=.), (>=.) :: ComparableInDbExp a b => a -> b -> ConditionExp+(>.) = compareInDbExp GreaterThan+(==.) = compareInDbExp Equal+(/=.) = compareInDbExp NotEqual+(<.) = compareInDbExp LessThan+(<=.) = compareInDbExp LessOrEqual+(>=.) = compareInDbExp GreaterOrEqual++(&&.) :: ConditionExp -> ConditionExp -> ConditionExp+(&&.) = BoolOp And

@@ -0,0 +1,136 @@+{-# LANGUAGE GADTs, ScopedTypeVariables, RankNTypes, DataKinds, AllowAmbiguousTypes, LambdaCase #-}+module Internal.Data.Basic.Compiler where++import Internal.Interlude++import Internal.Data.Basic.Types as Basic+import Internal.Data.Basic.Sql.Types as Sql+import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)+import Database.PostgreSQL.Simple.ToField (ToField(..))+import Database.PostgreSQL.Simple.ToRow (ToRow(..))++expToSql :: DbExp k a -> SqlValueExp+expToSql (Field (_ :: proxy name) (Var tab)) = SimpleName (QualifiedField tab (nameText @name))+expToSql (Literal a) = SqlLiteral (toField a)++literalCollectionToSql :: LiteralCollection collection a => collection -> [SqlValueExp]+literalCollectionToSql = fmap (\(SomeDbExp e) -> expToSql e) . getLiteralCollection++boolExpToSql :: ConditionExp -> Condition+boolExpToSql (Compare c f1 f2) =+    SqlOperator c (expToSql f1) (expToSql f2)+boolExpToSql (BoolOp And exp1 exp2) = SqlAnd (boolExpToSql exp1) (boolExpToSql exp2)+boolExpToSql (BoolOp Or exp1 exp2) = SqlOr (boolExpToSql exp1) (boolExpToSql exp2)+boolExpToSql (Basic.IsNull f) = Sql.IsNull (expToSql f)+boolExpToSql (Basic.In val vals) = Sql.In (expToSql val) (literalCollectionToSql vals)++conditionToSql :: forall tables. TableSetVars 'Filtering tables+               => (Variables 'Filtering tables -> ConditionExp) -> Condition+conditionToSql f = boolExpToSql (f (makeVars @'Filtering @tables))++uniqueNames :: [QualifiedTable] -> [QualifiedTable]+uniqueNames = flip evalState 0 . mapM (\(QualifiedTable t _) -> do+    n <- get+    modify' (+ 1)+    return (QualifiedTable t n))++compileTable :: forall name proxy. KnownSymbol name => proxy (name :: Symbol) -> SqlExp+compileTable _ =+    Select SelectEverything Nothing [QualifiedTable (nameText @name) 0] [] (Limit Nothing) (Sql.Grouping [])++updatedExpToSql :: UpdateExp fields table -> ([Text], [SqlValueExp])+updatedExpToSql = \upd -> updatedExpToSql' (varFromUpdateExp upd) upd+    where updatedExpToSql' :: Var 'Updating t -> UpdateExp fields t -> ([Text], [SqlValueExp])+          updatedExpToSql' _ (NoUpdate _) = ([], [])+          updatedExpToSql' v (SetField p upd val) = (toS (symbolVal p) : fs, expToSql val : vs)+              where (fs, vs) = updatedExpToSql' v upd++updateToSql :: forall table fields. (Var 'Updating table -> UpdateExp fields table)+             -> ([Text], [SqlValueExp])+updateToSql f = updatedExpToSql (f (makeVars @'Updating @'[table]))++orderingToSql :: forall tables ord. (Sortable ord, TableSetVars 'Sorting tables)+              => (Variables 'Sorting tables -> ord) -> [(SqlValueExp, SortDirection)]+orderingToSql f = fmap (first (\(SomeDbExp e) -> expToSql e))+                       (getOrdering (f (makeVars @'Sorting @tables)))++mappingToSql ::+    forall tables map.+    ( Mappable map+    , TableSetVars 'Mapping tables )+    => (Variables 'Mapping tables -> map) -> [SqlValueExp]+mappingToSql f = mapToSql (f (makeVars @'Mapping @tables))++mapToSql :: Mappable map => map -> [SqlValueExp]+mapToSql = fmap (\(SomeDbExp e) -> expToSql e) . getMapping++groupMapToSql :: GroupMappable map => map -> [SqlValueExp]+groupMapToSql = fmap (\(af, SomeDbExp e) -> AggregateFunction af (expToSql e)) . getGroupMapping+++grouppingToSql ::+    forall tables group.+    ( Groupable group+    , TableSetVars 'Basic.Grouping tables )+    => (Variables 'Basic.Grouping tables -> group) -> [SqlValueExp]+grouppingToSql f =+    fmap (\(SomeDbExp e) -> expToSql e) (getGrouping (f (makeVars @'Basic.Grouping @tables)))++groupStatementToSql :: forall tables group. GroupStatement group tables -> SqlExp+groupStatementToSql (GroupOn f t) =+    Select SelectEverything conditions tables ordering lim (Sql.Grouping (grouppingToSql @tables f))+    where Select SelectEverything conditions tables ordering lim (Sql.Grouping []) = compileToSql t++foldingToSql ::+    forall tables aggr.+    ( Aggregatable aggr+    , TableSetVars 'Folding tables )+    => (Variables 'Folding tables -> aggr) -> [SqlValueExp]+foldingToSql f =+    fmap (\(af, SomeDbExp e) -> AggregateFunction af (expToSql e))+         (getAggregating (f (makeVars @'Folding @tables)))+++aggregateStatementToSql :: AggregateStatement aggr 'AM -> SqlExp+aggregateStatementToSql (Aggregate f (t :: DbStatement f tables)) =+    Select (SelectExpressions (foldingToSql @tables f)) conditions tables ordering lim (Sql.Grouping [])+    where Select SelectEverything conditions tables ordering lim (Sql.Grouping []) = compileToSql t++compileToSql :: DbStatement f ts -> SqlExp+compileToSql (Table p) = compileTable p+compileToSql (Filter cond (t :: DbStatement f tables)) =+    Select sel (conditions <> Just newConditions) tables [] (Limit Nothing) (Sql.Grouping [])+    where Select sel conditions tables [] (Limit Nothing) (Sql.Grouping []) = compileToSql t+          newConditions = conditionToSql @tables cond+compileToSql (Join t1 t2) =+    Select SelectEverything Nothing (uniqueNames $ tab1 ++ tab2) [] (Limit Nothing) (Sql.Grouping [])+    where Select SelectEverything Nothing tab1 [] (Limit Nothing) (Sql.Grouping []) = compileToSql t1+          Select SelectEverything Nothing tab2 [] (Limit Nothing) (Sql.Grouping []) = compileToSql t2+compileToSql (Raw q pars) = RawQuery q (toRow pars)+compileToSql (Basic.Insert (a :: Entity entKind table)) =+    Sql.Insert (nameText @(TableName table))+               (mapTypeList (Proxy @KnownSymbol) (toS . symbolVal)+                            (Proxy @(SetFields (MissingFields entKind) table)))+               (mapFields @(TypeSatisfies ToField) @table @(SetFields (MissingFields entKind) table) (const toField) a)+compileToSql (Basic.Delete (t :: DbStatement f '[table])) =+    Sql.Delete table conditions+    where Select SelectEverything conditions [table] [] (Limit Nothing) (Sql.Grouping []) = compileToSql t+compileToSql (Basic.Update update t) = Sql.Update updateFields updateVals conditions table+    where Select SelectEverything conditions [table] [] (Limit Nothing) (Sql.Grouping []) = compileToSql t+          (updateFields, updateVals) = updateToSql update+compileToSql (SortOn selector (t :: DbStatement f tables)) =+    Select sel conditions tables orderings (Limit Nothing) (Sql.Grouping [])+    where Select sel conditions tables [] (Limit Nothing) (Sql.Grouping []) = compileToSql t+          orderings = orderingToSql @tables selector+compileToSql (Take n t) =+    Select sel conditions tables ordering (Limit (Just n)) (Sql.Grouping [])+    where Select sel conditions tables ordering (Limit Nothing) (Sql.Grouping []) = compileToSql t+compileToSql (Map f (t :: DbStatement f tables)) =+    Select (SelectExpressions (mappingToSql @tables f)) conditions tables ordering lim (Sql.Grouping [])+    where Select SelectEverything conditions tables ordering lim (Sql.Grouping []) = compileToSql t+compileToSql (AsGroup t) = compileToSql t+compileToSql (GroupMap f t@(GroupOn gf (gt :: DbStatement f tables))) =+    Select what conditions tables ordering lim grouping+    where Select SelectEverything conditions tables ordering lim grouping = groupStatementToSql t+          g = asAggregate (gf (makeVars @'Basic.Grouping @tables))+          what = SelectExpressions (groupMapToSql (f (g, AsGroup gt)))

@@ -0,0 +1,92 @@+{-# LANGUAGE UndecidableSuperClasses, AllowAmbiguousTypes, UndecidableInstances, TemplateHaskell #-}+module Internal.Data.Basic.Foreign where++import Internal.Interlude++import Control.Lens+import GHC.TypeLits+import Overload++import Internal.Data.Basic.Types+import Internal.Data.Basic.Common+import Internal.Data.Basic.Lens+import Internal.Data.Basic.Compare+import Internal.Control.Effects.Basic++import Database.PostgreSQL.Simple.ToField (ToField)++class ForeignKeyConstraint fk+    => ForeignKeyFieldsMatch (fk :: Symbol) (fromFields :: [Symbol]) (toFields :: [Symbol]) where+    foreignKeyFieldsMatch :: Entity ('FromDb c) (ForeignKeyFrom fk)+                          -> Var 'Filtering (ForeignKeyTo fk) -> ConditionExp+    foreignKeyFieldsSet :: Entity entKind (ForeignKeyFrom fk)+                        -> Entity ('FromDb c) (ForeignKeyTo fk)+                        -> Entity (WithFieldsSet fromFields entKind) (ForeignKeyFrom fk)++instance ( ForeignKeyConstraint fk+         , from ~ ForeignKeyFrom fk+         , to   ~ ForeignKeyTo fk+         , TableField to toField+         , TableField from fromField+         , TableFieldType to toField ~ TableFieldType from fromField+         , ToField (TableFieldType from fromField)+         , Ord (TableFieldType to toField)+         , KindOfDbExp (TableFieldType from fromField) ~ 'LiteralExp )+    => ForeignKeyFieldsMatch fk '[fromField] '[toField] where+    foreignKeyFieldsMatch ent var = ent ^. fieldOptic @fromField ==. var ^. fieldOptic @toField+    foreignKeyFieldsSet ent1 ent2 =+        ent1 & fieldOpticEntitySet @fromField .~ (ent2 ^. fieldOptic @toField)++instance ( from ~ ForeignKeyFrom fk+         , to   ~ ForeignKeyTo fk+         , TableField to toField+         , TableField from fromField+         , TableFieldType to toField ~ TableFieldType from fromField+         , ToField (TableFieldType from fromField)+         , Ord (TableFieldType to toField)+         , ForeignKeyFieldsMatch fk (f1 ': f1s) (f2 ': f2s)+         , KindOfDbExp (TableFieldType from fromField) ~ 'LiteralExp )+    => ForeignKeyFieldsMatch fk (fromField ': (f1 ': f1s)) (toField ': (f2 ': f2s)) where+    foreignKeyFieldsMatch ent var =+            (ent ^. fieldOptic @fromField ==. var ^. fieldOptic @toField)+        &&. foreignKeyFieldsMatch @fk @(f1 ': f1s) @(f2 ': f2s) ent var+    foreignKeyFieldsSet ent1 ent2 =+        foreignKeyFieldsSet @fk @(f1 ': f1s) @(f2 ': f2s) ent1 ent2+            & fieldOpticEntitySet @fromField .~ (ent2 ^. fieldOptic @toField)++type ForeignKeyLensGet fk m =+    ( ForeignKeyConstraint fk+    , MonadEffectBasic m+    , Table (ForeignKeyFrom fk)+    , Table (ForeignKeyTo fk)+    , ForeignKeyFieldsMatch fk (ForeignKeyFromFields fk) (ForeignKeyToFields fk) )++foreignKeyLensGet :: forall fk m proxy. ForeignKeyLensGet fk m+                  => proxy fk+                  -> Getter' (Entity ('FromDb 'Live) (ForeignKeyFrom fk))+                             (m (Entity ('FromDb 'Live) (ForeignKeyTo fk)))+foreignKeyLensGet _ = to $ \ent -> do+    [e] <- dfilter (foreignKeyFieldsMatch @fk @(ForeignKeyFromFields fk) @(ForeignKeyToFields fk)+                                          ent)+                   (allRows @(TableName (ForeignKeyTo fk)))+    return e++type ForeignKeyLensSet fk =+    ( ForeignKeyConstraint fk+    , ForeignKeyFieldsMatch fk (ForeignKeyFromFields fk) (ForeignKeyToFields fk) )++foreignKeyLensSet :: forall fk entKind c proxy. ForeignKeyLensSet fk+                  => proxy fk+                  -> PolyOptic Identity+                               (Entity entKind (ForeignKeyFrom fk))+                               (Entity (WithFieldsSet (ForeignKeyFromFields fk) entKind)+                                       (ForeignKeyFrom fk))+                               ()+                               (Entity ('FromDb c) (ForeignKeyTo fk))+foreignKeyLensSet _ = \f e ->+    foreignKeyFieldsSet @fk @(ForeignKeyFromFields fk) @(ForeignKeyToFields fk) e <$> f ()++overload "foreignKeyLensProxy" ['foreignKeyLensGet, 'foreignKeyLensSet]++foreignKeyLens :: forall name o. ForeignKeyLensProxy (Proxy name -> o) => o+foreignKeyLens = foreignKeyLensProxy (Proxy :: Proxy name)

@@ -0,0 +1,102 @@+{-# LANGUAGE FunctionalDependencies, AllowAmbiguousTypes, UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+module Internal.Data.Basic.Lens where++import Internal.Interlude+import Control.Lens+import Internal.Data.Basic.Types+import Overload++type PolyOptic fun inType outType inVal outVal = (inVal -> fun outVal) -> inType -> fun outType+type Getter' s a = PolyOptic (Const a) s s a a++fieldOpticVarExp :: forall name t anyCtx proxy. TableField t name+                 => proxy name+                 -> PolyOptic (Const (DbExp 'FieldExp (TableFieldType t name)))+                              (Var anyCtx t) (Var anyCtx t)+                              (DbExp 'FieldExp (TableFieldType t name))+                              (DbExp 'FieldExp (TableFieldType t name))+fieldOpticVarExp p = to (Field p)++fieldOpticEntityGet :: forall name t entKind proxy.+                     ( TableField t name+                     , FieldIsGettable name (MissingFields entKind) )+                    => proxy name+                    -> PolyOptic (Const (TableFieldType t name))+                                 (Entity entKind t) (Entity entKind t)+                                 (TableFieldType t name)+                                 (TableFieldType t name)+fieldOpticEntityGet _ = getEntity . tableFieldLens @_ @name+++class SupportedModifyAccess isSet existingValue outVal | isSet outVal -> existingValue where+    transformModifyFunction :: (existingValue -> f outVal) -> outVal -> f outVal+instance SupportedModifyAccess 'True outVal outVal where+    transformModifyFunction = identity+instance SupportedModifyAccess 'False () outVal where+    transformModifyFunction f _ = f ()++fieldOpticEntityModify ::+       forall name t entKind existingValue proxy.+     ( TableField t name+     , SupportedModifyAccess (FieldIsGettableBool name (MissingFields entKind))+                             existingValue+                             (TableFieldType t name) )+    => proxy name+    -> PolyOptic Identity+                 (Entity entKind t) (Entity (WithFieldSet name entKind) t)+                 existingValue+                 (TableFieldType t name)+fieldOpticEntityModify _ = getEntity . transLens+    where transLens f e =+              tableFieldLens @_ @name+                             (transformModifyFunction @(FieldIsGettableBool name+                                                                            (MissingFields entKind))+                                                      f)+                             e++fieldOpticUpdateVarSet :: forall name t val proxy.+                        ( ValueAsDbExp val (TableFieldType t name)+                        , TableField t name )+                       => proxy name+                       -> PolyOptic Identity+                                    (Var 'Updating t) (UpdateExp '[name] t)+                                    (DbExp 'FieldExp (TableFieldType t name))+                                    val+fieldOpticUpdateVarSet p =+    \f v -> SetField p (NoUpdate v) . valueAsDbExp <$> f (Field p v)++fieldOpticUpdatedSet :: forall name t fields val proxy.+                      ( TableField t name+                      , FieldIsNotSet name fields+                      , ValueAsDbExp val (TableFieldType t name) )+                     => proxy name+                     -> PolyOptic Identity+                                  (UpdateExp fields t) (UpdateExp (name ': fields) t)+                                  (DbExp 'FieldExp (TableFieldType t name))+                                  val+fieldOpticUpdatedSet p =+    \f v -> SetField p v . valueAsDbExp <$> f (Field p (varFromUpdateExp v))++overload "fieldOpticProxy" [ 'fieldOpticVarExp+                           , 'fieldOpticEntityGet+                           , 'fieldOpticEntityModify+                           , 'fieldOpticUpdateVarSet+                           , 'fieldOpticUpdatedSet ]++fieldOptic :: forall name o. FieldOpticProxy (Proxy name -> o) => o+fieldOptic = fieldOpticProxy (Proxy :: Proxy name)++++----------------+-- Helper lenses+----------------++fieldOpticEntitySet ::+       forall name t missing. TableField t name+    => PolyOptic Identity+                 (Entity missing t) (Entity (WithFieldSet name missing) t)+                 ()+                 (TableFieldType t name)+fieldOpticEntitySet = getEntity . (\f e -> tableFieldLens @_ @name (\_ -> f ()) e)

@@ -0,0 +1,69 @@+{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+module Internal.Data.Basic.Replace where++import Internal.Interlude++import Internal.Data.Basic.Types+import Internal.Data.Basic.Common+import Internal.Data.Basic.Lens+import Internal.Data.Basic.Compare+import Internal.Control.Effects.Basic+import GHC.TypeLits++import Database.PostgreSQL.Simple.ToField (ToField)++class PrimaryKeyMatch (fields :: [Symbol]) table where+    primaryKeyMatch :: Entity ('FromDb c) table -> Var 'Filtering table -> ConditionExp++instance ( Ord (TableFieldType table field)+         , TableField table field+         , ToField (TableFieldType table field)+         , KindOfDbExp (TableFieldType table field) ~ 'LiteralExp )+    => PrimaryKeyMatch '[field] table where+    primaryKeyMatch ent v = v ^. fieldOptic @field ==. ent ^. fieldOptic @field++instance ( Ord (TableFieldType table field)+         , TableField table field+         , ToField (TableFieldType table field)+         , fields ~ (f ': fs)+         , PrimaryKeyMatch fields table+         , KindOfDbExp (TableFieldType table field) ~ 'LiteralExp )+    => PrimaryKeyMatch (field ': (f ': fs)) table where+    primaryKeyMatch ent v =+            primaryKeyMatch @fields ent v+        &&. (v ^. fieldOptic @field ==. ent ^. fieldOptic @field)+++++class SetAllFields fields table where+    setAllFields :: Entity ('FromDb c) table -> Var 'Updating table -> UpdateExp fields table++instance SetAllFields '[] table where+    setAllFields _ v = NoUpdate v++instance ( SetAllFields fields table+         , CheckWithError (Not (Elem field fields))+                          (     'Text "Cannot update the field " ':<>: 'ShowType field+                          ':<>: 'Text " because it's already updated in this expression" )+         , TableField table field+         , ToField (TableFieldType table field)+         , KindOfDbExp (TableFieldType table field) ~ 'LiteralExp )+    => SetAllFields (field ': fields) table where+    setAllFields ent var =+        setAllFields @fields ent var & fieldOptic @field .~ ent ^. fieldOptic @field+++save :: forall table pk fields c m.+      ( Table table+      , 'Just pk ~ TablePrimaryKey table+      , fields ~ UniqueFields pk+      , PrimaryKeyMatch fields table+      , SetAllFields (TableFields table) table+      , MonadEffectBasic m )+     => Entity ('FromDb c) table -> m (Entity ('FromDb 'Live) table)+save ent =+    allRows @(TableName table) & dfilter (primaryKeyMatch @fields ent)+                               & dupdate (setAllFields @(TableFields table) ent)+                               & fmap unsafeHead

@@ -0,0 +1,179 @@+{-# OPTIONS_GHC -Wno-orphans -Wno-deprecations #-}+{-# LANGUAGE ExistentialQuantification, RankNTypes, FlexibleContexts #-}+module Internal.Data.Basic.Sql.Types where++import Internal.Interlude hiding (Sum)++import Data.String (IsString(..))+import Database.PostgreSQL.Simple hiding (In, Only)+import Database.PostgreSQL.Simple.Types (Query(..))+import Database.PostgreSQL.Simple.ToField (Action)++data QuerySegment = QuerySegment Query [Action]+    deriving (Show)++instance Semigroup Query where+    (<>) = mappend++instance Monoid QuerySegment where+    mempty = QuerySegment mempty mempty+    QuerySegment q1 as1 `mappend` QuerySegment q2 as2+        = QuerySegment (q1 <> q2) (as1 <> as2)+instance Semigroup QuerySegment++instance IsString QuerySegment where+    fromString s = QuerySegment (fromString s) []++data Comparison = LessThan | LessOrEqual | GreaterThan | GreaterOrEqual | Equal | NotEqual+                  deriving (Eq, Ord, Read, Show)++data SortDirection = Ascending | Descending deriving (Eq, Ord, Read, Show)++newtype SqlFunctionName = SqlFunctionName Text deriving (Eq, Ord, Read, Show)++data QualifiedField = QualifiedField Int Text deriving (Eq, Ord, Read, Show)+data QualifiedTable = QualifiedTable Text Int deriving (Eq, Ord, Read, Show)++data Condition = SqlAnd Condition Condition+               | SqlOr Condition Condition+               | SqlOperator Comparison SqlValueExp SqlValueExp+               | IsNull SqlValueExp+               | In SqlValueExp [SqlValueExp]+               deriving (Show)++data AggregateFunction = Avg | Max | Min | Count | Sum | Only deriving (Show)++data SqlValueExp = SimpleName QualifiedField+                 | SqlFunctionApplication SqlFunctionName SqlValueExp+                 | SqlLiteral Action+                 | AggregateFunction AggregateFunction SqlValueExp+                 deriving (Show)++newtype Limit = Limit (Maybe Int) deriving (Eq, Ord, Read, Show)++data Selection = SelectEverything | SelectExpressions [SqlValueExp] deriving (Show)++newtype Grouping = Grouping [SqlValueExp] deriving (Show)++data SqlExp =+    Select+        Selection+        (Maybe Condition)+        [QualifiedTable]+        [(SqlValueExp, SortDirection)]+        Limit+        Grouping+  | Insert Text [Text] [Action]+  | RawQuery Text [Action]+  | Delete QualifiedTable (Maybe Condition)+  | Update [Text] [SqlValueExp] (Maybe Condition) QualifiedTable+  deriving (Show)++sToQuery :: StringConv a ByteString => a -> QuerySegment+sToQuery bs = QuerySegment (Query (toS bs)) []++actionToQuery :: Action -> QuerySegment+actionToQuery a = QuerySegment "? " [a]++tableToQuery :: QualifiedTable -> QuerySegment+tableToQuery (QualifiedTable name index) = sToQuery name <> " as t" <> show index <> " "++comparisonToQuery :: Comparison -> QuerySegment+comparisonToQuery Equal          = "= "+comparisonToQuery NotEqual       = "!= "+comparisonToQuery LessThan       = "< "+comparisonToQuery LessOrEqual    = "<= "+comparisonToQuery GreaterThan    = "> "+comparisonToQuery GreaterOrEqual = ">= "++fieldToQuery :: QualifiedField -> QuerySegment+fieldToQuery (QualifiedField index name) = "t" <> show index <> "." <> sToQuery name <> " "++aggregateFunctionToQuery :: AggregateFunction -> QuerySegment+aggregateFunctionToQuery Avg = "avg "+aggregateFunctionToQuery Min = "min "+aggregateFunctionToQuery Max = "max "+aggregateFunctionToQuery Sum = "sum "+aggregateFunctionToQuery Count = "count "+aggregateFunctionToQuery Only = ""++valueToQuery :: SqlValueExp -> QuerySegment+valueToQuery (SimpleName field) = fieldToQuery field+valueToQuery (SqlFunctionApplication (SqlFunctionName name) val) =+    sToQuery name <> "( " <> valueToQuery val <> " ) "+valueToQuery (SqlLiteral l) = actionToQuery l+valueToQuery (AggregateFunction af v) =+    aggregateFunctionToQuery af <> "( " <> valueToQuery v <> " ) "++conditionToQuery :: Condition -> QuerySegment+conditionToQuery (SqlOperator comp v1 v2) = valueToQuery v1+                                         <> comparisonToQuery comp+                                         <> valueToQuery v2+conditionToQuery (SqlAnd cond1 cond2) = conditionToQuery cond1 <> "and " <> conditionToQuery cond2+conditionToQuery (SqlOr cond1 cond2) = conditionToQuery cond1 <> "or " <> conditionToQuery cond2+conditionToQuery (IsNull v) = "( " <> valueToQuery v <> ") is null "+conditionToQuery (In a b)+  | null b = "1!=1" -- SELECT * FROM bla where field in () is invalid+  | otherwise = valueToQuery a <> " in " <> toSqlList b+  where toSqlList xs = "( " <> foldl' (<>) mempty (intersperse ", " (valueToQuery <$> xs)) <> " )"++orderingToQuery :: (SqlValueExp, SortDirection) -> QuerySegment+orderingToQuery (e, Ascending) = valueToQuery e <> "asc "+orderingToQuery (e, Descending) = valueToQuery e <> "desc "++limitToQuery :: Limit -> QuerySegment+limitToQuery (Limit Nothing) = ""+limitToQuery (Limit (Just lim)) = "limit " <> sToQuery (show lim :: Text) <> " "++selectionToQuery :: Selection -> QuerySegment+selectionToQuery SelectEverything = "* "+selectionToQuery (SelectExpressions exps) = separateBy ", " (fmap valueToQuery exps)++groupToQuery :: Grouping -> QuerySegment+groupToQuery (Grouping []) = ""+groupToQuery (Grouping exps) = "group by " <> separateBy ", " (fmap valueToQuery exps)++listToTuple :: [QuerySegment] -> QuerySegment+listToTuple xs = "(" <> foldl1Def (\x y -> x <> ", " <> y) "" xs <> ") "++separateBy :: (Monoid a, Semigroup a, IsString a) => a -> [a] -> a+separateBy sep l = foldl1Def (\a b -> a <> sep <> b) mempty l <> " "++sqlExpToQuery :: SqlExp -> QuerySegment+sqlExpToQuery (Select selection cond tables ordering limit grouping) =+    traceShowId $ "select "+               <> selectionToQuery selection+               <> "from "+               <> tableAliases+               <> maybe "" (("where " <>) . conditionToQuery) cond+               <> (if null ordering then ""+                  else "order by " <> separateBy ", " (map orderingToQuery ordering))+               <> limitToQuery limit+               <> groupToQuery grouping+    where tableAliases = foldl1Def (\x y -> x <> ", " <> y) "" (map tableToQuery tables)++sqlExpToQuery (Insert table fields values) = traceShowId $+      "insert into " <> sToQuery table+    <> listToTuple (fmap sToQuery fields)+    <> "values " <> listToTuple (fmap actionToQuery values)+    <> "returning * "+sqlExpToQuery (RawQuery q as) = traceShowId $ QuerySegment (Query (toS q)) as+sqlExpToQuery (Delete table cond) = traceShowId $+       "delete from " <> tableAlias+    <> maybe " " (("where " <>) . conditionToQuery) cond+    <> "returning * "+    where tableAlias = foldl1Def (\x y -> x <> ", " <> y) "" (map tableToQuery [table])++sqlExpToQuery (Update fields values cond table) = traceShowId $+       "update " <> tableToQuery table+    <> " set " <> listToTuple (fmap sToQuery fields) <> " = "+               <> listToTuple (fmap valueToQuery values)+    <> maybe "" (("where " <>) . conditionToQuery) cond+    <> "returning * "++instance Semigroup Condition where+    (<>) = SqlAnd++data SqlResult = forall a. FromRow a => SqlResult [a]++data SomeFromRowProxy = forall a. FromRow a => SomeFromRowProxy (Proxy a)

@@ -0,0 +1,26 @@+module Internal.Data.Basic.SqlToHsTypes where++import Internal.Interlude+import Prelude (lex)++import Database.PostgreSQL.Simple.FromField+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TypeId+import qualified Data.ByteString.Char8 as B+import Database.PostgreSQL.Simple.ToField+import Data.Binary.Builder++data Point = Point {-# UNPACK #-} !Double {-# UNPACK #-} !Double+    deriving (Eq, Ord, Read, Show)++instance FromField Point where+  fromField f mdata =+    if typeOid f /= TypeId.typoid TypeId.point+      then returnError Incompatible f ""+      else case B.unpack <$> mdata of+          Nothing -> returnError UnexpectedNull f ""+          Just dat -> case [ x | (x,t) <- reads dat, ("","") <- lex t ] of+                    [(x, y)] -> return (Point x y)+                    _   -> returnError ConversionFailed f dat+instance ToField Point where+    toField (Point x y) = Plain (fromByteString bs)+        where bs = "point(" <> show x <> ", " <> show y <> ")"

@@ -0,0 +1,73 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DuplicateRecordFields      #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE Rank2Types                 #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE UndecidableSuperClasses    #-}+module Internal.Data.Basic.TH (mkFromFile, mkFromFiles, printToFile) where++import           Control.Monad                 (fail)+import           Internal.Interlude            hiding (Type)+import           Language.Haskell.TH           hiding (Name)+import qualified Language.Haskell.TH.Syntax    as TH++import           Control.Effects.Signal+import           Internal.Data.Basic.TH.Types+import           Internal.Data.Basic.TH.Compiler+++-- | Generates haskell code from an SQL file.+mkFromFile :: FilePath -> Q [Dec]+mkFromFile filename = do+  TH.addDependentFile filename+  eStatements <- compileSQL $ toS filename+  case eStatements of+    Left (ParseError e) -> runIO.fail $ toS e+    Right statements -> do+      r <- (runIO $ handleToEither @ParseError $ compileSQLStatements mempty statements)+      case r of+        Left (ParseError e) -> runIO.fail $ toS e -- actually a compile error+        Right context -> runQ $ compileContext context++-- MonadIO Identity+-- | Generates haskell code from multiple SQL files.+mkFromFiles :: [FilePath] -> Q [Dec]+mkFromFiles filenames = do+  _ <- sequence $ TH.addDependentFile <$> filenames+  res <- sequence $ compileSQL.toS <$> filenames+  let eStatements = concat <$> sequence res+  case eStatements of+    Left (ParseError e) -> runIO.fail $ toS e+    Right statements -> do+      r <- (runIO $ handleToEither @ParseError $ compileSQLStatements mempty statements)+      case r of+        Left (ParseError e) -> runIO.fail $ toS e -- actually a compile error+        Right context -> runQ $ compileContext context++-- | Allows you to print generated template haskell code to a file+printToFile :: [FilePath] -> FilePath -> Q [Dec]+printToFile filenames filenameOut = do+  res <- sequence $ compileSQL.toS <$> filenames+  let eStatements = concat <$> sequence res+  case eStatements of+    Left (ParseError e) -> runIO.fail $ toS e+    Right statements -> do+      r <- (runIO $ handleToEither @ParseError $ compileSQLStatements mempty statements)+      case r of+        Left (ParseError e) -> runIO.fail $ toS e -- actually a compile error+        Right context -> runQ $ do+          r <- compileContext context+          let out = concatMap (<> "\n\n") $ pprint <$> r+          runIO $ writeFile filenameOut $ toS out+          return []+

@@ -0,0 +1,137 @@+module Internal.Data.Basic.TH.Compiler where++import qualified Control.Lens.Internal.FieldTH as LTHI+import qualified Data.Text                     as T+import           Internal.Interlude            hiding (Type)+import           Language.Haskell.TH           hiding (Name)+import qualified Language.Haskell.TH.Syntax    as TH+import           Database.HsSqlPpp.Parse+import qualified Database.HsSqlPpp.Syntax      as SQL++import           Control.Effects.Signal+import qualified Internal.Data.Basic.TH.Generator       as G+import           Internal.Data.Basic.TH.Helper+import           Internal.Data.Basic.TH.Types+import           Internal.Data.Basic.TH.SqlToHsTypes+++compileSQL :: Text -> Q (Either ParseError [SQL.Statement])+compileSQL filename = do+  contents <- runIO $ liftIO $ readFile $ toS filename+  return $ runIdentity (handleToEither $ liftError $ parseProcSQL defaultParseFlags (toS filename) Nothing (toS contents))++compileContext :: ParseContext -> Q [Dec]+compileContext c = do+      let _entities = G.dataConstructor <$> c ^. entities+      let result = concat $ compileEntity c <$> c ^. entities+      let constraints = G.allConstraints c+      let fieldOptics = G.fieldOptics (c ^. entities)+      let fkOptics = G.fkOptics (c ^. fks)+      let virtualFields = G.virtualTables (c ^. fks)+      lenses <- concat <$> sequence (LTHI.makeFieldOpticsForDec lensRules <$> _entities)+      let tableFields = G.tableFields (c ^. entities)+      return $ concat [ _entities+                      , result+                      , constraints+                      , lenses+                      , tableFields+                      , fieldOptics+                      , fkOptics+                      , virtualFields]++compileEntity :: ParseContext -> EntityInfo -> [Dec]+compileEntity ctx info = G.tableInstance ctx info <>+  [G.fromRowInstance name cols] <>+  G.emptyEntity ctx info <>+  G.initialAccessor info+  where cols = info ^. entityInfoColumnMap+        name = _entityInfoName info+++compileSQLStatements :: (Throws ParseError m, MonadIO m)+                   => ParseContext -> [SQL.Statement] -> m ParseContext+compileSQLStatements = foldlM compileSQLStatement++-- | Updates 'CompileContext' with data. The kind of data that is being added depends on the+--   statement being processed.+compileSQLStatement :: (Throws ParseError m, MonadIO m) => ParseContext -> SQL.Statement -> m ParseContext+compileSQLStatement initialCtx (SQL.CreateTable _ name attrs constraints _ _) = do+  (ctx, ei) <- foldM (\(_ctx, _ei) attr -> updateContext _ctx entityName _ei attr) (initialCtx, entityInfo) attrs+  finalCtx <- foldM (\_ctx c -> compileConstraint ctx ei c) ctx constraints+  namedEi <- nameUnnamedConstraints ei+  return $ finalCtx {_entities = finalCtx ^. entities <> [namedEi] }+  where entityName = mkName (toS $ standardizeName $ toS $ getName name)+        n = toS $ getName name+        entityInfo = EntityInfo n entityName name (ConT entityName) constraints mempty+compileSQLStatement ctx (SQL.AlterTable _ tableName (SQL.AlterTableActions _ l)) =+  foldrM (\s _ctx -> handleAlterTableOperations _ctx tableName s) ctx l+compileSQLStatement ctx p = do+  print $ "Compile error: only CREATE TABLE statement can be parsed " `T.append` show p+  return ctx++-- | Updates 'CompileContext' with constraints that have been added using alter table+handleAlterTableOperations :: Throws ParseError m+                           => ParseContext -> SQL.Name -> SQL.AlterTableAction -> m ParseContext+handleAlterTableOperations ctx tableName (SQL.AddConstraint _ (SQL.PrimaryKeyConstraint _ name tables)) = do+    fromEntity <- getEntityByName tableName (ctx ^. entities)+    columns <- mapM (getColumn fromEntity) (toS. SQL.ncStr <$> tables)+    return $ ctx & pks .~ (ctx ^. pks <> [PrimaryKeyConstraint (toS name) fromEntity columns])+handleAlterTableOperations ctx tableName (SQL.AddConstraint _ (SQL.UniqueConstraint _ name tables)) = do+    fromEntity <- getEntityByName tableName (ctx ^. entities)+    columns <- mapM (getColumn fromEntity) (toS. SQL.ncStr <$> tables)+    return $ ctx & uqs .~ (ctx ^. uqs <> [UniqueKeyConstraint (toS name) fromEntity columns])+handleAlterTableOperations ctx tableName (SQL.AddConstraint _ (SQL.ReferenceConstraint _ refName fromTables toTable toTables _ _)) = do+    toEntity <- getEntityByName toTable $ ctx ^. entities+    fromEntity <- getEntityByName tableName (ctx ^. entities)+    fromColumns <- mapM (getColumn fromEntity) (toS. SQL.ncStr <$> fromTables)+    toColumns <- mapM (getColumn toEntity) (toS. SQL.ncStr <$> toTables)+    return $ ctx & fks .~ (ctx ^. fks <> [ForeignKeyConstraint (toS refName) fromEntity fromColumns toEntity toColumns])+handleAlterTableOperations _ _ _ = throwSignal+    $ ParseError "Compile error: only PRIMARY KEY, UNIQUE and FOREIGN KEY constraints are implemented"++-- | Updates compile context from CREATE TABLE statement.+--   Used when CREATE TABLE statement is used. Adds to 'CompileContext' any constraints that are found and returns updated+--   'EntityInfo' and 'CompileContext'+updateContext :: Throws ParseError m => ParseContext -> TH.Name -> EntityInfo -> SQL.AttributeDef -> m (ParseContext, EntityInfo)+updateContext ctx entityName ei (SQL.AttributeDef _ nameC typ _ consts) = do+  (columnHsType, constraints) <- toHsType typ+  let g = ColumnInfo (toS name) (mkName ("_" <> toS (lowerFirst (toS $ nameBase entityName)) <> "_" <> name)) columnHsType typ constraints+  (ctx2, ci) <- foldM (\(_ctx, _ci) cons -> compileRowConstraint _ctx ei _ci cons) (ctx, g) consts+  return (ctx2, ei & entityInfoColumnMap .~ (ei ^. entityInfoColumnMap <> [ci]))+  where name = SQL.ncStr nameC++-- | Adds sql row constraints to compile context+compileRowConstraint :: Throws ParseError m => ParseContext -> EntityInfo -> ColumnInfo -> SQL.RowConstraint -> m (ParseContext, ColumnInfo)+compileRowConstraint ctx _ ci (SQL.NullConstraint _ _) = return (ctx, ci & columnInfoConstraints .~ (ci ^. columnInfoConstraints <> [NullConstraint]))+compileRowConstraint ctx _ ci (SQL.NotNullConstraint _ _) = return (ctx, ci & columnInfoConstraints .~ (ci ^. columnInfoConstraints <> [NotNullConstraint]))+compileRowConstraint ctx ei ci (SQL.RowUniqueConstraint _ name) = return (ctx & uqs .~ ( ctx ^. uqs <> [UniqueKeyConstraint (toS name) ei [ci]])+                                                                         , ci & columnInfoConstraints .~ (ci ^. columnInfoConstraints <> [NotNullConstraint]))+compileRowConstraint ctx ei ci (SQL.RowPrimaryKeyConstraint _ name) = return (ctx & pks .~ (ctx ^. pks <> [PrimaryKeyConstraint (toS name) ei [ci]])+                                                                             , ci & columnInfoConstraints .~ (ci ^. columnInfoConstraints <> [NotNullConstraint]))+compileRowConstraint ctx ei ci (SQL.RowReferenceConstraint a name toTable mToColumn _ _) = do+  toEntityInfo <- getEntityByName toTable (ctx ^. entities)+  toColumnInfo <- maybe (throwSignal $ ParseError err) (getColumn toEntityInfo . toS . SQL.ncStr) mToColumn+  return (ctx & fks .~ (ctx ^. fks <> [ForeignKeyConstraint (toS name) ei [ci] toEntityInfo [toColumnInfo]]), ci)+  where err = "Compile error: Unable to find column " <> show a+compileRowConstraint ctx _ ci _ = return (ctx, ci)++-- | Adds sql constraint to compile context. If a sql constraint is unnamed, it will be named.+compileConstraint :: Throws ParseError m => ParseContext -> EntityInfo -> SQL.Constraint -> m ParseContext+compileConstraint ctx ei c = do+  constraint <- nameUnnamedConstraint ei c+  compileConstraint' ctx ei constraint++-- | Adds sql constraint to compile context.+compileConstraint' :: Throws ParseError m => ParseContext -> EntityInfo -> SQL.Constraint -> m ParseContext+compileConstraint' ctx ei (SQL.UniqueConstraint _ name tables) = do+  columnsInformation <- sequence $ getColumn ei <$> (toS. SQL.ncStr <$> tables)+  return $ ctx & uqs .~ (ctx ^. uqs <> [UniqueKeyConstraint (toS name) ei columnsInformation])+compileConstraint' ctx ei (SQL.PrimaryKeyConstraint _ name tables) = do+  columnsInformation <- sequence $ getColumn ei <$> (toS. SQL.ncStr <$> tables)+  return $ ctx & pks .~ (ctx ^. pks <> [PrimaryKeyConstraint (toS name) ei columnsInformation])+compileConstraint' ctx ei (SQL.ReferenceConstraint _ name fromTables toTableName toTables _ _) = do+  fromColumnsInfo <- sequence $ getColumn ei <$> (toS. SQL.ncStr <$> fromTables)+  toEntityInfo <- getEntityByName toTableName (ctx ^. entities)+  toColumnsInfo <- sequence $ getColumn toEntityInfo <$> (toS. SQL.ncStr <$> toTables)+  return $ ctx & fks .~ (ctx ^. fks <> [ForeignKeyConstraint (toS name) ei fromColumnsInfo toEntityInfo toColumnsInfo])+compileConstraint' _ _ a = throwSignal $ ParseError $ "Compile error: constraint not supported " <> show a

@@ -0,0 +1,327 @@+{-|+module Internal.     : Data.Basic.TH.Types+Description : Data types and utility function used during TH generation phase+License     : MIT++This module Internal.defines functions that are used to generate Template Haskell code from AST. For AST+description take a look at 'Data.Basic.TH.Types'.+-}+module Internal.Data.Basic.TH.Generator where++import Internal.Interlude+import Cases+import Internal.Data.Basic.TH.Types+import Data.List (nub, (\\))+import qualified Internal.Data.Basic.Types as BT+import qualified Internal.Data.Basic as B+import qualified Internal.Data.Basic.Foreign as F+import Language.Haskell.TH.Syntax as TH+import qualified Database.HsSqlPpp.Syntax as SQL+import Internal.Data.Basic.TH.Helper+import Internal.Data.Basic.Virtual+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromRow+import GHC.Generics (Generic)++-- | Generates a data constructor for an entity+--+-- > data Post = Post { _ostId     :: Key+-- >                  , _ostName   :: Text+-- >                  , _ostUserId :: Key } deriving (Show, Read, Generic)+--+dataConstructor :: EntityInfo -> TH.Dec+dataConstructor info = DataD [] entityName [] Nothing [RecC entityName fields] [ConT ''Show, ConT ''Read, ConT ''Generic]+  where entityName = _entityInfoName info+        fields = (\c -> (c ^. columnInfoName, Bang SourceUnpack SourceStrict, finalType c)) <$> (info ^. entityInfoColumnMap)++-- | Generates a fromRow instance for a entity.+--+-- > instance FromRow Post where+-- > fromRow = Post <$> field <*> field <*> field+--+-- fromRowInstance takes a name of the entity and a list of [a],+-- which is just used to count how many fields does the entity have - nothing+-- else. It generates something similar shown in a code snippet above - a+-- working FromRow instance for that datatype.+fromRowInstance :: TH.Name -> [a] -> TH.Dec+fromRowInstance entityName fields = InstanceD Nothing [] (AppT (ConT ''FromRow)+                                                                (ConT entityName))+                                     [ValD (VarP 'fromRow)+                                           (NormalB (addFields initial n)) []]+  where n = length fields+        initial = InfixE (Just (ConE entityName))+                         (VarE '(<$>))+                         (Just (VarE 'field))+++-- | Generates field optics for all entities+fieldOptics :: [EntityInfo] -> [TH.Dec]+fieldOptics em = concat $ fieldOptic <$> columnNames+  where columnNames = nub $ _columnInfoText <$> concat (_entityInfoColumnMap <$> em)++-- | Generates field optics for a column+--+--+-- > name :: (FieldOptic "username" fun inType outType inVal outVal) => PolyOptic fun inType outType inVal outVal+-- > name = fieldOpticProxy (Proxy :: Proxy "username")+--+--+fieldOptic :: Text -> [Dec]+fieldOptic t = [SigD fieldName (+                           ForallT [PlainTV o]+                           [+                             AppT (ConT ''B.FieldOpticProxy)+                                  (AppT (AppT ArrowT+                                              (AppT (ConT ''Proxy)+                                                    (LitT (StrTyLit $ toS t))))+                                        (VarT o))+                           ]+                           (VarT o)),++                         ValD (VarP fieldName) (+                           NormalB (AppE (VarE 'B.fieldOpticProxy)+                                         (SigE (ConE 'Proxy)+                                               (AppT (ConT ''Proxy)+                                                     (LitT (StrTyLit $ toS t)))))) []+                       ]+  where fieldName = mkName $ toS $ camelize t+        o = mkName "o"+++-- | Applies basic constraint depending on sql constraint+--   If columns is marked as primary or unique, add the 'Unique' haskell datatype+fieldConstraint :: SQL.Constraint -> Maybe [TH.Type]+fieldConstraint (SQL.UniqueConstraint _ name _) = Just [ConT 'BT.Unique `AppT` (LitT $ StrTyLit $ toS name)]+fieldConstraint (SQL.PrimaryKeyConstraint _ name _) = Just [ConT 'BT.Unique `AppT` (LitT $ StrTyLit $ toS name)]+fieldConstraint (SQL.CheckConstraint _ _ _) = Nothing -- @TODO dependent types? :)+fieldConstraint (SQL.ReferenceConstraint _ _ _ _ _ _ _) = Nothing -- @TODO foreign keys?+++-- |  Generates a table field instance for a column+--+-- > instance TableField Post "user_id" where+-- >   type TableFieldType Post "user_id" = Key+-- >   tableFieldLens = ostUserId+--+tableField :: EntityInfo -> ColumnInfo -> Dec+tableField ei ci = InstanceD Nothing [] (+                                AppT (ConT ''BT.TableField `AppT` (ConT entityName))+                                     (LitT $ StrTyLit $ toS columnText)+                                ) [+                                TySynInstD ''BT.TableFieldType $ TySynEqn+                                  [ConT entityName, LitT $ StrTyLit $ toS columnText]+                                  columnType,+                                  FunD 'BT.tableFieldLens [Clause [] (NormalB $ VarE lensName) []]+                                ]+  where entityName = ei ^. entityInfoName+        columnType = finalType ci+        columnText = ci ^. columnInfoText+        lensName = mkName $ toS ((lowerFirst.standardizeName $ ei ^. entityInfoText) <> "_" <> columnText)++-- | Generates required table field instances for all entities+tableFields :: [EntityInfo] -> [TH.Dec]+tableFields eis = concat ((\ei -> tableField ei <$> ei ^. entityInfoColumnMap) <$> eis)++-- | Generates final type for the sql column+finalType :: ColumnInfo -> TH.Type+finalType ci+  | null (ci ^. columnInfoConstraints) = ConT ''Maybe `AppT` (ci ^. columnInfoType)+  | otherwise = foldr (applyConstraint ci) (ci ^. columnInfoType) (ci ^. columnInfoConstraints)++-- | Generates initial accessor for the table+--+-- > allPosts = allRows (Proxy :: Proxy "post")+--+initialAccessor :: EntityInfo -> [TH.Dec]+initialAccessor ei =+    [ SigD accessor+           (ForallT [PlainTV res]+                    [ConT ''B.AllRows `AppT` tableType `AppT` VarT res]+                    (VarT res))+    , FunD accessor+           [Clause []+                   (NormalB (AppE (VarE 'B.allRowsProxy)+                                  (SigE (ConE 'Proxy) (ConT ''Proxy `AppT` tableType))))+                   []] ]+    where sTableName = standardizeName (toS tableName)+          res = mkName "res"+          accessor = mkName $ toS $ "all" <> quasyPlural sTableName+          tableName = ei ^. entityInfoText+          tableType = ei ^. entityInfoType+++-- | Generates foreign key optics+fkOptics :: [ForeignKeyConstraint] -> [Dec]+fkOptics = foldl' (\acc f -> fkOptic f <> acc) mempty++-- | Generates foreign key optic+--+-- > author :: ForeignKeyLensProxy (Proxy "blog_post_author_fkey" -> o) => o+-- > author = foreignKeyLens @"blog_post_author_fkey"+--+fkOptic :: ForeignKeyConstraint -> [Dec]+fkOptic fk = [+  SigD accName (ForallT [PlainTV o] [+                   AppT (ConT ''F.ForeignKeyLensProxy)+                        (AppT (ArrowT `AppT` (ConT ''Proxy `AppT` name))+                              (VarT o))] (VarT o)),+              ValD (VarP accName)+              (NormalB (AppE (VarE 'B.foreignKeyLensProxy)+                             (SigE (ConE 'Proxy) (ConT ''Proxy `AppT` name)))) []]+  where accName  = mkName $ toS $ (lowerFirst $ toS $ nameBase $ _entityInfoName (_fkFromT fk)) <> (toS $ nameBase $ _entityInfoName (_fkToT fk))+        o = mkName "o"+        name = LitT $ StrTyLit $ toS $ fk ^. fkName++-- | Generates virtual table optics+virtualTables :: [ForeignKeyConstraint] -> [Dec]+virtualTables = foldl' (\acc f -> acc <> virtualTable f) mempty++-- | Generates virtual table optic+--+-- > posts :: VirtualTable "blog_post_author_fkey" res+-- >    => Getter' (Entity ('FromDb c) (ForeignKeyTo "blog_post_author_fkey")) res+-- > posts = virtualTableLensProxy (Proxy :: Proxy "blog_post_author_fkey")+--+virtualTable :: ForeignKeyConstraint -> [Dec]+virtualTable fk = [+  SigD accName (ForallT [PlainTV o,PlainTV c_1] [+                    (ConT ''VirtualTable `AppT` name) `AppT` VarT o+                    ]+                  (AppT (AppT (ConT ''B.Getter')+                              (AppT (AppT (ConT ''BT.Entity)+                                          (PromotedT 'BT.FromDb `AppT` VarT c_1))+                                    (ConT ''BT.ForeignKeyTo `AppT` name)))+                        (VarT o))),+    ValD (VarP accName) (NormalB (AppE (VarE 'B.virtualTableLensProxy)+                                 (SigE (ConE 'Proxy) (ConT ''Proxy `AppT` name))))+    []]+  where accName  = mkName $ toS $ (lowerFirst $ toS $ nameBase $ _entityInfoName (_fkToT fk)) <> (toS $ nameBase $ _entityInfoName (_fkFromT fk))+        o = mkName "o"+        c_1 = mkName "c1"+        name = LitT $ StrTyLit $ toS $ fk ^. fkName+++-- | Generates all constraint declarations from the 'ParseContext'+allConstraints :: ParseContext -> [Dec]+allConstraints ctx = concat ((uniqueConstraintInstance <$>  ctx ^. uqs) <>+   (primaryKeyInstance <$> ctx ^. pks) <>+   [foreignKeyConstraint <$> ctx ^. fks])++-- | Generates unique key constraint instance+--+-- > instance UniqueConstraint "blog_user_pkey" where+-- >    type UniqueTable "blog_user_pkey" = User+-- >    type UniqueFields "blog_user_pkey" = '["id"]+--+uniqueConstraintInstance :: UniqueKeyConstraint -> [Dec]+uniqueConstraintInstance uq = [+  InstanceD Nothing [] (+      AppT (ConT ''BT.UniqueConstraint) (LitT (StrTyLit keyName))+      ) [+      TySynInstD ''BT.UniqueTable (+          TySynEqn [LitT (StrTyLit keyName)] (ConT entityName)),+      TySynInstD ''BT.UniqueFields (+          TySynEqn [LitT (StrTyLit keyName)] (listToTypeLevel cols))]]+  where keyName = toS $ uq ^. uqName+        ei = uq ^. uqEntity+        entityName = ei ^. entityInfoName+        cols = (LitT . StrTyLit . toS) <$> (_columnInfoText <$> (uq ^. uqCols))++-- | Generates primary key instance+--+-- > instance PrimaryKeyConstraint "blog_user_pkey"+--+primaryKeyInstance :: PrimaryKeyConstraint -> [Dec]+primaryKeyInstance (PrimaryKeyConstraint name entity cols) = uniqueConstraintInstance (UniqueKeyConstraint name entity cols) <> [InstanceD Nothing [] (AppT (ConT ''BT.PrimaryKeyConstraint) (LitT (StrTyLit $ toS name))) []]+++-- | Generates foreign key instance+--+-- > instance ForeignKeyConstraint "blog_post_author_fkey" where+-- > type ForeignKeyFrom "blog_post_author_fkey" = Post+-- > type ForeignKeyFromFields "blog_post_author_fkey" = '["author"]+-- > type ForeignKeyTo "blog_post_author_fkey" = User+-- > type ForeignKeyToFields "blog_post_author_fkey" = '["id"]+--+foreignKeyConstraint :: ForeignKeyConstraint -> Dec+foreignKeyConstraint (ForeignKeyConstraint name fromTableT fromCol toTableT toCol) = InstanceD Nothing [] (ConT ''BT.ForeignKeyConstraint `AppT` (LitT $ StrTyLit $ toS name)) [+        TySynInstD ''BT.ForeignKeyFrom $ TySynEqn [constraint] (fromTableT ^. entityInfoType),+        TySynInstD ''BT.ForeignKeyFromFields $ TySynEqn [constraint] (listToTypeLevel (LitT . StrTyLit . toS . _columnInfoText <$> fromCol)),+        TySynInstD ''BT.ForeignKeyTo $ TySynEqn [constraint] (toTableT ^. entityInfoType),+        TySynInstD ''BT.ForeignKeyToFields $ TySynEqn [constraint] (listToTypeLevel (LitT . StrTyLit . toS . _columnInfoText <$> toCol))+        ]+  where constraint = LitT $ StrTyLit $ toS name+++-- | Generates a table instance for an entity from a 'ParseContext'+--+-- > instance Table Post where+-- >     type TableName Post = "blog_post"+-- >     type TableFields Post = ["id", "name", "author"]+-- >     type TableConstraints Post = '[]+-- >     type TablePrimaryKey Post = 'Nothing+-- >     type TableRequiredFields Post = ['DynamicDefault 'id, 'Required "name", 'Required "author"]+--+tableInstance :: ParseContext ->  EntityInfo -> [Dec]+tableInstance ctx ei = [+  InstanceD Nothing [] (ConT ''BT.Table `AppT` entityType) [+      TySynInstD ''BT.TableName $ TySynEqn [entityType] (LitT $ StrTyLit tableName),+      TySynInstD ''BT.TableFields $ TySynEqn [entityType] entityFields,+      TySynInstD ''BT.TableConstraints $ TySynEqn [entityType] entityConstraints,+      TySynInstD ''BT.TablePrimaryKey $ TySynEqn [entityType] primaryKey,+      TySynInstD ''BT.TableRequiredFields $ TySynEqn [entityType] tableRequirements,+      ValD (VarP 'BT.newEntity) (coerceBody ei) []+      ]+  ]+  where fieldNames = view columnInfoText <$> columns+        columns = ei ^. entityInfoColumnMap+        constraints = ei ^. entityInfoConstraintList+        entityType = ei ^. entityInfoType+        tableName = toS $ ei ^. entityInfoText+        entityFields = listToTypeLevel $ LitT . StrTyLit . toS <$> fieldNames+        entityConstraints = listToTypeLevel $ (concat.catMaybes) (fieldConstraint <$> constraints)+        primaryKey = maybe (ConT 'Nothing) (AppT (ConT 'Just) . LitT . StrTyLit . toS . _pkName) (getEntityPrimaryKey ctx ei)+        requiredFields = ei ^. entityInfoColumnMap \\ optionalCols+        tableRequirements = listToTypeLevel $ required requiredFields <> dynamicDefault optionalCols+        optionalCols = getOptionalColumns ctx ei+-- | Generates a empty entity+--+-- > newPost = Entity ('Fresh ['DynamicDefault "id", 'Required "name", 'Required "author"])+-- > newPost = Entity (Post 1 "" 1)+--+emptyEntity :: ParseContext -> EntityInfo -> [Dec]+emptyEntity ctx ei = [+  SigD fname (AppT (AppT (ConT ''BT.Entity)+                         (PromotedT 'BT.Fresh `AppT` listToTypeLevel reqs))+                   (ei ^. entityInfoType)),+    ValD (VarP fname) (coerceBody ei) []]+  where fname = mkName $ toS $ "new" <> standardizeName name+        name = ei ^. entityInfoText+        requiredFields = ei ^. entityInfoColumnMap \\  optionalCols+        reqs = required requiredFields <> dynamicDefault optionalCols+        optionalCols = getOptionalColumns ctx ei++-- | Applies 'Required' constraint to list of columns+required :: [ColumnInfo] -> [TH.Type]+required cs = f <$> cs+  where f ci = ConT 'BT.Required `AppT` (LitT $ StrTyLit $ toS $ ci ^. columnInfoText)++-- | Applies 'DynamicDefault' constraint to a list of columns+dynamicDefault :: [ColumnInfo] -> [TH.Type]+dynamicDefault cs = f <$> cs+  where f ci = ConT 'BT.DynamicDefault `AppT` (LitT $ StrTyLit $ toS $ ci ^. columnInfoText)++-- | Modifies column type depending on column constraints+applyConstraint :: ColumnInfo -> ColumnConstraint -> TH.Type -> TH.Type+applyConstraint _ NullConstraint t = AppT (ConT ''Maybe) t+applyConstraint _ _ t = t++-- | Generates coerce body. See 'NullValue' why this is needed+coerceBody :: EntityInfo -> TH.Body+coerceBody ei = NormalB (AppE (ConE 'BT.Entity ) (nullValue' n $ ConE name))+  where n = length $ ei ^. entityInfoColumnMap+        name = ei ^. entityInfoName++nullValue' :: Int -> TH.Exp -> TH.Exp+nullValue' 0 initial = initial+nullValue' n initial = AppE (nullValue' (n - 1) initial) (VarE 'nullValue)

@@ -0,0 +1,121 @@+{-|+module Internal.     : Data.Basic.TH.Types+Description : Data types and utility function used during TH generation phase+License     : MIT++This module Internal.contains helper functions that are used in code generation process.+-}+module Internal.Data.Basic.TH.Helper where++import Internal.Interlude++import Cases+import Internal.Data.Basic.TH.Types+import Database.PostgreSQL.Simple.FromRow+import Database.HsSqlPpp.Parse++import qualified Data.Text as T+import Control.Effects.Signal+import Language.Haskell.TH.Syntax as TH+import qualified Database.HsSqlPpp.Syntax as SQL++liftError :: Throws ParseError m => Either ParseErrorExtra a -> m a+liftError (Left pex) = throwSignal $ ParseError $ toS $ "\n\n\nError while parsing sql file " ++ show pex+liftError (Right a) = return a++-- | lifts a list of types to a type level (i.e. typelevel list)+--   e.g. `listToTypeLeve [Int, String, Double] = '[ Int, String, Double ]`+listToTypeLevel :: [TH.Type] -> TH.Type+listToTypeLevel = foldr (\t le -> AppT (AppT PromotedConsT t) le) PromotedNilT+++-- | Used to append n times `<$> field` to the expression+addFields :: TH.Exp -> Int -> TH.Exp+addFields e n+  | n > 1 = addField (addFields e (n - 1))+  | otherwise = e++-- | Used to append `<$> field` at the end of the expression+addField :: TH.Exp -> TH.Exp+addField a = InfixE (Just a) (VarE '(<*>)) (Just $ VarE 'field)++-- Our convention for "standarnized names"+-- @TODO What if users have their own naming scheme?+standardizeName :: Text -> Text+standardizeName s = toS (process title camel $ camelize (toS s))++-- | returns a plural of a known noun.+--   Basically just appends `s` or `es`+quasyPlural :: Text -> Text+quasyPlural s = if T.null s then "" else case T.last s of+  's' -> s <> "es"+  _ -> s <> "s"++-- | Tries to name multiples constraints+nameUnnamedConstraints :: Throws ParseError m => EntityInfo -> m EntityInfo+nameUnnamedConstraints ei = do+  namedConstraints <- sequence $ nameUnnamedConstraint ei <$> cl+  return $ ei & entityInfoConstraintList .~ namedConstraints+  where cl = ei ^. entityInfoConstraintList++-- | Mechanism for naming unnamed constraints. If a constraint cannot be named, an error is trown+nameUnnamedConstraint :: Throws ParseError m => EntityInfo -> SQL.Constraint -> m SQL.Constraint+nameUnnamedConstraint ei (SQL.UniqueConstraint a name ncs) = return $ SQL.UniqueConstraint a cname ncs+  where cname = toS $ ei ^. entityInfoText <> "_uq_"<> nameConstraint (toS name) ncs+nameUnnamedConstraint ei (SQL.PrimaryKeyConstraint a name ncs) = return $ SQL.PrimaryKeyConstraint a cname ncs+  where cname = toS $ ei ^. entityInfoText <> "_pk_"<> nameConstraint (toS name) ncs+nameUnnamedConstraint _ a  = throwSignal $ ParseError  $ "Cannot name constraint: " <> show a++-- | Provides default naming scheme for constraints+nameConstraint :: Text -> [SQL.NameComponent] -> Text+nameConstraint s ncs = if T.null s then T.intercalate "_" (toS. SQL.ncStr <$> ncs) else s++-- | Converts a 'SQL.Name' to a plain text+-- @TODO test complex naming schemes+getName :: SQL.Name -> Text+getName n = toS $ fmap toLower (intercalate "." $ SQL.ncStr <$> SQL.nameComponents n)++-- | Retrieves a list of optional columns in an entity+getOptionalColumns :: ParseContext -> EntityInfo -> [ColumnInfo]+getOptionalColumns ctx ei = columns+  where columns = filter isOptional (ei ^. entityInfoColumnMap)+        isPrimaryKey ci = any (\pk -> ci `elem` (pk ^. pkCols)) (ctx ^. pks)+        isUnique ci = any (\uq -> ci `elem` (uq ^. uqCols)) (ctx ^. uqs)+        isOptional ci = isPrimaryKey ci || isUnique ci || hasOptionalConsts (ci ^. columnInfoConstraints)+        hasOptionalConsts consts = null consts || elem NullConstraint consts++-- | Tries to retrieve entity information. If an entity with that name doesn't exist an error is thrown.+getEntityByName :: Throws ParseError m => SQL.Name -> [EntityInfo] -> m EntityInfo+getEntityByName name m = maybe (throwSignal $ ParseError err) return els+  where els = listToMaybe $ filter (\v -> getName name == v ^. entityInfoText ) m+        err = "Lookup by Name failed: " <> getName name <> " not found in EntityMap"++-- | Tries to retrieve entity information. If an entity with that name doesn't exist an error is thrown.+getEntityBySQLName :: Throws ParseError m => SQL.Name -> [EntityInfo] -> m EntityInfo+getEntityBySQLName name m = maybe (throwSignal $ ParseError err) return els+  where els = listToMaybe $ filter (\v -> _entityInfoSQLName v == name) m+        err = "Lookup by SQL name failed: " <> getName name <> " not found in EntityMap"++-- | Tries to retrieve column information from entity. If a column with that name doesn't exist an error is thrown.+getColumn :: Throws ParseError m => EntityInfo -> Text -> m ColumnInfo+getColumn ei name = maybe (throwSignal $ ParseError err) return info+  where info = listToMaybe $ filter  (\c -> name == c ^. columnInfoText) (ei ^. entityInfoColumnMap)+        err = "Column lookup failed: " <> name <> " not found in EntityInfo: " <> show ei++lowerFirst :: Text -> Text+lowerFirst t = fromMaybe t (f <$> T.uncons t)+    where f (a, b) = T.cons (toLower a) b++upperFirst :: Text -> Text+upperFirst t = fromMaybe t (f <$> T.uncons t)+    where f (a, b) = T.cons (toUpper a) b+++-- | Retrieves the primary key for an entity from 'ParseContext'+getEntityPrimaryKey :: ParseContext -> EntityInfo -> Maybe PrimaryKeyConstraint+getEntityPrimaryKey ctx ei = listToMaybe $ filter (\pk -> pk ^. pkEntity == ei) (ctx ^. pks)+++-- | Generates name for the column lens (i.e. lowercases first letter)+columnNameToLensName :: Text -> Text+columnNameToLensName = lowerFirst

@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Internal.Data.Basic.TH.SqlToHsTypes+-- Copyright   :  (c) Nikola Henezi, Luka Horvat+-- License     :  MIT+--+-- Maintainer  :  nikola@henezi.com, luka.horvat9@gmail.com+--+-- Conversion between Postgres types and haskell datatypes. As a starting point,+-- 'fromField' from Database.PostgreSQL.Simple.FromField is used.+-- If you need support for additional datatypes, please open an issue+-- (https://gitlab.com/haskell-hr/basic) or email maintainers+-----------------------------------------------------------------------------+module Internal.Data.Basic.TH.SqlToHsTypes (toHsType) where++import qualified Data.Text                     as T+import           Data.Time.LocalTime           (LocalTime, TimeOfDay)+import           Internal.Interlude            hiding (Type)+import           Language.Haskell.TH           hiding (Name)+import qualified Database.HsSqlPpp.Syntax      as SQL++import           Control.Effects.Signal+import           Internal.Data.Basic.TH.Helper+import           Internal.Data.Basic.TH.Types++-- | Conversion between 'SQL.TypeName' to haskell 'Type'.+--  'SQL.TypeName' is used internaly by 'Database.HsSqlPpp'+toHsType :: Throws ParseError m => SQL.TypeName -> m (Type, [ColumnConstraint])+toHsType (SQL.SimpleTypeName _ name) = do+  t <- columnTypeToHs n+  return (t, applyColumnConstraints n)+  where n = getName name+toHsType (SQL.PrecTypeName _ name _) = do+  t <- columnTypeToHs n+  return (t, applyColumnConstraints n)+  where n = getName name+toHsType x = throwSignal $ ParseError $ "Compile error: unknown column type " <> show x++-- | Applies special constraint rules.+--   Rules:+--   "serial" type needs to have 'NotNullConstraint'+applyColumnConstraints :: Text -> [ColumnConstraint]+applyColumnConstraints fname+  | fname == "serial" = [NotNullConstraint]+  | otherwise = []++-- | Actual conversions. The following Postgres types are currently supported:+-- > serial+-- > bigint+-- > integer+-- > int+-- > int4+-- > boolean+-- > timestamp+-- > time+-- > point+-- > double precision+-- > double+-- > character varying+-- > text+-- > bytea+columnTypeToHs :: Throws ParseError m => Text -> m Type+columnTypeToHs fname+  | fname `elem` ["serial", "bigint", "integer", "int", "int4"] = use ''Int+  | fname == "boolean" = use ''Bool+  | fname == "timestamp" = use ''LocalTime+  | fname == "time" = use ''TimeOfDay+  | fname == "point" = return $ AppT (AppT (TupleT 2) (ConT ''Double)) (ConT ''Double)+  | fname `elem` ["double precision", "double"] = use ''Double+  | fname `elem` ["character varying", "text", "bytea"] = use ''Text+  | otherwise = throwSignal $ ParseError $ "Compile error: cannot deduct Haskell type " `T.append` toS fname+  where use x = return $ ConT x

@@ -0,0 +1,117 @@+{-|+module Internal.     : Data.Basic.TH.Types+Description : Data types and utility function used during TH generation phase+Copyright   : (c) Nikola Henezi, 2016-2017+                  Luka Horvat, 2016-2017+License     : MIT++This module Internal.defines data types that are used during parsing and TH generation stages. They describe+structure of the parser and define minimal representation that is needed from parser in order to+generate Template Haskell.+++-}+module Internal.Data.Basic.TH.Types where++import Internal.Interlude hiding (Type)++import           Data.Text                          (append)++import qualified Language.Haskell.TH.Syntax         as TH+import qualified Database.HsSqlPpp.Syntax           as SQL++import           Data.Time++-- | When something goes wrong, this explains what went wrong - hopefully...+data ParseError = ParseError Text deriving (Show)++instance Semigroup ParseError where+  (<>) (ParseError a) (ParseError b) = ParseError (a `append` b)++instance Monoid ParseError where+  mempty = ParseError ""+  mappend = (<>)++-- | List of constraints that can be applied to a Column and affect generated datatype+-- Currently, only Null constraint affects it by wrapping data type with 'Maybe'+data ColumnConstraint = NullConstraint | NotNullConstraint deriving (Show, Eq)++-- | Column information gathered from a parser+data ColumnInfo = ColumnInfo { _columnInfoText        :: !Text,    -- ^ name retrieved from the parser+                               _columnInfoName        :: !TH.Name, -- ^ generate TH name+                               _columnInfoType        :: !TH.Type, -- ^ generated TH type+                               _columnInfoSqlType     :: !SQL.TypeName, -- ^ original sql type+                               _columnInfoConstraints :: ![ColumnConstraint] -- ^ list of constraints that have to be applied+                             } deriving (Show)+makeLenses ''ColumnInfo+instance Eq ColumnInfo where+  (==) a b = _columnInfoName a == _columnInfoName b++-- | Entity information gathered from a parser+data EntityInfo = EntityInfo { _entityInfoText :: !Text, -- ^ name retrieved from the parser, basically a computed value of 'SQL.Name'+                               _entityInfoName :: !TH.Name, -- ^ generated TH name+                               _entityInfoSQLName :: !SQL.Name, -- ^ original sql name retrieved by hssqlpp+                               _entityInfoType :: !TH.Type, -- ^ generated datatype+                               _entityInfoConstraintList :: ![SQL.Constraint], -- ^ list of constraints that have to be applied+                               _entityInfoColumnMap :: [ColumnInfo] -- ^ list of all columns+                             } deriving (Show)+instance Eq EntityInfo where+  (==) a b = _entityInfoName a == _entityInfoName b++makeLenses ''EntityInfo++-- | Minimal context we need to generate a foreign key constraint+data ForeignKeyConstraint = ForeignKeyConstraint { _fkName :: !Text, -- ^ name of the foreign key+                                                   _fkFromT :: !EntityInfo,+                                                   _fkFromCols :: ![ColumnInfo],+                                                   _fkToT :: !EntityInfo, -- ^ referenced entity+                                                   _fkToCols :: ![ColumnInfo] -- ^ referenced columns+                                                 } deriving (Show)++makeLenses ''ForeignKeyConstraint++-- | Minimal context we need to generate a unique key constraint+data UniqueKeyConstraint = UniqueKeyConstraint { _uqName :: !Text, -- ^ name of the constraint+                                                 _uqEntity :: !EntityInfo, -- ^ referenced entity+                                                 _uqCols :: ![ColumnInfo] -- ^ referenced columns+                                               } deriving (Show)+makeLenses ''UniqueKeyConstraint++-- | Minimal context we need to generate a primary key constraint+data PrimaryKeyConstraint = PrimaryKeyConstraint { _pkName :: !Text, -- ^ name of the constraint+                                                   _pkEntity :: !EntityInfo, -- ^ referenced entity+                                                   _pkCols :: ![ColumnInfo] -- ^ referenced columns+                                                 } deriving (Show)+makeLenses ''PrimaryKeyConstraint++-- | Full parse context. This datatype is filled with information as parser goes trough the sql+-- file. After 'ParseContext' is filled, TH takes over and code generation starts.+data ParseContext = ParseContext { _entities :: ![EntityInfo], -- ^ list of entities found+                                   _fks :: ![ForeignKeyConstraint], -- ^ all foreign keys+                                   _pks :: ![PrimaryKeyConstraint], -- ^ all primary keys+                                   _uqs :: ![UniqueKeyConstraint] -- ^ all unique constraints+                                 } deriving (Show)+makeLenses ''ParseContext++instance Semigroup ParseContext where+    (<>) (ParseContext ei1 fk1 pk1 uq1) (ParseContext ei2 fk2 pk2 uq2) =+      ParseContext (ei1 <> ei2) (fk1 <> fk2) (pk1 <> pk2) (uq1 <> uq2)++instance Monoid ParseContext where+   mempty = ParseContext mempty mempty mempty mempty+   mappend = (<>)++-- | Defines null values for all datatypes that we support in Basic.+-- This is basically a hack to avoid usage of unsafeCoerce, because with unsafeCoerce+-- you can hit segmentation faults due to wrong memory allocation (e.g. 'Int' and 'Bool').+class NullValue a where+    nullValue :: a++instance NullValue Int where nullValue = 0+instance NullValue Bool where nullValue = False+instance NullValue TimeOfDay where nullValue = TimeOfDay 0 0 0+instance NullValue LocalTime where nullValue = LocalTime (ModifiedJulianDay 0) nullValue+instance (NullValue a, NullValue b) => NullValue (a, b) where nullValue = (nullValue, nullValue)+instance NullValue Double where nullValue = 0+instance NullValue Text where nullValue = ""+instance NullValue (Maybe a) where nullValue = Nothing

@@ -0,0 +1,232 @@+-- | This tutorial describes how to use the basic library.+--   Usually you would use the functions provided in the Data.Basic.TH module Internal.to generate all of+--   the declarations in this tutorial from your database schema.+--+--   Basic is a database-first library meaning the schema comes from the database instead of your+--   code. The library provides mechanisms for "explaining" your schema to the compiler. It can+--   then use this information to provide a typesafe and convenient access and control of your data.+--+--   We start by defining a data type.+--+--  @+--  data User = User { _serId   :: 'Key'+--                   , _serName :: 'Text' } deriving ('Eq', 'Ord', 'Read', 'Show')+--  @+--+--   Most of the functionality is implemented through lenses so we need to generate them for our+--   datatype.+--+--  @+--  'makeLenses' ''User+--  @+--+--   Next we provide a set of instances for our type. These describe how our type maps to a database+--   table. We use type level strings to represent database names of the fields. Instances are+--   needed for each field and for each constraint on the table. We also need a 'FromRow' instance+--   so the type can actually be deserialized from the query result.+--+--  @+--  instance 'Table' User where+--      -- the database name for this table+--      type 'TableName' User = "blog_user"+--+--      -- a type level list of all the fields in this table+--      type 'TableFields' User = ["id", "name"]+--+--      -- a type level list of constraints on this table; each of these will need a corresponding+--      -- instance that provides additional info+--      type 'TableConstraints' User = '[ \''Unique' "blog_user_pkey"]+--+--      -- the table can optionally have a primary key; for this we use a type level 'Maybe' value+--      type 'TablePrimaryKey' User = \''Just' "blog_user_pkey"+--+--      -- a type level list of fields that are either 'Required' or 'DynamicDefault'+--      type 'TableRequiredFields' User = [\''Required' "id", \''Required' "name"]+--+--      -- a default user+--      -- don't worry about undefined values, the types will make sure you can't accidentally evaluate+--      -- them+--      'newEntity' = 'Entity' (User 'undefined' 'undefined')+--+--  instance 'UniqueConstraint' "blog_user_pkey" where+--      -- the table which this constraint targets+--      type 'UniqueTable' "blog_user_pkey" = User+--+--      -- you can have multiple fields that make up one unique constraint+--      type 'UniqueFields' "blog_user_pkey" = '["id"]+--+--  -- 'PrimaryKeyConstraint' is really just a synonym for a unique constraint + the condition that+--  -- all the values must not be null+--  instance 'PrimaryKeyConstraint' "blog_user_pkey"+--+--  -- each field gets an instance saying what Haskell type it maps to and providing a lens+--  instance 'TableField' User "id" where+--      type 'TableFieldType' User "id" = 'Key'+--      'tableFieldLens' = serId+--+--  instance 'TableField' User "name" where+--      type 'TableFieldType' User "name" = 'Text'+--      'tableFieldLens' = serName+--+--  instance 'FromRow' User where+--      'fromRow' = User '<$>' field '<*>' field+--  @+--+--   Now we do the same for a "blog_post" table.+--+--  @+--  data Post = Post { _ostId     :: 'Key'+--                   , _ostName   :: 'Text'+--                   , _ostUserId :: 'Key' } deriving ('Eq', 'Ord', 'Read', 'Show')+--+--  instance 'Table' Post where+--      type 'TableName' Post = "blog_post"+--      type 'TableFields' Post = ["id", "name", "author"]+--      type 'TableConstraints' Post = '[ \''ForeignKey' "blog_post_author_fkey"]+--      type 'TablePrimaryKey' Post = \''Just' "blog_post_pkey"+--      type 'TableRequiredFields' Post = [\''Required' "id", \''Required' "name", \''Required' "author"]+--      'newEntity' = 'Entity' (Post 'undefined' 'undefined')++--  instance 'UniqueConstraint' "blog_post_pkey" where+--      type 'UniqueTable' "blog_post_pkey" = Post+--      type 'UniqueFields' "blog_post_pkey" = '["id"]+--+--  instance 'PrimaryKeyConstraint' "blog_post_pkey"+--+--  instance 'FromRow' Post where+--      fromRow = Post '<$>' field '<*>' field '<*>' field+--  'makeLenses' ''Post+--+--  instance 'TableField' Post "id" where+--      type 'TableFieldType' Post "id" = 'Key'+--      'tableFieldLens' = ostId+--+--  instance 'TableField' Post "name" where+--      type 'TableFieldType' Post "name" = 'Text'+--      'tableFieldLens' = ostName+--+--  instance 'TableField' Post "author" where+--      type 'TableFieldType' Post "author" = 'Key'+--      'tableFieldLens' = ostUserId+--  @+--+--   Next, we declare a foreign key from the post table to the user table. The instance is more or+--   less self explanatory.+--+--  @+--  instance 'ForeignKeyConstraint' "blog_post_author_fkey" where+--      type 'ForeignKeyFrom' "blog_post_author_fkey" = Post+--      type 'ForeignKeyFromFields' "blog_post_author_fkey" = '["author"]+--      type 'ForeignKeyTo' "blog_post_author_fkey" = User+--      type 'ForeignKeyToFields' "blog_post_author_fkey" = '["id"]+--  @+--+--  Now we're ready to create the lenses and values that we'll use to manipulate our data.+--  Again, keep in mind that all of this can be generated for you via the TH functions, directly+--  from your SQL schema.+--+--  @+--  -- this value will represent a virtual "list" of all the users in the database+--  allUsers :: 'AllRows' User m r => m r+--  allUsers = 'allRows' @"blog_user"+--+--  -- this is the same, but for posts+--  allPosts :: 'AllRows' Post m r => m r+--  allPosts = 'allRows' @"blog_post"+--+--  -- we use this value to construct new users+--  newUser :: 'Entity' (\''Fresh' [\''Required' "id", \''Required' "name"]) User+--  newUser = 'newEntity'+--+--  newPost :: 'Entity' (\''Fresh' [\''Required' "id", \''Required' "name", \''Required' "author"]) Post+--  newPost = 'newEntity'+--+--  -- we can use this lens to get all posts belonging to some author+--  posts :: 'VirtualTable' "blog_post_author_fkey" m r+--        => 'Getter'\' ('Entity' (\''FromDb' c) ('ForeignKeyTo' "blog_post_author_fkey")) (m r)+--  posts = 'virtualTableLens' @"blog_post_author_fkey"+--+--  -- a lens to access the id field of any table that has it; same for name and authorId+--  id :: 'FieldOpticProxy' ('Proxy' "id" -> o) => o+--  id = 'fieldOptic' @"id"+--+--  name :: 'FieldOpticProxy' ('Proxy' "name" -> o) => o+--  name = 'fieldOptic' @"name"+--+--  authorId :: 'FieldOpticProxy' ('Proxy' "author" -> o) => o+--  authorId = 'fieldOptic' @"author"+--+--  -- this lens will let us get the actual user value from a post, through the foreign key+--  author :: 'ForeignKeyLensProxy' ('Proxy' "blog_post_author_fkey" -> o) => o+--  author = 'foreignKeyLens' @"blog_post_author_fkey"+--  @+--+--   Finally, we get to a usage example.+--+--  @+--  test1 :: ('MonadIO' m, 'MonadEffectBasic' m) => m ()+--  test1 = do+--      'void' $ 'ddelete' allPosts+--      'void' $ 'ddelete' allUsers+--+--      -- we use the lens to construct values+--      let user = newUser '&' name '.~' "John"+--                         '&' id '.~' 1+--+--      -- check this out: try not setting one of the fields on user+--      -- the compiler will not let you insert the value into the database+--      user <- 'insert' user+--      let post = newPost '&' id '.~' 1+--                         '&' name '.~' "New post"+--                         '&' author '.~' user+--      post <- 'insert' post+--+--      -- to access our data we use functions like 'dfilter' and pretend we're dealing with+--      -- lists of values+--      users \<\- 'dfilter' (\\u -> (u '^.' id) `In` [1, 3, 4]) allUsers+--+--      -- get the author of a post, update the name and save it to the database+--      auth <- post '^.' author+--      'void' $ 'save' (auth '&' name '.~' "John H")+--+--      let user2 = newUser '&' name '.~' "Mike"+--                          '&' id '.~' 2+--      'void' $ 'insert' user2+--+--      -- sorting and taking works just like lists do, at least syntactically+--      -- the semantics still need to be translated to SQL so first taking, then sorting won't+--      -- compile+--      -- you can use the usual Down newtype for switching from ascending to descending+--      us \<\- 'dtake' 1 $ 'dsortOn' (\\u -> 'Down' (u '^.' id)) allUsers+--      'print' us+--+--      -- dupdate is like mapM+--      'void' $ 'dupdate' (\\u' -> u' '&' id '.~' (2 :: 'Key')) allUsers+--+--      [mike] \<\- 'dfilter' (\\u' -> u' '^.' id '==.' (1 :: 'Key')) allUsers+--      -- here we're using that special virtual table lens to get a list of all posts by Mike+--      psts <- mike '^.' posts+--      -- we can also filter on that list like it's a table in the database+--      somePsts \<\- dfilter (\\p -> p '^.' id '==.' (0 :: 'Key')) (mike '^.' posts)+--+--      -- joins are done with the djoin function; the resulting list can also be filtered+--      usersPosts <- allUsers `djoin` allPosts+--      print usersPosts+--+--  test :: 'IO' ()+--  test = do+--      conn <- 'connectPostgreSQL' "host=localhost port=5432 user=postgres dbname=postgres password=admin connect_timeout=10"+--      'handleBasicPsql' conn test1+--  @+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Internal.Data.Basic.Tutorial where++import Internal.Interlude hiding (filter)++import Database.PostgreSQL.Simple hiding (In)+import Database.PostgreSQL.Simple.FromRow++import Internal.Data.Basic+import Internal.Data.Basic.Types+import Internal.Control.Effects.Basic+import Language.Haskell.TH

@@ -0,0 +1,92 @@+{-# LANGUAGE PolyKinds, DataKinds, TypeOperators, TypeFamilies, AllowAmbiguousTypes #-}+{-# LANGUAGE TypeFamilyDependencies, FlexibleContexts, MultiParamTypeClasses, Rank2Types #-}+{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+module Internal.Data.Basic.TypeLevel+    ( AllSatisfy, MappableList(..), Elem, EqualOrError, CheckWithError+    , Not, ErrorText, type (++), Without, IsSubset, TypeSatisfies+    , OnMaybe, NotNull, ListToTuple+    , GHC.ErrorMessage(ShowType, (:<>:), (:$$:))+    , GHC.TypeError+    )  where++import Internal.Interlude++import GHC.TypeLits+import qualified GHC.TypeLits as GHC++type family AllSatisfy (c :: k -> Constraint) (l :: [k]) :: Constraint where+    AllSatisfy c '[] = ()+    AllSatisfy c (x ': xs) = (c x, AllSatisfy c xs)++class MappableList (l :: [k]) where+    mapTypeList :: AllSatisfy c l => proxy1 c -> (forall proxy2 x. c x => proxy2 x -> a) -> proxy3 l -> [a]++instance MappableList '[] where+    mapTypeList _ _ _ = []++instance MappableList ks => MappableList (k ': ks) where+    mapTypeList pc f _ = f (Proxy :: Proxy k) : mapTypeList pc f (Proxy :: Proxy ks)++type family Elem (x :: k) (xs :: [k]) :: Bool where+    Elem x '[] = 'False+    Elem x (x ': xs) = 'True+    Elem x (y ': xs) = Elem x xs++type family EqualOrError (a :: k) (b :: k) (err :: ErrorMessage) :: Constraint where+    EqualOrError a a err = ()+    EqualOrError a b err = GHC.TypeError err++type ErrorText = 'GHC.Text++type CheckWithError (b :: Bool) (err :: ErrorMessage) = EqualOrError b 'True err++type family Not (b :: Bool) where+    Not 'True = 'False+    Not 'False = 'True++type family IsSubset xs ys :: Constraint where+    IsSubset '[] ys = ()+    IsSubset (x ': xs) ys = (IsTrue (Elem x ys), IsSubset xs ys)++type IsTrue b = b ~ 'True++type family If (condition :: Bool) (t :: k) (e :: k) :: k where+    If 'True t e = t+    If 'False t e = e++type family Without (xs :: [k]) (ys :: [k]) :: [k] where+    Without xs '[] = xs+    Without '[] ys = '[]+    Without (x ': xs) ys = If (x `Elem` ys) (Without xs ys) (x ': Without xs ys)++type family NotMaybe (a :: *) :: Bool where+    NotMaybe (Maybe a) = 'False+    NotMaybe a = 'True++type FieldNullErr field =+    ErrorText "The field " ':<>: 'ShowType field ':<>: ErrorText " must not be optional (Maybe/Null)"+class CheckWithError (NotMaybe a) (FieldNullErr field) => NotNull (a :: *) (field :: Symbol)+instance CheckWithError (NotMaybe a) (FieldNullErr field) => NotNull a field++type family OnMaybe (a :: k) (f :: b -> k) (m :: Maybe b) :: k where+    OnMaybe a f ('Just b) = f b+    OnMaybe a f 'Nothing = a++type family FromJust (a :: Maybe x) :: x where+    FromJust ('Just x) = x++class c x => TypeSatisfies (c :: * -> Constraint) (x :: *) (field :: Symbol)+instance c x => TypeSatisfies c x field++type family ListToTuple (f :: k -> *) (l :: [k]) where+    ListToTuple f '[] = ()+    ListToTuple f '[a] = f a+    ListToTuple f '[a, b] = (f a, f b)+    ListToTuple f '[a, b, c] = (f a, f b, f c)+    ListToTuple f '[a, b, c, d] = (f a, f b, f c, f d)+    ListToTuple f '[a, b, c, d, e] = (f a, f b, f c, f d, f e)++type family xs ++ ys where+    '[] ++ ys = ys+    (x ': xs) ++ ys = x ': (xs ++ ys)

@@ -0,0 +1,581 @@+{-# LANGUAGE TemplateHaskell, PolyKinds, DataKinds, TypeOperators, TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies, FlexibleContexts, MultiParamTypeClasses, Rank2Types #-}+{-# LANGUAGE FunctionalDependencies, UndecidableInstances, UndecidableSuperClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, FlexibleInstances, AllowAmbiguousTypes #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE DefaultSignatures #-}+{-# OPTIONS_GHC -Wno-missing-methods #-}+module Internal.Data.Basic.Types+    ( module Internal.Data.Basic.Types+    , module Internal.Data.Basic.TypeLevel+    , Max(..), Min(..), Sum(..) ) where++import Internal.Interlude hiding (TypeError)+import Data.String (fromString)++import Control.Lens (Lens')+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Database.PostgreSQL.Simple.FromField (FromField)+import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow)+import Database.PostgreSQL.Simple.ToField (ToField)+import Database.PostgreSQL.Simple.ToRow (ToRow)+import qualified Database.PostgreSQL.Simple.Types as PSQL+import Data.Aeson (toJSON, parseJSON, object, Value(Object))+import Data.Aeson.Types (Parser)+import Data.Aeson.Lens (key)+import Data.Monoid (Sum(..))+import Data.Semigroup (Min(..), Max(..))++import Internal.Data.Basic.TypeLevel+import Internal.Data.Basic.Sql.Types (Comparison(..), SortDirection(..))+import qualified Internal.Data.Basic.Sql.Types as Sql++data VarContext = Filtering | Updating | Sorting | Grouping | Folding | Mapping+newtype Var (ctx :: VarContext) (a :: *) = Var Int deriving (Eq, Ord, Read, Show)++newtype Key = Key Int deriving (Eq, Ord, Read, Show, Num, FromField, ToField)+instance FromJSON Key where parseJSON = coerce (parseJSON @Int)+instance ToJSON Key where toJSON = coerce (toJSON @Int)++-- | Defines 'MissingField' kind.+data MissingField = Required Symbol | DynamicDefault Symbol+data Cached = Live | Cached+data EntityKind = Fresh [MissingField] | FromDb Cached+newtype Entity (entKind :: EntityKind) a = Entity { _getEntity :: a }+    deriving (Eq, Ord, Read, Show)+makeLenses ''Entity++toFreshEntity :: forall fs c a. Entity ('FromDb c) a -> Entity ('Fresh fs) a+toFreshEntity (Entity a) = Entity a++instance FromRow a => FromRow (Entity l a) where+    fromRow = Entity <$> fromRow++data FieldConstraint = Unique Symbol | ForeignKey Symbol++type family MissingFields (entKind :: EntityKind) :: [MissingField] where+    MissingFields ('Fresh missing) = missing+    MissingFields ('FromDb c) = '[]++type SetFields (missing :: [MissingField]) (table :: *) =+    TableFields table `Without` MissingFieldsNames missing++class (AllSatisfy (TableField table) fields)+    => AllTypesSatisfy (c :: * -> Symbol -> Constraint) (table :: *) (fields :: [Symbol]) where+    mapFields :: (fields `IsSubset` SetFields (MissingFields entKind) table)+              => (forall proxy n x. c x n => proxy n -> x -> a) -> Entity entKind table -> [a]++instance AllTypesSatisfy c table '[] where+    mapFields _ _ = []++instance ( TableField table x+         , c (TableFieldType table x) x+         , AllTypesSatisfy c table xs )+    => AllTypesSatisfy (c :: * -> Symbol -> Constraint) table (x ': xs) where+    mapFields f e = f (Proxy @x) (e ^. getEntity . tableFieldLens @table @x) : mapFields @c @table @xs f e++instance+    ( IsSubset (TableFields a) (TableFields a)+    , AllTypesSatisfy JSONableField a (TableFields a) )+    => ToJSON (Entity ('FromDb 'Live) a) where+    toJSON = toJSON . toFreshEntity @'[]++class    (KnownSymbol n, ToJSON a) => JSONableField a (n :: Symbol)+instance (KnownSymbol n, ToJSON a) => JSONableField a (n :: Symbol)++instance+    ( IsSubset (SetFields fs a) (SetFields fs a)+    , AllTypesSatisfy JSONableField a (SetFields fs a) )+    => ToJSON (Entity ('Fresh fs) a) where+    toJSON e = object (mapFields @JSONableField @a @(SetFields fs a)+                                 (\p a -> (toS (symbolVal p), toJSON a)) e)++class GetEntityFromValue (fs :: [Symbol]) a (miss :: [MissingField]) where+    getEntityFromObject :: Value -> Parser (Entity ('Fresh miss) a)+instance (Table a, miss ~ TableRequiredFields a) => GetEntityFromValue '[] a miss where+    getEntityFromObject (Object _) = return newEntity+    getEntityFromObject _ = fail "Cannot parse Entity from JSON that's not an object"+instance+    ( GetEntityFromValue fs a miss+    , miss' ~ WithoutMissingField f miss+    , FromJSON (TableFieldType a f)+    , TableField a f )+    => GetEntityFromValue (f ': fs) a miss' where+    getEntityFromObject o = case o ^? key k of+        Nothing -> fail $ "Cannot parse Entity. JSON value doesn't have the key \"" <> toS k <> "\""+        Just v  -> do+            parsedField <- parseJSON v+            Entity ent <- getEntityFromObject @fs @a @miss o+            return (Entity (ent & tableFieldLens @a @f .~ parsedField))+      where+        k = toS (symbolVal (Proxy :: Proxy f))+instance+    GetEntityFromValue (SetFields miss a) a miss+    => FromJSON (Entity ('Fresh miss) a) where+    parseJSON = getEntityFromObject @(SetFields miss a) @a++type family SameTypes toTable   (toFields :: [Symbol])+                      fromTable (fromFields :: [Symbol]) :: Constraint where+    SameTypes toTable '[] fromTable '[] = ()+    SameTypes toTable (x ': xs) fromTable (y ': ys) =+        (TableFieldType toTable x ~ TableFieldType fromTable y, SameTypes toTable xs fromTable ys)++class ( KnownSymbol (TableName table)+      , AllSatisfy (TableField table) (TableFields table)+      , AllSatisfy KnownSymbol (TableFields table)+      , AllSatisfy (ValidConstraint table) (TableConstraints table)+      , AllTypesSatisfy (TypeSatisfies ToField) table (TableFields table)+      , OnMaybe (() :: Constraint) PrimaryKeyConstraint (TablePrimaryKey table)+      , FromRow table )+    => Table table where+    type TableName table = (name :: Symbol) | name -> table+    type TableFields table :: [Symbol]+    type TableConstraints table :: [FieldConstraint]+    type TablePrimaryKey table :: Maybe Symbol+    type TableRequiredFields table :: [MissingField]+    newEntity :: Entity ('Fresh (TableRequiredFields table)) table++class ValidConstraint (table :: *) (constr :: FieldConstraint)+instance (UniqueConstraint name, table ~ UniqueTable name) => ValidConstraint table ('Unique name)+instance (ForeignKeyConstraint name, table ~ ForeignKeyFrom name)+    => ValidConstraint table ('ForeignKey name)++getDbFields :: forall table. (MappableList (TableFields table), Table table) => [Text]+getDbFields = mapTypeList (Proxy @KnownSymbol) (toS . symbolVal) (Proxy @(TableFields table))++type family IsDbExp a :: Bool where+    IsDbExp (DbExp k a) = 'True+    IsDbExp a = 'False++type family KindOfDbExp a :: ExpressionKind where+    KindOfDbExp (DbExp k a) = k+    KindOfDbExp a = 'LiteralExp++type family IsDbStatement (m :: k -> *) :: Bool where+    IsDbStatement (DbStatement r) = 'True+    IsDbStatement a = 'False++class ValueAsDbExp' (IsDbExp a) a b+    => ValueAsDbExp a b where+    valueAsDbExp :: a -> DbExp (KindOfDbExp a) b+instance ValueAsDbExp' (IsDbExp a) a b+    => ValueAsDbExp a b where+    valueAsDbExp = valueAsDbExp' @(IsDbExp a)++class ValueAsDbExp' (isDbExp :: Bool) a b where+    valueAsDbExp' :: a -> DbExp (KindOfDbExp a) b+instance (DbExp k b ~ a) => ValueAsDbExp' 'True a b where+    valueAsDbExp' = identity+instance (a ~ b, ToField a, KindOfDbExp a ~ 'LiteralExp) => ValueAsDbExp' 'False a b where+    valueAsDbExp' = Literal++class (KnownSymbol name, IsDbExp (TableFieldType table name) ~ 'False)+    => TableField (table :: *) (name :: Symbol) where+    type TableFieldType table name :: *+    tableFieldLens :: Lens' table (TableFieldType table name)++class ( UniqueConstraint name+      , AllTypesSatisfy NotNull (UniqueTable name) (UniqueFields name) )+     => PrimaryKeyConstraint (name :: Symbol)++class ( AllSatisfy (TableField (UniqueTable name)) (UniqueFields name)+      , KnownSymbol name )+   => UniqueConstraint (name :: Symbol) where+    type UniqueTable name :: *+    type UniqueFields name :: [Symbol]++class ( KnownSymbol name+      , AllSatisfy (TableField (ForeignKeyFrom name)) (ForeignKeyFromFields name)+      , AllSatisfy (TableField (ForeignKeyTo   name)) (ForeignKeyToFields   name)+      , SameTypes (ForeignKeyTo   name) (ForeignKeyToFields   name)+                  (ForeignKeyFrom name) (ForeignKeyFromFields name) )+   => ForeignKeyConstraint (name :: Symbol) where+    type ForeignKeyFrom name :: *+    type ForeignKeyTo   name :: *+    type ForeignKeyFromFields name :: [Symbol]+    type ForeignKeyToFields   name :: [Symbol]++type family MissingFieldName (f :: MissingField) :: Symbol where+    MissingFieldName ('Required s) = s+    MissingFieldName ('DynamicDefault s) = s++type family MissingFieldsNames (fs :: [MissingField]) :: [Symbol] where+    MissingFieldsNames '[] = '[]+    MissingFieldsNames (f ': fs) = MissingFieldName f ': MissingFieldsNames fs++type family WithFieldSet (field :: Symbol) (entKind :: EntityKind) :: EntityKind where+    WithFieldSet field ('FromDb c) = 'FromDb c+    WithFieldSet field ('Fresh missing) = 'Fresh (WithoutMissingField field missing)++type family WithFieldsSet (fields :: [Symbol]) (entKind :: EntityKind) :: EntityKind where+    WithFieldsSet '[] entKind = entKind+    WithFieldsSet (f ': fs) entKind = WithFieldSet f (WithFieldsSet fs entKind)+    WithFieldsSet field ('FromDb c) = 'FromDb c++type family WithoutMissingField (name :: Symbol) (fs :: [MissingField]) :: [MissingField] where+    WithoutMissingField name '[] = '[]+    WithoutMissingField name ('Required name ': fs) = fs+    WithoutMissingField name ('DynamicDefault name ': fs) = fs+    WithoutMissingField name (f ': fs) = f ': WithoutMissingField name fs++type family WithoutMissingFields (fields :: [Symbol]) (fs :: [MissingField]) :: [MissingField] where+    WithoutMissingFields '[] ms = ms+    WithoutMissingFields (f ': fs) ms = WithoutMissingField f (WithoutMissingFields fs ms)++type CanInsert entKind table = (Table table, CanInsertFresh (MissingFields entKind) table)+type family CanInsert' (entKind :: EntityKind) (table :: *) :: Constraint where+    CanInsert' ('Fresh missing) table = CanInsertFresh missing table+    CanInsert' ('FromDb c) table = ()+type CanInsertFresh (missing :: [MissingField]) (table :: *) =+    ( CanInsertMissing missing+    , SetFields missing table `IsSubset` SetFields missing table -- needed for the compile function+    , AllSatisfy KnownSymbol (SetFields missing table), MappableList (SetFields missing table)+    , AllTypesSatisfy (TypeSatisfies ToField) table (SetFields missing table) )+type family CanInsertMissing (fs :: [MissingField]) :: Constraint where+    CanInsertMissing '[] = ()+    CanInsertMissing ('DynamicDefault name ': fs) = CanInsertMissing fs+    CanInsertMissing (f ': fs) = TypeError ( ErrorText "Can't insert entity because the required field "+                                ':<>: 'ShowType (MissingFieldName f)+                                ':<>: ErrorText " is not set" )++type CanUpdate table pk =+    ( KnownSymbol pk+    , Table table+    , SetFields '[] table `IsSubset` SetFields '[] table -- needed for the compile function+    , MappableList (TableFields table)+    )++type DbResult list = ListToTuple (Entity ('FromDb 'Live)) list+type Variables ctx list = ListToTuple (Var ctx) list++class TableSetVars ctx (tables :: [*]) where+    makeVars :: Variables ctx tables+instance TableSetVars ctx '[] where+    makeVars = ()+instance TableSetVars ctx '[a] where+    makeVars = Var 0+instance TableSetVars ctx '[a, b] where+    makeVars = (Var 0, Var 1)+instance TableSetVars ctx '[a, b, c] where+    makeVars = (Var 0, Var 1, Var 2)++data BoolOp = And | Or deriving (Eq, Ord, Read, Show)++data ResultType = Filtered | Unfiltered | Inserted | Deleted | Updated | Sorted | Limited | Grouped+                | Mapped | Folded+type family Selection (t :: ResultType) :: Constraint where+    Selection 'Filtered = ()+    Selection 'Unfiltered = ()+type family SelectionOrSortedSelection (t :: ResultType) :: Constraint where+    SelectionOrSortedSelection 'Filtered = ()+    SelectionOrSortedSelection 'Unfiltered = ()+    SelectionOrSortedSelection 'Sorted = ()+type family CanAggregate (t :: ResultType) :: Constraint where+    CanAggregate 'Filtered = ()+    CanAggregate 'Unfiltered = ()+    CanAggregate 'Grouped = ()+type family CanMap (f :: ResultType) :: Constraint where+    CanMap 'Unfiltered = ()+    CanMap 'Filtered = ()+    CanMap 'Grouped = ()+++type FieldIsGettableBool field missing = Not (field `Elem` MissingFieldsNames missing)+type FieldIsGettable field missing =+    CheckWithError (FieldIsGettableBool field missing)+                   (ErrorText "Field " ':<>: 'ShowType field ':<>: ErrorText " is not set")++type FieldIsNotSet field setFields =+    CheckWithError (Not (Elem field setFields))+                   (     ErrorText "Cannot update the field "+                   ':<>: 'ShowType field+                   ':<>: ErrorText " because it's already updated in this expression")++varFromUpdateExp :: UpdateExp fields t -> Var 'Updating t+varFromUpdateExp (NoUpdate v) = v+varFromUpdateExp (SetField _ v _) = varFromUpdateExp v++type family ListToSimpleTuple (l :: [*]) :: * where+    ListToSimpleTuple '[] = ()+    ListToSimpleTuple '[a] = PSQL.Only a+    ListToSimpleTuple '[a, b] = (a, b)+    ListToSimpleTuple '[a, b, c] = (a, b, c)+    ListToSimpleTuple '[a, b, c, d] = (a, b, c, d)+    ListToSimpleTuple '[a, b, c, d, e] = (a, b, c, d, e)++type family TupleToList (map :: *) :: [*] where+    TupleToList () = '[]+    TupleToList (PSQL.Only a) = TupleToList a+    TupleToList (a, b) = TupleToList a ++ TupleToList b+    TupleToList (a, b, c) = TupleToList a ++ TupleToList b ++ TupleToList c+    TupleToList (a, b, c, d) = TupleToList a ++ TupleToList b ++ TupleToList c ++ TupleToList d+    TupleToList (a, b, c, d, e) = TupleToList a ++ TupleToList b ++ TupleToList c ++ TupleToList d ++ TupleToList e+    TupleToList a = '[a]+type FlattenTuple t = ListToSimpleTuple (TupleToList t)++instance k ~ 'LiteralExp => Num (DbExp k Key) where+    fromInteger = Literal . Key . fromInteger++instance k ~ 'LiteralExp => IsString (DbExp k Text) where+    fromString = Literal . toS++data DbStatement (resultType :: ResultType) (ts :: [*]) where+    Table    :: Table table => proxy (TableName table) -> DbStatement 'Unfiltered '[table]++    Filter   :: (TableSetVars 'Filtering tables, Selection f)+             => (Variables 'Filtering tables -> ConditionExp) -> DbStatement f tables+             -> DbStatement 'Filtered tables++    Join     :: DbStatement 'Unfiltered tables1 -> DbStatement 'Unfiltered tables2+             -> DbStatement 'Unfiltered (tables1 ++ tables2)++    Raw      :: ToRow r => Text -> r -> DbStatement f a++    Insert   :: CanInsert missing table+             => Entity missing table -> DbStatement 'Inserted '[table]++    Delete   :: (Selection f, Table table)+             => DbStatement f '[table] -> DbStatement 'Deleted '[table]++    Update   :: (Selection f)+             => (Var 'Updating table -> UpdateExp fields table) -> DbStatement f '[table]+             -> DbStatement 'Updated '[a]++    SortOn   :: (Selection f, TableSetVars 'Sorting tables, Sortable ord)+             => (Variables 'Sorting tables -> ord) -> DbStatement f tables+             -> DbStatement 'Sorted tables++    Take     :: SelectionOrSortedSelection f+             => Int -> DbStatement f tables -> DbStatement 'Limited tables++    Map     :: (Mappable map, CanMap f, TableSetVars 'Mapping tables)+            => (Variables 'Mapping tables -> map) -> DbStatement f tables+            -> DbStatement 'Mapped '[MapResult map]++    AsGroup :: TableSetVars 'Grouping tables+            => DbStatement f tables -> DbStatement 'Grouped tables++    GroupMap :: GroupMappable map+             => ((AsAggregate group, DbStatement 'Grouped tables) -> map)+             -> GroupStatement group tables+             -> DbStatement 'Folded '[GroupMapResult map]++data GroupStatement group tables where+    GroupOn  :: (Selection f, TableSetVars 'Grouping tables, Groupable group)+             => (Variables 'Grouping tables -> group) -> DbStatement f tables+             -> GroupStatement group tables++-- | A kind and type used so LiftAggregation can differentiate types like `m a` from+--   `AggregateStatement` by their kind.+data AM = AM+data AggregateStatement aggr (marker :: AM) where+    Aggregate :: (Aggregatable aggr, CanAggregate f, TableSetVars 'Folding tables)+              => (Variables 'Folding tables -> aggr) -> DbStatement f tables+              -> AggregateStatement aggr 'AM++data UpdateExp (fields :: [Symbol]) (table :: *) where+    NoUpdate :: Var 'Updating table -> UpdateExp '[] table++    SetField :: (TableField table fieldName, FieldIsNotSet fieldName fields)+             => proxy fieldName -> UpdateExp fields table+             -> DbExp k (TableFieldType table fieldName)+             -> UpdateExp (fieldName ': fields) table++data ConditionExp where+    Compare  :: Ord a => Comparison -> DbExp k1 a -> DbExp k2 a -> ConditionExp++    BoolOp   :: BoolOp -> ConditionExp -> ConditionExp -> ConditionExp++    IsNull   :: DbExp 'FieldExp (Maybe a) -> ConditionExp++    In       :: LiteralCollection collection a => DbExp k a -> collection -> ConditionExp++data ExpressionKind = FieldExp | LiteralExp+data DbExp (kind :: ExpressionKind) a where+    Field    :: TableField table fieldName+             => proxy fieldName -> Var anyCtx table -> DbExp 'FieldExp (TableFieldType table fieldName)++    Literal  :: ToField a => a -> DbExp 'LiteralExp a++data SomeDbExp = forall k a. SomeDbExp (DbExp k a)+class Sortable ord where+    getOrdering :: ord -> [(SomeDbExp, SortDirection)]++instance Ord a => Sortable (DbExp k a) where+    getOrdering e = [(SomeDbExp e, Ascending)]+instance Sortable a => Sortable (Down a) where+    getOrdering (Down a) = fmap (second flipDirection) (getOrdering a)+        where flipDirection Ascending = Descending+              flipDirection Descending = Ascending+instance (Sortable a, Sortable b) => Sortable (a, b) where+    getOrdering (a, b) = getOrdering a <> getOrdering b+instance (Sortable a, Sortable b, Sortable c) => Sortable (a, b, c) where+    getOrdering (a, b, c) = getOrdering a <> getOrdering b <> getOrdering c+++class LiteralCollection collection a | collection -> a where+    getLiteralCollection :: collection -> [SomeDbExp]+instance a ~ b => LiteralCollection (DbExp k a) a where+    getLiteralCollection e = [SomeDbExp e]+instance (LiteralCollection a x, LiteralCollection b x) => LiteralCollection (a, b) x where+    getLiteralCollection (a, b) = getLiteralCollection a <> getLiteralCollection b+instance+    (LiteralCollection a x, LiteralCollection b x, LiteralCollection c x)+    => LiteralCollection (a, b, c) x where+    getLiteralCollection (a, b, c) =+        getLiteralCollection a <> getLiteralCollection b <> getLiteralCollection c+instance DbExp b x ~ a => LiteralCollection [a] x where+    getLiteralCollection as = as >>= getLiteralCollection+++class Groupable group where+    -- | Wrapps every DbExp in the tuple with the GroupMappableDbExp+    type AsAggregate group :: *+    getGrouping :: group -> [SomeDbExp]+    asAggregate :: group -> AsAggregate group+instance Groupable (DbExp k a) where+    type AsAggregate (DbExp k a) = GroupMappableThing a 'AM+    getGrouping e = [SomeDbExp e]+    asAggregate = GroupMappableDbExp+instance (Groupable a, Groupable b) => Groupable (a, b) where+    type AsAggregate (a, b) = (AsAggregate a, AsAggregate b)+    getGrouping (a, b) = getGrouping a <> getGrouping b+    asAggregate (a, b) = (asAggregate a, asAggregate b)+instance (Groupable a, Groupable b, Groupable c) => Groupable (a, b, c) where+    type AsAggregate (a, b, c) = (AsAggregate a, AsAggregate b, AsAggregate c)+    getGrouping (a, b, c) = getGrouping a <> getGrouping b <> getGrouping c+    asAggregate (a, b, c) = (asAggregate a, asAggregate b, asAggregate c)+instance (Groupable a, Groupable b, Groupable c, Groupable d) => Groupable (a, b, c, d) where+    type AsAggregate (a, b, c, d) = (AsAggregate a, AsAggregate b, AsAggregate c, AsAggregate d)+    getGrouping (a, b, c, d) = getGrouping a <> getGrouping b <> getGrouping c <> getGrouping d+    asAggregate (a, b, c, d) = (asAggregate a, asAggregate b, asAggregate c, asAggregate d)++data GroupMappableThing res (am :: AM) where+    GroupMappableDbExp :: DbExp k a -> GroupMappableThing a 'AM+    GroupMappableAggr  :: Aggregatable aggr => AggregateStatement aggr 'AM -> GroupMappableThing (AggregationResult aggr) 'AM++type family GroupMapResultBase a where+    GroupMapResultBase (GroupMappableThing res 'AM) = res+class GroupMappableBase map where+    getGroupMappingBase :: map -> [(Sql.AggregateFunction, SomeDbExp)]+instance GroupMappableThing res 'AM ~ a => GroupMappableBase a where+    getGroupMappingBase (GroupMappableDbExp d) = [(Sql.Only, SomeDbExp d)]+    getGroupMappingBase (GroupMappableAggr as) = getAggregating (getAggr as)++type family GroupMapResult (map :: *) :: * where+    GroupMapResult (a, b) = FlattenTuple (GroupMapResultBase a, GroupMapResultBase b)+    GroupMapResult (a, b, c) = FlattenTuple (GroupMapResultBase a, GroupMapResultBase b, GroupMapResultBase c)+    GroupMapResult (a, b, c, d) = FlattenTuple (GroupMapResultBase a, GroupMapResultBase b, GroupMapResultBase c, GroupMapResultBase d)+    GroupMapResult (a, b, c, d, e) = FlattenTuple (GroupMapResultBase a, GroupMapResultBase b, GroupMapResultBase c, GroupMapResultBase d, GroupMapResultBase e)+    GroupMapResult a = FlattenTuple (PSQL.Only (GroupMapResultBase a))+class GroupMappable map where+    getGroupMapping :: map -> [(Sql.AggregateFunction, SomeDbExp)]+instance (GroupMappableBase a, GroupMappableBase b) => GroupMappable (a, b) where+    getGroupMapping (a, b) = getGroupMappingBase a <> getGroupMappingBase b+instance (GroupMappableBase a, GroupMappableBase b, GroupMappableBase c) => GroupMappable (a, b, c) where+    getGroupMapping (a, b, c) = getGroupMappingBase a <> getGroupMappingBase b <> getGroupMappingBase c+instance (GroupMappableBase a, GroupMappableBase b, GroupMappableBase c, GroupMappableBase d) => GroupMappable (a, b, c, d) where+    getGroupMapping (a, b, c, d) = getGroupMappingBase a <> getGroupMappingBase b <> getGroupMappingBase c <> getGroupMappingBase d+instance (GroupMappableBase a, GroupMappableBase b, GroupMappableBase c, GroupMappableBase d, GroupMappableBase e) => GroupMappable (a, b, c, d, e) where+    getGroupMapping (a, b, c, d, e) = getGroupMappingBase a <> getGroupMappingBase b <> getGroupMappingBase c <> getGroupMappingBase d <> getGroupMappingBase e+instance {-# OVERLAPPABLE #-} GroupMappableBase (m a) => GroupMappable (m (a :: AM)) where+    getGroupMapping = getGroupMappingBase++-- | So dfoldMap knows to behave like an expression when used inside of a dmap+type family InterpretAsGroupMap (a :: *) :: Bool where+    InterpretAsGroupMap (a, b) = 'True+    InterpretAsGroupMap (a, b, c) = 'True+    InterpretAsGroupMap (a, b, c, d) = 'True+    InterpretAsGroupMap (a, b, c, d, e) = 'True+    InterpretAsGroupMap (a, b, c, d, e, f) = 'True+    InterpretAsGroupMap (m (a :: *)) = 'False+    InterpretAsGroupMap a = 'True+++++class MappableBase map where+    type MapResultBase map :: *+    getMappingBase :: map -> [SomeDbExp]+instance MappableBase (DbExp k a) where+    type MapResultBase (DbExp k a) = a+    getMappingBase d = [SomeDbExp d]++type family MapResult (map :: *) :: * where+    MapResult (a, b) = FlattenTuple (MapResultBase a, MapResultBase b)+    MapResult (a, b, c) = FlattenTuple (MapResultBase a, MapResultBase b, MapResultBase c)+    MapResult (a, b, c, d) = FlattenTuple (MapResultBase a, MapResultBase b, MapResultBase c, MapResultBase d)+    MapResult (a, b, c, d, e) = FlattenTuple (MapResultBase a, MapResultBase b, MapResultBase c, MapResultBase d, MapResultBase e)+    MapResult a = FlattenTuple (PSQL.Only (MapResultBase a))+class Mappable map where+    getMapping :: map -> [SomeDbExp]+instance (MappableBase a, MappableBase b) => Mappable (a, b) where+    getMapping (a, b) = getMappingBase a <> getMappingBase b+instance (MappableBase a, MappableBase b, MappableBase c) => Mappable (a, b, c) where+    getMapping (a, b, c) = getMappingBase a <> getMappingBase b <> getMappingBase c+instance (MappableBase a, MappableBase b, MappableBase c, MappableBase d) => Mappable (a, b, c, d) where+    getMapping (a, b, c, d) = getMappingBase a <> getMappingBase b <> getMappingBase c <> getMappingBase d+instance (MappableBase a, MappableBase b, MappableBase c, MappableBase d, MappableBase e) => Mappable (a, b, c, d, e) where+    getMapping (a, b, c, d, e) = getMappingBase a <> getMappingBase b <> getMappingBase c <> getMappingBase d <> getMappingBase e+instance {-# OVERLAPPABLE #-} MappableBase a => Mappable a where+    getMapping = getMappingBase++++++getAggr :: AggregateStatement aggr 'AM -> aggr+getAggr (Aggregate f (_ :: DbStatement f ts)) = f (makeVars @'Folding @ts)++newtype Avg a = Avg a+newtype Count a = Count a+newtype Only a = Only a+class AggregatableBase aggr where+    type AggregationBaseResult aggr :: *+    getAggregatingBase :: aggr -> (Sql.AggregateFunction, SomeDbExp)+instance Ord a => AggregatableBase (Max (DbExp f a)) where+    type AggregationBaseResult (Max (DbExp f a)) = a+    getAggregatingBase (Max e) = (Sql.Max, SomeDbExp e)+instance Ord a => AggregatableBase (Min (DbExp f a)) where+    type AggregationBaseResult (Min (DbExp f a)) = a+    getAggregatingBase (Min e) = (Sql.Min, SomeDbExp e)+instance Num a => AggregatableBase (Avg (DbExp f a)) where+    type AggregationBaseResult (Avg (DbExp f a)) = a+    getAggregatingBase (Avg e) = (Sql.Avg, SomeDbExp e)+instance AggregatableBase (Count (DbExp f a)) where+    type AggregationBaseResult (Count (DbExp f a)) = a+    getAggregatingBase (Count e) = (Sql.Count, SomeDbExp e)+instance Num a => AggregatableBase (Sum (DbExp f a)) where+    type AggregationBaseResult (Sum (DbExp f a)) = a+    getAggregatingBase (Sum e) = (Sql.Sum, SomeDbExp e)+instance AggregatableBase (Only (DbExp f a)) where+    type AggregationBaseResult (Only (DbExp f a)) = a+    getAggregatingBase (Only e) = (Sql.Only, SomeDbExp e)++type family BadAggregateBaseError where+    BadAggregateBaseError =+        TypeError (+            ErrorText "The only types that can exist in a fold expression are expressions \+                      \involving entity fields wrapped in one of the Monoid newtypes."+      ':$$: ErrorText "Along with the newtypes from Data.Monoid (Max, Min, Sum), there are \+                      \Avg and Count."+      ':$$: ErrorText "Example: dfoldMap (\\e -> (Max (e ^. height), Avg (e ^. weigth))) t")+instance {-# OVERLAPPABLE #-} BadAggregateBaseError => AggregatableBase a where++type family AggregationResult (aggr :: *) where+    AggregationResult (a, b) = (AggregationBaseResult a, AggregationBaseResult b)+    AggregationResult (a, b, c) = (AggregationBaseResult a, AggregationBaseResult b, AggregationBaseResult c)+    AggregationResult a = PSQL.Only (AggregationBaseResult a)+class Aggregatable aggr where+    getAggregating :: aggr -> [(Sql.AggregateFunction, SomeDbExp)]+instance (AggregatableBase a, AggregatableBase b) => Aggregatable (a, b) where+    getAggregating (a, b) = [getAggregatingBase a, getAggregatingBase b]+instance (AggregatableBase a, AggregatableBase b, AggregatableBase c) => Aggregatable (a, b, c) where+    getAggregating (a, b, c) = [getAggregatingBase a, getAggregatingBase b, getAggregatingBase c]+instance {-# OVERLAPPABLE #-}+    AggregatableBase a+    => Aggregatable a where+    getAggregating a = [getAggregatingBase a]++nameText :: forall name. KnownSymbol name => Text+nameText = toS (symbolVal (Proxy @name))

@@ -0,0 +1,81 @@+{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses, AllowAmbiguousTypes #-}+module Internal.Data.Basic.Virtual where++import Internal.Interlude++import GHC.TypeLits+import Control.Lens++import Internal.Data.Basic.Types+import Internal.Data.Basic.Common+import Internal.Data.Basic.Lens+import Internal.Data.Basic.Compare++import Database.PostgreSQL.Simple.ToField (ToField)++fieldMatch :: forall (toField :: Symbol) (fromField :: Symbol) toTable fromTable c.+              ( TableField toTable toField, TableField fromTable fromField+              , TableFieldType toTable toField ~ TableFieldType fromTable fromField+              , Ord (TableFieldType toTable toField)+              , ToField (TableFieldType toTable toField) )+           => Entity ('FromDb c) toTable -> Var 'Filtering fromTable -> ConditionExp+fieldMatch toTable fromTable =+    Literal (toTable ^. fieldOptic @toField) ==. fromTable ^. fieldOptic @fromField++class ( Table fromTable, Table toTable+      , AllSatisfy (TableField fromTable) fromFields+      , AllSatisfy (TableField toTable)   toFields+      , SameTypes toTable toFields fromTable fromFields+      , AllTypesSatisfy (TypeSatisfies Ord) fromTable fromFields+      , AllTypesSatisfy (TypeSatisfies ToField) fromTable fromFields )+      => AllFieldsMatch (toFields :: [Symbol]) (fromFields :: [Symbol]) toTable fromTable where+    allFieldsMatch :: Entity ('FromDb c) toTable -> Var 'Filtering fromTable -> ConditionExp++instance ( Table fromTable, Table toTable+         , TableField fromTable fromField+         , TableField toTable   toField+         , TableFieldType fromTable fromField ~ TableFieldType toTable toField+         , Ord (TableFieldType toTable toField), ToField (TableFieldType fromTable fromField) )+         => AllFieldsMatch '[toField] '[fromField] toTable fromTable where+    allFieldsMatch = fieldMatch @toField @fromField++instance {-# OVERLAPPABLE #-}+         ( Table fromTable, Table toTable+         , TableField fromTable fromField+         , TableField toTable   toField+         , TableFieldType fromTable fromField ~ TableFieldType toTable toField+         , Ord (TableFieldType toTable toField), ToField (TableFieldType fromTable fromField)+         , AllFieldsMatch toFields fromFields toTable fromTable )+         => AllFieldsMatch (toField ': toFields) (fromField ': fromFields) toTable fromTable where+    allFieldsMatch toTable fromTable =+         fieldMatch @toField @fromField toTable fromTable+     &&. allFieldsMatch @toFields @fromFields toTable fromTable++virtualTableDbExpLens+    :: forall foreignKeyName c.+       ( ForeignKeyConstraint foreignKeyName+       , AllFieldsMatch (ForeignKeyToFields foreignKeyName) (ForeignKeyFromFields foreignKeyName)+                        (ForeignKeyTo foreignKeyName) (ForeignKeyFrom foreignKeyName) )+    => Getter' (Entity ('FromDb c) (ForeignKeyTo foreignKeyName))+               (DbStatement 'Filtered '[ForeignKeyFrom foreignKeyName])+virtualTableDbExpLens = to $ \u ->+    dfilter (allFieldsMatch @(ForeignKeyToFields foreignKeyName)+                            @(ForeignKeyFromFields foreignKeyName)+                            u)+            (allRows @(TableName (ForeignKeyFrom foreignKeyName)))++type VirtualTable foreignKeyName res =+    ( ForeignKeyConstraint foreignKeyName+    , AllFieldsMatch (ForeignKeyToFields foreignKeyName) (ForeignKeyFromFields foreignKeyName)+                     (ForeignKeyTo foreignKeyName) (ForeignKeyFrom foreignKeyName)+    , LiftedStatement 'Filtered '[(ForeignKeyFrom foreignKeyName)] res )++virtualTableLens :: forall foreignKeyName c res. VirtualTable foreignKeyName res+                 => Getter' (Entity ('FromDb c) (ForeignKeyTo foreignKeyName)) (res)+virtualTableLens = to (\u -> liftDbExp (u ^. expLens))+    where expLens = virtualTableDbExpLens @foreignKeyName++virtualTableLensProxy ::+    forall foreignKeyName res c proxy. VirtualTable foreignKeyName res+    => proxy foreignKeyName -> Getter' (Entity ('FromDb c) (ForeignKeyTo foreignKeyName)) (res)+virtualTableLensProxy _ = virtualTableLens @foreignKeyName

@@ -0,0 +1,59 @@+module Internal.Interlude (module X, module Internal.Interlude) where++import Prelude as X hiding (show, id, head, putStrLn, print, readFile)+import qualified Prelude+import Data.Proxy as X+import Data.Kind as X+import Data.Semigroup as X hiding (Min, Max)+import Data.Text as X (Text)+import Data.ByteString as X (ByteString)+import Control.Lens as X (makeLenses, (^.), (.~), (%~), (^?), view, lensRules)+import Data.String.Conv as X+import Data.Function as X hiding (id)+import Data.Char as X+import Data.List as X hiding (head, insert)+import Data.Maybe as X+import Debug.Trace as X+import Data.String as X (IsString(..))+import Data.Aeson as X+import Data.Ord as X (Down(..))+import Data.Coerce as X+import Data.Bifunctor as X+import GHC.TypeLits as X (TypeError)+import Control.Monad.State as X (evalState, get, modify')+import Control.Monad.IO.Class as X+import Control.Monad as X+import Data.Functor.Identity as X+import qualified Data.Text.IO as Text+import Data.Foldable as X++show :: (Show a, IsString c) => a -> c+show = fromString . Prelude.show++identity :: a -> a+identity = Prelude.id+{-# INLINE identity #-}++head :: [a] -> Maybe a+head = listToMaybe+{-# INLINE head #-}++unsafeHead :: [a] -> a+unsafeHead = Prelude.head+{-# INLINE unsafeHead #-}++putStrLn :: MonadIO m => String -> m ()+putStrLn = liftIO . Prelude.putStrLn++print :: (MonadIO m, Show a) => a -> m ()+print = liftIO . Prelude.print++putText :: MonadIO m => Text -> m ()+putText = putStrLn . toS++readFile :: FilePath -> IO Text+readFile = Text.readFile++foldl1Def :: (a -> a -> a) -> a -> [a] -> a+foldl1Def _ d [] = d+foldl1Def f _ as = foldl1' f as

@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell, DataKinds, TypeFamilies, FlexibleContexts, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Model where++import Data.Basic++mkFromFile "test/initial.sql"

@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds, NoImplicitPrelude, TypeFamilies, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, OverloadedStrings #-}+import Prelude hiding (id)++import Data.Time+import System.Mem+import Database.PostgreSQL.Simple++import Data.Basic+import Control.Monad.IO.Class+import Control.Lens+import Control.Monad+import Data.Function ((&))+++import Control.Concurrent+import Model++insertNewSession :: MonadIO m => Connection -> LocalTime -> m ()+insertNewSession conn expiration =+    handleBasicPsql conn query'+    where+        session = newUserSession+            & expirationDate .~ expiration+            & id .~ 0+        query'  = void $ insert session++main :: IO ()+main = do+    conn <- connectPostgreSQL "host=localhost port=5432 user=postgres dbname=postgres password=admin connect_timeout=10"+    t <- do+        t <- getCurrentTime+        tz <- getCurrentTimeZone+        return (utcToLocalTime tz t)+    insertNewSession conn t+    performGC+    insertNewSession conn t+    -- performGC+    threadDelay 1000000