Coverage report: /home/ati/workspace/perec/persistence/standard-type.lisp

Kind	Covered	All	%
expression	249	370	67.3
branch	9	10	90.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;; -*- mode: Lisp; Syntax: Common-Lisp; -*-

2

;;;

3

4

;;;

5

;;; See LICENCE for details.

6

7

(in-package :cl-perec)

8

9

;;;;;;

10

;;; Or

11

;;;

12

;;; May be used to combine null and unbound with a primitive type and may generate an extra column.

13

;;; See compute-reader and compute-writer generic function definitions

14

15

(defptype or (&rest types)

16

`(or ,@types))

17

18

(defmethod parse-keyword-type-parameters ((type or-type) type-parameters)

19

(append (list :types (mapcar #'parse-type (getf type-parameters :types)))

20

(call-next-method type (remove-keywords type-parameters :types))))

21

22

(defmethod parse-positional-type-parameters ((type or-type) type-parameters)

23

(list :types (mapcar #'parse-type type-parameters)))

24

25

;;;;;;;

26

;;; And

27

;;;

28

;;; Not supported

29

30

(defptype and (&rest types)

31

`(and ,@types))

32

33

(defmethod parse-keyword-type-parameters ((type and-type) type-parameters)

34

(append (list :types (mapcar #'parse-type (getf type-parameters :types)))

35

(call-next-method type (remove-keywords type-parameters :types))))

36

37

(defmethod parse-positional-type-parameters ((type and-type) type-parameters)

38

(list :types (mapcar #'parse-type type-parameters)))

39

40

;;;;;;;

41

;;; Not

42

;;;

43

;;; Not supported

44

45

(defptype not (negated-type)

46

`(not ,negated-type))

47

48

(defmethod parse-keyword-type-parameters((type not-type) type-parameters)

49

(append (list :negated-type (parse-type (getf type-parameters :negated-type)))

50

(call-next-method type (remove-keywords type-parameters :negated-type))))

51

52

(defmethod parse-positional-type-parameters ((type not-type) type-parameters)

53

(list :negated-type (parse-type (first type-parameters))))

54

55

;;;;;;;;;;;;;

56

;;; Satisfies

57

58

(defptype satisfies (function)

59

`(satisfies ,function))

60

61

;;;;;;;

62

;;; Nil

63

;;;

64

;;; other -> (type-error)

65

66

(defptype nil ()

67

nil)

68

69

(defmapping nil nil

70

#L(error 'type-error :datum (first !1) :expected-type nil)

71

#L(error 'type-error :datum !1 :expected-type nil))

72

73

;;;;;;;;;;

74

;;; Member

75

;;;

76

;;; not found in members -> (type-error)

77

78

(defptype member (&rest members)

79

`(member ,@members))

80

81

(defmapping member (sql-integer-type :bit-size 16)

82

(integer->member-reader type-specification)

83

(member->integer-writer type-specification))

84

85

(defmacro def-member-type (name &body members)

86

`(defptype ,name ()

87

`(member ,@',members)))

88

89

;;;;;;;;;;;

90

;;; Unbound

91

;;;

92

;;; unbound -> NULL

93

;;; t -> type-error

94

95

(defptype eql (value)

96

`(eql ,value))

97

98

;; this type must be used to mark slots which might be unbound (e.g. (or unbound integer))

99

(defptype unbound ()

100

`(eql ,+unbound-slot-value+))

101

102

(defmapping unbound (sql-boolean-type)

103

(unbound-reader #L(error 'type-error :datum (first !1) :expected-type type))

104

(unbound-writer #L(error 'type-error :datum !1 :expected-type type)))

105

106

;;;;;;;;

107

;;; Null

108

;;;

109

;;; nil -> NULL

110

;;; t -> (type-error)

111

112

(defptype null ()

113

'null)

114

115

(defmapping null (sql-boolean-type)

116

(null-reader #L(error 'type-error :datum (first !1) :expected-type type))

117

(null-writer #L(error 'type-error :datum !1 :expected-type type)))

118

119

;;;;;

120

;;; t

121

;;;

122

;;; unbound -> NULL, NULL

123

;;; nil -> true, NULL

124

;;; other -> true, (base64)

125

126

(defptype t ()

127

t)

128

129

(defmapping t (sql-character-large-object-type)

130

'base64->object-reader

131

'object->base64-writer)

132

133

;;;;;;;;;;;;;;

134

;;; Serialized

135

;;;

136

;;; unbound -> (type-error)

137

;;; nil -> (type-error)

138

;;; other -> (base64)

139

140

(defun maximum-serialized-size-p (serialized)

141

(declare (ignore serialized))

142

t)

143

144

(defptype serialized (&optional byte-size)

145

(declare (ignore byte-size))

146

'(and (not unbound)

147

(not null)

148

(satisfies maximum-serialized-size-p)))

149

150

(defmapping serialized (if (consp type-specification)

151

                            (sql-character-varying-type :size (second type-specification))

152

(sql-character-large-object-type))

153

'base64->object-reader

154

'object->base64-writer)

155

156

;;;;;;;;;;;

157

;;; Boolean

158

;;;

159

;;; nil -> false

160

;;; t -> true

161

;;; other -> (type-error)

162

163

(defptype boolean ()

164

'boolean)

165

166

(defmapping boolean (sql-boolean-type)

167

'object->boolean-reader

168

'boolean->string-writer)

169

170

;;;;;;;;;;;

171

;;; Integer

172

;;;

173

;;; non integer -> (type-error)

174

175

(defptype integer (&optional minimum-value maximum-value bit-size)

176

(declare (ignore bit-size))

177

`(integer ,minimum-value ,maximum-value))

178

179

(defmapping integer (sql-integer-type)

180

'object->integer-reader

181

'identity-writer)

182

183

;;;;;;;;;;;;;;

184

;;; Integer-16

185

;;;

186

;;; non integer -> (type-error)

187

188

(defptype integer-16 ()

189

`(integer ,(- (expt 2 15)) ,(1- (expt 2 15))))

190

191

(defmapping integer-16 (sql-integer-type :bit-size 16)

192

'object->integer-reader

193

'identity-writer)

194

195

;;;;;;;;;;;;;;

196

;;; Integer-32

197

;;;

198

;;; non integer -> (type-error)

199

200

(defptype integer-32 ()

201

`(integer ,(- (expt 2 31)) ,(1- (expt 2 31))))

202

203

(defmapping integer-32 (sql-integer-type :bit-size 32)

204

'object->integer-reader

205

'identity-writer)

206

207

;;;;;;;;;;;;;;

208

;;; Integer-64

209

;;;

210

;;; non integer -> (type-error)

211

212

(defptype integer-64 ()

213

`(integer ,(- (expt 2 63)) ,(1- (expt 2 63))))

214

215

(defmapping integer-64 (sql-integer-type :bit-size 64)

216

'object->integer-reader

217

'identity-writer)

218

219

;;;;;;;;;

220

;;; Float

221

;;;

222

;;; non float -> (type-error)

223

224

(defptype float (&optional minimum-value maximum-value)

225

`(float ,minimum-value ,maximum-value))

226

227

(defmapping float (sql-float-type :bite-size 64)

228

'object->number-reader

229

'identity-writer)

230

231

;;;;;;;;;;;;

232

;;; Float-32

233

;;;

234

;;; non float -> (type-error)

235

236

(defptype float-32 ()

237

'float)

238

239

(defmapping float-32 (sql-float-type :bit-size 32)

240

'object->number-reader

241

'identity-writer)

242

243

;;;;;;;;;;;;

244

;;; Float-64

245

;;;

246

;;; non float -> (type-error)

247

248

(defptype float-64 ()

249

'float)

250

251

(defmapping float-64 (sql-float-type :bit-size 64)

252

'object->number-reader

253

'identity-writer)

254

255

;;;;;;;;;;

256

;;; Double

257

;;;

258

;;; non double -> (type-error)

259

260

(defptype double ()

261

'double-float)

262

263

(defmapping double-float (sql-float-type :bit-size 64)

264

'object->number-reader

265

'identity-writer)

266

267

;;;;;;;;;;

268

;;; Number

269

;;;

270

;;; non number -> (type-error)

271

272

(defptype number ()

273

'number)

274

275

(defmapping number (sql-numeric-type)

276

'object->number-reader

277

'identity-writer)

278

279

;;;;;;;;;;

280

;;; String

281

;;;

282

;;; non string -> (type-error)

283

284

(defptype string (&optional length acceptable-characters)

285

(declare (ignore acceptable-characters))

286

`(string ,length))

287

288

(defmapping string (if (consp type-specification)

289

(sql-character-type :size (second type-specification))

290

(sql-character-large-object-type))

291

'identity-reader

292

'identity-writer)

293

294

;;;;;;;;

295

;;; Text

296

;;;

297

;;; non string -> (type-error)

298

299

;; TODO:

300

(defun maximum-length-p (string)

301

(declare (ignore string))

302

t)

303

304

(defptype text (&optional maximum-length minimum-length acceptable-characters)

305

(declare (ignore maximum-length minimum-length acceptable-characters))

306

'(and string

307

(satisfies maximum-length-p)))

308

309

(defmapping text (if (consp type-specification)

310

(sql-character-varying-type :size (second type-specification))

311

(sql-character-large-object-type))

312

'identity-reader

313

'identity-writer)

314

315

;;;;;;;;;;

316

;;; Symbol

317

;;;

318

;;; non symbol -> (type-error)

319

320

(defptype symbol ()

321

'symbol)

322

323

(defmapping symbol (sql-character-large-object-type)

324

'string->symbol-reader

325

'symbol->string-writer)

326

327

;; TODO:

328

(defun maximum-symbol-name-length-p (symbol)

329

(declare (ignore symbol))

330

t)

331

332

(defptype symbol* (&optional maximum-length)

333

(declare (ignore maximum-length))

334

'(and symbol

335

(satisfies maximum-symbol-name-length-p)))

336

337

(defmapping symbol* (if (consp type-specification)

338

                         (sql-character-varying-type :size (second (find 'symbol* type-specification

339

                                                                         :key #L(when (listp !1) (first !1)))))

340

(sql-character-large-object-type))

341

'string->symbol-reader

342

'symbol->string-writer)

343

344

;;;;;;;;

345

;;; Date

346

;;;

347

;;; non date -> (type-error)

348

349

;; TODO:

350

(defun date-p (date)

351

(declare (ignore date))

352

t)

353

354

(defptype date ()

355

'(and local-time

356

(satisfies date-p)))

357

358

(defmapping date (sql-date-type)

359

'integer->local-time-reader

360

'local-time->string-writer)

361

362

;;;;;;;;

363

;;; Time

364

;;;

365

;;; non date -> (type-error)

366

367

;; TODO:

368

(defun time-p (time)

369

(declare (ignore time))

370

t)

371

372

(defptype time ()

373

'(and local-time

374

(satisfies time-p)))

375

376

(defmapping time (sql-time-type)

377

'string->local-time-reader

378

'local-time->string-writer)

379

380

;;;;;;;;;;;;;

381

;;; Timestamp

382

;;;

383

;;; non date -> (type-error)

384

385

(defptype timestamp ()

386

'(and local-time

387

(satisfies date-p)

388

(satisfies time-p)))

389

390

(defmapping timestamp (sql-timestamp-type)

391

'integer->local-time-reader

392

'local-time->string-writer)

393

394

;;;;;;;;;;;;

395

;;; Duration

396

;;;

397

;;; non string -> (type-error)

398

399

;; TODO:

400

(defun duration-p (duration)

401

(declare (ignore duration))

402

t)

403

404

(defptype duration ()

405

'(and string

406

(satisfies duration-p)))

407

408

(defmapping duration (sql-character-varying-type :size 32)

409

'identity-reader

410

'identity-writer)

411

412

;;;;;;;;

413

;;; Form

414

;;;

415

;;; non form -> (type-error)

416

417

(defptype form (&optional byte-size)

418

(declare (ignore byte-size))

419

'(and list

420

(satisfies maximum-serialized-size-p)))

421

422

(defmapping form (sql-character-varying-type)

423

'string->list-reader

424

'list->string-writer)