diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data-basic.cabal b/data-basic.cabal new file mode 100644 --- /dev/null +++ b/data-basic.cabal @@ -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 diff --git a/src/Data/Basic.hs b/src/Data/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Basic.hs @@ -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 diff --git a/src/Data/Basic/Example.hs b/src/Data/Basic/Example.hs new file mode 100644 --- /dev/null +++ b/src/Data/Basic/Example.hs @@ -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 "" diff --git a/src/Internal/Control/Effects/Basic.hs b/src/Internal/Control/Effects/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Control/Effects/Basic.hs @@ -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 diff --git a/src/Internal/Data/Basic.hs b/src/Internal/Data/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic.hs @@ -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 diff --git a/src/Internal/Data/Basic/Common.hs b/src/Internal/Data/Basic/Common.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/Common.hs @@ -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) diff --git a/src/Internal/Data/Basic/Compare.hs b/src/Internal/Data/Basic/Compare.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/Compare.hs @@ -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 diff --git a/src/Internal/Data/Basic/Compiler.hs b/src/Internal/Data/Basic/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/Compiler.hs @@ -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))) diff --git a/src/Internal/Data/Basic/Foreign.hs b/src/Internal/Data/Basic/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/Foreign.hs @@ -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) diff --git a/src/Internal/Data/Basic/Lens.hs b/src/Internal/Data/Basic/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/Lens.hs @@ -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) diff --git a/src/Internal/Data/Basic/Replace.hs b/src/Internal/Data/Basic/Replace.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/Replace.hs @@ -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 diff --git a/src/Internal/Data/Basic/Sql/Types.hs b/src/Internal/Data/Basic/Sql/Types.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/Sql/Types.hs @@ -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) diff --git a/src/Internal/Data/Basic/SqlToHsTypes.hs b/src/Internal/Data/Basic/SqlToHsTypes.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/SqlToHsTypes.hs @@ -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 <> ")" diff --git a/src/Internal/Data/Basic/TH.hs b/src/Internal/Data/Basic/TH.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/TH.hs @@ -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 [] + diff --git a/src/Internal/Data/Basic/TH/Compiler.hs b/src/Internal/Data/Basic/TH/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/TH/Compiler.hs @@ -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 diff --git a/src/Internal/Data/Basic/TH/Generator.hs b/src/Internal/Data/Basic/TH/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/TH/Generator.hs @@ -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) diff --git a/src/Internal/Data/Basic/TH/Helper.hs b/src/Internal/Data/Basic/TH/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/TH/Helper.hs @@ -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 diff --git a/src/Internal/Data/Basic/TH/SqlToHsTypes.hs b/src/Internal/Data/Basic/TH/SqlToHsTypes.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/TH/SqlToHsTypes.hs @@ -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 diff --git a/src/Internal/Data/Basic/TH/Types.hs b/src/Internal/Data/Basic/TH/Types.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/TH/Types.hs @@ -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 diff --git a/src/Internal/Data/Basic/Tutorial.hs b/src/Internal/Data/Basic/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/Tutorial.hs @@ -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 diff --git a/src/Internal/Data/Basic/TypeLevel.hs b/src/Internal/Data/Basic/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/TypeLevel.hs @@ -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) diff --git a/src/Internal/Data/Basic/Types.hs b/src/Internal/Data/Basic/Types.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/Types.hs @@ -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)) diff --git a/src/Internal/Data/Basic/Virtual.hs b/src/Internal/Data/Basic/Virtual.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Data/Basic/Virtual.hs @@ -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 diff --git a/src/Internal/Interlude.hs b/src/Internal/Interlude.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Interlude.hs @@ -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 diff --git a/test/Model.hs b/test/Model.hs new file mode 100644 --- /dev/null +++ b/test/Model.hs @@ -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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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