git.iko.soy/squeal
on dev help sign in
Merge pull request #147 from morphismtech/dev-free
1855995Eitan Chatav
squeal-postgresql/squeal-postgresql.cabal+1
compare with dev
unifiedsplit
@@ -63,6 +63,7 @@ library
63 , bytestring >= 0.10.8.2
63 , bytestring >= 0.10.8.2
64 , bytestring-strict-builder >= 0.4.5
64 , bytestring-strict-builder >= 0.4.5
65 , deepseq >= 1.4.3.0
65 , deepseq >= 1.4.3.0
66+ , free-categories >= 0.1.0.0
66 , generics-sop >= 0.3.2.0 && < 0.5.0.0
67 , generics-sop >= 0.3.2.0 && < 0.5.0.0
67 , mmorph >= 1.1.1
68 , mmorph >= 1.1.1
68 , mtl >= 2.2.2
69 , mtl >= 2.2.2
squeal-postgresql/src/Squeal/PostgreSQL/List.hs+5−43
@@ -33,16 +33,16 @@ module Squeal.PostgreSQL.List
33 , Join
33 , Join
34 , disjoin
34 , disjoin
35 , Additional (..)
35 , Additional (..)
36− , AlignedList (..)
36+ , Path (..)
37− , single
37+ , CFunctor (..)
38− , extractList
38+ , CFoldable (..)
39− , mapAligned
39+ , CFree (..)
40 , Elem
40 , Elem
41 , In
41 , In
42 , Length
42 , Length
43 ) where
43 ) where
44
44
45−import Control.Category
45+import Control.Category.Free
46import Data.Function ((&))
46import Data.Function ((&))
47import Data.Kind
47import Data.Kind
48import Data.Type.Bool
48import Data.Type.Bool
@@ -50,8 +50,6 @@ import GHC.TypeLits
50
50
51import Generics.SOP as SOP
51import Generics.SOP as SOP
52
52
53−import Squeal.PostgreSQL.Render
54−
55-- | `Join` is simply promoted `++` and is used in @JOIN@s in
53-- | `Join` is simply promoted `++` and is used in @JOIN@s in
56-- `Squeal.PostgreSQL.Query.FromClause`s.
54-- `Squeal.PostgreSQL.Query.FromClause`s.
57type family Join xs ys where
55type family Join xs ys where
@@ -78,42 +76,6 @@ instance Additional (NP expr) where
78 Nil -> ys
76 Nil -> ys
79 x :* xs -> x :* (xs & also ys)
77 x :* xs -> x :* (xs & also ys)
80
78
81−-- | An `AlignedList` is a type-aligned list or free category.
82−data AlignedList p x0 x1 where
83− Done :: AlignedList p x x
84− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
85−infixr 7 :>>
86−instance Category (AlignedList p) where
87− id = Done
88− (.) list = \case
89− Done -> list
90− step :>> steps -> step :>> (steps >>> list)
91−instance (forall t0 t1. RenderSQL (p t0 t1))
92− => RenderSQL (AlignedList p x0 x1) where
93− renderSQL = \case
94− Done -> ""
95− step :>> Done -> renderSQL step
96− step :>> steps -> renderSQL step <> ", " <> renderSQL steps
97−
98−-- | `extractList` turns an `AlignedList` into a standard list.
99−extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]
100−extractList f = \case
101− Done -> []
102− step :>> steps -> (f step):extractList f steps
103−
104−-- | `mapAligned` applies a function to each element of an `AlignedList`.
105−mapAligned
106− :: (forall z0 z1. p z0 z1 -> q z0 z1)
107− -> AlignedList p x0 x1
108− -> AlignedList q x0 x1
109−mapAligned f = \case
110− Done -> Done
111− x :>> xs -> f x :>> mapAligned f xs
112−
113−-- | A `single` step.
114−single :: p x0 x1 -> AlignedList p x0 x1
115−single step = step :>> Done
116−
117-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
79-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
118(*:) :: f x -> f y -> NP f '[x,y]
80(*:) :: f x -> f y -> NP f '[x,y]
119x *: y = x :* y :* Nil
81x *: y = x :* y :* Nil
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+1−1
@@ -99,7 +99,7 @@ instance RenderSQL (Manipulation commons schemas params columns) where
99instance With Manipulation where
99instance With Manipulation where
100 with Done manip = manip
100 with Done manip = manip
101 with ctes manip = UnsafeManipulation $
101 with ctes manip = UnsafeManipulation $
102− "WITH" <+> renderSQL ctes <+> renderSQL manip
102+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip
103
103
104{- |
104{- |
105The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
105The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+12−12
@@ -66,7 +66,7 @@ let
66 }
66 }
67:}
67:}
68
68
69−Now that we have a couple migrations we can chain them together into an `AlignedList`.
69+Now that we have a couple migrations we can chain them together into a `Path`.
70
70
71>>> let migrations = makeUsers :>> makeEmails :>> Done
71>>> let migrations = makeUsers :>> makeEmails :>> Done
72
72
@@ -190,34 +190,34 @@ data Migration p schemas0 schemas1 = Migration
190
190
191{- |
191{- |
192A `Migratory` @p@ is a `Category` for which one can execute or rewind
192A `Migratory` @p@ is a `Category` for which one can execute or rewind
193−an `AlignedList` of `Migration`s over @p@. This includes the category of pure
193+a `Path` of `Migration`s over @p@. This includes the category of pure
194SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
194SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
195-}
195-}
196class Category p => Migratory p where
196class Category p => Migratory p where
197
197
198 {- |
198 {- |
199− Run an `AlignedList` of `Migration`s.
199+ Run a `Path` of `Migration`s.
200 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
200 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
201 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
201 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
202 if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
202 if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
203 -}
203 -}
204 migrateUp
204 migrateUp
205− :: AlignedList (Migration p) schemas0 schemas1
205+ :: Path (Migration p) schemas0 schemas1
206 -> PQ schemas0 schemas1 IO ()
206 -> PQ schemas0 schemas1 IO ()
207
207
208 {- |
208 {- |
209− Rewind an `AlignedList` of `Migration`s.
209+ Rewind a `Path` of `Migration`s.
210 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
210 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
211 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
211 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
212 if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
212 if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
213 -}
213 -}
214 migrateDown
214 migrateDown
215− :: AlignedList (Migration p) schemas0 schemas1
215+ :: Path (Migration p) schemas0 schemas1
216 -> PQ schemas1 schemas0 IO ()
216 -> PQ schemas1 schemas0 IO ()
217
217
218instance Migratory Definition where
218instance Migratory Definition where
219− migrateUp = migrateUp . mapAligned pureMigration
219+ migrateUp = migrateUp . cmap pureMigration
220− migrateDown = migrateDown . mapAligned pureMigration
220+ migrateDown = migrateDown . cmap pureMigration
221
221
222{- | `Terminally` turns an indexed monad transformer and the monad it transforms
222{- | `Terminally` turns an indexed monad transformer and the monad it transforms
223into a category by restricting the return type to @()@ and permuting the type variables.
223into a category by restricting the return type to @()@ and permuting the type variables.
@@ -266,7 +266,7 @@ instance Migratory (Terminally PQ IO) where
266 where
266 where
267
267
268 upMigrations
268 upMigrations
269− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
269+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
270 -> PQ MigrationsSchemas MigrationsSchemas IO ()
270 -> PQ MigrationsSchemas MigrationsSchemas IO ()
271 upMigrations = \case
271 upMigrations = \case
272 Done -> return ()
272 Done -> return ()
@@ -295,7 +295,7 @@ instance Migratory (Terminally PQ IO) where
295 where
295 where
296
296
297 downMigrations
297 downMigrations
298− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
298+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
299 -> PQ MigrationsSchemas MigrationsSchemas IO ()
299 -> PQ MigrationsSchemas MigrationsSchemas IO ()
300 downMigrations = \case
300 downMigrations = \case
301 Done -> return ()
301 Done -> return ()
@@ -382,7 +382,7 @@ defaultMain
382 :: Migratory p
382 :: Migratory p
383 => ByteString
383 => ByteString
384 -- ^ connection string
384 -- ^ connection string
385− -> AlignedList (Migration p) db0 db1
385+ -> Path (Migration p) db0 db1
386 -- ^ migrations
386 -- ^ migrations
387 -> IO ()
387 -> IO ()
388defaultMain connectTo migrations = do
388defaultMain connectTo migrations = do
@@ -403,7 +403,7 @@ defaultMain connectTo migrations = do
403 migrateStatus :: PQ schema schema IO ()
403 migrateStatus :: PQ schema schema IO ()
404 migrateStatus = unsafePQ $ do
404 migrateStatus = unsafePQ $ do
405 runNames <- getRunMigrationNames
405 runNames <- getRunMigrationNames
406− let names = extractList name migrations
406+ let names = ctoList name migrations
407 unrunNames = names \\ runNames
407 unrunNames = names \\ runNames
408 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
408 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
409
409
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+4−4
@@ -1041,8 +1041,8 @@ instance
1041 , commons1 ~ (cte ::: common ': commons)
1041 , commons1 ~ (cte ::: common ': commons)
1042 ) => Aliasable cte
1042 ) => Aliasable cte
1043 (statement commons schemas params common)
1043 (statement commons schemas params common)
1044− (AlignedList (CommonTableExpression statement schemas params) commons commons1) where
1044+ (Path (CommonTableExpression statement schemas params) commons commons1) where
1045− statement `as` cte = single (statement `as` cte)
1045+ statement `as` cte = csingleton (statement `as` cte)
1046
1046
1047instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1047instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1048 (CommonTableExpression statement schemas params commons0 commons1) where
1048 (CommonTableExpression statement schemas params commons0 commons1) where
@@ -1054,7 +1054,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1054-- defining temporary tables that exist just for one query.
1054-- defining temporary tables that exist just for one query.
1055class With statement where
1055class With statement where
1056 with
1056 with
1057− :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1
1057+ :: Path (CommonTableExpression statement schemas params) commons0 commons1
1058 -- ^ common table expressions
1058 -- ^ common table expressions
1059 -> statement commons1 schemas params row
1059 -> statement commons1 schemas params row
1060 -- ^ larger query
1060 -- ^ larger query
@@ -1062,7 +1062,7 @@ class With statement where
1062instance With (Query outer) where
1062instance With (Query outer) where
1063 with Done query = query
1063 with Done query = query
1064 with ctes query = UnsafeQuery $
1064 with ctes query = UnsafeQuery $
1065− "WITH" <+> renderSQL ctes <+> renderSQL query
1065+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
1066
1066
1067{- |
1067{- |
1068>>> import Data.Monoid (Sum (..))
1068>>> import Data.Monoid (Sum (..))
stack.yaml+2
@@ -4,3 +4,5 @@ packages:
4
4
5extra-deps:
5extra-deps:
6- unliftio-pool-0.2.1.0
6- unliftio-pool-0.2.1.0
7+- github: morphismtech/free-categories
8+ commit: c0e555fbefb5c21619e532264c4dfeac556d0630