Merge pull request #147 from morphismtech/dev-free

factor out free categories

squeal-postgresql/squeal-postgresql.cabal

@@ -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

squeal-postgresql/src/Squeal/PostgreSQL/List.hs

@@ -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

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs

@@ -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`,

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs

@@ -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
 

squeal-postgresql/src/Squeal/PostgreSQL/Query.hs

@@ -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 (..))

stack.yaml

@@ -4,3 +4,5 @@ packages:
 
 extra-deps:
 - unliftio-pool-0.2.1.0
+- github: morphismtech/free-categories
+  commit: c0e555fbefb5c21619e532264c4dfeac556d0630