git.iko.soy/rel8
on 7f5801f help sign in
rel8/src/Rel8/Expr.hs
155 lines 4.3 kB history raw
1{-# language DataKinds #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleInstances #-}
4{-# language GADTs #-}
5{-# language MultiParamTypeClasses #-}
6{-# language PolyKinds #-}
7{-# language RoleAnnotations #-}
8{-# language ScopedTypeVariables #-}
9{-# language StandaloneDeriving #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language UndecidableInstances #-}
14{-# language UndecidableSuperClasses #-}
16module Rel8.Expr
17 ( Expr(..)
18 , Col( E, unE )
19 )
20where
22-- base
23import Data.Functor.Identity ( Identity )
24import Data.Kind ( Type )
25import Data.String ( IsString, fromString )
26import Prelude hiding ( null )
28-- opaleye
29import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
31-- rel8
32import Rel8.Expr.Function ( function, nullaryFunction )
33import Rel8.Expr.Null ( liftOpNull, nullify )
34import Rel8.Expr.Opaleye
35 ( castExpr
36 , fromPrimExpr
37 , mapPrimExpr
38 , zipPrimExprsWith
39 )
40import Rel8.Expr.Serialize ( litExpr )
41import Rel8.Schema.Context ( Interpretation, Col )
42import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
43import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
44import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
45import Rel8.Schema.Reify ( notReify )
46import Rel8.Schema.Result ( Result )
47import Rel8.Schema.Spec ( Spec( Spec ) )
48import Rel8.Table
49 ( Table, Columns, Context, fromColumns, toColumns, reify, unreify
50 )
51import Rel8.Table.Recontextualize ( Recontextualize )
52import Rel8.Type ( DBType )
53import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
54import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )
55import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
58-- | Typed SQL expressions.
59type role Expr representational
60type Expr :: k -> Type
61data Expr a where
62 Expr :: k ~ Type => !Opaleye.PrimExpr -> Expr (a :: k)
65deriving stock instance Show (Expr a)
68instance Sql DBSemigroup a => Semigroup (Expr a) where
69 (<>) = case nullable @a of
70 Null -> liftOpNull (<>.)
71 NotNull -> (<>.)
72 {-# INLINABLE (<>) #-}
75instance Sql DBMonoid a => Monoid (Expr a) where
76 mempty = case nullable @a of
77 Null -> nullify memptyExpr
78 NotNull -> memptyExpr
79 {-# INLINABLE mempty #-}
82instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where
83 fromString = litExpr . case nullable @a of
84 Null -> Just . fromString
85 NotNull -> fromString
88instance Sql DBNum a => Num (Expr a) where
89 (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
90 (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*))
91 (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-))
93 abs = mapPrimExpr (Opaleye.UnExpr Opaleye.OpAbs)
94 negate = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNegate)
96 signum = castExpr . mapPrimExpr (Opaleye.UnExpr (Opaleye.UnOpOther "SIGN"))
98 fromInteger = castExpr . fromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit
101instance Sql DBFractional a => Fractional (Expr a) where
102 (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))
104 fromRational =
105 castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
108instance Sql DBFloating a => Floating (Expr a) where
109 pi = nullaryFunction "PI"
110 exp = function "exp"
111 log = function "ln"
112 sqrt = function "sqrt"
113 (**) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:^))
114 logBase = function "log"
115 sin = function "sin"
116 cos = function "cos"
117 tan = function "tan"
118 asin = function "asin"
119 acos = function "acos"
120 atan = function "atan"
121 sinh = function "sinh"
122 cosh = function "cosh"
123 tanh = function "tanh"
124 asinh = function "asinh"
125 acosh = function "acosh"
126 atanh = function "atanh"
129instance Interpretation Expr where
130 data Col Expr _spec where
131 E :: {unE :: !(Expr a)} -> Col Expr ('Spec labels a)
134instance Sql DBType a => Table Expr (Expr a) where
135 type Columns (Expr a) = HType a
136 type Context (Expr a) = Expr
138 toColumns a = HType (E a)
139 fromColumns (HType (E a)) = a
140 reify = notReify
141 unreify = notReify
144instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
147instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a)
150instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a)
153instance Labelable Expr where
154 labeler (E a) = E a
155 unlabeler (E a) = E a