ColumnConstraints.hs

module Sqel.ColumnConstraints where

import Generics.SOP (I (I), NP (Nil, (:*)))
import Lens.Micro ((%~), (.~))
import Sqel.Data.Mods (
  Mods (Mods),
  Nullable (Nullable),
  PgDefault (PgDefault),
  PrimaryKey (PrimaryKey),
  Unique (Unique),
  )
import Sqel.Data.Sql (Sql, sql)

data Constraints =
  Constraints {
    unique :: Bool,
    nullable :: Bool,
    extra :: [Sql]
  }
  deriving stock (Eq, Show, Generic)

class ColumnConstraint mod where
  columnConstraint :: mod -> Constraints -> Constraints

instance {-# overlappable #-} ColumnConstraint mod where
  columnConstraint _ = id

instance ColumnConstraint Nullable where
  columnConstraint Nullable =
    #nullable .~ True

instance ColumnConstraint PrimaryKey where
  columnConstraint PrimaryKey Constraints {..} =
    Constraints {
      unique = True,
      extra = "primary key" : extra,
      ..
    }

instance ColumnConstraint PgDefault where
  columnConstraint (PgDefault val) =
    #extra %~ ([sql|default ##{val}|] :)

instance ColumnConstraint Unique where
  columnConstraint Unique Constraints {..} =
    Constraints {
      unique = True,
      extra = "unique" : extra,
      ..
    }

class ColumnConstraints mods where
  collectConstraints :: NP I mods -> Constraints

instance ColumnConstraints '[] where
  collectConstraints Nil = Constraints False False []

instance (
    ColumnConstraint mod,
    ColumnConstraints mods
  ) => ColumnConstraints (mod : mods) where
  collectConstraints (I h :* t) =
    columnConstraint h (collectConstraints t)

columnConstraints ::
  ColumnConstraints mods =>
  Mods mods ->
  (Bool, [Sql])
columnConstraints (Mods mods) =
  (unique, notNull <> extra)
  where
    notNull | nullable = []
            | otherwise = ["not null"]
    Constraints {..} = collectConstraints mods