EntityFields generated from sum tables are partial

[tysonzero]

Specifically when reading the field the output is not wrapped in a Maybe, even though the result can be null. The main examples of this occurring are in fieldLens, and when reading a subset of the fields using libraries like esqueleto.

[parsonsmatt]

To elaborate on the problem: take the definition from persistent-test for the vehicle sum:

share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "sumTypeMigrate"] [persistLowerCase|
Bicycle
    brand T.Text
Car
    make T.Text
    model T.Text
+Vehicle
    bicycle BicycleId
    car CarId
    deriving Eq Show
|]

For simplicity, I've made mpsGeneric = False to reduce the Generic clutter. We can query GHCi for the info on Vehicle:

λ> :i Vehicle

data Vehicle
  = VehicleBicycleSum (Key Bicycle) | VehicleCarSum (Key Car)
        -- Defined at /home/matt/Projects/persistent/persistent-test/src/SumTypeTest.hs:11:1

-- snipping instances ...
data instance EntityField Vehicle typ
  = (typ ~ Key Vehicle) => VehicleId
  | (typ ~ Key Bicycle) => VehicleBicycle
  | (typ ~ Key Car) => VehicleCar
        -- Defined at /home/matt/Projects/persistent/persistent-test/src/SumTypeTest.hs:11:1

This is another way of writing a GADT, and can also be written as:

data instance EntityField Vehicle where
  VehicleId :: EntityField Vehicle VehicleId
  VehicleBicycle :: EntityField Vehicle BycicleId
  VehicleCar :: EntityField Vehicle CarId

This definition is wrong - it should really be:

data instance EntityField Vehicle where
  VehicleId :: EntityField Vehicle VehicleId
  VehicleBicycle :: EntityField Vehicle (Maybe BycicleId)
  VehicleCar :: EntityField Vehicle (Maybe CarId)

The generated SQL results in a table like this:

CREATE TABLE vehicle (
    id SERIAL PRIMARY KEY,
    bicycle INTEGER REFERENCES bicycle(id),
    car INTEGER REFERENCES car(id)
);

Notably absent are the NOT NULL clauses. So the EntityFields don't agree with the database.

esqueleto stuff doesn't work for the same reason that the generated SQL doesn't align.As an example, consider:

bicycleIds :: SqlPersistM [BicycleId]
bicycleIds =
    select $
    from $ \vehicle -> do
    pure (vehicle ^. VehicleBicycle)

This says it returns a [BicycleId], but the underlying SQL will return NULL for any VehicleCarSum in the database, so you'll get a PersistMarshallException because the real type should be SqlPersistM [Maybe BicycleId]. Setting the field type to Maybe ... would fix this issue.

Let's look at fieldLens for this generated type by doing a :set -ddump-splices in GHCi and reloading. And uh let's clean it up a bit.

fieldLens VehicleId = 
    lensPTH entityKey (\ (Entity _ x) k -> Entity k x)
fieldLens VehicleBicycle = 
    lensPTH
        (\ (Entity _ val) -> case val of
            VehicleBicycleSum x -> x
            _ -> error "Tried to use fieldLens on a Sum type")
        (\ (Entity k _) x -> Entity k (VehicleBicycleSum x)
fieldLens VehicleCar = 
    lensPTH
        (\ (Entity _ value)
        -> case value of
            VehicleCarSum x -> 
                x
            _ -> 
                error "Tried to use fieldLens on a Sum type")
        (\ (Entity key _) x -> Entity key (VehicleCarSum x))

SO if we do VehicleCarSum (toSqlKey 1) & fieldLens VehicleBicycle .~ toSqlKey 3 we'll get back VehicleBicycleSum (BicycleKey 3). I doubt that's a valid lens.

If we just set EntityField to Maybe, then we have an issue with this. We're promising a fieldLens VehicleBicycle :: Lens' Vehicle (Maybe BicycleId). This isn't quite right. It allows us to do things like set (fieldLens VehicleBicycle) Nothing - how are we supposed to do that?

What we really want to do here is provide a Prism, not a Lens. The signature for fieldLens is given, along with the definition of a Prism from lens:

    fieldLens :: EntityField record field
              -> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record))

type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)

I may be wrong, but I think that we can transparently move the forall and Functor constraint out into the body of the function without breaking anything due to the way function arrows parenthesize and foralls and constraints float around. That would allow us to change the signature to:

fieldLens 
    :: forall f. Functor f 
    => EntityField record field 
    -> (field -> f field) -> Entity record -> f (Entity record)

Testing this out locally, and it works. Can we drop the constraint on f, allowing us to provide an arbitrary optic? Well, no. At least, not easily. The lensPTH function requires the Functor constraint, so existing generated lenses don't work without the constraint.

We get this error message:

