data-basic 0.2.0.3 → 0.2.0.4

raw patch · 21 files changed

+779/−279 lines, 21 filesdep +attoparsecdep +data-basicdep +scientificdep −basicdep ~aesondep ~basedep ~binaryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: attoparsec, data-basic, scientific, simple-logging

Dependencies removed: basic

Dependency ranges changed: aeson, base, binary, bytestring, cases, containers, hssqlppp, lens, lens-aeson, mtl, overload, postgresql-simple, simple-effects, string-conv, template-haskell, text, time

API changes (from Hackage documentation)

Files

• README.md +1/−1
• data-basic.cabal +109/−84
• src/Data/Basic.hs +9/−3
• src/Data/Basic/Example.hs +53/−7
• src/Internal/Composite.hs +111/−0
• src/Internal/Control/Effects/Basic.hs +79/−23
• src/Internal/Data/Basic/Common.hs +28/−2
• src/Internal/Data/Basic/Compare.hs +2/−2
• src/Internal/Data/Basic/Compiler.hs +27/−13
• src/Internal/Data/Basic/Lens.hs +30/−15
• src/Internal/Data/Basic/Sql/Types.hs +43/−24
• src/Internal/Data/Basic/SqlToHsTypes.hs +3/−1
• src/Internal/Data/Basic/TH.hs +8/−4
• src/Internal/Data/Basic/TH/Compiler.hs +4/−3
• src/Internal/Data/Basic/TH/Generator.hs +41/−24
• src/Internal/Data/Basic/TH/Helper.hs +31/−9
• src/Internal/Data/Basic/TH/SqlToHsTypes.hs +13/−2
• src/Internal/Data/Basic/TH/Types.hs +9/−2
• src/Internal/Data/Basic/TypeLevel.hs +18/−15
• src/Internal/Data/Basic/Types.hs +150/−32
• test/Spec.hs +10/−13

@@ -71,7 +71,7 @@ Let's start by inserting some data. All basic functions work in any monad with a `MonadEffect Basic` instance. Practically, this means it integrates well with a mtl-style codebase.  ```haskell-sandbox :: MonadEffect1 Basic m => m ()+sandbox :: MonadEffect Basic m => m () sandbox = return () ``` 

@@ -1,88 +1,113 @@-name: data-basic-version: 0.2.0.3-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-extra-source-files:-    README.md-    CHANGELOG.md--source-repository head-    type: git-    location: https://gitlab.com/haskell-hr/basic.git+name:                data-basic+version:             0.2.0.4+synopsis:            A database library with a focus on ease of use, type safety and useful error messages+description:         Please see README.md+homepage:            https://gitlab.com/haskell-hr/basic+license:             MIT+license-file:        LICENSE+author:              Nikola Henezi, Luka Horvat+maintainer:          nikola@henezi.com, luka.horvat9@gmail.com+category:            Database+build-type:          Simple+cabal-version:       >=1.10+extra-source-files:  README.md, CHANGELOG.md  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-        Data.Basic.Example-        Data.Basic.Tutorial-        Data.Basic-    build-depends:-        base >=4.7 && <5,-        simple-effects >=0.9.0.0,-        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.4,-        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+  hs-source-dirs:      src+  other-modules:       Internal.Interlude+  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.Composite+                       Data.Basic.Example+                       Data.Basic.Tutorial+                       Data.Basic+  build-depends:       base >= 4.7 && < 5+                     , simple-effects >= 0.10.0.0+                     , lens+                     , postgresql-simple+                     , text+                     , hssqlppp+                     , template-haskell >= 2.12.0.0+                     , cases+                     , containers+                     , time+                     , bytestring+                     , overload+                     , aeson+                     , lens-aeson+                     , binary+                     , string-conv+                     , mtl+                     , simple-logging+                     , scientific+                     , attoparsec+  default-language:    Haskell2010+  default-extensions:  NoImplicitPrelude+                       OverloadedStrings+                       DuplicateRecordFields+                       MultiParamTypeClasses+                       DataKinds+                       TemplateHaskell+                       FlexibleContexts+                       FlexibleInstances+                       TypeFamilies+                       ScopedTypeVariables+                       ConstraintKinds+                       NoMonomorphismRestriction+                       TypeOperators+                       TypeApplications+                       PolyKinds+                       DeriveGeneric+  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+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  other-modules:       Model+  build-depends:       base+                     , data-basic+                     , postgresql-simple+                     , time+                     , lens+                     , aeson+                     , string-conv+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010+  default-extensions:  NoImplicitPrelude+                       OverloadedStrings+                       DuplicateRecordFields+                       MultiParamTypeClasses+                       DataKinds+                       TemplateHaskell+                       FlexibleContexts+                       FlexibleInstances+                       TypeFamilies+                       ScopedTypeVariables+                       ConstraintKinds+                       NoMonomorphismRestriction+                       TypeOperators+                       TypeApplications+                       PolyKinds+                       DeriveGeneric+source-repository head+  type:     git+  location: https://gitlab.com/haskell-hr/basic.git

@@ -7,15 +7,21 @@     , ddelete, dupdate, insert, dfilter, save, dtake, djoin, dsortOn, dfoldMap, dfoldMapInner, dmap     , dgroupOn, rawQuery     , (<.), (>.), (==.), (/=.), (<=.), (>=.), (&&.), (||.)-    , ConditionExp(In), Avg(..), Count(..), Min(..), Max(..), Sum(..)-    , handleBasicPsql, handleBasic, connectPostgreSQL-    , mkFromFile, mkFromFiles, printToFile, FromRow(..), field, Cached(..) )+    , ConditionExp(In), Avg(..), Count(..), Min(..), Max(..), Sum(..), List(..), PGArray(..)+    , handleBasicPsql, connectPostgreSQL, handleBasicPsqlWithLogging+    , BasicException(..), throwBasicToIO, logOnlyErrors, prettyPrintSummary+    , mkFromFile, mkFromFiles, printToFile, FromRow(..), field, Cached(..)+    , delem, disNothing, disJust, GettableField, ModifyableField, SettableField+    , WithFieldSet, like, ilike, dtrue, dfalse, executeQuery, applySchema, Schema, toFreshEntity )     where  import Internal.Data.Basic.Types import Internal.Data.Basic import Internal.Data.Basic.TH+import Internal.Data.Basic.TH.Types (Schema) import Internal.Control.Effects.Basic import Internal.Data.Basic.SqlToHsTypes import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.FromRow+import Database.PostgreSQL.Simple.Types+import Control.Effects.Logging

