8d840c2 · squeal · git.iko.soy

git.iko.soy/squeal

CREATE & DROP TABLE statements

commit8d840c21b3ba5108800ff80d47c1d6fc2b398f0b authorEitan Chatav <eitan.chatav@gmail.com> dateSat 10 Jun 2017, 08:58 (9 years ago) parent0f0e616

3 files changed+97−1

compare with dev

unifiedsplit

squeel-postgresql/src/Squeel/PostgreSQL/Query.hs+25 squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+58 squeel-postgresql/test/Squeel/PostgreSQL/QuerySpec.hs+14−1

squeel-postgresql/src/Squeel/PostgreSQL/Query.hs+25

@@ -348,3 +348,28 @@ insertInto (Alias table) expressions = UnsafeQuery $ "INSERT INTO "

348348 values = recordToList $ rmap

349349 (\ (expression `As` _) -> Const (renderExpression expression))

350350 expressions

351+

352+createTable

353+ :: (KnownSymbol table, KnownColumns columns)

354+ => Alias table

355+ -> Proxy# columns

356+ -> Query '[] schema ((table ::: columns) ': schema) '[]

357+createTable (Alias table) columns = UnsafeQuery $ mconcat

358+ [ "CREATE TABLE "

359+ , fromString $ symbolVal' table

360+ , " ("

361+ , renderColumns columns

362+ , ");"

363+ ]

364+

365+class KnownSymbol table => DropTable table schema0 schema1

366+ | table schema0 -> schema1 where

367+ dropTable :: Alias table -> Query '[] schema0 schema1 '[]

368+ dropTable (Alias table) = UnsafeQuery $

