git.iko.soy/rowtype-yoga/purescript-yoga-postgres
on main help sign in
commit42c4438faa3d97d04002c80d402671de4b679a8f authorMark <mark.eibes@gmail.com> dateFri 13 Feb 2026, 15:32 (8 months ago) parent9ed1354
2 files changed+349−25
compare with main
unifiedsplit
src/Yoga/Postgres/Schema.purs+299−13 test/Schema.purs+50−12
src/Yoga/Postgres/Schema.purs+299−13
@@ -13,6 +13,7 @@ import Prim.RowList (class RowToList)
1313import Prim.Symbol (class Cons, class Append) as Symbol
1414import Prim.TypeError (class Fail, Beside, Text, Quote)
1515import Type.Proxy (Proxy(..))
16+import Type.RowList (class ListToRow)
1617
1718-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
1819-- Core phantom types
@@ -591,33 +592,318 @@ class SkipSpacesGo head tail result | head tail -> result
591592instance SkipSpaces tail result => SkipSpacesGo " " tail result
592593else instance Symbol.Cons head tail result => SkipSpacesGo head tail result
593594
595+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
596+-- Type utilities
597+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
598+
599+class UnwrapMaybe :: Type -> Type -> Constraint
600+class UnwrapMaybe a b | a -> b
601+
602+instance UnwrapMaybe (Maybe a) a
603+else instance UnwrapMaybe a a
604+
605+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
606+-- StripColumns: (name :: Column String None, ...) → (name :: String, ...)
607+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
608+
609+class StripColumnsRL :: RL.RowList Type -> RL.RowList Type -> Constraint
610+class StripColumnsRL rl out | rl -> out
611+
612+instance StripColumnsRL RL.Nil RL.Nil
613+instance StripColumnsRL tail out' => StripColumnsRL (RL.Cons name (Column typ constraints) tail) (RL.Cons name typ out')
614+
615+class StripColumns :: Row Type -> Row Type -> Constraint
616+class StripColumns cols result | cols -> result
617+
618+instance (RowToList cols rl, StripColumnsRL rl outRL, ListToRow outRL result) => StripColumns cols result
619+
620+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
621+-- ParseSelect: parse "name, email AS e" → RowList (name :: String, e :: String)
622+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
623+
624+class ParseSelect :: Symbol -> Row Type -> Row Type -> Constraint
625+class ParseSelect sym cols result | sym cols -> result
626+
627+instance ParseSelect "" cols ()
628+else instance
629+ ( Symbol.Cons h t sym
630+ , ParseSelectGo h t "" cols RL.Nil outRL
631+ , ListToRow outRL result
632+ ) =>
633+ ParseSelect sym cols result
634+
635+class ParseSelectGo :: Symbol -> Symbol -> Symbol -> Row Type -> RL.RowList Type -> RL.RowList Type -> Constraint
636+class ParseSelectGo head tail acc cols accRL outRL | head tail acc cols accRL -> outRL
637+
638+-- Comma: emit column, continue
639+instance
640+ ( Row.Cons acc (Column typ constraints) rest cols
641+ , SkipSpaces tail rest'
642+ , ParseSelectContinue rest' cols (RL.Cons acc typ accRL) outRL
643+ ) =>
644+ ParseSelectGo "," tail acc cols accRL outRL
645+
646+-- Space: column name done, check for AS or comma
647+else instance
648+ ( SkipSpaces tail rest
649+ , ParseSelectAfterCol acc rest cols accRL outRL
650+ ) =>
651+ ParseSelectGo " " tail acc cols accRL outRL
652+
653+-- End of string: emit final column
654+else instance
655+ ( Symbol.Append acc h acc'
656+ , Row.Cons acc' (Column typ constraints) rest cols
657+ ) =>
658+ ParseSelectGo h "" acc cols accRL (RL.Cons acc' typ accRL)
659+
660+-- Regular char: accumulate
661+else instance
662+ ( Symbol.Append acc h acc'
663+ , Symbol.Cons nextH nextT tail
664+ , ParseSelectGo nextH nextT acc' cols accRL outRL
665+ ) =>
666+ ParseSelectGo h tail acc cols accRL outRL
667+
668+-- After column name + space: AS alias, comma, or end
669+class ParseSelectAfterCol :: Symbol -> Symbol -> Row Type -> RL.RowList Type -> RL.RowList Type -> Constraint
670+class ParseSelectAfterCol colName rest cols accRL outRL | colName rest cols accRL -> outRL
671+
672+-- End: emit column with its own name
673+instance
674+ ( Row.Cons colName (Column typ constraints) rest' cols
675+ ) =>
676+ ParseSelectAfterCol colName "" cols accRL (RL.Cons colName typ accRL)
677+
678+-- Non-empty: branch on first char
679+else instance
680+ ( Symbol.Cons h t rest
681+ , ParseSelectAfterColByHead h t colName cols accRL outRL
682+ ) =>
683+ ParseSelectAfterCol colName rest cols accRL outRL
684+
685+class ParseSelectAfterColByHead :: Symbol -> Symbol -> Symbol -> Row Type -> RL.RowList Type -> RL.RowList Type -> Constraint
686+class ParseSelectAfterColByHead head tail colName cols accRL outRL | head tail colName cols accRL -> outRL
687+
688+-- Comma: emit column with own name, continue
689+instance
690+ ( Row.Cons colName (Column typ constraints) rest cols
691+ , SkipSpaces tail rest'
692+ , ParseSelectContinue rest' cols (RL.Cons colName typ accRL) outRL
693+ ) =>
694+ ParseSelectAfterColByHead "," tail colName cols accRL outRL
695+
696+-- Otherwise (AS ...): extract word
697+else instance
698+ ( Symbol.Append h t rest
699+ , ExtractWord rest word afterWord
700+ , ParseSelectHandleAS word afterWord colName cols accRL outRL
701+ ) =>
702+ ParseSelectAfterColByHead h t colName cols accRL outRL
703+
704+-- Handle AS keyword: extract alias name
705+class ParseSelectHandleAS :: Symbol -> Symbol -> Symbol -> Row Type -> RL.RowList Type -> RL.RowList Type -> Constraint
706+class ParseSelectHandleAS keyword afterKeyword colName cols accRL outRL | keyword afterKeyword colName cols accRL -> outRL
707+
708+instance
709+ ( ExtractWord afterKeyword alias afterAlias
710+ , Row.Cons colName (Column typ constraints) rest cols
711+ , SkipSpaces afterAlias rest'
712+ , ParseSelectExpectCommaOrEnd rest' cols (RL.Cons alias typ accRL) outRL
713+ ) =>
714+ ParseSelectHandleAS "AS" afterKeyword colName cols accRL outRL
715+
716+else instance
717+ ( ExtractWord afterKeyword alias afterAlias
718+ , Row.Cons colName (Column typ constraints) rest cols
719+ , SkipSpaces afterAlias rest'
720+ , ParseSelectExpectCommaOrEnd rest' cols (RL.Cons alias typ accRL) outRL
721+ ) =>
722+ ParseSelectHandleAS "as" afterKeyword colName cols accRL outRL
723+
724+class ParseSelectExpectCommaOrEnd :: Symbol -> Row Type -> RL.RowList Type -> RL.RowList Type -> Constraint
725+class ParseSelectExpectCommaOrEnd sym cols accRL outRL | sym cols accRL -> outRL
726+
727+instance ParseSelectExpectCommaOrEnd "" cols accRL accRL
728+else instance
729+ ( Symbol.Cons h t sym
730+ , ParseSelectExpectCommaOrEndByHead h t cols accRL outRL
731+ ) =>
732+ ParseSelectExpectCommaOrEnd sym cols accRL outRL
733+
734+class ParseSelectExpectCommaOrEndByHead :: Symbol -> Symbol -> Row Type -> RL.RowList Type -> RL.RowList Type -> Constraint
735+class ParseSelectExpectCommaOrEndByHead head tail cols accRL outRL | head tail cols accRL -> outRL
736+
737+instance
738+ ( SkipSpaces tail rest
739+ , ParseSelectContinue rest cols accRL outRL
740+ ) =>
741+ ParseSelectExpectCommaOrEndByHead "," tail cols accRL outRL
742+
743+-- Continue parsing more columns
744+class ParseSelectContinue :: Symbol -> Row Type -> RL.RowList Type -> RL.RowList Type -> Constraint
745+class ParseSelectContinue sym cols accRL outRL | sym cols accRL -> outRL
746+
747+instance ParseSelectContinue "" cols accRL accRL
748+else instance
749+ ( Symbol.Cons h t sym
750+ , ParseSelectGo h t "" cols accRL outRL
751+ ) =>
752+ ParseSelectContinue sym cols accRL outRL
753+
754+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
755+-- ParseWhere: parse "id = $id AND age > $age" → params (id :: Int, age :: Int)
756+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
757+
758+-- Sentinel type for "no current column type yet"
759+data NoType
760+
761+class ParseWhere :: Symbol -> Row Type -> Row Type -> Constraint
762+class ParseWhere sym cols params | sym cols -> params
763+
764+instance ParseWhere "" cols ()
765+else instance
766+ ( Symbol.Cons h t sym
767+ , ParseWhereGo h t "" NoType cols RL.Nil outRL
768+ , ListToRow outRL params
769+ ) =>
770+ ParseWhere sym cols params
771+
772+class ParseWhereGo :: Symbol -> Symbol -> Symbol -> Type -> Row Type -> RL.RowList Type -> RL.RowList Type -> Constraint
773+class ParseWhereGo head tail acc currentType cols paramsIn paramsOut | head tail acc currentType cols paramsIn -> paramsOut
774+
775+-- Space: flush word, continue
776+instance
777+ ( FlushWhereWord acc currentType cols paramsIn currentType' paramsOut'
778+ , SkipSpaces tail rest
779+ , ParseWhereContinue rest currentType' cols paramsOut' paramsOut
780+ ) =>
781+ ParseWhereGo " " tail acc currentType cols paramsIn paramsOut
782+
783+-- Operators: flush word, continue
784+else instance (FlushWhereWord acc currentType cols paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' cols paramsOut' paramsOut) => ParseWhereGo "=" tail acc currentType cols paramsIn paramsOut
785+else instance (FlushWhereWord acc currentType cols paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' cols paramsOut' paramsOut) => ParseWhereGo ">" tail acc currentType cols paramsIn paramsOut
786+else instance (FlushWhereWord acc currentType cols paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' cols paramsOut' paramsOut) => ParseWhereGo "<" tail acc currentType cols paramsIn paramsOut
787+else instance (FlushWhereWord acc currentType cols paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' cols paramsOut' paramsOut) => ParseWhereGo "!" tail acc currentType cols paramsIn paramsOut
788+else instance (FlushWhereWord acc currentType cols paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' cols paramsOut' paramsOut) => ParseWhereGo "(" tail acc currentType cols paramsIn paramsOut
789+else instance (FlushWhereWord acc currentType cols paramsIn currentType' paramsOut', ParseWhereContinue tail currentType' cols paramsOut' paramsOut) => ParseWhereGo ")" tail acc currentType cols paramsIn paramsOut
790+
791+-- End of string: flush final word
792+else instance
793+ ( Symbol.Append acc h acc'
794+ , FlushWhereWord acc' currentType cols paramsIn _ct paramsOut
795+ ) =>
796+ ParseWhereGo h "" acc currentType cols paramsIn paramsOut
797+
798+-- Regular char: accumulate
799+else instance
800+ ( Symbol.Append acc h acc'
801+ , Symbol.Cons nextH nextT tail
802+ , ParseWhereGo nextH nextT acc' currentType cols paramsIn paramsOut
803+ ) =>
804+ ParseWhereGo h tail acc currentType cols paramsIn paramsOut
805+
806+class ParseWhereContinue :: Symbol -> Type -> Row Type -> RL.RowList Type -> RL.RowList Type -> Constraint
807+class ParseWhereContinue sym currentType cols paramsIn paramsOut | sym currentType cols paramsIn -> paramsOut
808+
809+instance ParseWhereContinue "" currentType cols paramsIn paramsIn
810+else instance
811+ ( Symbol.Cons h t sym
812+ , ParseWhereGo h t "" currentType cols paramsIn paramsOut
813+ ) =>
814+ ParseWhereContinue sym currentType cols paramsIn paramsOut
815+
816+-- Flush a word in WHERE context: updates currentType and/or emits params
817+class FlushWhereWord :: Symbol -> Type -> Row Type -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
818+class FlushWhereWord word currentType cols paramsIn currentTypeOut paramsOut | word currentType cols paramsIn -> currentTypeOut paramsOut
819+
820+-- Empty: pass through
821+instance FlushWhereWord "" currentType cols paramsIn currentType paramsIn
822+
823+-- SQL keywords: pass through
824+else instance FlushWhereWord "AND" currentType cols paramsIn currentType paramsIn
825+else instance FlushWhereWord "OR" currentType cols paramsIn currentType paramsIn
826+else instance FlushWhereWord "NOT" currentType cols paramsIn currentType paramsIn
827+else instance FlushWhereWord "IS" currentType cols paramsIn currentType paramsIn
828+else instance FlushWhereWord "NULL" currentType cols paramsIn currentType paramsIn
829+else instance FlushWhereWord "LIKE" currentType cols paramsIn currentType paramsIn
830+else instance FlushWhereWord "ILIKE" currentType cols paramsIn currentType paramsIn
831+else instance FlushWhereWord "IN" currentType cols paramsIn currentType paramsIn
832+else instance FlushWhereWord "TRUE" currentType cols paramsIn currentType paramsIn
833+else instance FlushWhereWord "FALSE" currentType cols paramsIn currentType paramsIn
834+else instance FlushWhereWord "BETWEEN" currentType cols paramsIn currentType paramsIn
835+else instance FlushWhereWord "ANY" currentType cols paramsIn currentType paramsIn
836+else instance FlushWhereWord "ALL" currentType cols paramsIn currentType paramsIn
837+
838+-- Non-keyword: check first char
839+else instance
840+ ( Symbol.Cons head rest word
841+ , FlushWhereWordByHead head word currentType cols paramsIn currentTypeOut paramsOut
842+ ) =>
843+ FlushWhereWord word currentType cols paramsIn currentTypeOut paramsOut
844+
845+class FlushWhereWordByHead :: Symbol -> Symbol -> Type -> Row Type -> RL.RowList Type -> Type -> RL.RowList Type -> Constraint
846+class FlushWhereWordByHead head word currentType cols paramsIn currentTypeOut paramsOut | head word currentType cols paramsIn -> currentTypeOut paramsOut
847+
848+-- $param: extract param name (rest after $), emit with currentType
849+instance
850+ ( Symbol.Cons "$" paramName word
851+ ) =>
852+ FlushWhereWordByHead "$" word currentType cols paramsIn currentType (RL.Cons paramName currentType paramsIn)
853+
854+-- Digit: number literal, pass through
855+else instance FlushWhereWordByHead "0" word currentType cols paramsIn currentType paramsIn
856+else instance FlushWhereWordByHead "1" word currentType cols paramsIn currentType paramsIn
857+else instance FlushWhereWordByHead "2" word currentType cols paramsIn currentType paramsIn
858+else instance FlushWhereWordByHead "3" word currentType cols paramsIn currentType paramsIn
859+else instance FlushWhereWordByHead "4" word currentType cols paramsIn currentType paramsIn
860+else instance FlushWhereWordByHead "5" word currentType cols paramsIn currentType paramsIn
861+else instance FlushWhereWordByHead "6" word currentType cols paramsIn currentType paramsIn
862+else instance FlushWhereWordByHead "7" word currentType cols paramsIn currentType paramsIn
863+else instance FlushWhereWordByHead "8" word currentType cols paramsIn currentType paramsIn
864+else instance FlushWhereWordByHead "9" word currentType cols paramsIn currentType paramsIn
865+
866+-- Column name: look up type, strip Maybe, set as currentType
867+else instance
868+ ( Row.Cons word (Column typ constraints) rest cols
869+ , UnwrapMaybe typ unwrapped
870+ ) =>
871+ FlushWhereWordByHead head word currentType cols paramsIn unwrapped paramsIn
872+
873+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
594874-- Query builder
875+-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
595876
596−newtype Q :: Symbol -> Row Type -> Type
597−newtype Q name cols = Q String
877+newtype Q :: Symbol -> Row Type -> Row Type -> Row Type -> Type
878+newtype Q name cols result params = Q String
598879
599−from :: forall name cols. Proxy (Table name cols) -> Q name cols
880+from :: forall name cols. Proxy (Table name cols) -> Q name cols () ()
600881from _ = Q ""
601882
602−selectAll :: forall name cols. IsSymbol name => Q name cols -> Q name cols
883+selectAll
884+ :: forall name cols result r p
885+ . IsSymbol name
886+ => StripColumns cols result
887+ => Q name cols r p
888+ -> Q name cols result p
603889selectAll _ = Q ("SELECT * FROM " <> reflectSymbol (Proxy :: Proxy name))
604890
605891select
606− :: forall @sel name cols
892+ :: forall @sel name cols result r p
607893 . IsSymbol name
608894 => IsSymbol sel
609− => ValidateColumns sel cols
610− => Q name cols
611− -> Q name cols
895+ => ParseSelect sel cols result
896+ => Q name cols r p
897+ -> Q name cols result p
612898select _ = Q ("SELECT " <> reflectSymbol (Proxy :: Proxy sel) <> " FROM " <> reflectSymbol (Proxy :: Proxy name))
613899
614900where_
615− :: forall @whr name cols
901+ :: forall @whr name cols result params p
616902 . IsSymbol whr
617− => ValidateWhere whr cols
618− => Q name cols
619− -> Q name cols
903+ => ParseWhere whr cols params
904+ => Q name cols result p
905+ -> Q name cols result params
620906where_ (Q base) = Q (base <> " WHERE " <> reflectSymbol (Proxy :: Proxy whr))
621907
622−toSQL :: forall name cols. Q name cols -> String
908+toSQL :: forall name cols result params. Q name cols result params -> String
623909toSQL (Q s) = s
test/Schema.purs+50−12
@@ -88,23 +88,61 @@ deleteSQL = deleteSQLFor @UsersTable @(id :: Int)
8888usersTable :: Proxy UsersTable
8989usersTable = Proxy
9090
91+-- Type annotations prove the compiler tracks result and param types
92+
93+typedSelectAll
94+ :: Q "users" _
95+ (age :: Maybe Int, email :: String, id :: Int, name :: String)
96+ ()
97+typedSelectAll = from usersTable # selectAll
98+
99+typedSelectCols
100+ :: Q "users" _
101+ (name :: String, email :: String)
102+ ()
103+typedSelectCols = from usersTable # select @"name, email"
104+
105+typedSelectAlias
106+ :: Q "users" _
107+ (name :: String, e :: String)
108+ ()
109+typedSelectAlias = from usersTable # select @"name, email AS e"
110+
111+typedWhere
112+ :: Q "users" _
113+ (age :: Maybe Int, email :: String, id :: Int, name :: String)
114+ (id :: Int)
115+typedWhere = from usersTable # selectAll # where_ @"id = $id"
116+
117+typedWhereComplex
118+ :: Q "users" _
119+ (age :: Maybe Int, email :: String, id :: Int, name :: String)
120+ (name :: String, age :: Int)
121+typedWhereComplex = from usersTable # selectAll # where_ @"name = $name AND age > $age"
122+
123+typedSelectColsWhere
124+ :: Q "users" _
125+ (name :: String)
126+ (age :: Int)
127+typedSelectColsWhere = from usersTable # select @"name" # where_ @"age > $age"
128+
91129builderSelectAll :: String
92−builderSelectAll = from usersTable # selectAll # toSQL
130+builderSelectAll = typedSelectAll # toSQL
93131
94132builderSelectCols :: String
95−builderSelectCols = from usersTable # select @"name, email" # toSQL
133+builderSelectCols = typedSelectCols # toSQL
134+
135+builderSelectAlias :: String
136+builderSelectAlias = typedSelectAlias # toSQL
96137
97138builderSelectWhere :: String
98−builderSelectWhere = from usersTable # selectAll # where_ @"id = $1" # toSQL
139+builderSelectWhere = typedWhere # toSQL
99140
100141builderSelectColsWhere :: String
101−builderSelectColsWhere = from usersTable # select @"name" # where_ @"age > $1" # toSQL
102−
103−builderSelectAlias :: String
104−builderSelectAlias = from usersTable # select @"name AS n, email AS e" # toSQL
142+builderSelectColsWhere = typedSelectColsWhere # toSQL
105143
106144builderWhereComplex :: String
107−builderWhereComplex = from usersTable # selectAll # where_ @"name = $1 AND age > $2" # toSQL
145+builderWhereComplex = typedWhereComplex # toSQL
108146
109147-- ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
110148-- Spec
@@ -156,10 +194,10 @@ spec = do
156194 it "builds SELECT with columns" do
157195 builderSelectCols `shouldEqual` "SELECT name, email FROM users"
158196 it "builds SELECT * with WHERE" do
159− builderSelectWhere `shouldEqual` "SELECT * FROM users WHERE id = $1"
197+ builderSelectWhere `shouldEqual` "SELECT * FROM users WHERE id = $id"
160198 it "builds SELECT columns with WHERE" do
161− builderSelectColsWhere `shouldEqual` "SELECT name FROM users WHERE age > $1"
199+ builderSelectColsWhere `shouldEqual` "SELECT name FROM users WHERE age > $age"
162200 it "builds SELECT with aliases" do
163− builderSelectAlias `shouldEqual` "SELECT name AS n, email AS e FROM users"
201+ builderSelectAlias `shouldEqual` "SELECT name, email AS e FROM users"
164202 it "builds complex WHERE" do
165− builderWhereComplex `shouldEqual` "SELECT * FROM users WHERE name = $1 AND age > $2"
203+ builderWhereComplex `shouldEqual` "SELECT * FROM users WHERE name = $name AND age > $age"