@@ -1,16 +1,17 @@ {-# OPTIONS_GHC -Wno-orphans #-}-module Data.Basic.Example where+module Data.Basic.Example (module Data.Basic.Example) where  import Internal.Interlude hiding (filter)  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)+                 , _userLocation :: Point } deriving (Eq, Read, Show)  makeLenses ''User @@ -127,10 +128,11 @@                        & name .~ "New post"                        & author .~ user'     post' <- insert post-    void $ dfilter (\u -> In (u ^. id) [1, 3, 4]) allUsers+    void $ dfilter (\u -> (u ^. id) `delem` [1, 3, 4]) allUsers     void $ dfilter (\u -> u ^. id <. (2 :: Key)) allUsers      auth <- post' ^. author+    putText (toS $ encode auth)     void $ save (auth & name .~ "Luka H")      let user2 = newUser & name .~ "Ivan"@@ -139,13 +141,17 @@     void $ insert user2      us <- dtake 1 $ dsortOn (\u -> Down (u ^. id)) allUsers-    print us+    putText (toS $ encode us)      void $ dupdate (\u' -> u' & location .~ Point 7 8) allUsers      usersPosts <- allUsers `djoin` allPosts-    print usersPosts+    putText (toS $ encode usersPosts) +    users <- dfilter (\u -> (u ^. name) `ilike` "%uka%") allUsers+    putText (toS $ encode users)++     -- Folding/grouping test     void $ ddelete allPosts     void $ ddelete allUsers@@ -174,7 +180,9 @@             & location .~ Point 0 0      print =<< dfoldMap (\u -> (Min (u ^. id), Max (u ^. id))) allUsers-    print =<< dmap (\u -> u ^. name) allUsers+    -- putText . toS . encode =<< dtake 1 (dmap (^. name) allUsers)+    putText . toS . encode =<< dmap fst (allUsers `djoin` allUsers)+    print =<< dmap (^. location) (dsortOn (view name) allUsers)     allUsers         & dgroupOn (view name)         & dmap (\(_, g) ->@@ -186,10 +194,48 @@         & dfoldMapInner ((,) <$> Min . view id <*> Max . view id)         & (>>= print) +    -- Comparing+    print $ (newUser & name .~ "abc" & id .~ 1) > (newUser & name .~ "abd" & id .~ 0)+    print $ (newUser & location .~ Point 0 0) == (newUser & location .~ Point 0 1)++    void $ ddelete allPosts+    void $ ddelete allUsers+    l <- insert $ newUser+        & name .~ "Luka"+        & id .~ 0+        & location .~ Point 0 0+    void $ insert $+        newPost+            & id .~ 10+            & name .~ "Post 1\"\\"+            & author .~ l+    void $ insert $+        newPost+            & id .~ 11+            & name .~ ""+            & author .~ l++    pairs' <- allUsers `djoin` allPosts+        & dfilter (\(u, p) -> u ^. id ==. p ^. authorId)+        & dgroupOn fst+        & dfoldMapInner (List . snd)+    print pairs'++    -- print $ (newUser & name .~ "abc") > (newUser & location .~ Point 0 0)++ test :: IO () test = do     conn <- connectPostgreSQL "host=localhost port=5432 user=postgres dbname=postgres password=admin connect_timeout=10"-    handleBasicPsql conn test1+    test1+        & handleBasicPsqlWithLogging conn+        & prettyPrintSummary 1000+        & throwBasicToIO+        -- & handleSignal (\(b :: BasicException) -> do+        --     print b+        --     (q :: Query) <- readLn+        --     return (Resume q)+        --     )  -- Two very useful functions. -- And these are just good for printing out code.

@@ -0,0 +1,111 @@+{-# LANGUAGE GADTs #-}
+-- | Decode postgresql composites into entities
+-- Adapted code from: https://hackage.haskell.org/package/postgresql-simple-0.4.10.0/docs/src/Database-PostgreSQL-Simple-Arrays.html
+module Internal.Composite where
+
+import Internal.Interlude hiding (show, option) 
+import Prelude (Show(..))
+import Database.PostgreSQL.Simple.FromField
+import Data.Typeable
+import qualified Database.PostgreSQL.Simple.TypeInfo as TI
+import Data.Attoparsec.ByteString.Char8 hiding (Result)
+import Control.Applicative ((<|>), many)
+import qualified Data.ByteString.Char8 as B
+import Data.Foldable (toList)
+
+data Composite (ts :: [*]) where
+    EmptyComposite :: Composite '[]
+    ConsComposite :: t -> Composite ts -> Composite (t ': ts)
+
+instance Show (Composite '[]) where
+    show EmptyComposite = "EmptyComposite"
+instance (Show (Composite ts), Show t) => Show (Composite (t ': ts)) where
+    show (ConsComposite t r) = "ConsComposite " <> show t <> " (" <> show r <> ")"
+
+-- | any postgresql composite type whose fields are compatible with types @ts@
+instance FieldParsers ts => FromField (Composite ts) where
+    fromField = pgCompositeFieldParser
+
+pgCompositeFieldParser :: FieldParsers ts => FieldParser (Composite ts)
+pgCompositeFieldParser f mdat = do
+    info <- typeInfo f
+    let cont = case mdat of
+            Nothing  -> returnError UnexpectedNull f ""
+            Just dat ->
+                case parseOnly (fromComposite info f) dat of
+                    Left  err  -> returnError ConversionFailed f err
+                    Right conv -> conv
+    case info of
+        TI.Composite{} -> cont
+        TI.Basic{typname = "composite"} -> cont
+        _ -> returnError Incompatible f ("TypeInfo: " <> show info)
+
+class Typeable ts => FieldParsers ts where
+    fromCompositeFormats :: [TypeInfo] -> Field -> [CompositeFormat] -> Conversion (Composite ts)
+instance FieldParsers '[] where
+    fromCompositeFormats [] _ [] = return EmptyComposite
+    fromCompositeFormats _ f _ = returnError Incompatible f "The Composite's type indicates a smaller number of elements than the composite that was received"
+instance (FromField t, Typeable t, FieldParsers ts) => FieldParsers (t ': ts) where
+    fromCompositeFormats (ti : tis) f (af : afs) = 
+        ConsComposite 
+            <$> fromField @t fElem (if af == NullStr then Nothing else Just item')
+            <*> fromCompositeFormats @ts tis f afs
+        where
+        fElem = f { typeOid = typoid ti }
+        item' = fmt af
+    fromCompositeFormats _ f _ = returnError Incompatible f "The Composite's type indicates a greater number of elements than the composite that was received"
+
+fromComposite :: FieldParsers ts => TypeInfo -> Field -> Parser (Conversion (Composite ts))
+fromComposite ti f = fromCompositeFormats elems f <$> composite
+    where
+    elems = toList . fmap atttype . attributes $ ti
+
+compositeFormat :: Parser CompositeFormat
+compositeFormat = 
+    Plain <$> plain
+    <|> Quoted <$> quoted
+
+data CompositeFormat = 
+    Plain B.ByteString
+    | Quoted B.ByteString
+    | NullStr
+    deriving (Eq, Show, Ord)
+
+composite :: Parser [CompositeFormat]
+composite = char '(' *> option [] strings <* char ')'
+    where
+    strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain <|> return NullStr) (char ',')
+
+quoted :: Parser B.ByteString
+quoted  = char '"' *> option "" contents <* char '"'
+    where
+    esc' = (char '\\' *> char '\\')
+       <|> (char '"' *> char '"')
+    unQ = takeWhile1 (notInClass "\"\\")
+    contents = mconcat <$> many (unQ <|> B.singleton <$> esc')
+
+plain :: Parser B.ByteString
+plain = takeWhile1 (notInClass ",\"() ")
+
+fmt :: CompositeFormat -> B.ByteString
+fmt = fmt' False
+
+delimit :: [CompositeFormat] -> B.ByteString
+delimit [] = ""
+delimit [x] = fmt' True x
+delimit (x:y:z) = (fmt' True x `B.snoc` ',') `mappend` delimit (y:z)
+
+fmt' :: Bool -> CompositeFormat -> B.ByteString
+fmt' quoting x = case x of
+    Plain bytes          -> B.copy bytes
+    Quoted q 
+        | quoting   -> '"' `B.cons` (esc q `B.snoc` '"')
+        | otherwise -> B.copy q
+    NullStr -> ""
+
+esc :: B.ByteString -> B.ByteString
+esc = B.concatMap f
+    where
+    f '"'  = "\\\""
+    f '\\' = "\\\\"
+    f c    = B.singleton c

@@ -1,11 +1,11 @@ {-# LANGUAGE RankNTypes, ConstraintKinds, FlexibleContexts, TypeFamilies, ScopedTypeVariables #-} {-# LANGUAGE TypeApplications, TypeOperators, DataKinds, FlexibleInstances, UndecidableInstances #-}-{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeFamilyDependencies, NoMonomorphismRestriction #-} {-# LANGUAGE GADTs #-} module Internal.Control.Effects.Basic (module Internal.Control.Effects.Basic, module Control.Effects)     where -import Internal.Interlude+import Internal.Interlude hiding (Error)  import Control.Effects import Database.PostgreSQL.Simple@@ -14,32 +14,85 @@ import Internal.Data.Basic.Types import Internal.Data.Basic.Sql.Types import Internal.Data.Basic.Compiler--newtype Basic = RunSql Type+import Control.Effects.Logging+import Control.Exception+import Control.Effects.Signal+import Control.Monad.Trans  newtype SqlRequest a = SqlRequest { getSqlRequest :: SqlExp } deriving Show+data Basic -- = RunSql Type | ExecuteSql -data instance Effect Basic method mr where-    RunSqlMsg :: FromRow a => SqlRequest a -> Effect Basic ('RunSql a) 'Msg-    RunSqlRes :: FromRow a => { getRunSqlRes :: [a] } -> Effect Basic ('RunSql a) 'Res+instance Effect Basic where+    data EffMethods Basic m = BasicMethods+        { _runSql :: forall a. FromRow a => SqlRequest a -> m [a]+        , _executeSql :: SqlExp -> m () }+    liftThrough (BasicMethods r e) = BasicMethods+        (lift . r)+        (lift . e)+    mergeContext m = BasicMethods+        (\a -> ($ a) . _runSql =<< m)+        (\a -> ($ a) . _executeSql =<< m) -effectBasic :: (MonadEffect Basic m, FromRow a) => SqlRequest a -> m [a]-effectBasic = fmap getRunSqlRes . effect . RunSqlMsg+runSql :: MonadEffect Basic m => forall a. FromRow a => SqlRequest a -> m [a]+executeSql :: MonadEffect Basic m => SqlExp -> m ()+BasicMethods runSql executeSql = effect -handleBasic ::-    Functor m-    => (forall b. FromRow b => SqlRequest b -> m [b])-    -> EffectHandler Basic m a -> m a-handleBasic f = handleEffect (\(RunSqlMsg r) -> RunSqlRes <$> f r)+data BasicException =+      BasicFormatError FormatError+    | BasicQueryError QueryError+    | BasicResultError ResultError+    | BasicSqlError SqlError+    deriving (Eq, Show) --- | Handles SQL by querying a PostgreSQL database.-handleBasicPsql :: MonadIO m => Connection -> EffectHandler Basic m a -> m a-handleBasicPsql conn = handleBasic-    (liftIO . runQuerySegment . sqlExpToQuery . getSqlRequest)+-- | Handles SQL by querying a PostgreSQL database. Leaves logs unhandled.+handleBasicPsqlWithLogging ::+    forall m a. (MonadEffects '[Logging, Signal BasicException Query] m, MonadIO m)+    => Connection -> RuntimeImplemented Basic m a -> m a+handleBasicPsqlWithLogging conn = implement $+    BasicMethods (queryOrExec query . sqlExpToQuery . getSqlRequest) (void . queryOrExec execute . sqlExpToQuery)   where-    runQuerySegment :: FromRow b => QuerySegment -> IO [b]-    runQuerySegment (QuerySegment q as) = query conn q as+    queryOrExec :: forall b. (forall q. ToRow q => Connection -> Query -> q -> IO b) -> QuerySegment -> m b+    queryOrExec qe qs@(QuerySegment q as) = do+        logDebug "Executing query"+            & setDataToShowOf qs+            & layerLogs (Context "data-basic")+            & setTimestampToNow+        eitherRes <- liftIO $+            qe conn q as+                & fmap Right+                & handle (\(e :: FormatError) -> return $ Left (BasicFormatError e))+                & handle (\(e :: QueryError) -> return $ Left (BasicQueryError e))+                & handle (\(e :: ResultError) -> return $ Left (BasicResultError e))+                & handle (\(e :: SqlError) -> return $ Left (BasicSqlError e))+        case eitherRes of+            Left e -> do+                logError "Error while executing query" & setDataToShowOf e+                q' <- signal e+                queryOrExec qe (QuerySegment q' [])+            Right res -> return res ++throwBasicToIO :: forall m a. MonadIO m => ExceptT BasicException m a -> m a+throwBasicToIO = handleException throwBasicEx+    where+    throwBasicEx :: BasicException -> m a+    throwBasicEx (BasicFormatError fe) = liftIO $ throwIO fe+    throwBasicEx (BasicQueryError fe) = liftIO $ throwIO fe+    throwBasicEx (BasicResultError fe) = liftIO $ throwIO fe+    throwBasicEx (BasicSqlError fe) = liftIO $ throwIO fe++logOnlyErrors :: MonadEffect Logging m => RuntimeImplemented Logging m a -> m a+logOnlyErrors = filterLogs (\l -> originContext l /= Just (Context "data-basic") || logLevel l == Error)++-- | Handles SQL by querying a PostgreSQL database. Writes logs to console.+handleBasicPsql ::+    MonadIO m+    => Connection -> RuntimeImplemented Basic (RuntimeImplemented Logging (ExceptT BasicException m)) a -> m a+handleBasicPsql conn =+      throwBasicToIO+    . prettyPrintSummary 100+    . handleBasicPsqlWithLogging conn+ type family AllTables tables where     AllTables '[x] = x     AllTables (x ': xs) = x :. AllTables xs@@ -60,10 +113,13 @@             (AllHaveFromRowInstance ts, MonadEffect Basic m)          => DbStatement f ts -> m [DbResult ts] runDbStatement = fmap (map (compositeToTuple (Proxy @ts)))-         . effectBasic+         . runSql          . SqlRequest          . compileToSql +executeDbStatement :: MonadEffect Basic m =>  DbStatement f ts -> m ()+executeDbStatement = executeSql . compileToSql+ runAggregateStatement ::     forall aggr m.     ( MonadEffect Basic m@@ -71,7 +127,7 @@     => AggregateStatement aggr 'AM -> m (AggregationResult aggr) runAggregateStatement =       fmap unsafeHead-    . effectBasic+    . runSql     . SqlRequest     . aggregateStatementToSql @@ -95,6 +151,6 @@     => DbStatement f '[res] -> m [WithoutOnly res] runMapStatement =       fmap (fmap (noOnly @res))-    . effectBasic+    . runSql     . SqlRequest     . compileToSql

@@ -14,6 +14,7 @@ import Overload  import Internal.Data.Basic.Types+import Internal.Data.Basic.TH.Types (Schema(..)) import Internal.Control.Effects.Basic  class LiftedStatement fs t res where@@ -55,7 +56,7 @@  rawQuery :: forall a r m. (MonadEffect Basic m, FromRow a, ToRow r)          => Text -> r -> m [Entity ('FromDb 'Live) a]-rawQuery q r = runDbStatement (Raw q r :: DbStatement f '[a])+rawQuery q r = runDbStatement (Raw q r :: DbStatement 'RawQueried '[a])  insert :: (CanInsert entKind table, MonadEffect Basic m, FromRow table)        => Entity entKind table -> m (Entity ('FromDb 'Live) table)@@ -74,7 +75,7 @@ dsortOn f t = liftDbExp (SortOn f t)  dtake :: ( LiftedStatement 'Limited tables res-         , SelectionOrSortedSelection f )+         , CanTake f )       => Int -> DbStatement f tables -> res dtake n t = liftDbExp (Take n t) @@ -153,3 +154,28 @@     , TableSetVars 'Folding tables )     => (Variables 'Folding tables -> aggr) -> GroupStatement group tables -> res dfoldMapInner f s = liftMapStatement (dgroupMap (\(g, t) -> (g, GroupMappableAggr (Aggregate f t))) s)++delem :: (LiteralCollection collection a) => DbExp k a -> collection -> ConditionExp+delem = In++disNothing :: DbExp 'FieldExp (Maybe a) -> ConditionExp+disNothing = IsNull++disJust :: DbExp 'FieldExp (Maybe a) -> ConditionExp+disJust = IsNotNull++dtrue :: ConditionExp+dtrue = BoolLit True++dfalse :: ConditionExp+dfalse = BoolLit False++like, ilike :: DbExp 'FieldExp Text -> Text -> ConditionExp+like = Like False+ilike = Like True++executeQuery :: (ToRow r, MonadEffect Basic m) => Text -> r -> m ()+executeQuery q r = executeDbStatement (Execute q r :: DbStatement 'RawQueried '[])++applySchema :: MonadEffect Basic m => Schema -> m ()+applySchema (Schema sch) = void $ executeQuery sch ()

@@ -21,8 +21,8 @@ infix 4 <. infix 4 <=. infix 4 >=.-infix 3 &&.-infix 2 ||.+infixr 3 &&.+infixr 2 ||.  (>.), (==.), (/=.), (<.), (<=.), (>=.) :: ComparableInDbExp a b => a -> b -> ConditionExp (>.) = compareInDbExp GreaterThan

@@ -1,20 +1,29 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, RankNTypes, DataKinds, AllowAmbiguousTypes, LambdaCase #-}+{-# LANGUAGE GADTs, ScopedTypeVariables, RankNTypes, DataKinds, AllowAmbiguousTypes #-}+-- {-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-} 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 GHC.TypeLits (Symbol, KnownSymbol) 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 (Field (_ :: proxy1 table) (_ :: proxy2 name) (Var tab)) =+    SimpleName (QualifiedField tab (nameText @(CapsName table name))) expToSql (Literal a) = SqlLiteral (toField a) +varToSql :: Var k a -> SqlValueExp+varToSql (Var idx) = TableRecord (TableValue idx)++someDbExpToSqlExp :: SomeDbExp -> SqlValueExp+someDbExpToSqlExp (SomeDbExp e) = expToSql e+someDbExpToSqlExp (SomeVar v) = varToSql v+ literalCollectionToSql :: LiteralCollection collection a => collection -> [SqlValueExp]-literalCollectionToSql = fmap (\(SomeDbExp e) -> expToSql e) . getLiteralCollection+literalCollectionToSql = fmap someDbExpToSqlExp . getLiteralCollection  boolExpToSql :: ConditionExp -> Condition boolExpToSql (Compare c f1 f2) =@@ -22,7 +31,10 @@ 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.IsNotNull f) = Sql.IsNotNull (expToSql f) boolExpToSql (Basic.In val vals) = Sql.In (expToSql val) (literalCollectionToSql vals)+boolExpToSql (Basic.BoolLit b) = Sql.BoolLit b+boolExpToSql (Basic.Like b e v) = Sql.Like b (expToSql e) v  conditionToSql :: forall tables. TableSetVars 'Filtering tables                => (Variables 'Filtering tables -> ConditionExp) -> Condition@@ -38,11 +50,12 @@ compileTable _ =     Select SelectEverything Nothing [QualifiedTable (nameText @name) 0] [] (Limit Nothing) (Sql.Grouping []) -updatedExpToSql :: UpdateExp fields table -> ([Text], [SqlValueExp])+updatedExpToSql :: forall fields table. UpdateExp fields table -> ([Text], [SqlValueExp]) updatedExpToSql = \upd -> updatedExpToSql' (varFromUpdateExp upd) upd-    where updatedExpToSql' :: Var 'Updating t -> UpdateExp fields t -> ([Text], [SqlValueExp])+    where updatedExpToSql' :: Var 'Updating t -> UpdateExp fields' table -> ([Text], [SqlValueExp])           updatedExpToSql' _ (NoUpdate _) = ([], [])-          updatedExpToSql' v (SetField p upd val) = (toS (symbolVal p) : fs, expToSql val : vs)+          updatedExpToSql' v (SetField (_ :: proxy field) upd val) =+              (nameText @(CapsName table field) : fs, expToSql val : vs)               where (fs, vs) = updatedExpToSql' v upd  updateToSql :: forall table fields. (Var 'Updating table -> UpdateExp fields table)@@ -51,7 +64,7 @@  orderingToSql :: forall tables ord. (Sortable ord, TableSetVars 'Sorting tables)               => (Variables 'Sorting tables -> ord) -> [(SqlValueExp, SortDirection)]-orderingToSql f = fmap (first (\(SomeDbExp e) -> expToSql e))+orderingToSql f = fmap (first someDbExpToSqlExp)                        (getOrdering (f (makeVars @'Sorting @tables)))  mappingToSql ::@@ -62,10 +75,10 @@ mappingToSql f = mapToSql (f (makeVars @'Mapping @tables))  mapToSql :: Mappable map => map -> [SqlValueExp]-mapToSql = fmap (\(SomeDbExp e) -> expToSql e) . getMapping+mapToSql = fmap someDbExpToSqlExp . getMapping  groupMapToSql :: GroupMappable map => map -> [SqlValueExp]-groupMapToSql = fmap (\(af, SomeDbExp e) -> AggregateFunction af (expToSql e)) . getGroupMapping+groupMapToSql = fmap (\(af, someExp) -> AggregateFunction af (someDbExpToSqlExp someExp)) . getGroupMapping   grouppingToSql ::@@ -74,7 +87,7 @@     , TableSetVars 'Basic.Grouping tables )     => (Variables 'Basic.Grouping tables -> group) -> [SqlValueExp] grouppingToSql f =-    fmap (\(SomeDbExp e) -> expToSql e) (getGrouping (f (makeVars @'Basic.Grouping @tables)))+    fmap someDbExpToSqlExp (getGrouping (f (makeVars @'Basic.Grouping @tables)))  groupStatementToSql :: forall tables group. GroupStatement group tables -> SqlExp groupStatementToSql (GroupOn f t) =@@ -87,7 +100,7 @@     , TableSetVars 'Folding tables )     => (Variables 'Folding tables -> aggr) -> [SqlValueExp] foldingToSql f =-    fmap (\(af, SomeDbExp e) -> AggregateFunction af (expToSql e))+    fmap (\(af, someExp) -> AggregateFunction af (someDbExpToSqlExp someExp))          (getAggregating (f (makeVars @'Folding @tables)))  @@ -107,9 +120,10 @@     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 (Execute q pars) = RawQuery q (toRow pars) compileToSql (Basic.Insert (a :: Entity entKind table)) =     Sql.Insert (nameText @(TableName table))-               (mapTypeList (Proxy @KnownSymbol) (toS . symbolVal)+               (mapTypeList (Proxy @(HasCapsFieldName table)) (capsFieldName @table)                             (Proxy @(SetFields (MissingFields entKind) table)))                (mapFields @(TypeSatisfies ToField) @table @(SetFields (MissingFields entKind) table) (const toField) a) compileToSql (Basic.Delete (t :: DbStatement f '[table])) =

@@ -16,11 +16,14 @@                               (Var anyCtx t) (Var anyCtx t)                               (DbExp 'FieldExp (TableFieldType t name))                               (DbExp 'FieldExp (TableFieldType t name))-fieldOpticVarExp p = to (Field p)+fieldOpticVarExp p = to (Field (Proxy @t) p) +type GettableField entKind field =+    FieldIsGettable field (MissingFields entKind)+ fieldOpticEntityGet :: forall name t entKind proxy.                      ( TableField t name-                     , FieldIsGettable name (MissingFields entKind) )+                     , GettableField entKind name )                     => proxy name                     -> PolyOptic (Const (TableFieldType t name))                                  (Entity entKind t) (Entity entKind t)@@ -29,32 +32,43 @@ 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+class SupportedModifyAccess isSet outVal where+    type ExistingValue isSet outVal :: *+    transformModifyFunction :: (ExistingValue isSet outVal -> f outVal) -> outVal -> f outVal+instance SupportedModifyAccess 'True outVal where+    type ExistingValue 'True outVal = outVal     transformModifyFunction = identity-instance SupportedModifyAccess 'False () outVal where+instance SupportedModifyAccess 'False outVal where+    type ExistingValue 'False outVal = ()     transformModifyFunction f _ = f () +-- | A field that's settable, but also potentially gettable (if it's already set).+--   If it is gettable then you can modify it, otherwise you can just set it.+type ModifyableField table entKind field =+    SupportedModifyAccess+        (FieldIsGettableBool field (MissingFields entKind))+        (TableFieldType table field)++-- | A synonym for ModifyableField. It still checks if the field is already set.+type SettableField table entKind field = ModifyableField table entKind field+ fieldOpticEntityModify ::-       forall name t entKind existingValue proxy.+       forall name t entKind proxy.      ( TableField t name-     , SupportedModifyAccess (FieldIsGettableBool name (MissingFields entKind))-                             existingValue-                             (TableFieldType t name) )+     , ModifyableField t entKind name )     => proxy name     -> PolyOptic Identity                  (Entity entKind t) (Entity (WithFieldSet name entKind) t)-                 existingValue+                 (ExistingValue (FieldIsGettableBool name (MissingFields entKind)) (TableFieldType t name))                  (TableFieldType t name) fieldOpticEntityModify _ = getEntity . transLens-    where transLens f e =+    where transLens f =               tableFieldLens @_ @name                              (transformModifyFunction @(FieldIsGettableBool name                                                                             (MissingFields entKind))                                                       f)-                             e +{-# ANN fieldOpticUpdateVarSet ("HLint: ignore Redundant lambda" :: Text) #-} fieldOpticUpdateVarSet :: forall name t val proxy.                         ( ValueAsDbExp val (TableFieldType t name)                         , TableField t name )@@ -64,8 +78,9 @@                                     (DbExp 'FieldExp (TableFieldType t name))                                     val fieldOpticUpdateVarSet p =-    \f v -> SetField p (NoUpdate v) . valueAsDbExp <$> f (Field p v)+    \f v -> SetField p (NoUpdate v) . valueAsDbExp <$> f (Field (Proxy @t) p v) +{-# ANN fieldOpticUpdatedSet ("HLint: ignore Redundant lambda" :: Text) #-} fieldOpticUpdatedSet :: forall name t fields val proxy.                       ( TableField t name                       , FieldIsNotSet name fields@@ -76,7 +91,7 @@                                   (DbExp 'FieldExp (TableFieldType t name))                                   val fieldOpticUpdatedSet p =-    \f v -> SetField p v . valueAsDbExp <$> f (Field p (varFromUpdateExp v))+    \f v -> SetField p v . valueAsDbExp <$> f (Field (Proxy @t) p (varFromUpdateExp v))  overload "fieldOpticProxy" [ 'fieldOpticVarExp                            , 'fieldOpticEntityGet

@@ -7,7 +7,7 @@ import Data.String (IsString(..)) import Database.PostgreSQL.Simple hiding (In, Only) import Database.PostgreSQL.Simple.Types (Query(..))-import Database.PostgreSQL.Simple.ToField (Action)+import Database.PostgreSQL.Simple.ToField (Action(Escape))  data QuerySegment = QuerySegment Query [Action]     deriving (Show)@@ -32,18 +32,23 @@ newtype SqlFunctionName = SqlFunctionName Text deriving (Eq, Ord, Read, Show)  data QualifiedField = QualifiedField Int Text deriving (Eq, Ord, Read, Show)+newtype TableValue = TableValue Int 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+               | IsNotNull SqlValueExp                | In SqlValueExp [SqlValueExp]+               | BoolLit Bool+               | Like Bool SqlValueExp Text                deriving (Show) -data AggregateFunction = Avg | Max | Min | Count | Sum | Only deriving (Show)+data AggregateFunction = Avg | Max | Min | Count | Sum | Only | ArrayAgg deriving (Show)  data SqlValueExp = SimpleName QualifiedField+                 | TableRecord TableValue                  | SqlFunctionApplication SqlFunctionName SqlValueExp                  | SqlLiteral Action                  | AggregateFunction AggregateFunction SqlValueExp@@ -76,7 +81,7 @@ actionToQuery a = QuerySegment "? " [a]  tableToQuery :: QualifiedTable -> QuerySegment-tableToQuery (QualifiedTable name index) = sToQuery name <> " as t" <> show index <> " "+tableToQuery (QualifiedTable name index) = "\"" <> sToQuery name <> "\" as t" <> show index <> " "  comparisonToQuery :: Comparison -> QuerySegment comparisonToQuery Equal          = "= "@@ -87,8 +92,11 @@ comparisonToQuery GreaterOrEqual = ">= "  fieldToQuery :: QualifiedField -> QuerySegment-fieldToQuery (QualifiedField index name) = "t" <> show index <> "." <> sToQuery name <> " "+fieldToQuery (QualifiedField index name) = "t" <> show index <> ".\"" <> sToQuery name <> "\" " +tableValueToQuery :: TableValue -> QuerySegment+tableValueToQuery (TableValue index) = "t" <> show index <> " "+ aggregateFunctionToQuery :: AggregateFunction -> QuerySegment aggregateFunctionToQuery Avg = "avg " aggregateFunctionToQuery Min = "min "@@ -96,9 +104,11 @@ aggregateFunctionToQuery Sum = "sum " aggregateFunctionToQuery Count = "count " aggregateFunctionToQuery Only = ""+aggregateFunctionToQuery ArrayAgg = "array_agg "  valueToQuery :: SqlValueExp -> QuerySegment valueToQuery (SimpleName field) = fieldToQuery field+valueToQuery (TableRecord tv) = tableValueToQuery tv valueToQuery (SqlFunctionApplication (SqlFunctionName name) val) =     sToQuery name <> "( " <> valueToQuery val <> " ) " valueToQuery (SqlLiteral l) = actionToQuery l@@ -106,16 +116,25 @@     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 (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 (IsNotNull v) = "( " <> valueToQuery v <> ") IS NOT NULL " conditionToQuery (In a b)-  | null b = "1!=1" -- SELECT * FROM bla where field in () is invalid+  | 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)) <> " )"+conditionToQuery (BoolLit b) = if b then "true " else "false "+conditionToQuery (Like False e v) = valueToQuery e <> "like ?" <> QuerySegment "" [Escape (toS v)]+conditionToQuery (Like True e v) = valueToQuery e <> "ilike ?" <> QuerySegment "" [Escape (toS v)]  orderingToQuery :: (SqlValueExp, SortDirection) -> QuerySegment orderingToQuery (e, Ascending) = valueToQuery e <> "asc "@@ -141,30 +160,30 @@  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+       "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+sqlExpToQuery (Insert table fields values) =+      "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 $+sqlExpToQuery (RawQuery q as) = QuerySegment (Query (toS q)) as+sqlExpToQuery (Delete table cond) =        "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 $+sqlExpToQuery (Update fields values cond table) =        "update " <> tableToQuery table     <> " set " <> listToTuple (fmap sToQuery fields) <> " = "                <> listToTuple (fmap valueToQuery values)

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Internal.Data.Basic.SqlToHsTypes where  import Internal.Interlude@@ -8,9 +9,10 @@ import qualified Data.ByteString.Char8 as B import Database.PostgreSQL.Simple.ToField import Data.Binary.Builder+import GHC.Generics  data Point = Point {-# UNPACK #-} !Double {-# UNPACK #-} !Double-    deriving (Eq, Ord, Read, Show)+    deriving (Eq, Read, Show, Generic, ToJSON, FromJSON)  instance FromField Point where   fromField f mdata =

@@ -20,11 +20,12 @@ import           Internal.Interlude            hiding (Type) import           Language.Haskell.TH           hiding (Name) import qualified Language.Haskell.TH.Syntax    as TH+import           System.FilePath.Lens  import           Control.Effects.Signal import           Internal.Data.Basic.TH.Types import           Internal.Data.Basic.TH.Compiler-+import           Internal.Data.Basic.TH.Generator (schemaValue)  -- | Generates haskell code from an SQL file. mkFromFile :: FilePath -> Q [Dec]@@ -34,11 +35,15 @@   case eStatements of     Left (ParseError e) -> runIO.fail $ toS e     Right statements -> do-      r <- (runIO $ handleToEither @ParseError $ compileSQLStatements mempty statements)+      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+        Right context -> do+          ctx <- compileContext context+          schemaTxt <- runIO $ readFile filename+          return (ctx <> schemaValue (toS $ filename ^. basename) schemaTxt) + -- MonadIO Identity -- | Generates haskell code from multiple SQL files. mkFromFiles :: [FilePath] -> Q [Dec]@@ -70,4 +75,3 @@           let out = concatMap (<> "\n\n") $ pprint <$> r           runIO $ writeFile filenameOut $ toS out           return []-

@@ -60,7 +60,7 @@   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)+  where entityName = mkName (toS $ normalizeTable $ toS $ getName name)         n = toS $ getName name         entityInfo = EntityInfo n entityName name (ConT entityName) constraints mempty compileSQLStatement ctx (SQL.AlterTable _ tableName (SQL.AlterTableActions _ l)) =@@ -95,10 +95,11 @@ 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+  let g = ColumnInfo name normName (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+  where name = toS $ SQL.ncStr nameC+        normName = normalizeName name  -- | Adds sql row constraints to compile context compileRowConstraint :: Throws ParseError m => ParseContext -> EntityInfo -> ColumnInfo -> SQL.RowConstraint -> m (ParseContext, ColumnInfo)

@@ -9,7 +9,6 @@ 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@@ -30,7 +29,8 @@ -- >                  , _ostUserId :: Key } deriving (Show, Read, Generic) -- dataConstructor :: EntityInfo -> TH.Dec-dataConstructor info = DataD [] entityName [] Nothing [RecC entityName fields] [ConT ''Show, ConT ''Read, ConT ''Generic]+dataConstructor info = DataD [] entityName [] Nothing [RecC entityName fields]+    [DerivClause Nothing [ConT ''Show, ConT ''Read, ConT ''Generic]]   where entityName = _entityInfoName info         fields = (\c -> (c ^. columnInfoName, Bang SourceUnpack SourceStrict, finalType c)) <$> (info ^. entityInfoColumnMap) @@ -57,7 +57,7 @@ -- | Generates field optics for all entities fieldOptics :: [EntityInfo] -> [TH.Dec] fieldOptics em = concat $ fieldOptic <$> columnNames-  where columnNames = nub $ _columnInfoText <$> concat (_entityInfoColumnMap <$> em)+  where columnNames = nub $ _columnInfoNormalName <$> concat (_entityInfoColumnMap <$> em)  -- | Generates field optics for a column --@@ -84,10 +84,11 @@                                                (AppT (ConT ''Proxy)                                                      (LitT (StrTyLit $ toS t)))))) []                        ]-  where fieldName = mkName $ toS $ camelize t-        o = mkName "o"+  where o = mkName "o"+        fieldName = mkName $ toS t  + -- | 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]@@ -105,18 +106,22 @@ -- 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) []]+                                AppT (ConT ''BT.TableField `AppT` ConT entityName)+                                     (LitT $ StrTyLit $ toS normalName)+                                )+                                [ TySynInstD ''BT.TableFieldType $ TySynEqn+                                    [ConT entityName, LitT $ StrTyLit $ toS normalName]+                                    columnType+                                , TySynInstD ''BT.TableFieldCapsName $ TySynEqn+                                    [ConT entityName, LitT $ StrTyLit $ toS normalName]+                                    (PromotedT 'Just `AppT` LitT (StrTyLit (toS columnText)))+                                , 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)+        normalName = ci ^. columnInfoNormalName+        lensName = mkName $ toS ((lowerFirst.normalizeTable $ ei ^. entityInfoText) <> "_" <> columnText)  -- | Generates required table field instances for all entities tableFields :: [EntityInfo] -> [TH.Dec]@@ -143,7 +148,7 @@                    (NormalB (AppE (VarE 'B.allRowsProxy)                                   (SigE (ConE 'Proxy) (ConT ''Proxy `AppT` tableType))))                    []] ]-    where sTableName = standardizeName (toS tableName)+    where sTableName = normalizeTable (toS tableName)           res = mkName "res"           accessor = mkName $ toS $ "all" <> quasyPlural sTableName           tableName = ei ^. entityInfoText@@ -225,7 +230,7 @@   where keyName = toS $ uq ^. uqName         ei = uq ^. uqEntity         entityName = ei ^. entityInfoName-        cols = (LitT . StrTyLit . toS) <$> (_columnInfoText <$> (uq ^. uqCols))+        cols = (LitT . StrTyLit . toS) <$> (_columnInfoNormalName <$> (uq ^. uqCols))  -- | Generates primary key instance --@@ -246,9 +251,9 @@ 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.ForeignKeyFromFields $ TySynEqn [constraint] (listToTypeLevel (LitT . StrTyLit . toS . _columnInfoNormalName <$> fromCol)),         TySynInstD ''BT.ForeignKeyTo $ TySynEqn [constraint] (toTableT ^. entityInfoType),-        TySynInstD ''BT.ForeignKeyToFields $ TySynEqn [constraint] (listToTypeLevel (LitT . StrTyLit . toS . _columnInfoText <$> toCol))+        TySynInstD ''BT.ForeignKeyToFields $ TySynEqn [constraint] (listToTypeLevel (LitT . StrTyLit . toS . _columnInfoNormalName <$> toCol))         ]   where constraint = LitT $ StrTyLit $ toS name @@ -273,7 +278,7 @@       ValD (VarP 'BT.newEntity) (coerceBody ei) []       ]   ]-  where fieldNames = view columnInfoText <$> columns+  where fieldNames = view columnInfoNormalName <$> columns         columns = ei ^. entityInfoColumnMap         constraints = ei ^. entityInfoConstraintList         entityType = ei ^. entityInfoType@@ -283,10 +288,10 @@         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+        optionalCols = getDynamicDefaultColumns ctx ei -- | Generates a empty entity ----- > newPost = Entity ('Fresh ['DynamicDefault "id", 'Required "name", 'Required "author"])+-- > newPost :: Entity ('Fresh ['DynamicDefault "id", 'Required "name", 'Required "author"]) -- > newPost = Entity (Post 1 "" 1) -- emptyEntity :: ParseContext -> EntityInfo -> [Dec]@@ -295,21 +300,21 @@                          (PromotedT 'BT.Fresh `AppT` listToTypeLevel reqs))                    (ei ^. entityInfoType)),     ValD (VarP fname) (coerceBody ei) []]-  where fname = mkName $ toS $ "new" <> standardizeName name+  where fname = mkName $ toS $ "new" <> normalizeTable name         name = ei ^. entityInfoText         requiredFields = ei ^. entityInfoColumnMap \\  optionalCols         reqs = required requiredFields <> dynamicDefault optionalCols-        optionalCols = getOptionalColumns ctx ei+        optionalCols = getDynamicDefaultColumns 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)+  where f ci = ConT 'BT.Required `AppT` (LitT $ StrTyLit $ toS $ ci ^. columnInfoNormalName)  -- | 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)+  where f ci = ConT 'BT.DynamicDefault `AppT` (LitT $ StrTyLit $ toS $ ci ^. columnInfoNormalName)  -- | Modifies column type depending on column constraints applyConstraint :: ColumnInfo -> ColumnConstraint -> TH.Type -> TH.Type@@ -325,3 +330,15 @@ nullValue' :: Int -> TH.Exp -> TH.Exp nullValue' 0 initial = initial nullValue' n initial = AppE (nullValue' (n - 1) initial) (VarE 'nullValue)++-- | Generated the value representing the schema that can be applied to the database+--++-- > initialSchema :: Schema+-- > initialSchema = Schema "CREATE...+schemaValue :: Text -> Text -> [Dec]+schemaValue name text =+    [ SigD sname (ConT ''Schema)+    , ValD (VarP sname) (NormalB (ConE 'Schema `AppE` LitE (StringL (toS text)))) [] ]+    where+    sname = mkName (toS name <> "Schema")

