71b64ef · squeal · git.iko.soy

git.iko.soy/squeal

Merge pull request #24 from echatav/numbers

Numbers

commit71b64effa323f560e30f5fa727e516039e4ea01f authorEitan Chatav <eitan.chatav@gmail.com> dateMon 3 Jul 2017, 16:28 (9 years ago) parent49cbdef 13b1364

3 files changed+223−18

compare with dev

unifiedsplit

squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+12 squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+205−12 squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+6−6

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

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

1818 , ToOid (..)

1919 , ToOids (..)

2020 , PGNum

21+ , PGFractional

22+ , PGFloating

2123 , (:::)

2224 , Alias (Alias)

2325 , Aliased (As)

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

8789instance PGNum 'PGFloat4

8890instance PGNum 'PGFloat8

8991

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+

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

91103

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

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

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

77 , LambdaCase

88 , MagicHash

99 , OverloadedStrings

10+ , ScopedTypeVariables

1011 , TypeFamilies

1112 , TypeOperators

1213 , UndecidableInstances

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

1617

1718import Control.Category

1819import Data.Boolean

20+import Data.Boolean.Numbers

1921import Data.ByteString (ByteString)

2022import Data.Maybe

2123import Data.Monoid

24+import Data.Ratio

2225import Data.String

2326import Generics.SOP

2427import GHC.Exts

2528import GHC.OverloadedLabels

2629import GHC.TypeLits

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

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

2831

2932import qualified Data.ByteString as ByteString

3033

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

124127unsafeFunction fun x = UnsafeExpression $ mconcat

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

126129

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

128− (+) = unsafeBinaryOp "+"

129− (-) = unsafeBinaryOp "-"

130− (*) = unsafeBinaryOp "*"

131− abs = unsafeUnaryOp "@"

132− signum = unsafeFunction "sign"

133− fromInteger = UnsafeExpression . fromString . show

130+instance PGNum ty

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

132+ (+) = unsafeBinaryOp "+"

133+ (-) = unsafeBinaryOp "-"

134+ (*) = unsafeBinaryOp "*"

135+ abs = unsafeFunction "abs"

136+ signum = unsafeFunction "sign"

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 <> ")"

134244

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

136246 fromString str = UnsafeExpression $

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

467577 = UnsafeTypeExpression { renderTypeExpression :: ByteString }

468578 deriving (Show,Eq)

469579

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

581+bool = UnsafeTypeExpression "bool"

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

471583int2 = UnsafeTypeExpression "int2"

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

585+smallint = UnsafeTypeExpression "smallint"

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

473587int4 = UnsafeTypeExpression "int4"

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

589+int = UnsafeTypeExpression "int"

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

591+integer = UnsafeTypeExpression "integer"

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

475593int8 = UnsafeTypeExpression "int8"

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

477−bool = UnsafeTypeExpression "bool"

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

595+bigint = UnsafeTypeExpression "bigint"

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

597+numeric = UnsafeTypeExpression "numeric"

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))

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"

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

479621text = 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+

480667notNull

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

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

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

487674 -> TypeExpression ('Optional ty)

488675default_ x ty = UnsafeTypeExpression $

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

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

491−serial = UnsafeTypeExpression "serial"

677+

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

492685

493686createTable

494687 :: (KnownSymbol table, SListI columns)

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

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

4747 let

4848 statement :: Statement '[] Columns Tables Tables

4949 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.;"

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

5252 let

5353 statement :: Statement '[] Columns Tables Tables

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

5555 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;"

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

5858 let

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

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

6363 let

6464 statement :: Statement '[] Columns Tables Tables

6565 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.;"

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

6868 let

6969 statement :: Statement '[] Columns Tables Tables

7070 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.);"

7272 it "correctly render simple INSERTs" $ do

7373 let

7474 statement :: Statement '[] '[] Tables Tables

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

7676 statement `shouldRenderAs`

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

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

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

7979 let

8080 statement :: Statement '[] '[] StudentsTable StudentsTable

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

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

146146 :* Nil)

147147 `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.);"

149149 it "should render DROP TABLE statements" $ do

150150 let

151151 statement :: Statement '[] '[] Tables '[]