@@ -1,8 +1,11 @@
11{-# LANGUAGE
22 DataKinds
3+ , FlexibleContexts
34 , FlexibleInstances
45 , GADTs
6+ , MagicHash
57 , MultiParamTypeClasses
8+ , OverloadedLabels
69 , OverloadedStrings
710 , PolyKinds
811 , RankNTypes
@@ -20,82 +23,77 @@ import Data.Monoid
2023import Data.Proxy
2124import Data.String
2225import Data.Vinyl
23−-- import Data.Vinyl.Functor
26+import GHC.OverloadedLabels
2427import GHC.TypeLits
2528
26−-- import qualified Data.ByteString as ByteString
2729import qualified Data.ByteString.Char8 as Char8
2830
2931import Squeel.PostgreSQL.Type
3032
31−newtype Expression ps xs y =
32− UnsafeExpression { renderExpression :: ByteString }
33−
34−param1 :: Expression (p1:ps) cols p1
35−param1 = UnsafeExpression "$1"
36−param2 :: Expression (p1:p2:ps) cols p2
37−param2 = UnsafeExpression "$2"
38−param3 :: Expression (p1:p2:p3:ps) cols p3
39−param3 = UnsafeExpression "$3"
40−param4 :: Expression (p1:p2:p3:p4:ps) cols p4
41−param4 = UnsafeExpression "$4"
42−param5 :: Expression (p1:p2:p3:p4:p5:ps) cols p5
43−param5 = UnsafeExpression "$5"
44−
45−class HasField ident xs x where
46− fieldName :: Proxy ident -> Proxy xs -> Proxy x -> ByteString
47−instance KnownSymbol name => HasField '[name] ((name ':= x) ': xs) x where
48− fieldName _ _ _ = Char8.pack (symbolVal (Proxy @name))
49−instance HasField ident xs x => HasField ident (y ': xs) x where
50− fieldName _ _ _ = fieldName (Proxy @ident) (Proxy @xs) (Proxy @x)
51−instance (KnownSymbol name, HasField names xs x)
52− => HasField (name ': names) ((name ':= xs) ': xss) x where
53− fieldName _ _ _ = Char8.pack (symbolVal (Proxy @name))
54− <> "." <> fieldName (Proxy @names) (Proxy @xs) (Proxy @x)
55−
56−column_
57− :: forall ident xs x ps
58− . HasField ident xs x
59− => Proxy ident
60− -> Expression ps xs x
61−column_ (_ :: Proxy ident) = UnsafeExpression $
62− fieldName (Proxy @ident) (Proxy @xs) (Proxy @x)
63−
64−data Identified ident x = (:=) ident x
65−data Aliased obj named where AS :: obj x -> Aliased obj (name ':= x)
66−
67−unalias :: Aliased obj (name ':= x) -> obj x
68−unalias (AS obj) = obj
69−
70−column
71− :: forall ident xs x ps
72− . HasField ident xs x
73− => Aliased (Expression ps xs) (ident ':= x)
74−column = AS $ column_ (Proxy @ident)
33+class HasField label xs x where
34+ fieldName :: Proxy label -> Proxy xs -> Proxy x -> ByteString
35+instance {-# OVERLAPPING #-} KnownSymbol label
36+ => HasField label ('(label, x) ': xs) x where
37+ fieldName _ _ _ = Char8.pack (symbolVal (Proxy @label))
38+instance {-# OVERLAPPABLE #-} HasField label xs y
39+ => HasField label (x ': xs) y where
40+ fieldName _ _ _ = fieldName (Proxy @label) (Proxy @xs) (Proxy @y)
41+
42+data Alias label = Alias
43+data Aliased obj labeled where
44+ As :: obj x -> Alias label -> Aliased obj '(label, x)
45+instance IsLabel label (Alias label) where fromLabel _ = Alias
46+instance IsLabel label (obj x)
47+ => IsLabel label (Aliased obj '(label, x)) where
48+ fromLabel p = fromLabel p `As` fromLabel p
49+
50+alias :: Aliased obj '(label, x) -> Alias label
51+alias _ = Alias
52+
53+unalias :: Aliased obj '(label, x) -> obj x
54+unalias (obj `As` _) = obj
7555
7656renderAliased
77− :: KnownSymbol name
57+ :: KnownSymbol label
7858 => (obj x -> ByteString)
79− -> Aliased obj (name ':= x)
59+ -> Aliased obj '(label, x)
8060 -> ByteString
81−renderAliased render (AS obj :: Aliased obj (name ':= x)) =
82− render obj <> " AS " <> Char8.pack (symbolVal (Proxy @name))
61+renderAliased render (obj `As` label) =
62+ render obj <> " AS " <> Char8.pack (symbolVal label)
8363
8464class AllAliased xs where
8565 renderAllAliased
8666 :: (forall x. obj x -> ByteString)
8767 -> Rec (Aliased obj) xs
8868 -> ByteString
89−instance KnownSymbol name => AllAliased '[name ':= x] where
69+instance KnownSymbol label => AllAliased '[ '(label, x)] where
9070 renderAllAliased render
91− (aliased :& RNil :: Rec (Aliased obj) '[name ':= x]) =
71+ (aliased :& RNil :: Rec (Aliased obj) '[ '(label, x)]) =
9272 renderAliased render aliased
93−instance (KnownSymbol name, AllAliased xs)
94− => AllAliased ((name ':= x) ': xs) where
73+instance (KnownSymbol label, AllAliased (x' ': xs))
74+ => AllAliased ('(label, x) ': (x' ': xs)) where
9575 renderAllAliased render
96− (x :& xs :: Rec (Aliased obj) ((name ':= x) ': xs)) =
76+ (x :& xs :: Rec (Aliased obj) ('(label, x) ': x' : xs)) =
9777 renderAliased render x <> ", " <> renderAllAliased render xs
9878
79+newtype Expression ps xs y =
80+ UnsafeExpression { renderExpression :: ByteString }
81+
82+param1 :: Expression (p1:ps) cols p1
83+param1 = UnsafeExpression "$1"
84+param2 :: Expression (p1:p2:ps) cols p2
85+param2 = UnsafeExpression "$2"
86+param3 :: Expression (p1:p2:p3:ps) cols p3
87+param3 = UnsafeExpression "$3"
88+param4 :: Expression (p1:p2:p3:p4:ps) cols p4
89+param4 = UnsafeExpression "$4"
90+param5 :: Expression (p1:p2:p3:p4:p5:ps) cols p5
91+param5 = UnsafeExpression "$5"
92+
93+instance HasField label xs x => IsLabel label (Expression ps xs x) where
94+ fromLabel _ = UnsafeExpression $
95+ fieldName (Proxy @label) (Proxy @xs) (Proxy @x)
96+
9997instance IsString (Expression ps xs 'PGText) where
10098 fromString str = UnsafeExpression $ "\'" <> fromString str <> "\'"
10199
@@ -149,47 +147,52 @@ project
149147 -> Projection ps xs ys
150148project = UnsafeProjection . renderAllAliased renderExpression
151149
152−newtype Relation ps xss ys = UnsafeRelation
153− { renderRelation :: ByteString }
150+data Tabulation ps xss xs = UnsafeTabulation
151+ { renderTabulation :: ByteString }
154152
155−table_
156− :: forall ident xss xs ps
157− . HasField ident xss xs
158− => Proxy ident
159− -> Relation ps xss xs
160−table_ (_ :: Proxy ident) = UnsafeRelation $
161− fieldName (Proxy @ident) (Proxy @xss) (Proxy @xs)
162−
163−table
164− :: forall ident xss xs ps
165− . HasField ident xss xs
166− => Aliased (Relation ps xss) (ident ':= xs)
167−table = AS $ table_ (Proxy @ident)
168−
169−data Selection ps xss xs ys = Selection
170− { projection :: Projection ps xs ys
171− , relation :: Relation ps xss xs
153+data Relation ps xss xs = Relation
154+ { tabulation :: Tabulation ps xss xs
172155 , restriction :: Maybe (Expression ps xs 'PGBool)
173156 }
174157
175−renderSelection :: Selection ps xss xs ys -> ByteString
176−renderSelection (Selection xs ys wh) =
177− renderProjection xs <> " FROM " <> renderRelation ys
178− <> maybe "" ((" WHERE " <>) . renderExpression) wh
179−
180−from :: Projection ps xs ys -> Relation ps xss xs -> Selection ps xss xs ys
181−ys `from` xs = Selection ys xs Nothing
158+renderRelation :: Relation ps xss xs -> ByteString
159+renderRelation (Relation tab wh) =
160+ renderTabulation tab <> maybe "" ((" WHERE " <>) . renderExpression) wh
182161
183162where_
184− :: Selection ps xss xs ys
163+ :: Relation ps xss xs
185164 -> Expression ps xs 'PGBool
186− -> Selection ps xss xs ys
165+ -> Relation ps xss xs
187166ys `where_` condition = ys
188167 { restriction = case restriction ys of
189168 Nothing -> Just condition
190− Just conditions -> Just (condition &&* conditions)
169+ Just conditions -> Just (conditions &&* condition)
170+ }
171+
172+instance HasField label xss xs
173+ => IsLabel label (Relation ps xss xs) where
174+ fromLabel _ = Relation
175+ { tabulation = UnsafeTabulation $
176+ fieldName (Proxy @label) (Proxy @xss) (Proxy @xs)
177+ , restriction = Nothing
178+ }
179+
180+newtype Selection ps xss ys = UnsafeSelection
181+ { renderSelection :: ByteString }
182+
183+from :: Projection ps xs ys -> Relation ps xss xs -> Selection ps xss ys
184+ys `from` xs = UnsafeSelection $
185+ renderProjection ys <> " FROM " <> renderRelation xs
186+
187+subselect :: Selection ps xss ys -> Relation ps xss ys
188+subselect selection = Relation
189+ { tabulation = UnsafeTabulation $ "SELECT " <> renderSelection selection
190+ , restriction = Nothing
191191 }
192192
193193newtype Query ps xss yss zs = UnsafeQuery { renderQuery :: ByteString }
194194newtype PreparedQuery ps xss yss zs =
195195 UnsafePreparedQuery { renderPreparedQuery :: ByteString }
196+
197+select :: Selection ps xss ys -> Query ps xss xss ys
198+select selection = UnsafeQuery $ "SELECT " <> renderSelection selection <> ";"