@@ -1,207 +1,131 @@
11{-# LANGUAGE
2− PolyKinds
3− , DataKinds
4− , FlexibleContexts
2+ DataKinds
53 , FlexibleInstances
64 , GADTs
7− , KindSignatures
8− , LambdaCase
5+ , MultiParamTypeClasses
96 , OverloadedStrings
10− , RankNTypes
7+ , PolyKinds
118 , ScopedTypeVariables
129 , TypeApplications
13− , TypeInType
10+ , TypeFamilies
1411 , TypeOperators
1512#-}
1613
17−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
18−
1914module Squeel.PostgreSQL.Query where
2015
21−import Data.ByteString (ByteString)
16+import Data.Boolean
17+import Data.ByteString
2218import Data.Monoid
2319import Data.Proxy
2420import Data.String
25−import Data.Vinyl
26−import Data.Vinyl.Functor
2721import GHC.TypeLits
2822
2923import qualified Data.ByteString.Char8 as Char8
3024
3125import Squeel.PostgreSQL.Type
3226
33−data Expression ps cols x =
34− Expression { unExpression :: ByteString } deriving Show
27+newtype Expression ps xs y =
28+ UnsafeExpression { renderExpression :: ByteString }
3529
3630param1 :: Expression (p1:ps) cols p1
37−param1 = Expression "$1"
38−
31+param1 = UnsafeExpression "$1"
3932param2 :: Expression (p1:p2:ps) cols p2
40−param2 = Expression "$2"
41−
33+param2 = UnsafeExpression "$2"
4234param3 :: Expression (p1:p2:p3:ps) cols p3
43−param3 = Expression "$3"
44−
35+param3 = UnsafeExpression "$3"
4536param4 :: Expression (p1:p2:p3:p4:ps) cols p4
46−param4 = Expression "$4"
47−
37+param4 = UnsafeExpression "$4"
4838param5 :: Expression (p1:p2:p3:p4:p5:ps) cols p5
49−param5 = Expression "$5"
50−
51−whenThen :: (Expression ps cols x,Expression ps cols y) -> ByteString
52−whenThen (Expression when_,Expression then_) = mconcat
53− [" WHEN ",when_," THEN ",then_,"\n"]
54−
55−case_
56− :: [(Expression ps cols 'PGBool,Expression ps cols x)]
57− -> Expression ps cols x
58− -> Expression ps cols x
59−case_ whens (Expression else_) = Expression $ mconcat
60− [ "CASE\n"
61− , mconcat (map whenThen whens)
62− , " ELSE ",else_
63− , "\nEND"
64− ]
65−
66−caseSwitch
67− :: Expression ps cols x
68− -> [(Expression ps cols x,Expression ps cols y)]
69− -> Expression ps cols y
70− -> Expression ps cols y
71−caseSwitch (Expression val) whens (Expression else_) = Expression $ mconcat
72− [ "CASE ",val,"\n"
73− , mconcat (map whenThen whens)
74− , " ELSE ",else_
75− ,"\nEND"
76− ]
39+param5 = UnsafeExpression "$5"
40+
41+class HasField ident xs x where
42+ fieldName :: Proxy ident -> Proxy xs -> Proxy x -> ByteString
43+instance KnownSymbol name => HasField '[name] ((name ':= x) ': xs) x where
44+ fieldName _ _ _ = Char8.pack (symbolVal (Proxy @name))
45+instance HasField ident xs x => HasField ident (y ': xs) x where
46+ fieldName _ _ _ = fieldName (Proxy @ident) (Proxy @xs) (Proxy @x)
47+instance (KnownSymbol name, HasField names xs x)
48+ => HasField (name ': names) ((name ':= xs) ': xss) x where
49+ fieldName _ _ _ = Char8.pack (symbolVal (Proxy @name))
50+ <> "." <> fieldName (Proxy @names) (Proxy @xs) (Proxy @x)
51+
52+column_
53+ :: forall ident xs x ps
54+ . HasField ident xs x
55+ => Proxy ident
56+ -> Expression ps xs x
57+column_ (_ :: Proxy ident) = UnsafeExpression $
58+ fieldName (Proxy @ident) (Proxy @xs) (Proxy @x)
59+
60+data Identified ident x = (:=) ident x
61+data Aliased obj named where AS :: obj x -> Aliased obj (name ':= x)
62+
63+unalias :: Aliased obj (name ':= x) -> obj x
64+unalias (AS obj) = obj
7765
7866column
79− :: forall colName colType params columns
80− . Alias (Expression params columns) (colName ':= colType)
81− -> Expression params columns colType
82−column = \case
83− As x -> x
84− Elem -> Expression $ Char8.pack (symbolVal (Proxy @colName))
85−
86−true :: Expression ps cols 'PGBool
87−true = Expression "true"
88−
89−false :: Expression ps cols 'PGBool
90−false = Expression "false"
91−
92−(.==)
93− :: Expression ps cols x
94− -> Expression ps cols x
95− -> Expression ps cols 'PGBool
96−(.==) (Expression x1) (Expression x2) = Expression $ x1 <> "=" <> x2
97−
98−(./=)
99− :: Expression ps cols x
100− -> Expression ps cols x
101− -> Expression ps cols 'PGBool
102−(./=) (Expression x1) (Expression x2) = Expression $ x1 <> "<>" <> x2
103−
104−(.>)
105− :: Expression ps cols x
106− -> Expression ps cols x
107− -> Expression ps cols 'PGBool
108−(.>) (Expression x1) (Expression x2) = Expression $ x1 <> ">" <> x2
109−
110−(.<)
111− :: Expression ps cols x
112− -> Expression ps cols x
113− -> Expression ps cols 'PGBool
114−(.<) (Expression x1) (Expression x2) = Expression $ x1 <> "<" <> x2
115−
116−(.>=)
117− :: Expression ps cols x
118− -> Expression ps cols x
119− -> Expression ps cols 'PGBool
120−(.>=) (Expression x1) (Expression x2) = Expression $ x1 <> ">=" <> x2
121−
122−(.<=)
123− :: Expression ps cols x
124− -> Expression ps cols x
125− -> Expression ps cols 'PGBool
126−(.<=) (Expression x1) (Expression x2) = Expression $ x1 <> "<=" <> x2
127−
128−instance IsString (Expression ps cols 'PGText) where
129− fromString str = Expression $ "\'" <> fromString str <> "\'"
130−
131−instance Num (Expression ps cols 'PGInt4) where
132− fromInteger n = Expression . fromString $ show n
133− Expression x + Expression y = Expression $ x <> "+" <> y
134− Expression x * Expression y = Expression $ x <> "*" <> y
135− Expression x - Expression y = Expression $ x <> "+" <> y
136− abs (Expression x) = Expression $ "@" <> x
137− signum (Expression x) = Expression $ "sign(" <> x <> ")"
138−
139−data Relation ps xs ys = Relation { unRelation :: ByteString } deriving Show
140−
141−star :: Relation ps xs xs
142−star = Relation "*"
143−
144−project :: Rec (Alias (Expression ps xs)) ys -> Relation ps xs ys
145−project
146− = Relation
147− . Char8.intercalate ", "
148− . recordToList
149− . rmap (Const . expressionString)
150− where
151− expressionString :: Alias (Expression ps xs) y -> ByteString
152− expressionString = \case
153− (As (Expression expr) :: Alias (Expression ps xs) y)
154− -> expr <> " AS " <> Char8.pack (symbolVal (Proxy @(Name y)))
155− (Elem :: Alias (Expression ps xs) y)
156− -> Char8.pack (symbolVal (Proxy @(Name y)))
157−
158−-- star :: Relation db params xs xs
159−-- star = Relation "SELECT * FROM "
160−
161−-- table
162−-- :: forall tableName tableCols db params.
163−-- ( KnownSymbol tableName
164−-- , (tableName ':= tableCols) `Elem` Unnamed db ~ 'True
165−-- ) => Proxy tableName -> Relation db params '[] tableCols
166−-- table (_ :: Proxy tableName) = Relation $
167−-- "SELECT * FROM " <> Char8.pack (symbolVal (Proxy @tableName))
168−
169−-- starFrom
170−-- :: forall tableName tableCols db params columns
171−-- . Alias (Relation params columns db) (tableName ':= tableCols)
172−-- -> Relation params columns db tableCols
173−-- starFrom = \case
174−-- As x -> x
175−-- Elem -> Relation $
176−-- "SELECT * FROM " <> Char8.pack (symbolVal (Proxy @tableName))
177−
178−-- from
179−-- :: Relation db params ys zs
180−-- -> Relation db params xs ys
181−-- -> Relation db params xs zs
182−-- from (Relation rel1) (Relation rel2) = Relation $ rel1 <> rel2
183−
184−-- project :: Rec (Alias (Expression ps xs)) ys -> Relation db params xs ys
185−-- project exprs = Relation $
186−-- "SELECT " <> Char8.intercalate "," (exprStrings exprs) <> " FROM "
187−-- where
188−-- exprStrings :: Rec (Alias (Expression ps xs)) ys -> [ByteString]
189−-- exprStrings = \case
190−-- RNil -> []
191−-- (As (Expression expr) :: Alias (Expression _ _) (exprName ':= _))
192−-- :& exprs ->
193−-- (expr <> " As " <> Char8.pack (symbolVal (Proxy @exprName)))
194−-- : expressionStrings exprs
195−
196−newtype Query
197− (db0 :: [Table])
198− (db1 :: [Table])
199− (ps :: [PGType])
200− (xs :: [Column])
201− = Query { unQuery :: ByteString }
202−
203−newtype PreparedQuery db0 db1 ps xs
204− = PreparedQuery { unPreparedQuery :: ByteString }
205−
206−-- select :: Relation ps ('[] :: [Column]) db xs -> Query db db ps xs
207−-- select (Relation x) = Query x
67+ :: forall ident xs x ps
68+ . HasField ident xs x
69+ => Aliased (Expression ps xs) (ident ':= x)
70+column = AS $ column_ (Proxy @ident)
71+
72+instance IsString (Expression ps xs 'PGText) where
73+ fromString str = UnsafeExpression $ "\'" <> fromString str <> "\'"
74+
75+instance Num (Expression ps xs 'PGInt4) where
76+ fromInteger n = UnsafeExpression . fromString $ show n
77+ x + y = UnsafeExpression $ renderExpression x <> "+" <> renderExpression y
78+ x * y = UnsafeExpression $ renderExpression x <> "*" <> renderExpression y
79+ UnsafeExpression x - UnsafeExpression y = UnsafeExpression $ x <> "+" <> y
80+ abs (UnsafeExpression x) = UnsafeExpression $ "@" <> x
81+ signum (UnsafeExpression x) = UnsafeExpression $ "sign(" <> x <> ")"
82+
83+instance Boolean (Expression ps xs 'PGBool) where
84+ true = UnsafeExpression "TRUE"
85+ false = UnsafeExpression "FALSE"
86+ notB x = UnsafeExpression $ "NOT " <> renderExpression x
87+ x &&* y = UnsafeExpression $
88+ renderExpression x <> " AND " <> renderExpression y
89+ x ||* y = UnsafeExpression $
90+ renderExpression x <> " OR " <> renderExpression y
91+
92+type instance BooleanOf (Expression ps xs y) = Expression ps xs 'PGBool
93+
94+instance IfB (Expression ps xs y) where
95+ ifB predicate then_ else_ = UnsafeExpression $ mconcat
96+ [ "CASE"
97+ , "\n WHEN ",renderExpression predicate
98+ , "\n THEN ",renderExpression then_
99+ , "\n ELSE ",renderExpression else_
100+ , "\nEND"
101+ ]
102+
103+instance EqB (Expression ps xs y) where
104+ x ==* y = UnsafeExpression $ renderExpression x <> "=" <> renderExpression y
105+ x /=* y = UnsafeExpression $ renderExpression x <> "<>" <> renderExpression y
106+
107+instance OrdB (Expression ps xs y) where
108+ x >* y = UnsafeExpression $ renderExpression x <> ">" <> renderExpression y
109+ x >=* y = UnsafeExpression $ renderExpression x <> ">=" <> renderExpression y
110+ x <* y = UnsafeExpression $ renderExpression x <> "<" <> renderExpression y
111+ x <=* y = UnsafeExpression $ renderExpression x <> "<=" <> renderExpression y
112+
113+data Relation ps xs ys = UnsafeRelation { renderRelation :: ByteString }
114+
115+table_
116+ :: forall ident xss xs ps
117+ . HasField ident xss xs
118+ => Proxy ident
119+ -> Relation ps xss xs
120+table_ (_ :: Proxy ident) = UnsafeRelation $
121+ fieldName (Proxy @ident) (Proxy @xss) (Proxy @xs)
122+
123+table
124+ :: forall ident xss xs ps
125+ . HasField ident xss xs
126+ => Aliased (Relation ps xss) (ident ':= xs)
127+table = AS $ table_ (Proxy @ident)
128+
129+newtype Query ps xss yss zs = UnsafeQuery { renderQuery :: ByteString }
130+newtype PreparedQuery ps xss yss zs =
131+ UnsafePreparedQuery { renderPreparedQuery :: ByteString }