git.iko.soy/rel8
on 11bcbbb help sign in
rel8/src/Rel8/Expr.hs
142 lines 4.0 kB history raw
1{-# language DataKinds #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleInstances #-}
4{-# language GADTs #-}
5{-# language MultiParamTypeClasses #-}
6{-# language NamedFieldPuns #-}
7{-# language RoleAnnotations #-}
8{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
12{-# language UndecidableInstances #-}
13{-# language UndecidableSuperClasses #-}
15module Rel8.Expr
16 ( Expr(..)
17 , Col( DB, unDB )
18 )
19where
21-- base
22import Data.Functor.Identity ( Identity )
23import Data.Kind ( Type )
24import Data.String ( IsString, fromString )
25import Prelude hiding ( null )
27-- opaleye
28import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
30-- rel8
31import Rel8.Expr.Null ( liftOpNullable, nullify )
32import Rel8.Expr.Opaleye
33 ( castExpr
34 , fromPrimExpr
35 , mapPrimExpr
36 , zipPrimExprsWith
37 )
38import Rel8.Expr.Serialize ( litExpr )
39import Rel8.Schema.Context ( Interpretation, Col )
40import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
41import Rel8.Schema.Context.Nullify
42 ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
43 , runTag, unnull
44 )
45import Rel8.Schema.HTable.Type ( HType( HType ) )
46import Rel8.Schema.Nullability
47 ( Nullability( Nullable, NonNullable )
48 , Sql, nullabilization
49 )
50import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
51import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
52import Rel8.Table.Recontextualize ( Recontextualize )
53import Rel8.Type ( DBType )
54import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
55import Rel8.Type.Num ( DBFractional, DBNum )
56import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
59-- | Typed SQL expressions.
60type role Expr representational
61type Expr :: Type -> Type
62newtype Expr a = Expr Opaleye.PrimExpr
63 deriving stock Show
66instance Sql DBSemigroup a => Semigroup (Expr a) where
67 (<>) = case nullabilization @a of
68 Nullable -> liftOpNullable (<>.)
69 NonNullable -> (<>.)
70 {-# INLINABLE (<>) #-}
73instance Sql DBMonoid a => Monoid (Expr a) where
74 mempty = case nullabilization @a of
75 Nullable -> nullify memptyExpr
76 NonNullable -> memptyExpr
77 {-# INLINABLE mempty #-}
80instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where
81 fromString = litExpr . case nullabilization @a of
82 Nullable -> Just . fromString
83 NonNullable -> fromString
86instance Sql DBNum a => Num (Expr a) where
87 (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
88 (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*))
89 (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-))
91 abs = mapPrimExpr (Opaleye.UnExpr Opaleye.OpAbs)
92 negate = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNegate)
94 signum = castExpr . mapPrimExpr (Opaleye.UnExpr (Opaleye.UnOpOther "SIGN"))
96 fromInteger = castExpr . fromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit
99instance Sql DBFractional a => Fractional (Expr a) where
100 (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))
102 fromRational =
103 castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
106instance Interpretation Expr where
107 data Col Expr _spec where
108 DB :: {unDB :: Expr a} -> Col Expr ('Spec labels necessity a)
111instance Sql DBType a => Table Expr (Expr a) where
112 type Columns (Expr a) = HType a
113 type Context (Expr a) = Expr
115 toColumns a = HType (DB a)
116 fromColumns (HType (DB a)) = a
119instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
122instance Sql DBType a => Recontextualize Expr Identity (Expr a) (Identity a)
125instance Sql DBType a => Recontextualize Identity Expr (Identity a) (Expr a)
128instance Labelable Expr where
129 labeler (DB a) = DB a
130 unlabeler (DB a) = DB a
133instance Nullifiable Expr where
134 encodeTag = DB
135 decodeTag (DB a) = a
136 nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
137 unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
139 {-# INLINABLE encodeTag #-}
140 {-# INLINABLE decodeTag #-}
141 {-# INLINABLE nullifier #-}
142 {-# INLINABLE unnullifier #-}