71b64ef · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

Merge pull request #24 from echatav/numbers

71b64efEitan Chatav9 years ago

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

compare with dev

unifiedsplit

@@ -18,6 +18,8 @@ module Squeel.PostgreSQL.Schema

18 , ToOid (..)

19 , ToOids (..)

20 , PGNum

21+ , PGFractional

22+ , PGFloating

21 , (:::)

23 , (:::)

22 , Alias (Alias)

24 , Alias (Alias)

23 , Aliased (As)

25 , Aliased (As)

@@ -87,6 +89,16 @@ instance PGNum 'PGNumeric

87instance PGNum 'PGFloat4

89instance PGNum 'PGFloat4

88instance PGNum 'PGFloat8

90instance PGNum 'PGFloat8

92+class PGNum ty => PGFractional (ty :: PGType) where

93+instance PGFractional 'PGNumeric

94+instance PGFractional 'PGFloat4

95+instance PGFractional 'PGFloat8

96+

97+class PGFractional ty => PGFloating (ty :: PGType) where

98+instance PGFloating 'PGNumeric

99+instance PGFloating 'PGFloat4

100+instance PGFloating 'PGFloat8

101+

90type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)

102type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)

103

92data Alias (alias :: Symbol) = Alias (Proxy# alias)

104data Alias (alias :: Symbol) = Alias (Proxy# alias)

squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+205−12

@@ -7,6 +7,7 @@

7 , LambdaCase

8 , MagicHash

9 , OverloadedStrings

10+ , ScopedTypeVariables

10 , TypeFamilies

11 , TypeFamilies

11 , TypeOperators

12 , TypeOperators

12 , UndecidableInstances

13 , UndecidableInstances

@@ -16,15 +17,17 @@ module Squeel.PostgreSQL.Statement where

17import Control.Category

18import Control.Category

18import Data.Boolean

19import Data.Boolean

20+import Data.Boolean.Numbers

19import Data.ByteString (ByteString)

21import Data.ByteString (ByteString)

20import Data.Maybe

22import Data.Maybe

21import Data.Monoid

23import Data.Monoid

24+import Data.Ratio

22import Data.String

25import Data.String

23import Generics.SOP

26import Generics.SOP

24import GHC.Exts

27import GHC.Exts

25import GHC.OverloadedLabels

28import GHC.OverloadedLabels

26import GHC.TypeLits

29import GHC.TypeLits

27−import Prelude hiding (id,(.))

30+import Prelude hiding (id,(.),RealFrac(..))

29import qualified Data.ByteString as ByteString

32import qualified Data.ByteString as ByteString

@@ -124,13 +127,120 @@ unsafeFunction

124unsafeFunction fun x = UnsafeExpression $ mconcat

127unsafeFunction fun x = UnsafeExpression $ mconcat

125 [fun, "(", renderExpression x, ")"]

128 [fun, "(", renderExpression x, ")"]

126

129

130+instance PGNum ty

127−instance PGNum ty => Num (Expression params tables ('Required (nullity ty))) where

131+ => Num (Expression params tables ('Required (nullity ty))) where

128− (+) = unsafeBinaryOp "+"

132+ (+) = unsafeBinaryOp "+"

129− (-) = unsafeBinaryOp "-"

133+ (-) = unsafeBinaryOp "-"

130− (*) = unsafeBinaryOp "*"

134+ (*) = unsafeBinaryOp "*"

131− abs = unsafeUnaryOp "@"

135+ abs = unsafeFunction "abs"

132− signum = unsafeFunction "sign"

136+ signum = unsafeFunction "sign"

133− fromInteger = UnsafeExpression . fromString . show

137+ fromInteger = UnsafeExpression . (<> ".") . fromString . show

138+

139+instance PGFractional ty

140+ => Fractional (Expression params tables ('Required (nullity ty))) where

141+ (/) = unsafeBinaryOp "/"

142+ fromRational x = fromInteger (numerator x) / fromInteger (denominator x)

143+

144+instance (PGFloating ty, PGCast 'PGNumeric ty, PGTyped ty)

145+ => Floating (Expression params tables ('Required (nullity ty))) where

146+ pi = UnsafeExpression "pi()"

147+ exp = unsafeFunction "exp"

148+ log = unsafeFunction "ln"

149+ sqrt = unsafeFunction "sqrt"

150+ b ** x = UnsafeExpression $

151+ "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"

152+ logBase b y = cast pgtype $ logBaseNumeric b y

153+ where

154+ logBaseNumeric

155+ :: Expression params tables ('Required (nullity ty))

156+ -> Expression params tables ('Required (nullity ty))

157+ -> Expression params tables ('Required (nullity 'PGNumeric))

158+ logBaseNumeric b' y' = UnsafeExpression $ mconcat

159+ [ "log("

160+ , renderExpression b' <> "::numeric"

161+ , ", "

162+ , renderExpression y' <> "::numeric"

163+ , ")"

164+ ]

165+ sin = unsafeFunction "sin"

166+ cos = unsafeFunction "cos"

167+ tan = unsafeFunction "tan"

168+ asin = unsafeFunction "asin"

169+ acos = unsafeFunction "acos"

170+ atan = unsafeFunction "atan"

171+ sinh x = (exp x - exp (-x)) / 2

172+ cosh x = (exp x + exp (-x)) / 2

173+ tanh x = sinh x / cosh x

174+ asinh x = log (x + sqrt (x*x + 1))

175+ acosh x = log (x + sqrt (x*x - 1))

176+ atanh x = log ((1 + x) / (1 - x)) / 2

177+

178+class PGCast (ty0 :: PGType) (ty1 :: PGType) where

179+ cast

180+ :: TypeExpression ('Required ('Null ty1))

181+ -> Expression params tables ('Required (nullity ty0))

182+ -> Expression params tables ('Required (nullity ty1))

183+ cast ty x = UnsafeExpression $

184+ "(" <> renderExpression x <> "::" <> renderTypeExpression ty <> ")"

185+instance PGCast 'PGInt2 'PGInt2

186+instance PGCast 'PGInt2 'PGInt4

187+instance PGCast 'PGInt2 'PGInt8

188+instance PGCast 'PGInt4 'PGInt2

189+instance PGCast 'PGInt4 'PGInt4

190+instance PGCast 'PGInt4 'PGInt8

191+instance PGCast 'PGInt8 'PGInt2

192+instance PGCast 'PGInt8 'PGInt4

193+instance PGCast 'PGInt8 'PGInt8

194+instance PGCast 'PGInt8 'PGFloat4

195+instance PGCast 'PGInt8 'PGFloat8

196+instance PGCast 'PGInt8 'PGNumeric

197+

198+instance (PGNum ty, PGTyped ty, PGCast 'PGInt8 ty)

199+ => NumB (Expression params tables ('Required (nullity ty))) where

200+ type IntegerOf (Expression params tables ('Required (nullity ty)))

201+ = (Expression params tables ('Required (nullity 'PGInt8)))

202+ fromIntegerB = cast pgtype

203+

204+instance (PGNum ty, PGTyped ty, PGCast 'PGInt8 ty, PGCast ty 'PGInt8)

205+ => IntegralB (Expression params tables ('Required ('NotNull ty))) where

206+ quot = unsafeBinaryOp "/"

207+ rem = unsafeBinaryOp "%"

208+ div = unsafeBinaryOp "/"

209+ mod = unsafeBinaryOp "%"

210+ toIntegerB = cast int8

211+

212+instance

213+ ( IntegerOf (Expression params tables ('Required ('NotNull ty)))

214+ ~ (Expression params tables ('Required ('NotNull 'PGInt8)))

215+ , PGNum ty

216+ , PGTyped ty

217+ , PGCast 'PGInt8 ty

218+ , PGFractional ty

219+ )

220+ => RealFracB (Expression params tables ('Required ('NotNull ty))) where

221+ properFraction x = (truncate x, x - unsafeFunction "trunc" x)

222+ truncate = fromIntegerB . unsafeFunction "trunc"

223+ round = fromIntegerB . unsafeFunction "round"

224+ ceiling = fromIntegerB . unsafeFunction "ceiling"

225+ floor = fromIntegerB . unsafeFunction "floor"

226+

227+instance

228+ ( IntegerOf (Expression params tables ('Required ('NotNull ty)))

229+ ~ (Expression params tables ('Required ('NotNull 'PGInt8)))

230+ , PGNum ty

231+ , PGTyped ty

232+ , PGCast 'PGInt8 ty

233+ , PGCast 'PGNumeric ty

234+ , PGFloating ty

235+ )

236+ => RealFloatB (Expression params tables ('Required ('NotNull ty))) where

237+ isNaN x = x ==* UnsafeExpression "\'NaN\'"

238+ isInfinite x = x ==* UnsafeExpression "\'Infinity\'"

239+ ||* x ==* UnsafeExpression "\'-Infinity\'"

240+ isNegativeZero x = x ==* UnsafeExpression "-0"

241+ isIEEE _ = true

242+ atan2 y x = UnsafeExpression $

243+ "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"

134

244

135instance IsString (Expression params tables ('Required (nullity 'PGText))) where

245instance IsString (Expression params tables ('Required (nullity 'PGText))) where

136 fromString str = UnsafeExpression $

246 fromString str = UnsafeExpression $

@@ -467,16 +577,93 @@ newtype TypeExpression (ty :: ColumnType)

467 = UnsafeTypeExpression { renderTypeExpression :: ByteString }

577 = UnsafeTypeExpression { renderTypeExpression :: ByteString }

468 deriving (Show,Eq)

578 deriving (Show,Eq)

469

579

580+bool :: TypeExpression ('Required ('Null 'PGBool))

581+bool = UnsafeTypeExpression "bool"

470int2 :: TypeExpression ('Required ('Null 'PGInt2))

582int2 :: TypeExpression ('Required ('Null 'PGInt2))

471int2 = UnsafeTypeExpression "int2"

583int2 = UnsafeTypeExpression "int2"

584+smallint :: TypeExpression ('Required ('Null 'PGInt2))

585+smallint = UnsafeTypeExpression "smallint"

472int4 :: TypeExpression ('Required ('Null 'PGInt4))

586int4 :: TypeExpression ('Required ('Null 'PGInt4))

473int4 = UnsafeTypeExpression "int4"

587int4 = UnsafeTypeExpression "int4"

588+int :: TypeExpression ('Required ('Null 'PGInt4))

589+int = UnsafeTypeExpression "int"

590+integer :: TypeExpression ('Required ('Null 'PGInt4))

591+integer = UnsafeTypeExpression "integer"

474int8 :: TypeExpression ('Required ('Null 'PGInt8))

592int8 :: TypeExpression ('Required ('Null 'PGInt8))

475int8 = UnsafeTypeExpression "int8"

593int8 = UnsafeTypeExpression "int8"

594+bigint :: TypeExpression ('Required ('Null 'PGInt8))

595+bigint = UnsafeTypeExpression "bigint"

596+numeric :: TypeExpression ('Required ('Null 'PGNumeric))

597+numeric = UnsafeTypeExpression "numeric"

476−bool :: TypeExpression ('Required ('Null 'PGBool))

598+float4 :: TypeExpression ('Required ('Null 'PGFloat4))

599+float4 = UnsafeTypeExpression "float4"

600+real :: TypeExpression ('Required ('Null 'PGFloat4))

601+real = UnsafeTypeExpression "real"

602+float8 :: TypeExpression ('Required ('Null 'PGFloat8))

603+float8 = UnsafeTypeExpression "float8"

604+doublePrecision :: TypeExpression ('Required ('Null 'PGFloat8))

605+doublePrecision = UnsafeTypeExpression "double precision"

606+serial2 :: TypeExpression ('Optional ('NotNull 'PGInt2))

607+serial2 = UnsafeTypeExpression "serial2"

608+smallserial :: TypeExpression ('Optional ('NotNull 'PGInt2))

609+smallserial = UnsafeTypeExpression "smallserial"

610+serial4 :: TypeExpression ('Optional ('NotNull 'PGInt4))

477−bool = UnsafeTypeExpression "bool"

611+serial4 = UnsafeTypeExpression "serial4"

612+serial :: TypeExpression ('Optional ('NotNull 'PGInt4))

613+serial = UnsafeTypeExpression "serial"

614+serial8 :: TypeExpression ('Optional ('NotNull 'PGInt8))

615+serial8 = UnsafeTypeExpression "serial8"

616+bigserial :: TypeExpression ('Optional ('NotNull 'PGInt8))

617+bigserial = UnsafeTypeExpression "bigserial"

618+money :: TypeExpression ('Optional ('NotNull 'PGMoney))

619+money = UnsafeTypeExpression "money"

478text :: TypeExpression ('Required ('Null 'PGText))

620text :: TypeExpression ('Required ('Null 'PGText))

479text = UnsafeTypeExpression "text"

621text = UnsafeTypeExpression "text"

622+char

623+ :: KnownNat n

624+ => proxy n

625+ -> TypeExpression ('Optional ('NotNull ('PGChar n)))

626+char (_ :: proxy n) = UnsafeTypeExpression $

627+ "char(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"

628+character

629+ :: KnownNat n

630+ => proxy n

631+ -> TypeExpression ('Optional ('NotNull ('PGChar n)))

632+character (_ :: proxy n) = UnsafeTypeExpression $

633+ "character(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"

634+varchar

635+ :: KnownNat n

636+ => proxy n

637+ -> TypeExpression ('Optional ('NotNull ('PGVarChar n)))

638+varchar (_ :: proxy n) = UnsafeTypeExpression $

639+ "varchar(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"

640+characterVarying

641+ :: KnownNat n

642+ => proxy n

643+ -> TypeExpression ('Optional ('NotNull ('PGVarChar n)))

644+characterVarying (_ :: proxy n) = UnsafeTypeExpression $

645+ "character varying(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"

646+bytea :: TypeExpression ('Optional ('NotNull ('PGBytea)))

647+bytea = UnsafeTypeExpression "bytea"

648+timestamp :: TypeExpression ('Optional ('NotNull ('PGTimestamp)))

649+timestamp = UnsafeTypeExpression "timestamp"

650+timestampWithTimeZone :: TypeExpression ('Optional ('NotNull ('PGTimestampTZ)))

651+timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

652+date :: TypeExpression ('Optional ('NotNull ('PGDate)))

653+date = UnsafeTypeExpression "date"

654+time :: TypeExpression ('Optional ('NotNull ('PGTime)))

655+time = UnsafeTypeExpression "time"

656+timeWithTimeZone :: TypeExpression ('Optional ('NotNull ('PGTimeTZ)))

657+timeWithTimeZone = UnsafeTypeExpression "time with time zone"

658+interval :: TypeExpression ('Optional ('NotNull ('PGInterval)))

659+interval = UnsafeTypeExpression "interval"

660+uuid :: TypeExpression ('Optional ('NotNull ('PGUuid)))

661+uuid = UnsafeTypeExpression "uuid"

662+json :: TypeExpression ('Optional ('NotNull ('PGJson)))

663+json = UnsafeTypeExpression "json"

664+jsonb :: TypeExpression ('Optional ('NotNull ('PGJsonb)))

665+jsonb = UnsafeTypeExpression "jsonb"

666+

480notNull

667notNull

481 :: TypeExpression ('Required ('Null ty))

668 :: TypeExpression ('Required ('Null ty))

482 -> TypeExpression ('Required ('NotNull ty))

669 -> TypeExpression ('Required ('NotNull ty))

@@ -487,8 +674,14 @@ default_

487 -> TypeExpression ('Optional ty)

674 -> TypeExpression ('Optional ty)

488default_ x ty = UnsafeTypeExpression $

675default_ x ty = UnsafeTypeExpression $

489 renderTypeExpression ty <> " DEFAULT " <> renderExpression x

676 renderTypeExpression ty <> " DEFAULT " <> renderExpression x

490−serial :: TypeExpression ('Optional ('NotNull 'PGInt4))

677+

491−serial = UnsafeTypeExpression "serial"

678+class PGTyped (ty :: PGType) where

679+ pgtype :: TypeExpression ('Required ('Null ty))

680+instance PGTyped 'PGInt2 where pgtype = int2

681+instance PGTyped 'PGInt4 where pgtype = int4

682+instance PGTyped 'PGInt8 where pgtype = int8

683+instance PGTyped 'PGBool where pgtype = bool

684+instance PGTyped 'PGText where pgtype = text

492

685

493createTable

686createTable

494 :: (KnownSymbol table, SListI columns)

687 :: (KnownSymbol table, SListI columns)

squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+6−6

@@ -47,13 +47,13 @@ spec = do

47 let

48 statement :: Statement '[] Columns Tables Tables

49 statement = select $ starFrom (#table1 & limit 1)

50− statement `shouldRenderAs` "SELECT * FROM table1 AS table1 LIMIT 1;"

50+ statement `shouldRenderAs` "SELECT * FROM table1 AS table1 LIMIT 1.;"

51 it "should use the minimum of given LIMITs" $ do

52 let

53 statement :: Statement '[] Columns Tables Tables

54 statement = select $ starFrom (#table1 & limit 1 & limit 2)

55 statement `shouldRenderAs`

56− "SELECT * FROM table1 AS table1 LIMIT CASE WHEN (1 <= 2) THEN 1 ELSE 2 END;"

56+ "SELECT * FROM table1 AS table1 LIMIT CASE WHEN (1. <= 2.) THEN 1. ELSE 2. END;"

57 it "should render parameters using $ signs" $ do

58 let

59 statement :: Statement '[ 'Required ('NotNull 'PGInt8)] Columns Tables Tables

@@ -63,18 +63,18 @@ spec = do

63 let

64 statement :: Statement '[] Columns Tables Tables

65 statement = select $ starFrom (#table1 & offset 1)

66− statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET 1;"

66+ statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET 1.;"

67 it "should use the sum of given OFFSETs" $ do

68 let

69 statement :: Statement '[] Columns Tables Tables

70 statement = select $ starFrom (#table1 & offset 1 & offset 2)

71− statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET (1 + 2);"

71+ statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET (1. + 2.);"

72 it "correctly render simple INSERTs" $ do

73 let

74 statement :: Statement '[] '[] Tables Tables

75 statement = insertInto #table1 $ 2 `As` #col1 :* 4 `As` #col2 :* Nil

76 statement `shouldRenderAs`

77− "INSERT INTO table1 (col1, col2) VALUES (2, 4);"

77+ "INSERT INTO table1 (col1, col2) VALUES (2., 4.);"

78 it "should be safe against SQL injection in literal text" $ do

79 let

80 statement :: Statement '[] '[] StudentsTable StudentsTable

@@ -145,7 +145,7 @@ spec = do

145 :* (int8 & notNull & default_ 8) `As` #col3

146 :* Nil)

147 `shouldRenderAs`

148− "CREATE TABLE table2 (col1 serial, col2 text, col3 int8 NOT NULL DEFAULT 8);"

148+ "CREATE TABLE table2 (col1 serial, col2 text, col3 int8 NOT NULL DEFAULT 8.);"

149 it "should render DROP TABLE statements" $ do

150 let

151 statement :: Statement '[] '[] Tables '[]