369+ "DROP TABLE " <> fromString (symbolVal' table) <> ";"

370+instance {-# OVERLAPPING #-}

371+ (KnownSymbol table, table ~ table')

372+ => DropTable table ((table' ::: columns) ': schema) schema

373+instance {-# OVERLAPPABLE #-}

374+ (KnownSymbol table, DropTable table schema0 schema1)

375+ => DropTable table (tabCols ': schema0) (tabCols ': schema1)

squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+58

@@ -1,5 +1,6 @@

11{-# LANGUAGE

22 DataKinds

3+ , FlexibleContexts

34 , FlexibleInstances

45 , GADTs

56 , MagicHash

@@ -19,6 +20,8 @@ module Squeel.PostgreSQL.Schema

1920 , (:::)

2021 , Alias (Alias)

2122 , Aliased (As)

23+ , KnownPGType (..)

24+ , KnownColumns (..)

2225 , renderAliased

2326 , module GHC.OverloadedLabels

2427 , module GHC.TypeLits

@@ -97,3 +100,58 @@ renderAliased

97100 -> ByteString

98101renderAliased render (expression `As` Alias alias) =

99102 render expression <> " AS " <> fromString (symbolVal' alias)

103+

104+class KnownPGType (ty :: PGType) where

105+ renderPGType :: Proxy# ty -> ByteString

106+instance KnownPGType 'PGBool where renderPGType _ = "bool"

107+instance KnownPGType 'PGInt2 where renderPGType _ = "int2"

108+instance KnownPGType 'PGInt4 where renderPGType _ = "int4"

109+instance KnownPGType 'PGInt8 where renderPGType _ = "int8"

110+instance KnownPGType 'PGNumeric where renderPGType _ = "numeric"

111+instance KnownPGType 'PGFloat4 where renderPGType _ = "float4"

112+instance KnownPGType 'PGFloat8 where renderPGType _ = "float8"

113+instance KnownPGType 'PGSerial2 where renderPGType _ = "serial2"

114+instance KnownPGType 'PGSerial4 where renderPGType _ = "serial4"

115+instance KnownPGType 'PGSerial8 where renderPGType _ = "serial8"

116+instance KnownPGType 'PGMoney where renderPGType _ = "money"

117+instance KnownNat n => KnownPGType ('PGChar n) where

118+ renderPGType _ = "char("

119+ <> fromString (show (natVal' (proxy# :: Proxy# n)))

120+ <> ")"

121+instance KnownNat n => KnownPGType ('PGVarChar n) where

122+ renderPGType _ = "varchar("

123+ <> fromString (show (natVal' (proxy# :: Proxy# n)))

124+ <> ")"

125+instance KnownPGType 'PGText where renderPGType _ = "text"

126+instance KnownPGType 'PGBytea where renderPGType _ = "bytea"

127+instance KnownPGType 'PGTimestamp where renderPGType _ = "timestamp"

128+instance KnownPGType 'PGTimestampTZ where renderPGType _ = "timestampTZ"

129+instance KnownPGType 'PGDate where renderPGType _ = "date"

130+instance KnownPGType 'PGTime where renderPGType _ = "time"

131+instance KnownPGType 'PGTimeTZ where renderPGType _ = "timeTZ"

132+instance KnownPGType 'PGInterval where renderPGType _ = "interval"

133+instance KnownPGType 'PGUuid where renderPGType _ = "uuid"

134+instance KnownPGType 'PGJson where renderPGType _ = "json"

135+instance KnownPGType 'PGJsonb where renderPGType _ = "jsonb"

136+

137+class KnownColumns (columns :: [(Symbol,PGType)]) where

138+ renderColumns :: Proxy# columns -> ByteString

139+instance

140+ ( KnownSymbol column

141+ , KnownPGType ty

142+ ) => KnownColumns '[column ::: ty] where

143+ renderColumns _ =

144+ fromString (symbolVal' (proxy# :: Proxy# column))

145+ <> " "

146+ <> renderPGType (proxy# :: Proxy# ty)

147+instance

148+ ( KnownSymbol column

149+ , KnownPGType ty

150+ , KnownColumns (columnsHead ': columnsTail)

151+ ) => KnownColumns ((column ::: ty) ': columnsHead ': columnsTail) where

152+ renderColumns _ =

153+ fromString (symbolVal' (proxy# :: Proxy# column))

154+ <> " "

155+ <> renderPGType (proxy# :: Proxy# ty)

156+ <> ", "

157+ <> renderColumns (proxy# :: Proxy# (columnsHead ': columnsTail))

squeel-postgresql/test/Squeel/PostgreSQL/QuerySpec.hs+14−1

@@ -1,8 +1,8 @@

11{-# LANGUAGE

22 DataKinds

3+ , MagicHash

34 , OverloadedLabels

45 , OverloadedStrings

5− , PolyKinds

66 , TypeOperators

77#-}

@@ -11,6 +11,7 @@ module Squeel.PostgreSQL.QuerySpec where

1111import Data.Boolean

1212import Data.Function

1313import Data.Vinyl

14+import GHC.Exts

1415import Test.Hspec

1516

1617import Squeel.PostgreSQL.Query

@@ -122,6 +123,18 @@ spec = do

122123 \ ON (orders.customerID = customers.customerID)\

123124 \ INNER JOIN shippers\

124125 \ ON (orders.shipperID = shippers.shipperID);"

126+ it "should render simple CREATE TABLE statements" $ do

127+ let

128+ statement :: Query '[] '[] Tables '[]

129+ statement = createTable #table1 (proxy# :: Proxy# Columns)

130+ statement `shouldRenderAs`

131+ "CREATE TABLE table1 (col1 int4, col2 int4);"

132+ it "should render DROP TABLE statements" $ do

133+ let

134+ statement :: Query '[] Tables '[] '[]

135+ statement = dropTable #table1

136+ statement `shouldRenderAs`

137+ "DROP TABLE table1;"

125138

126139type Columns = '[ "col1" ::: 'PGInt4, "col2" ::: 'PGInt4]

127140type Tables = '[ "table1" ::: Columns ]