git.iko.soy/squeal
on dev help sign in
Merge pull request #147 from morphismtech/dev-free

factor out free categories

commit1855995881c976622927976869cbdb9bb08e4672 authorEitan Chatav <eitan.chatav@gmail.com> dateMon 23 Sep 2019, 22:55 (7 years ago) parentccc4620ba71252
6 files changed+25−60
compare with dev
unifiedsplit
squeal-postgresql/squeal-postgresql.cabal+1 squeal-postgresql/src/Squeal/PostgreSQL/List.hs+5−43 squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+1−1 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+12−12 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+4−4 stack.yaml+2
squeal-postgresql/squeal-postgresql.cabal+1
@@ -63,6 +63,7 @@ library
6363 , bytestring >= 0.10.8.2
6464 , bytestring-strict-builder >= 0.4.5
6565 , deepseq >= 1.4.3.0
66+ , free-categories >= 0.1.0.0
6667 , generics-sop >= 0.3.2.0 && < 0.5.0.0
6768 , mmorph >= 1.1.1
6869 , mtl >= 2.2.2
squeal-postgresql/src/Squeal/PostgreSQL/List.hs+5−43
@@ -33,16 +33,16 @@ module Squeal.PostgreSQL.List
3333 , Join
3434 , disjoin
3535 , Additional (..)
36− , AlignedList (..)
37− , single
38− , extractList
39− , mapAligned
36+ , Path (..)
37+ , CFunctor (..)
38+ , CFoldable (..)
39+ , CFree (..)
4040 , Elem
4141 , In
4242 , Length
4343 ) where
4444
45−import Control.Category
45+import Control.Category.Free
4646import Data.Function ((&))
4747import Data.Kind
4848import Data.Type.Bool
@@ -50,8 +50,6 @@ import GHC.TypeLits
5050
5151import Generics.SOP as SOP
5252
53−import Squeal.PostgreSQL.Render
54−
5553-- | `Join` is simply promoted `++` and is used in @JOIN@s in
5654-- `Squeal.PostgreSQL.Query.FromClause`s.
5755type family Join xs ys where
@@ -78,42 +76,6 @@ instance Additional (NP expr) where
7876 Nil -> ys
7977 x :* xs -> x :* (xs & also ys)
8078
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−
11779-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
11880(*:) :: f x -> f y -> NP f '[x,y]
11981x *: 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
9999instance With Manipulation where
100100 with Done manip = manip
101101 with ctes manip = UnsafeManipulation $
102− "WITH" <+> renderSQL ctes <+> renderSQL manip
102+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip
103103
104104{- |
105105The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+12−12
@@ -66,7 +66,7 @@ let
6666 }
6767:}
6868
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`.
7070
7171>>> let migrations = makeUsers :>> makeEmails :>> Done
7272
@@ -190,34 +190,34 @@ data Migration p schemas0 schemas1 = Migration
190190
191191{- |
192192A `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
194194SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
195195-}
196196class Category p => Migratory p where
197197
198198 {- |
199− Run an `AlignedList` of `Migration`s.
199+ Run a `Path` of `Migration`s.
200200 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
201201 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
202202 if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
203203 -}
204204 migrateUp
205− :: AlignedList (Migration p) schemas0 schemas1
205+ :: Path (Migration p) schemas0 schemas1
206206 -> PQ schemas0 schemas1 IO ()
207207
208208 {- |
209− Rewind an `AlignedList` of `Migration`s.
209+ Rewind a `Path` of `Migration`s.
210210 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
211211 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
212212 if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
213213 -}
214214 migrateDown
215− :: AlignedList (Migration p) schemas0 schemas1
215+ :: Path (Migration p) schemas0 schemas1
216216 -> PQ schemas1 schemas0 IO ()
217217
218218instance Migratory Definition where
219− migrateUp = migrateUp . mapAligned pureMigration
220− migrateDown = migrateDown . mapAligned pureMigration
219+ migrateUp = migrateUp . cmap pureMigration
220+ migrateDown = migrateDown . cmap pureMigration
221221
222222{- | `Terminally` turns an indexed monad transformer and the monad it transforms
223223into a category by restricting the return type to @()@ and permuting the type variables.
@@ -266,7 +266,7 @@ instance Migratory (Terminally PQ IO) where
266266 where
267267
268268 upMigrations
269− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
269+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
270270 -> PQ MigrationsSchemas MigrationsSchemas IO ()
271271 upMigrations = \case
272272 Done -> return ()
@@ -295,7 +295,7 @@ instance Migratory (Terminally PQ IO) where
295295 where
296296
297297 downMigrations
298− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
298+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
299299 -> PQ MigrationsSchemas MigrationsSchemas IO ()
300300 downMigrations = \case
301301 Done -> return ()
@@ -382,7 +382,7 @@ defaultMain
382382 :: Migratory p
383383 => ByteString
384384 -- ^ connection string
385− -> AlignedList (Migration p) db0 db1
385+ -> Path (Migration p) db0 db1
386386 -- ^ migrations
387387 -> IO ()
388388defaultMain connectTo migrations = do
@@ -403,7 +403,7 @@ defaultMain connectTo migrations = do
403403 migrateStatus :: PQ schema schema IO ()
404404 migrateStatus = unsafePQ $ do
405405 runNames <- getRunMigrationNames
406− let names = extractList name migrations
406+ let names = ctoList name migrations
407407 unrunNames = names \\ runNames
408408 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
409409
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+4−4
@@ -1041,8 +1041,8 @@ instance
10411041 , commons1 ~ (cte ::: common ': commons)
10421042 ) => Aliasable cte
10431043 (statement commons schemas params common)
1044− (AlignedList (CommonTableExpression statement schemas params) commons commons1) where
1045− statement `as` cte = single (statement `as` cte)
1044+ (Path (CommonTableExpression statement schemas params) commons commons1) where
1045+ statement `as` cte = csingleton (statement `as` cte)
10461046
10471047instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
10481048 (CommonTableExpression statement schemas params commons0 commons1) where
@@ -1054,7 +1054,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
10541054-- defining temporary tables that exist just for one query.
10551055class With statement where
10561056 with
1057− :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1
1057+ :: Path (CommonTableExpression statement schemas params) commons0 commons1
10581058 -- ^ common table expressions
10591059 -> statement commons1 schemas params row
10601060 -- ^ larger query
@@ -1062,7 +1062,7 @@ class With statement where
10621062instance With (Query outer) where
10631063 with Done query = query
10641064 with ctes query = UnsafeQuery $
1065− "WITH" <+> renderSQL ctes <+> renderSQL query
1065+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
10661066
10671067{- |
10681068>>> import Data.Monoid (Sum (..))
stack.yaml+2
@@ -4,3 +4,5 @@ packages:
44
55extra-deps:
66- unliftio-pool-0.2.1.0
7+- github: morphismtech/free-categories
8+ commit: c0e555fbefb5c21619e532264c4dfeac556d0630