mirror of
https://github.com/ilyakooo0/squeal.git
synced 2024-09-11 13:57:29 +03:00
Merge pull request #147 from morphismtech/dev-free
factor out free categories
This commit is contained in:
commit
1855995881
@ -63,6 +63,7 @@ library
|
||||
, bytestring >= 0.10.8.2
|
||||
, bytestring-strict-builder >= 0.4.5
|
||||
, deepseq >= 1.4.3.0
|
||||
, free-categories >= 0.1.0.0
|
||||
, generics-sop >= 0.3.2.0 && < 0.5.0.0
|
||||
, mmorph >= 1.1.1
|
||||
, mtl >= 2.2.2
|
||||
|
@ -33,16 +33,16 @@ module Squeal.PostgreSQL.List
|
||||
, Join
|
||||
, disjoin
|
||||
, Additional (..)
|
||||
, AlignedList (..)
|
||||
, single
|
||||
, extractList
|
||||
, mapAligned
|
||||
, Path (..)
|
||||
, CFunctor (..)
|
||||
, CFoldable (..)
|
||||
, CFree (..)
|
||||
, Elem
|
||||
, In
|
||||
, Length
|
||||
) where
|
||||
|
||||
import Control.Category
|
||||
import Control.Category.Free
|
||||
import Data.Function ((&))
|
||||
import Data.Kind
|
||||
import Data.Type.Bool
|
||||
@ -50,8 +50,6 @@ import GHC.TypeLits
|
||||
|
||||
import Generics.SOP as SOP
|
||||
|
||||
import Squeal.PostgreSQL.Render
|
||||
|
||||
-- | `Join` is simply promoted `++` and is used in @JOIN@s in
|
||||
-- `Squeal.PostgreSQL.Query.FromClause`s.
|
||||
type family Join xs ys where
|
||||
@ -78,42 +76,6 @@ instance Additional (NP expr) where
|
||||
Nil -> ys
|
||||
x :* xs -> x :* (xs & also ys)
|
||||
|
||||
-- | An `AlignedList` is a type-aligned list or free category.
|
||||
data AlignedList p x0 x1 where
|
||||
Done :: AlignedList p x x
|
||||
(:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
|
||||
infixr 7 :>>
|
||||
instance Category (AlignedList p) where
|
||||
id = Done
|
||||
(.) list = \case
|
||||
Done -> list
|
||||
step :>> steps -> step :>> (steps >>> list)
|
||||
instance (forall t0 t1. RenderSQL (p t0 t1))
|
||||
=> RenderSQL (AlignedList p x0 x1) where
|
||||
renderSQL = \case
|
||||
Done -> ""
|
||||
step :>> Done -> renderSQL step
|
||||
step :>> steps -> renderSQL step <> ", " <> renderSQL steps
|
||||
|
||||
-- | `extractList` turns an `AlignedList` into a standard list.
|
||||
extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]
|
||||
extractList f = \case
|
||||
Done -> []
|
||||
step :>> steps -> (f step):extractList f steps
|
||||
|
||||
-- | `mapAligned` applies a function to each element of an `AlignedList`.
|
||||
mapAligned
|
||||
:: (forall z0 z1. p z0 z1 -> q z0 z1)
|
||||
-> AlignedList p x0 x1
|
||||
-> AlignedList q x0 x1
|
||||
mapAligned f = \case
|
||||
Done -> Done
|
||||
x :>> xs -> f x :>> mapAligned f xs
|
||||
|
||||
-- | A `single` step.
|
||||
single :: p x0 x1 -> AlignedList p x0 x1
|
||||
single step = step :>> Done
|
||||
|
||||
-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
|
||||
(*:) :: f x -> f y -> NP f '[x,y]
|
||||
x *: y = x :* y :* Nil
|
||||
|
@ -99,7 +99,7 @@ instance RenderSQL (Manipulation commons schemas params columns) where
|
||||
instance With Manipulation where
|
||||
with Done manip = manip
|
||||
with ctes manip = UnsafeManipulation $
|
||||
"WITH" <+> renderSQL ctes <+> renderSQL manip
|
||||
"WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip
|
||||
|
||||
{- |
|
||||
The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
|
||||
|
@ -66,7 +66,7 @@ let
|
||||
}
|
||||
:}
|
||||
|
||||
Now that we have a couple migrations we can chain them together into an `AlignedList`.
|
||||
Now that we have a couple migrations we can chain them together into a `Path`.
|
||||
|
||||
>>> let migrations = makeUsers :>> makeEmails :>> Done
|
||||
|
||||
@ -190,34 +190,34 @@ data Migration p schemas0 schemas1 = Migration
|
||||
|
||||
{- |
|
||||
A `Migratory` @p@ is a `Category` for which one can execute or rewind
|
||||
an `AlignedList` of `Migration`s over @p@. This includes the category of pure
|
||||
a `Path` of `Migration`s over @p@. This includes the category of pure
|
||||
SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
|
||||
-}
|
||||
class Category p => Migratory p where
|
||||
|
||||
{- |
|
||||
Run an `AlignedList` of `Migration`s.
|
||||
Run a `Path` of `Migration`s.
|
||||
Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
|
||||
In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
|
||||
if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
|
||||
-}
|
||||
migrateUp
|
||||
:: AlignedList (Migration p) schemas0 schemas1
|
||||
:: Path (Migration p) schemas0 schemas1
|
||||
-> PQ schemas0 schemas1 IO ()
|
||||
|
||||
{- |
|
||||
Rewind an `AlignedList` of `Migration`s.
|
||||
Rewind a `Path` of `Migration`s.
|
||||
Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
|
||||
In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
|
||||
if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
|
||||
-}
|
||||
migrateDown
|
||||
:: AlignedList (Migration p) schemas0 schemas1
|
||||
:: Path (Migration p) schemas0 schemas1
|
||||
-> PQ schemas1 schemas0 IO ()
|
||||
|
||||
instance Migratory Definition where
|
||||
migrateUp = migrateUp . mapAligned pureMigration
|
||||
migrateDown = migrateDown . mapAligned pureMigration
|
||||
migrateUp = migrateUp . cmap pureMigration
|
||||
migrateDown = migrateDown . cmap pureMigration
|
||||
|
||||
{- | `Terminally` turns an indexed monad transformer and the monad it transforms
|
||||
into a category by restricting the return type to @()@ and permuting the type variables.
|
||||
@ -266,7 +266,7 @@ instance Migratory (Terminally PQ IO) where
|
||||
where
|
||||
|
||||
upMigrations
|
||||
:: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
|
||||
:: Path (Migration (Terminally PQ IO)) schemas0 schemas1
|
||||
-> PQ MigrationsSchemas MigrationsSchemas IO ()
|
||||
upMigrations = \case
|
||||
Done -> return ()
|
||||
@ -295,7 +295,7 @@ instance Migratory (Terminally PQ IO) where
|
||||
where
|
||||
|
||||
downMigrations
|
||||
:: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
|
||||
:: Path (Migration (Terminally PQ IO)) schemas0 schemas1
|
||||
-> PQ MigrationsSchemas MigrationsSchemas IO ()
|
||||
downMigrations = \case
|
||||
Done -> return ()
|
||||
@ -382,7 +382,7 @@ defaultMain
|
||||
:: Migratory p
|
||||
=> ByteString
|
||||
-- ^ connection string
|
||||
-> AlignedList (Migration p) db0 db1
|
||||
-> Path (Migration p) db0 db1
|
||||
-- ^ migrations
|
||||
-> IO ()
|
||||
defaultMain connectTo migrations = do
|
||||
@ -403,7 +403,7 @@ defaultMain connectTo migrations = do
|
||||
migrateStatus :: PQ schema schema IO ()
|
||||
migrateStatus = unsafePQ $ do
|
||||
runNames <- getRunMigrationNames
|
||||
let names = extractList name migrations
|
||||
let names = ctoList name migrations
|
||||
unrunNames = names \\ runNames
|
||||
liftIO $ displayRunned runNames >> displayUnrunned unrunNames
|
||||
|
||||
|
@ -1041,8 +1041,8 @@ instance
|
||||
, commons1 ~ (cte ::: common ': commons)
|
||||
) => Aliasable cte
|
||||
(statement commons schemas params common)
|
||||
(AlignedList (CommonTableExpression statement schemas params) commons commons1) where
|
||||
statement `as` cte = single (statement `as` cte)
|
||||
(Path (CommonTableExpression statement schemas params) commons commons1) where
|
||||
statement `as` cte = csingleton (statement `as` cte)
|
||||
|
||||
instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
|
||||
(CommonTableExpression statement schemas params commons0 commons1) where
|
||||
@ -1054,7 +1054,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
|
||||
-- defining temporary tables that exist just for one query.
|
||||
class With statement where
|
||||
with
|
||||
:: AlignedList (CommonTableExpression statement schemas params) commons0 commons1
|
||||
:: Path (CommonTableExpression statement schemas params) commons0 commons1
|
||||
-- ^ common table expressions
|
||||
-> statement commons1 schemas params row
|
||||
-- ^ larger query
|
||||
@ -1062,7 +1062,7 @@ class With statement where
|
||||
instance With (Query outer) where
|
||||
with Done query = query
|
||||
with ctes query = UnsafeQuery $
|
||||
"WITH" <+> renderSQL ctes <+> renderSQL query
|
||||
"WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
|
||||
|
||||
{- |
|
||||
>>> import Data.Monoid (Sum (..))
|
||||
|
@ -4,3 +4,5 @@ packages:
|
||||
|
||||
extra-deps:
|
||||
- unliftio-pool-0.2.1.0
|
||||
- github: morphismtech/free-categories
|
||||
commit: c0e555fbefb5c21619e532264c4dfeac556d0630
|
||||
|
Loading…
Reference in New Issue
Block a user