@@ -18,7 +18,10 @@ import Control.Effects.Signal import Language.Haskell.TH.Syntax as TH import qualified Database.HsSqlPpp.Syntax as SQL+import Data.Void +type Throws e = MonadEffect (Signal e Void)+ 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@@ -39,11 +42,6 @@ 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@@ -76,13 +74,13 @@ 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+getDynamicDefaultColumns :: ParseContext -> EntityInfo -> [ColumnInfo]+getDynamicDefaultColumns 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+        isOptional ci = elem DefaultConstraint (ci ^. columnInfoConstraints) ||+            not (isPrimaryKey ci) && not (isUnique ci) && notElem NotNullConstraint (ci ^. columnInfoConstraints)  -- | 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@@ -110,6 +108,30 @@ upperFirst t = fromMaybe t (f <$> T.uncons t)     where f (a, b) = T.cons (toUpper a) b +-- | Converts camel case or snake case to normal form. Examples:+--+-- > normalizeName "ABCDE"+-- "abcde"+-- > normalizeName "ABC_DE"+-- "abcDe"+-- > normalizeName "AbcDe"+-- "abcDe"+-- > normalizeName "abcDe"+-- "abcDe"+-- > normalizeName "abcde"+-- "abcde"+normalizeName :: Text -> Text+normalizeName =+      lowerFirst+    . camelize+    . mconcat+    . fmap (\g -> if isUpper (T.head g) then upperFirst (T.map toLower g) else g)+    . T.groupBy (\c1 c2 -> isUpper c1 && isUpper c2)++-- Our convention for "standarnized names"+-- @TODO What if users have their own naming scheme?+normalizeTable :: Text -> Text+normalizeTable = upperFirst . normalizeName  -- | Retrieves the primary key for an entity from 'ParseContext' getEntityPrimaryKey :: ParseContext -> EntityInfo -> Maybe PrimaryKeyConstraint

