{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{-|
Module      : Polytropos.Persistent
Description : persistent PersistValue marshalling for Polytropos records
Copyright   : (c) 2026 The Polytropos Authors
License     : EUPL-1.2 OR Apache-2.0
Maintainer  : nadia.yvette.chambers@ik.me
Stability   : experimental
Portability : non-portable (GHC extensions)

Bridges @polytropos@ open records with the Yesod ecosystem's
@persistent@ relational database framework.

= Architectural Overview & Rationale

'PersistRow' provides fast marshalling of records to and from
@['PersistValue']@ rows: 'toPersistFieldsRecord' serializes the flat
payload in row order, and 'fromPersistValuesRecord' reconstructs the
record by filling the payload slots directly, in \(O(N)\), with no
intermediate tuples. The walk is heterogeneous: each field uses its own
'PersistField' instance.

'PersistField (Record r)' lets a whole record travel through
persistent's value machinery as a 'PersistList' (a nested-column
analogue), and @t'PolyRowEntity'@ pairs an integer key with a record in the
shape of persistent's 'Database.Persist.Entity', marshalling to the
key-then-fields row layout backends use for @Entity@ rows.

= When to Use This Module

* When persisting @polytropos@ open records with Yesod and the @persistent@ ORM.

= Worked Example

> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE TypeApplications #-}
> {-# OPTIONS_GHC -fplugin=Polytropos.Plugin #-}
>
> import Database.Persist
> import Polytropos
> import Polytropos.Persistent
>
> type PersonRow = Record '["name" ':= Text, "age" ':= Int]
>
> person :: PersonRow
> person = REC { name = "Alice", age = 30 }
>
> -- Convert to persistent values:
> vals :: [PersistValue]
> vals = toPersistFieldsRecord person
-}
module Polytropos.Persistent
  ( -- * Row Marshalling
    PersistRow (..)

    -- * Row Constraint Walks
  , AllToPersist (..)
  , AllFromPersist (..)

    -- * Entity Wrapper
  , PolyRowEntity (..)
  , toPolyRowEntity
  , fromPolyRowEntity
  ) where

import Data.Functor.Identity (Identity (..))
import Data.Int              (Int64)
import Data.Proxy            (Proxy (..))
import Data.Text             (Text)
import qualified Data.Text as T
import GHC.Exts              (Any, toList)
import Polytropos            (Record)
import Polytropos.Core       (Pair (..), Row, RowRep (..), noInlineUnsafeCo,
                              productRep, repVals)
import Database.Persist      (PersistField (..), PersistValue (..))

{-------------------------------------------------------------------------------
  Row constraint walks
-------------------------------------------------------------------------------}

-- | Heterogeneous encode walk: every field of the row @r@ has a
-- 'PersistField' instance at its own type; 'toVals' serializes the erased
-- payload slots in row order.
class AllToPersist (r :: Row) where
  toVals :: Proxy r -> [Identity Any] -> [PersistValue]

instance AllToPersist '[] where
  toVals :: Proxy '[] -> [Identity Any] -> [PersistValue]
toVals Proxy '[]
_ [Identity Any]
_ = []

instance (PersistField a, AllToPersist r) => AllToPersist ((n ':= a) ': r) where
  toVals :: Proxy ((n ':= a) : r) -> [Identity Any] -> [PersistValue]
toVals Proxy ((n ':= a) : r)
_ (Identity Any
x : [Identity Any]
xs) =
    a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (Any -> a
forall a b. a -> b
noInlineUnsafeCo Any
x :: a) PersistValue -> [PersistValue] -> [PersistValue]
forall a. a -> [a] -> [a]
: Proxy r -> [Identity Any] -> [PersistValue]
forall (r :: Row).
AllToPersist r =>
Proxy r -> [Identity Any] -> [PersistValue]
toVals (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r) [Identity Any]
xs
  toVals Proxy ((n ':= a) : r)
_ [] = [Char] -> [PersistValue]
forall a. HasCallStack => [Char] -> a
error [Char]
"polytropos-persistent: payload arity mismatch"

-- | Heterogeneous decode walk: fills the payload slots from a
-- @['PersistValue']@ row in O(n).
class AllFromPersist (r :: Row) where
  fromVals :: Proxy r -> [PersistValue] -> Either Text [Identity Any]

instance AllFromPersist '[] where
  fromVals :: Proxy '[] -> [PersistValue] -> Either Text [Identity Any]
fromVals Proxy '[]
_ [] = [Identity Any] -> Either Text [Identity Any]
forall a b. b -> Either a b
Right []
  fromVals Proxy '[]
_ [PersistValue]
vs = Text -> Either Text [Identity Any]
forall a b. a -> Either a b
Left ([Char] -> Text
T.pack ([Char]
"polytropos-persistent: expected 0 fields, got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([PersistValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PersistValue]
vs)))

instance (PersistField a, AllFromPersist r) => AllFromPersist ((n ':= a) ': r) where
  fromVals :: Proxy ((n ':= a) : r)
-> [PersistValue] -> Either Text [Identity Any]
fromVals Proxy ((n ':= a) : r)
_ (PersistValue
v : [PersistValue]
vs) = do
    x <- PersistValue -> Either Text a
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v :: Either Text a
    xs <- fromVals (Proxy @r) vs
    Right (Identity (noInlineUnsafeCo x :: Any) : xs)
  fromVals Proxy ((n ':= a) : r)
_ [] = Text -> Either Text [Identity Any]
forall a b. a -> Either a b
Left ([Char] -> Text
T.pack [Char]
"polytropos-persistent: row too short for record")

{-------------------------------------------------------------------------------
  PersistRow
-------------------------------------------------------------------------------}

-- | Fast marshalling of a polytropos record to and from a @['PersistValue']@
-- database row, in field order.
class PersistRow (r :: Row) where
  toPersistFieldsRecord :: Record r -> [PersistValue]
  fromPersistValuesRecord :: [PersistValue] -> Either Text (Record r)

instance (AllToPersist r, AllFromPersist r) => PersistRow r where
  toPersistFieldsRecord :: Record r -> [PersistValue]
toPersistFieldsRecord (RowRep Rep Identity ()
rep) = Proxy r -> [Identity Any] -> [PersistValue]
forall (r :: Row).
AllToPersist r =>
Proxy r -> [Identity Any] -> [PersistValue]
toVals (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r) (SmallArray (Identity Any) -> [Item (SmallArray (Identity Any))]
forall l. IsList l => l -> [Item l]
toList (Rep Identity () -> SmallArray (Identity Any)
forall {k} (f :: * -> *) (a :: k). Rep f a -> SmallArray (f Any)
repVals Rep Identity ()
rep))
  fromPersistValuesRecord :: [PersistValue] -> Either Text (Record r)
fromPersistValuesRecord [PersistValue]
vs =
    Rep Identity () -> Record r
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep (Rep Identity () -> Record r)
-> ([Identity Any] -> Rep Identity ())
-> [Identity Any]
-> Record r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Identity Any] -> Rep Identity ()
forall {k} (f :: * -> *) (a :: k). [f Any] -> Rep f a
productRep ([Identity Any] -> Record r)
-> Either Text [Identity Any] -> Either Text (Record r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy r -> [PersistValue] -> Either Text [Identity Any]
forall (r :: Row).
AllFromPersist r =>
Proxy r -> [PersistValue] -> Either Text [Identity Any]
fromVals (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r) [PersistValue]
vs

{-------------------------------------------------------------------------------
  PersistField bridge and entity wrapper
-------------------------------------------------------------------------------}

-- | A whole record travels through persistent's value machinery as a
-- 'PersistList' of its fields.
instance PersistRow r => PersistField (Record r) where
  toPersistValue :: Record r -> PersistValue
toPersistValue = [PersistValue] -> PersistValue
PersistList ([PersistValue] -> PersistValue)
-> (Record r -> [PersistValue]) -> Record r -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record r -> [PersistValue]
forall (r :: Row). PersistRow r => Record r -> [PersistValue]
toPersistFieldsRecord
  fromPersistValue :: PersistValue -> Either Text (Record r)
fromPersistValue (PersistList [PersistValue]
vs) = [PersistValue] -> Either Text (Record r)
forall (r :: Row).
PersistRow r =>
[PersistValue] -> Either Text (Record r)
fromPersistValuesRecord [PersistValue]
vs
  fromPersistValue PersistValue
v = Text -> Either Text (Record r)
forall a b. a -> Either a b
Left ([Char] -> Text
T.pack ([Char]
"polytropos-persistent: expected PersistList, got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PersistValue -> [Char]
forall a. Show a => a -> [Char]
show PersistValue
v))

-- | Key-plus-record wrapper in the shape of persistent's 'Database.Persist.Entity' for a
-- record table: an integer key followed by the record's field values.
data PolyRowEntity (r :: Row) = PolyRowEntity
  { forall (r :: Row). PolyRowEntity r -> Int64
polyRowKey    :: Int64
  , forall (r :: Row). PolyRowEntity r -> Record r
polyRowRecord :: Record r
  }

-- | Wrap a record under the given integer key.
toPolyRowEntity :: Int64 -> Record r -> PolyRowEntity r
toPolyRowEntity :: forall (r :: Row). Int64 -> Record r -> PolyRowEntity r
toPolyRowEntity Int64
k Record r
r = Int64 -> Record r -> PolyRowEntity r
forall (r :: Row). Int64 -> Record r -> PolyRowEntity r
PolyRowEntity Int64
k Record r
r

-- | Unwrap an entity to its key and field values (key first, matching the
-- @id | fields@ layout backends use for entity rows).
fromPolyRowEntity :: PersistRow r => PolyRowEntity r -> (Int64, [PersistValue])
fromPolyRowEntity :: forall (r :: Row).
PersistRow r =>
PolyRowEntity r -> (Int64, [PersistValue])
fromPolyRowEntity (PolyRowEntity Int64
k Record r
r) = (Int64
k, Int64 -> PersistValue
PersistInt64 Int64
k PersistValue -> [PersistValue] -> [PersistValue]
forall a. a -> [a] -> [a]
: Record r -> [PersistValue]
forall (r :: Row). PersistRow r => Record r -> [PersistValue]
toPersistFieldsRecord Record r
r)