persistent-template  > /home/matt/Projects/persistent/persistent-template/test/main.hs:48:1: error:
persistent-template  >     • Could not deduce (Functor f) arising from a use of ‘lensPTH’
persistent-template  >       from the context: field ~ Maybe Int
persistent-template  >         bound by a pattern with constructor:
persistent-template  >                    LaddressZip :: forall typ.
persistent-template  >                                   (typ ~ Maybe Int) =>
persistent-template  >                                   EntityField Laddress typ,
persistent-template  >                  in an equation for ‘fieldLens’
persistent-template  >         at test/main.hs:(48,1)-(59,2)
persistent-template  >       Possible fix:
persistent-template  >         add (Functor f) to the context of
persistent-template  >           the type signature for:
persistent-template  >             fieldLens :: forall field (f :: * -> *).
persistent-template  >                          EntityField Laddress field
persistent-template  >                          -> (field -> f field) -> Entity Laddress -> f (Entity Laddress)
persistent-template  >     • In the expression:
persistent-template  >         (lensPTH (_laddressZip . entityVal))
persistent-template  >           (\ (Entity key_ao3E value_ao3F) x_ao3G
persistent-template  >              -> (Entity key_ao3E) value_ao3F {_laddressZip = x_ao3G})
persistent-template  >       In an equation for ‘fieldLens’:
persistent-template  >           fieldLens LaddressZip
persistent-template  >             = (lensPTH (_laddressZip . entityVal))
persistent-template  >                 (\ (Entity key_ao3E value_ao3F) x_ao3G
persistent-template  >                    -> (Entity key_ao3E) value_ao3F {_laddressZip = x_ao3G})
persistent-template  >       In the instance declaration for ‘PersistEntity Laddress’
persistent-template  >    |
persistent-template  > 48 | share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase|
persistent-template  >    | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...
persistent-template  >

The suggested fix is interesting - if we just add the Functor constraint to the instance method, maybe it'll work? Unfortunately not. We get this error when we add it to the InstanceSig:

persistent-template  > /home/matt/Projects/persistent/persistent-template/test/main.hs:49:1: error:
persistent-template  >     • No instance for (Functor f)
persistent-template  >       Possible fix:
persistent-template  >         add (Functor f) to the context of
persistent-template  >           the type signature for:
persistent-template  >             fieldLens :: forall field (f :: * -> *).
persistent-template  >                          EntityField Laddress field
persistent-template  >                          -> (field -> f field) -> Entity Laddress -> f (Entity Laddress)
persistent-template  >     • When checking that instance signature for ‘fieldLens’
persistent-template  >         is more general than its signature in the class
persistent-template  >         Instance sig: forall (f0 :: * -> *) field0.
persistent-template  >                       Functor f0 =>
persistent-template  >                       EntityField Laddress field0
persistent-template  >                       -> (field0 -> f0 field0) -> Entity Laddress -> f0 (Entity Laddress)
persistent-template  >            Class sig: forall field (f :: * -> *).
persistent-template  >                       EntityField Laddress field
persistent-template  >                       -> (field -> f field) -> Entity Laddress -> f (Entity Laddress)
persistent-template  >       In the instance declaration for ‘PersistEntity Laddress’
persistent-template  >    |
persistent-template  > 49 | share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase|
persistent-template  >    | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...
persistent-template  >

So it turns out we need to have that Functor defined on the class in order to use the fieldLens as a Lens anywhere.

Well. Hmm. I suppose we could have an associated type type FieldLensConstraint :: record -> (Type -> Type) -> Constraint, and we can change the signature to fieldLens :: (FieldLensConstraint record f) => ..., and that may work out.

[tysonzero]

That all makes a lot of sense, thanks!

Thinking about it more I think it might make sense to instead try and deprecate the "sum table" support.

There is clearly a non-trivial amount of complexity required to properly support it, and as per your blog post as well as my own personal experience, I am not convinced it is the best way to model sum types in SQL.

With that said it does look like there are some issues with using the shared primary key strategy in persistent currently. For example: #994

[parsonsmatt]

Yeah, I think I am going to deprecate sum-type support in 2.14.

[parsonsmatt]

Someone can migrate away from this with the following:

mkPersist sqlSettings [persistLowerCase|

Bike
    name Text

Car
    carbonEmissions Int64

+VehicleDeprecated
    bike BikeId
    car CarId

Vehicle
    bike BikeId Maybe
    car CarId Maybe
|]

data VehicleSum = VehicleBike BikeId | VehicleCar CarId

fromDb :: Vehicle -> VehicleSum
fromDb (Vehicle (Just bikeId) _) = VehicleBike bikeId
fromDb (Vehicle _ (Just carId)) = VehicleCar carId
fromDb _ = error "database invariant violated"

and manually finagling the values out of the database. Creating a constraint (bike is not null or car is not null) is probably a good idea to have on the table.