git.iko.soy/rel8
on dec2074 help sign in
rel8/src/Rel8/Expr.hs
153 lines 4.4 kB history raw
1{-# language DataKinds #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
4{-# language FlexibleInstances #-}
5{-# language GADTs #-}
6{-# language MultiParamTypeClasses #-}
7{-# language NamedFieldPuns #-}
8{-# language RoleAnnotations #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language UndecidableInstances #-}
14{-# language UndecidableSuperClasses #-}
16module Rel8.Expr
17 ( Expr(..)
18 , Col( DB, unDB )
19 , Encodes
20 )
21where
23-- base
24import Data.Functor.Identity ( Identity )
25import Data.Kind ( Constraint, Type )
26import Data.String ( IsString, fromString )
27import Prelude hiding ( null )
29-- opaleye
30import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
32-- rel8
33import Rel8.Expr.Null ( liftOpNullable, nullify )
34import Rel8.Expr.Opaleye
35 ( castExpr
36 , fromPrimExpr
37 , mapPrimExpr
38 , zipPrimExprsWith
39 )
40import Rel8.Expr.Serialize ( litExpr )
41import Rel8.Opaque ( Opaque, Opaque1 )
42import Rel8.Schema.Context ( Interpretation, Col )
43import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
44import Rel8.Schema.Context.Nullify
45 ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
46 , runTag, unnull
47 )
48import Rel8.Schema.HTable.Type ( HType( HType ) )
49import Rel8.Schema.Nullability
50 ( Nullability( Nullable, NonNullable )
51 , Sql, nullabilization
52 )
53import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
54import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
55import Rel8.Table.Recontextualize ( Recontextualize )
56import Rel8.Type ( DBType )
57import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
58import Rel8.Type.Num ( DBFractional, DBNum )
59import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
62-- | Typed SQL expressions.
63type role Expr representational
64type Expr :: Type -> Type
65newtype Expr a = Expr Opaleye.PrimExpr
66 deriving stock Show
69instance Sql DBSemigroup a => Semigroup (Expr a) where
70 (<>) = case nullabilization @a of
71 Nullable -> liftOpNullable (<>.)
72 NonNullable -> (<>.)
73 {-# INLINABLE (<>) #-}
76instance Sql DBMonoid a => Monoid (Expr a) where
77 mempty = case nullabilization @a of
78 Nullable -> nullify memptyExpr
79 NonNullable -> memptyExpr
80 {-# INLINABLE mempty #-}
83instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where
84 fromString = litExpr . case nullabilization @a of
85 Nullable -> Just . fromString
86 NonNullable -> fromString
89instance Sql DBNum a => Num (Expr a) where
90 (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
91 (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*))
92 (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-))
94 abs = mapPrimExpr (Opaleye.UnExpr Opaleye.OpAbs)
95 negate = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNegate)
97 signum = castExpr . mapPrimExpr (Opaleye.UnExpr (Opaleye.UnOpOther "SIGN"))
99 fromInteger = castExpr . fromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit
102instance Sql DBFractional a => Fractional (Expr a) where
103 (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))
105 fromRational =
106 castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
109instance Interpretation Expr where
110 data Col Expr _spec where
111 DB :: ()
112 => { unDB :: Expr a }
113 -> Col Expr ('Spec labels necessity db a)
116instance Sql DBType a => Table Expr (Expr a) where
117 type Columns (Expr a) = HType a
118 type Context (Expr a) = Expr
120 toColumns a = HType (DB a)
121 fromColumns (HType (DB a)) = a
124instance Sql DBType a => Recontextualize Expr Expr (Expr a) (Expr a)
127instance Sql DBType a => Recontextualize Expr Identity (Expr a) (Identity a)
130instance Sql DBType a => Recontextualize Identity Expr (Identity a) (Expr a)
133instance Labelable Expr where
134 labeler (DB a) = DB a
135 unlabeler (DB a) = DB a
138instance Nullifiable Expr where
139 encodeTag = DB
140 decodeTag (DB a) = a
141 nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
142 unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
144 {-# INLINABLE encodeTag #-}
145 {-# INLINABLE decodeTag #-}
146 {-# INLINABLE nullifier #-}
147 {-# INLINABLE unnullifier #-}
150type Encodes :: Type -> Type -> Constraint
151class Recontextualize Identity Expr a exprs => Encodes a exprs
152instance Recontextualize Identity Expr a exprs => Encodes a exprs
153instance {-# OVERLAPPING #-} Encodes (Opaque1 Identity Opaque) (Opaque1 Expr Opaque)