@@ -15,9 +15,11 @@  import qualified Data.Text                     as T import           Data.Time.LocalTime           (LocalTime, TimeOfDay)+import           Data.Time                     (Day) import           Internal.Interlude            hiding (Type) import           Language.Haskell.TH           hiding (Name) import qualified Database.HsSqlPpp.Syntax      as SQL+import           Data.Scientific  import           Control.Effects.Signal import           Internal.Data.Basic.TH.Helper@@ -34,6 +36,10 @@   t <- columnTypeToHs n   return (t, applyColumnConstraints n)   where n = getName name+toHsType (SQL.Prec2TypeName _ 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.@@ -41,7 +47,7 @@ --   "serial" type needs to have 'NotNullConstraint' applyColumnConstraints :: Text -> [ColumnConstraint] applyColumnConstraints fname-  | fname == "serial" = [NotNullConstraint]+  | fname == "serial" = [NotNullConstraint, DefaultConstraint]   | otherwise = []  -- | Actual conversions. The following Postgres types are currently supported:@@ -59,6 +65,8 @@ -- > character varying -- > text -- > bytea+-- > date+-- > numeric columnTypeToHs :: Throws ParseError m => Text -> m Type columnTypeToHs fname   | fname `elem` ["serial", "bigint", "integer", "int", "int4"] = use ''Int@@ -67,6 +75,9 @@   | 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+  | fname `elem` ["character varying", "text"] = use ''Text+  | fname == "numeric" = use ''Scientific+  | fname == "date" = use ''Day+  | fname == "bytea" = use ''ByteString   | otherwise = throwSignal $ ParseError $ "Compile error: cannot deduct Haskell type " `T.append` toS fname   where use x = return $ ConT x

@@ -21,6 +21,7 @@ import qualified Database.HsSqlPpp.Syntax           as SQL  import           Data.Time+import           Data.Scientific  -- | When something goes wrong, this explains what went wrong - hopefully... data ParseError = ParseError Text deriving (Show)@@ -34,10 +35,11 @@  -- | 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)+data ColumnConstraint = NullConstraint | NotNullConstraint | DefaultConstraint deriving (Show, Eq)  -- | Column information gathered from a parser data ColumnInfo = ColumnInfo { _columnInfoText        :: !Text,    -- ^ name retrieved from the parser+                               _columnInfoNormalName  :: !Text,    -- ^ normalized name of the field                                _columnInfoName        :: !TH.Name, -- ^ generate TH name                                _columnInfoType        :: !TH.Type, -- ^ generated TH type                                _columnInfoSqlType     :: !SQL.TypeName, -- ^ original sql type@@ -109,9 +111,14 @@  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 TimeOfDay where nullValue = TimeOfDay 0 0 0 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 Scientific where nullValue = 0+instance NullValue Day where nullValue = ModifiedJulianDay 0+instance NullValue ByteString where nullValue = "" instance NullValue (Maybe a) where nullValue = Nothing++newtype Schema = Schema Text

@@ -3,9 +3,9 @@ {-# LANGUAGE UndecidableInstances, UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} module Internal.Data.Basic.TypeLevel-    ( AllSatisfy, MappableList(..), Elem, EqualOrError, CheckWithError+    ( AllSatisfy(..), Elem, EqualOrError, CheckWithError     , Not, ErrorText, type (++), Without, IsSubset, TypeSatisfies-    , OnMaybe, NotNull, ListToTuple+    , OnMaybe, NotNull, ListToTuple, Trivial, SetEqual     , GHC.ErrorMessage(ShowType, (:<>:), (:$$:))     , GHC.TypeError     )  where@@ -15,17 +15,13 @@ 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]+class AllSatisfy c (l :: [k]) where+    mapTypeList :: proxy1 c -> (forall proxy2 (x :: k). c x => proxy2 x -> a) -> proxy3 l -> [a] -instance MappableList '[] where+instance AllSatisfy c '[] where     mapTypeList _ _ _ = [] -instance MappableList ks => MappableList (k ': ks) where+instance (c k, AllSatisfy c ks) => AllSatisfy c (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@@ -51,15 +47,15 @@  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)+    Without (x ': xs) ys = Without' (x `Elem` ys) x xs ys +type family Without' el x xs ys where+    Without' 'True x xs ys = Without xs ys+    Without' 'False x xs ys = x ': Without xs ys+ type family NotMaybe (a :: *) :: Bool where     NotMaybe (Maybe a) = 'False     NotMaybe a = 'True@@ -90,3 +86,10 @@ type family xs ++ ys where     '[] ++ ys = ys     (x ': xs) ++ ys = x ': (xs ++ ys)++class Trivial a+instance Trivial a++type family SetEqual (as :: [k]) (bs :: [k]) :: Constraint where+    SetEqual (a ': as) bs = (IsTrue (Elem a bs), SetEqual as (bs `Without` '[a]))+    SetEqual '[] '[] = ()

@@ -11,11 +11,12 @@     , Max(..), Min(..), Sum(..) ) where  import Internal.Interlude hiding (TypeError)+import Prelude (Show(..)) import Data.String (fromString)  import Control.Lens (Lens') import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)-import Database.PostgreSQL.Simple.FromField (FromField)+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)@@ -29,6 +30,7 @@ import Internal.Data.Basic.TypeLevel import Internal.Data.Basic.Sql.Types (Comparison(..), SortDirection(..)) import qualified Internal.Data.Basic.Sql.Types as Sql+import Internal.Composite  data VarContext = Filtering | Updating | Sorting | Grouping | Folding | Mapping newtype Var (ctx :: VarContext) (a :: *) = Var Int deriving (Eq, Ord, Read, Show)@@ -42,12 +44,17 @@ 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+toFreshEntity = coerce +reorderMissingFieldsTo ::+    forall fs2 fs1 a. SetEqual fs1 fs2+    => Entity ('Fresh fs1) a -> Entity ('Fresh fs2) a+reorderMissingFieldsTo = coerce+ instance FromRow a => FromRow (Entity l a) where     fromRow = Entity <$> fromRow @@ -60,6 +67,15 @@ type SetFields (missing :: [MissingField]) (table :: *) =     TableFields table `Without` MissingFieldsNames missing +type family TableFieldTypes (a :: *) (fs :: [Symbol]) :: [*] where+    TableFieldTypes a '[] = '[]+    TableFieldTypes a (f ': fs) = TableFieldType a f ': TableFieldTypes a fs++class (KnownSymbol (CapsName t s)) => HasCapsFieldName t (s :: Symbol) where+    capsFieldName :: proxy s -> Text+instance (KnownSymbol (CapsName t s)) => HasCapsFieldName t (s :: Symbol) where+    capsFieldName _ = toS $ symbolVal (Proxy @(CapsName t s))+ class (AllSatisfy (TableField table) fields)     => AllTypesSatisfy (c :: * -> Symbol -> Constraint) (table :: *) (fields :: [Symbol]) where     mapFields :: (fields `IsSubset` SetFields (MissingFields entKind) table)@@ -90,30 +106,89 @@     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+instance ToJSON (Entity entKind a) => Show (Entity entKind a) where+    show = toS . encode++class GetEntityFromValue (fs :: [Symbol]) a where+    type MissingFieldsFromValue fs a :: [MissingField]+    getEntityFromObject :: Value -> Parser (Entity ('Fresh (MissingFieldsFromValue fs a)) a)+instance Table a => GetEntityFromValue '[] a where+    type MissingFieldsFromValue '[] a = TableRequiredFields a     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+    ( GetEntityFromValue fs a     , FromJSON (TableFieldType a f)     , TableField a f )-    => GetEntityFromValue (f ': fs) a miss' where+    => GetEntityFromValue (f ': fs) a where+    type MissingFieldsFromValue (f ': fs) a = WithoutMissingField f (MissingFieldsFromValue fs a)     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))+            ent <- getEntityFromObject @fs @a o+            return (ent & getEntity . tableFieldLens @a @f .~ parsedField)       where         k = toS (symbolVal (Proxy :: Proxy f)) instance-    GetEntityFromValue (SetFields miss a) a miss+    ( GetEntityFromValue (SetFields miss a) a+    , SetEqual (MissingFieldsFromValue (SetFields miss a) a) miss )     => FromJSON (Entity ('Fresh miss) a) where-    parseJSON = getEntityFromObject @(SetFields miss a) @a+    parseJSON = fmap (reorderMissingFieldsTo @miss) . getEntityFromObject @(SetFields miss a) @a +class (TableField table field, Ord (TableFieldType table field)) => OrdableField table field+instance (TableField table field, Ord (TableFieldType table field)) => OrdableField table field+class (TableField table field, Eq (TableFieldType table field)) => EqableField table field+instance (TableField table field, Eq (TableFieldType table field)) => EqableField table field++instance+    ( AllSatisfy (OrdableField a) (SetFields (MissingFields entKind) a)+    , Eq (Entity entKind a) )+    => Ord (Entity entKind a) where+    compare a b = mconcat $ mapTypeList (Proxy @(OrdableField a))+        (\(_ :: proxy f) -> compare (a ^. getEntity . tableFieldLens @a @f) (b ^. getEntity . tableFieldLens @a @f))+        (Proxy @(SetFields (MissingFields entKind) a))++instance+    ( AllSatisfy (EqableField a) (SetFields (MissingFields entKind) a) )+    => Eq (Entity entKind a) where+    (==) a b = and $ mapTypeList (Proxy @(EqableField a))+        (\(_ :: proxy f) -> (a ^. getEntity . tableFieldLens @a @f) == (b ^. getEntity . tableFieldLens @a @f))+        (Proxy @(SetFields (MissingFields entKind) a))++class TableFieldTypes a fs ~ ts => FoldCompositeIntoEntity fs ts a where+    foldCompositeIntoEntity :: +        Entity entKind a -> Composite ts -> Entity ('Fresh '[]) a+instance FoldCompositeIntoEntity '[] '[] a where+    foldCompositeIntoEntity e _ = coerce e+instance +    ( TableField a f+    , TableFieldType a f ~ t+    , FoldCompositeIntoEntity fs ts a)+    => FoldCompositeIntoEntity (f ': fs) (t ': ts) a where+    foldCompositeIntoEntity ent (ConsComposite x xs) = +        foldCompositeIntoEntity @fs @ts+            (ent & getEntity . tableFieldLens @a @f .~ x)+            xs++compositeToEntity :: +    forall a fs ts.+    ( fs ~ TableFields a+    , ts ~ TableFieldTypes a fs+    , FoldCompositeIntoEntity fs ts a+    , Table a )+    => Composite ts -> Entity ('Fresh '[]) a+compositeToEntity = foldCompositeIntoEntity @(TableFields a) newEntity++instance+    ( fs ~ TableFields a+    , ts ~ TableFieldTypes a fs+    , FoldCompositeIntoEntity fs ts a+    , FieldParsers ts+    , Table a )+    => FromField (Entity ('FromDb 'Live) a) where+    fromField f b = coerce @(Entity ('Fresh '[]) a) . compositeToEntity <$> fromField f b+ type family SameTypes toTable   (toFields :: [Symbol])                       fromTable (fromFields :: [Symbol]) :: Constraint where     SameTypes toTable '[] fromTable '[] = ()@@ -140,7 +215,7 @@ instance (ForeignKeyConstraint name, table ~ ForeignKeyFrom name)     => ValidConstraint table ('ForeignKey name) -getDbFields :: forall table. (MappableList (TableFields table), Table table) => [Text]+getDbFields :: forall table. Table table => [Text] getDbFields = mapTypeList (Proxy @KnownSymbol) (toS . symbolVal) (Proxy @(TableFields table))  type family IsDbExp a :: Bool where@@ -169,9 +244,19 @@ instance (a ~ b, ToField a, KindOfDbExp a ~ 'LiteralExp) => ValueAsDbExp' 'False a b where     valueAsDbExp' = Literal -class (KnownSymbol name, IsDbExp (TableFieldType table name) ~ 'False)+type family CapsName table name where+    CapsName table name = CapsName' name (TableFieldCapsName table name)+type family CapsName' name capsName where+    CapsName' name 'Nothing = name+    CapsName' name ('Just cName) = cName++class+    ( KnownSymbol name, KnownSymbol (CapsName table name)+    , IsDbExp (TableFieldType table name) ~ 'False )     => TableField (table :: *) (name :: Symbol) where     type TableFieldType table name :: *+    type TableFieldCapsName table name :: Maybe Symbol+    type TableFieldCapsName table name = 'Nothing     tableFieldLens :: Lens' table (TableFieldType table name)  class ( UniqueConstraint name@@ -229,7 +314,7 @@ 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)+    , AllSatisfy (HasCapsFieldName table) (SetFields missing table)     , AllTypesSatisfy (TypeSatisfies ToField) table (SetFields missing table) ) type family CanInsertMissing (fs :: [MissingField]) :: Constraint where     CanInsertMissing '[] = ()@@ -242,7 +327,6 @@     ( 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@@ -262,14 +346,15 @@ data BoolOp = And | Or deriving (Eq, Ord, Read, Show)  data ResultType = Filtered | Unfiltered | Inserted | Deleted | Updated | Sorted | Limited | Grouped-                | Mapped | Folded+                | Mapped | Folded | RawQueried 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 CanTake (t :: ResultType) :: Constraint where+    CanTake 'Filtered = ()+    CanTake 'Unfiltered = ()+    CanTake 'Sorted = ()+    CanTake 'Mapped = () type family CanAggregate (t :: ResultType) :: Constraint where     CanAggregate 'Filtered = ()     CanAggregate 'Unfiltered = ()@@ -278,6 +363,7 @@     CanMap 'Unfiltered = ()     CanMap 'Filtered = ()     CanMap 'Grouped = ()+    CanMap 'Sorted = ()   type FieldIsGettableBool field missing = Not (field `Elem` MissingFieldsNames missing)@@ -313,8 +399,8 @@     TupleToList a = '[a] type FlattenTuple t = ListToSimpleTuple (TupleToList t) -instance k ~ 'LiteralExp => Num (DbExp k Key) where-    fromInteger = Literal . Key . fromInteger+instance (k ~ 'LiteralExp, Num a, ToField a) => Num (DbExp k a) where+    fromInteger = Literal . fromInteger  instance k ~ 'LiteralExp => IsString (DbExp k Text) where     fromString = Literal . toS@@ -329,8 +415,10 @@     Join     :: DbStatement 'Unfiltered tables1 -> DbStatement 'Unfiltered tables2              -> DbStatement 'Unfiltered (tables1 ++ tables2) -    Raw      :: ToRow r => Text -> r -> DbStatement f a+    Raw      :: ToRow r => Text -> r -> DbStatement 'RawQueried a +    Execute  :: ToRow r => Text -> r -> DbStatement 'RawQueried '[]+     Insert   :: CanInsert missing table              => Entity missing table -> DbStatement 'Inserted '[table] @@ -345,7 +433,7 @@              => (Variables 'Sorting tables -> ord) -> DbStatement f tables              -> DbStatement 'Sorted tables -    Take     :: SelectionOrSortedSelection f+    Take     :: CanTake f              => Int -> DbStatement f tables -> DbStatement 'Limited tables      Map     :: (Mappable map, CanMap f, TableSetVars 'Mapping tables)@@ -388,16 +476,26 @@      IsNull   :: DbExp 'FieldExp (Maybe a) -> ConditionExp +    IsNotNull :: DbExp 'FieldExp (Maybe a) -> ConditionExp+     In       :: LiteralCollection collection a => DbExp k a -> collection -> ConditionExp +    Like     :: Bool -> DbExp 'FieldExp Text -> Text -> ConditionExp++    BoolLit  :: Bool -> 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)+             => proxy1 table -> proxy2 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)+data SomeDbExp where+    SomeDbExp :: DbExp k a -> SomeDbExp+    SomeVar :: Var k a -> SomeDbExp+ class Sortable ord where     getOrdering :: ord -> [(SomeDbExp, SortDirection)] @@ -415,7 +513,7 @@  class LiteralCollection collection a | collection -> a where     getLiteralCollection :: collection -> [SomeDbExp]-instance a ~ b => LiteralCollection (DbExp k a) a where+instance a ~ b => LiteralCollection (DbExp k a) b where     getLiteralCollection e = [SomeDbExp e] instance (LiteralCollection a x, LiteralCollection b x) => LiteralCollection (a, b) x where     getLiteralCollection (a, b) = getLiteralCollection a <> getLiteralCollection b@@ -437,6 +535,11 @@     type AsAggregate (DbExp k a) = GroupMappableThing a 'AM     getGrouping e = [SomeDbExp e]     asAggregate = GroupMappableDbExp+instance (Table a, TablePrimaryKey a ~ 'Just pk, AllSatisfy (TableField a) (UniqueFields pk)) +    => Groupable (Var 'Grouping a) where+    type AsAggregate (Var 'Grouping a) = GroupMappableThing (Entity ('FromDb 'Live) a) 'AM+    getGrouping v = mapTypeList (Proxy @(TableField a)) (\(_ :: proxy f) -> SomeDbExp (Field (Proxy @a) (Proxy @f) v)) (Proxy @(UniqueFields pk))+    asAggregate = GroupMappableVar instance (Groupable a, Groupable b) => Groupable (a, b) where     type AsAggregate (a, b) = (AsAggregate a, AsAggregate b)     getGrouping (a, b) = getGrouping a <> getGrouping b@@ -452,6 +555,7 @@  data GroupMappableThing res (am :: AM) where     GroupMappableDbExp :: DbExp k a -> GroupMappableThing a 'AM+    GroupMappableVar :: Var k a -> GroupMappableThing (Entity ('FromDb 'Live) a) 'AM     GroupMappableAggr  :: Aggregatable aggr => AggregateStatement aggr 'AM -> GroupMappableThing (AggregationResult aggr) 'AM  type family GroupMapResultBase a where@@ -460,6 +564,7 @@     getGroupMappingBase :: map -> [(Sql.AggregateFunction, SomeDbExp)] instance GroupMappableThing res 'AM ~ a => GroupMappableBase a where     getGroupMappingBase (GroupMappableDbExp d) = [(Sql.Only, SomeDbExp d)]+    getGroupMappingBase (GroupMappableVar v) = [(Sql.Only, SomeVar v)]     getGroupMappingBase (GroupMappableAggr as) = getAggregating (getAggr as)  type family GroupMapResult (map :: *) :: * where@@ -498,15 +603,20 @@     type MapResultBase map :: *     getMappingBase :: map -> [SomeDbExp] instance MappableBase (DbExp k a) where-    type MapResultBase (DbExp k a) = a+    type MapResultBase (DbExp k a) = PSQL.Only a     getMappingBase d = [SomeDbExp d]+instance (Table t)+    => MappableBase (Var 'Mapping t) where+    type MapResultBase (Var 'Mapping t) = Entity ('FromDb 'Live) t+    getMappingBase v =+        mapTypeList (Proxy @(TableField t)) (\p -> SomeDbExp (Field (Proxy @t) p v)) (Proxy @(TableFields t))  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))+    MapResult a = MapResultBase a class Mappable map where     getMapping :: map -> [SomeDbExp] instance (MappableBase a, MappableBase b) => Mappable (a, b) where@@ -530,6 +640,7 @@ newtype Avg a = Avg a newtype Count a = Count a newtype Only a = Only a+newtype List a = List a class AggregatableBase aggr where     type AggregationBaseResult aggr :: *     getAggregatingBase :: aggr -> (Sql.AggregateFunction, SomeDbExp)@@ -551,6 +662,12 @@ instance AggregatableBase (Only (DbExp f a)) where     type AggregationBaseResult (Only (DbExp f a)) = a     getAggregatingBase (Only e) = (Sql.Only, SomeDbExp e)+instance AggregatableBase (List (DbExp f a)) where+    type AggregationBaseResult (List (DbExp f a)) = PSQL.PGArray a+    getAggregatingBase (List e) = (Sql.ArrayAgg, SomeDbExp e)+instance AggregatableBase (List (Var 'Folding a)) where+    type AggregationBaseResult (List (Var 'Folding a)) = PSQL.PGArray (Entity ('FromDb 'Live) a)+    getAggregatingBase (List v) = (Sql.ArrayAgg, SomeVar v)  type family BadAggregateBaseError where     BadAggregateBaseError =@@ -558,7 +675,8 @@             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."+                      \Avg, Count and List."+      ':$$: ErrorText "List can be applied to the whole entity, instead of just to it's fields."       ':$$: ErrorText "Example: dfoldMap (\\e -> (Max (e ^. height), Avg (e ^. weigth))) t") instance {-# OVERLAPPABLE #-} BadAggregateBaseError => AggregatableBase a where 

@@ -3,7 +3,6 @@ import Prelude hiding (id)  import Data.Time-import System.Mem import Database.PostgreSQL.Simple  import Data.Basic@@ -11,9 +10,9 @@ import Control.Lens import Control.Monad import Data.Function ((&))-+import Data.Aeson+import Data.String.Conv (toS) -import Control.Concurrent import Model  insertNewSession :: MonadIO m => Connection -> LocalTime -> m ()@@ -27,13 +26,11 @@  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+    conn <- connectPostgreSQL "host=localhost port=5432 user=postgres dbname=test password=admin connect_timeout=10"+    handleBasicPsql conn $ do+        executeQuery "drop schema if exists public cascade;" ()+        applySchema initialSchema+        us <- allUsers+        liftIO $ putStrLn (toS $ encode us)+        _ <- dmap (view upper) allCapstables+        void $ dmap (view upper) allLowers