{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module Database.Esqueleto.Record
  ( deriveEsqueletoRecord
  , deriveEsqueletoRecordWith

  , DeriveEsqueletoRecordSettings(..)
  , defaultDeriveEsqueletoRecordSettings
  ) where

import Control.Monad.Trans.State.Strict (StateT(..), evalStateT)
import Data.Proxy (Proxy(..))
import Database.Esqueleto.Experimental
       (Entity, PersistValue, SqlExpr, Value(..), (:&)(..))
import Database.Esqueleto.Experimental.ToAlias (ToAlias(..))
import Database.Esqueleto.Experimental.ToAliasReference (ToAliasReference(..))
import Database.Esqueleto.Internal.Internal (SqlSelect(..))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Bifunctor (first)
import Data.Text (Text)
import Control.Monad (forM)
import Data.Foldable (foldl')
import GHC.Exts (IsString(fromString))
import Data.Maybe (mapMaybe, fromMaybe, listToMaybe)

-- | Takes the name of a Haskell record type and creates a variant of that
-- record prefixed with @Sql@ which can be used in esqueleto expressions. This
-- reduces the amount of pattern matching on large tuples required to interact
-- with data extracted with esqueleto.
--
-- Note that because the input record and the @Sql@-prefixed record share field
-- names, the @{-# LANGUAGE DuplicateRecordFields #-}@ extension is required in
-- modules that use `deriveEsqueletoRecord`. Additionally, the @{-# LANGUAGE
-- TypeApplications #-}@ extension is required for some of the generated code.
--
-- Given the following record:
--
-- @
-- data MyRecord = MyRecord
--   { myName    :: 'Text'
--   , myAge     :: 'Maybe' 'Int'
--   , myUser    :: 'Entity' User
--   , myAddress :: 'Maybe' ('Entity' Address)
--   }
-- @
--
-- @$('deriveEsqueletoRecord' ''MyRecord)@ will generate roughly the following code:
--
-- @
-- data SqlMyRecord =
--   SqlMyRecord { myName    :: 'SqlExpr' ('Value' Text)
--               , myAge     :: 'SqlExpr' ('Value' Int)
--               , myUser    :: 'SqlExpr' ('Entity' User)
--               , myAddress :: 'SqlExpr' ('Maybe' ('Entity' Address))
--               }
--
-- instance 'SqlSelect' SqlMyRecord MyRecord where
--   'sqlSelectCols'
--     identInfo
--     SqlMyRecord { myName    = myName
--                 , myAge     = myAge
--                 , myUser    = myUser
--                 , myAddress = myAddress
--                 } =
--     'sqlSelectCols' identInfo (myName :& myAge :& myUser :& myAddress)
--
--   'sqlSelectColCount' _ =
--     'sqlSelectColCount'
--       ('Proxy' \@(   ('SqlExpr' ('Value' Text))
--                :& ('SqlExpr' ('Value' Int))
--                :& ('SqlExpr' ('Entity' User))
--                :& ('SqlExpr' ('Maybe' ('Entity' Address)))))
--
--   'sqlSelectProcessRow' columns =
--     'first' (('fromString' "Failed to parse MyRecord: ") <>)
--           ('evalStateT' process columns)
--     where
--       process = do
--         'Value' myName <- 'takeColumns' \@('SqlExpr' ('Value' Text))
--         'Value' myAge  <- 'takeColumns' \@('SqlExpr' ('Value' Int))
--         myUser       <- 'takeColumns' \@('SqlExpr' ('Entity' User))
--         myAddress    <- 'takeColumns' \@('SqlExpr' ('Maybe' ('Entity' Address)))
--         'pure' MyRecord { myName = myName
--                       , myAge = myAge
--                       , myUser = myUser
--                       , myAddress = myAddress
--                       }
-- @
--
-- Then, we could write a selection function to use the record in queries:
--
-- @
-- getMyRecord :: 'Database.Esqueleto.SqlPersistT' 'IO' [MyRecord]
-- getMyRecord = 'Database.Esqueleto.Experimental.select' myRecordQuery
--
-- myRecordQuery :: 'Database.Esqueleto.SqlQuery' SqlMyRecord
-- myRecordQuery = do
--   user ':&' address <- 'Database.Esqueleto.Experimental.from' '$'
--     'Database.Esqueleto.Experimental.table' \@User
--       \`'Database.Esqueleto.Experimental.leftJoin'\`
--       'Database.Esqueleto.Experimental.table' \@Address
--       \`'Database.Esqueleto.Experimental.on'\` (do \\(user ':&' address) -> user 'Database.Esqueleto.Experimental.^.' #address 'Database.Esqueleto.Experimental.==.' address 'Database.Esqueleto.Experimental.?.' #id)
--   'pure'
--     SqlMyRecord
--       { myName = 'Database.Esqueleto.Experimental.castString' '$' user 'Database.Esqueleto.Experimental.^.' #firstName
--       , myAge = 'Database.Esqueleto.Experimental.val' 10
--       , myUser = user
--       , myAddress = address
--       }
-- @
--
-- @since 3.5.6.0
deriveEsqueletoRecord :: Name -> Q [Dec]
deriveEsqueletoRecord :: Name -> Q [Dec]
deriveEsqueletoRecord = DeriveEsqueletoRecordSettings -> Name -> Q [Dec]
deriveEsqueletoRecordWith DeriveEsqueletoRecordSettings
defaultDeriveEsqueletoRecordSettings

-- | Codegen settings for 'deriveEsqueletoRecordWith'.
--
-- @since 3.5.8.0
data DeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings
  { DeriveEsqueletoRecordSettings -> String -> String
sqlNameModifier :: String -> String
    -- ^ Function applied to the Haskell record's type name and constructor
    -- name to produce the SQL record's type name and constructor name.
    --
    -- @since 3.5.8.0
  , DeriveEsqueletoRecordSettings -> String -> String
sqlFieldModifier :: String -> String
    -- ^ Function applied to the Haskell record's field names to produce the
    -- SQL record's field names.
    --
    -- @since 3.5.8.0
  }

-- | The default codegen settings for 'deriveEsqueletoRecord'.
--
-- These defaults will cause you to require @{-# LANGUAGE DuplicateRecordFields #-}@
-- in certain cases (see 'deriveEsqueletoRecord'.) If you don't want to do this,
-- change the value of 'sqlFieldModifier' so the field names of the generated SQL
-- record different from those of the Haskell record.
--
-- @since 3.5.8.0
defaultDeriveEsqueletoRecordSettings :: DeriveEsqueletoRecordSettings
defaultDeriveEsqueletoRecordSettings :: DeriveEsqueletoRecordSettings
defaultDeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings :: (String -> String)
-> (String -> String) -> DeriveEsqueletoRecordSettings
DeriveEsqueletoRecordSettings
  { sqlNameModifier :: String -> String
sqlNameModifier = (String
"Sql" String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  , sqlFieldModifier :: String -> String
sqlFieldModifier = String -> String
forall a. a -> a
id
  }

-- | Takes the name of a Haskell record type and creates a variant of that
-- record based on the supplied settings which can be used in esqueleto
-- expressions. This reduces the amount of pattern matching on large tuples
-- required to interact with data extracted with esqueleto.
--
-- This is a variant of 'deriveEsqueletoRecord' which allows you to avoid the
-- use of @{-# LANGUAGE DuplicateRecordFields #-}@, by configuring the
-- 'DeriveEsqueletoRecordSettings' used to generate the SQL record.
--
-- @since 3.5.8.0
deriveEsqueletoRecordWith :: DeriveEsqueletoRecordSettings -> Name -> Q [Dec]
deriveEsqueletoRecordWith :: DeriveEsqueletoRecordSettings -> Name -> Q [Dec]
deriveEsqueletoRecordWith DeriveEsqueletoRecordSettings
settings Name
originalName = do
  RecordInfo
info <- DeriveEsqueletoRecordSettings -> Name -> Q RecordInfo
getRecordInfo DeriveEsqueletoRecordSettings
settings Name
originalName
  -- It would be nicer to use `mconcat` here but I don't think the right
  -- instance is available in GHC 8.
  Dec
recordDec <- RecordInfo -> Q Dec
makeSqlRecord RecordInfo
info
  Dec
sqlSelectInstanceDec <- RecordInfo -> Q Dec
makeSqlSelectInstance RecordInfo
info
  Dec
toAliasInstanceDec <- RecordInfo -> Q Dec
makeToAliasInstance RecordInfo
info
  Dec
toAliasReferenceInstanceDec <- RecordInfo -> Q Dec
makeToAliasReferenceInstance RecordInfo
info
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Dec
recordDec
    , Dec
sqlSelectInstanceDec
    , Dec
toAliasInstanceDec
    , Dec
toAliasReferenceInstanceDec
    ]

-- | Information about a record we need to generate the declarations.
-- We compute this once and then pass it around to save on complexity /
-- repeated work.
data RecordInfo = RecordInfo
  { -- | The original record's name.
    RecordInfo -> Name
name :: Name
  , -- | The generated SQL record's name.
    RecordInfo -> Name
sqlName :: Name
  , -- | The original record's constraints. If this isn't empty it'll probably
    -- cause problems, but it's easy to pass around so might as well.
    RecordInfo -> Cxt
constraints :: Cxt
  , -- | The original record's type-variable-binders.
#if MIN_VERSION_template_haskell(2,17,0)
    typeVarBinders :: [TyVarBndr ()]
#else
    RecordInfo -> [TyVarBndr]
typeVarBinders :: [TyVarBndr]
#endif
  , -- | The original record's kind, I think.
    RecordInfo -> Maybe Kind
kind :: Maybe Kind
  , -- | The original record's constructor name.
    RecordInfo -> Name
constructorName :: Name
  , -- | The generated SQL record's constructor name.
    RecordInfo -> Name
sqlConstructorName :: Name
  , -- | The original record's field names and types, derived from the
    -- constructors.
    RecordInfo -> [(Name, Kind)]
fields :: [(Name, Type)]
  , -- | The generated SQL record's field names and types, computed
    -- with 'sqlFieldType'.
    RecordInfo -> [(Name, Kind)]
sqlFields :: [(Name, Type)]
  }

-- | Get a `RecordInfo` instance for the given record name.
getRecordInfo :: DeriveEsqueletoRecordSettings -> Name -> Q RecordInfo
getRecordInfo :: DeriveEsqueletoRecordSettings -> Name -> Q RecordInfo
getRecordInfo DeriveEsqueletoRecordSettings
settings Name
name = do
  TyConI Dec
dec <- Name -> Q Info
reify Name
name
  (Cxt
constraints, [TyVarBndr]
typeVarBinders, Maybe Kind
kind, [Con]
constructors) <-
        case Dec
dec of
          DataD Cxt
constraints' Name
_name [TyVarBndr]
typeVarBinders' Maybe Kind
kind' [Con]
constructors' [DerivClause]
_derivingClauses ->
            (Cxt, [TyVarBndr], Maybe Kind, [Con])
-> Q (Cxt, [TyVarBndr], Maybe Kind, [Con])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt
constraints', [TyVarBndr]
typeVarBinders', Maybe Kind
kind', [Con]
constructors')
          NewtypeD Cxt
constraints' Name
_name [TyVarBndr]
typeVarBinders' Maybe Kind
kind' Con
constructor' [DerivClause]
_derivingClauses ->
            (Cxt, [TyVarBndr], Maybe Kind, [Con])
-> Q (Cxt, [TyVarBndr], Maybe Kind, [Con])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt
constraints', [TyVarBndr]
typeVarBinders', Maybe Kind
kind', [Con
constructor'])
          Dec
_ -> String -> Q (Cxt, [TyVarBndr], Maybe Kind, [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Cxt, [TyVarBndr], Maybe Kind, [Con]))
-> String -> Q (Cxt, [TyVarBndr], Maybe Kind, [Con])
forall a b. (a -> b) -> a -> b
$ String
"Esqueleto records can only be derived for records and newtypes, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is neither"
  Con
constructor <- case [Con]
constructors of
                  (Con
c : [Con]
_) -> Con -> Q Con
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
c
                  [] -> String -> Q Con
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Con) -> String -> Q Con
forall a b. (a -> b) -> a -> b
$ String
"Cannot derive Esqueleto record for a type with no constructors: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
  let constructorName :: Name
constructorName =
        case [Con] -> Con
forall a. [a] -> a
head [Con]
constructors of
          RecC Name
name' [VarBangType]
_fields -> Name
name'
          Con
con -> String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Con -> String
nonRecordConstructorMessage Con
con
      fields :: [(Name, Kind)]
fields = Con -> [(Name, Kind)]
getFields Con
constructor
      sqlName :: Name
sqlName = DeriveEsqueletoRecordSettings -> Name -> Name
makeSqlName DeriveEsqueletoRecordSettings
settings Name
name
      sqlConstructorName :: Name
sqlConstructorName = DeriveEsqueletoRecordSettings -> Name -> Name
makeSqlName DeriveEsqueletoRecordSettings
settings Name
constructorName

  [(Name, Kind)]
sqlFields <- ((Name, Kind) -> Q (Name, Kind))
-> [(Name, Kind)] -> Q [(Name, Kind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, Kind) -> Q (Name, Kind)
toSqlField [(Name, Kind)]
fields

  RecordInfo -> Q RecordInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecordInfo :: Name
-> Name
-> Cxt
-> [TyVarBndr]
-> Maybe Kind
-> Name
-> Name
-> [(Name, Kind)]
-> [(Name, Kind)]
-> RecordInfo
RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
sqlConstructorName :: Name
sqlName :: Name
fields :: [(Name, Kind)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
name :: Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
sqlConstructorName :: Name
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
..}
  where
    getFields :: Con -> [(Name, Type)]
    getFields :: Con -> [(Name, Kind)]
getFields (RecC Name
_name [VarBangType]
fields) = [(Name
fieldName', Kind
fieldType') | (Name
fieldName', Bang
_bang, Kind
fieldType') <- [VarBangType]
fields]
    getFields Con
con = String -> [(Name, Kind)]
forall a. HasCallStack => String -> a
error (String -> [(Name, Kind)]) -> String -> [(Name, Kind)]
forall a b. (a -> b) -> a -> b
$ Con -> String
nonRecordConstructorMessage Con
con

    toSqlField :: (Name, Kind) -> Q (Name, Kind)
toSqlField (Name
fieldName', Kind
ty) = do
      let modifier :: Name -> Name
modifier = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeriveEsqueletoRecordSettings -> String -> String
sqlFieldModifier DeriveEsqueletoRecordSettings
settings (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
      Kind
sqlTy <- Kind -> Q Kind
sqlFieldType Kind
ty
      (Name, Kind) -> Q (Name, Kind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Name
modifier Name
fieldName', Kind
sqlTy)

-- | Create a new name by prefixing @Sql@ to a given name.
makeSqlName :: DeriveEsqueletoRecordSettings -> Name -> Name
makeSqlName :: DeriveEsqueletoRecordSettings -> Name -> Name
makeSqlName DeriveEsqueletoRecordSettings
settings Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DeriveEsqueletoRecordSettings -> String -> String
sqlNameModifier DeriveEsqueletoRecordSettings
settings (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name

-- | Transforms a record field type into a corresponding `SqlExpr` type.
--
-- * @'Entity' x@ is transformed into @'SqlExpr' ('Entity' x)@.
-- * @'Maybe' ('Entity' x)@ is transformed into @'SqlExpr' ('Maybe' ('Entity' x))@.
-- * @x@ is transformed into @'SqlExpr' ('Value' x)@.
-- * If there exists an instance @'SqlSelect' sql x@, then @x@ is transformed into @sql@.
--
-- This function should match `sqlSelectProcessRowPat`.
sqlFieldType :: Type -> Q Type
sqlFieldType :: Kind -> Q Kind
sqlFieldType Kind
fieldType = do
  Maybe Kind
maybeSqlType <- Kind -> Q (Maybe Kind)
reifySqlSelectType Kind
fieldType

  Kind -> Q Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Q Kind) -> Kind -> Q Kind
forall a b. (a -> b) -> a -> b
$
    (Kind -> Maybe Kind -> Kind) -> Maybe Kind -> Kind -> Kind
forall a b c. (a -> b -> c) -> b -> a -> c
flip Kind -> Maybe Kind -> Kind
forall a. a -> Maybe a -> a
fromMaybe Maybe Kind
maybeSqlType (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
      case Kind
fieldType of
        -- Entity x -> SqlExpr (Entity x)
        AppT (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True)) Kind
_innerType -> Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''SqlExpr) Kind
fieldType

        -- Maybe (Entity x) -> SqlExpr (Maybe (Entity x))
        (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Maybe -> Bool
True))
          `AppT` ((ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True))
                  `AppT` Kind
_innerType) -> Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''SqlExpr) Kind
fieldType

        -- x -> SqlExpr (Value x)
        Kind
_ -> (Name -> Kind
ConT ''SqlExpr)
                Kind -> Kind -> Kind
`AppT` ((Name -> Kind
ConT ''Value)
                        Kind -> Kind -> Kind
`AppT` Kind
fieldType)

-- | Generates the declaration for an @Sql@-prefixed record, given the original
-- record's information.
makeSqlRecord :: RecordInfo -> Q Dec
makeSqlRecord :: RecordInfo -> Q Dec
makeSqlRecord RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
sqlConstructorName :: Name
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
sqlConstructorName :: RecordInfo -> Name
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
  let newConstructor :: Con
newConstructor = Name -> [VarBangType] -> Con
RecC Name
sqlConstructorName ((Name, Kind) -> VarBangType
forall a c. (a, c) -> (a, Bang, c)
makeField ((Name, Kind) -> VarBangType) -> [(Name, Kind)] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
`map` [(Name, Kind)]
sqlFields)
      derivingClauses :: [a]
derivingClauses = []
  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
constraints Name
sqlName [TyVarBndr]
typeVarBinders Maybe Kind
kind [Con
newConstructor] [DerivClause]
forall a. [a]
derivingClauses
  where
    makeField :: (a, c) -> (a, Bang, c)
makeField (a
fieldName', c
fieldType) =
      (a
fieldName', SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, c
fieldType)

-- | Generates an `SqlSelect` instance for the given record and its
-- @Sql@-prefixed variant.
makeSqlSelectInstance :: RecordInfo -> Q Dec
makeSqlSelectInstance :: RecordInfo -> Q Dec
makeSqlSelectInstance info :: RecordInfo
info@RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
sqlConstructorName :: Name
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
sqlConstructorName :: RecordInfo -> Name
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
  Dec
sqlSelectColsDec' <- RecordInfo -> Q Dec
sqlSelectColsDec RecordInfo
info
  Dec
sqlSelectColCountDec' <- RecordInfo -> Q Dec
sqlSelectColCountDec RecordInfo
info
  Dec
sqlSelectProcessRowDec' <- RecordInfo -> Q Dec
sqlSelectProcessRowDec RecordInfo
info
  let overlap :: Maybe a
overlap = Maybe a
forall a. Maybe a
Nothing
      instanceConstraints :: [a]
instanceConstraints = []
      instanceType :: Kind
instanceType =
        (Name -> Kind
ConT ''SqlSelect)
          Kind -> Kind -> Kind
`AppT` (Name -> Kind
ConT Name
sqlName)
          Kind -> Kind -> Kind
`AppT` (Name -> Kind
ConT Name
name)

  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
overlap Cxt
forall a. [a]
instanceConstraints Kind
instanceType [Dec
sqlSelectColsDec', Dec
sqlSelectColCountDec', Dec
sqlSelectProcessRowDec']

-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance.
sqlSelectColsDec :: RecordInfo -> Q Dec
sqlSelectColsDec :: RecordInfo -> Q Dec
sqlSelectColsDec RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
sqlConstructorName :: Name
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
sqlConstructorName :: RecordInfo -> Name
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
  -- Pairs of record field names and local variable names.
  [(Name, Name)]
fieldNames <- [(Name, Kind)]
-> ((Name, Kind) -> Q (Name, Name)) -> Q [(Name, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, Kind)]
sqlFields (\(Name
name', Kind
_type) -> do
    Name
var <- String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name'
    (Name, Name) -> Q (Name, Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name', Name
var))

  -- Patterns binding record fields to local variables.
  let fieldPatterns :: [FieldPat]
      fieldPatterns :: [FieldPat]
fieldPatterns = [(Name
name', Name -> Pat
VarP Name
var) | (Name
name', Name
var) <- [(Name, Name)]
fieldNames]

      -- Local variables for fields joined with `:&` in a single expression.
      joinedFields :: Exp
      joinedFields :: Exp
joinedFields =
        case (Name, Name) -> Name
forall a b. (a, b) -> b
snd ((Name, Name) -> Name) -> [(Name, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
`map` [(Name, Name)]
fieldNames of
          [] -> [Maybe Exp] -> Exp
TupE []
          [Name
f1] -> Name -> Exp
VarE Name
f1
          Name
f1 : [Name]
rest ->
            let helper :: Exp -> Name -> Exp
helper Exp
lhs Name
field =
                  Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
                    (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
lhs)
                    (Name -> Exp
ConE '(:&))
                    (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
field)
             in (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Name -> Exp
helper (Name -> Exp
VarE Name
f1) [Name]
rest

  Name
identInfo <- String -> Q Name
newName String
"identInfo"
  -- Roughly:
  -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields
  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
    Name -> [Clause] -> Dec
FunD
      'sqlSelectCols
      [ [Pat] -> Body -> [Dec] -> Clause
Clause
          [ Name -> Pat
VarP Name
identInfo
          , Name -> [FieldPat] -> Pat
RecP Name
sqlName [FieldPat]
fieldPatterns
          ]
          ( Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
              (Name -> Exp
VarE 'sqlSelectCols)
                Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE Name
identInfo)
                Exp -> Exp -> Exp
`AppE` (Exp -> Exp
ParensE Exp
joinedFields)
          )
          -- `where` clause.
          []
      ]

-- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance.
sqlSelectColCountDec :: RecordInfo -> Q Dec
sqlSelectColCountDec :: RecordInfo -> Q Dec
sqlSelectColCountDec RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
sqlConstructorName :: Name
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
sqlConstructorName :: RecordInfo -> Name
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
  let joinedTypes :: Kind
joinedTypes =
        case (Name, Kind) -> Kind
forall a b. (a, b) -> b
snd ((Name, Kind) -> Kind) -> [(Name, Kind)] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
`map` [(Name, Kind)]
sqlFields of
          [] -> Int -> Kind
TupleT Int
0
          Kind
t1 : Cxt
rest ->
            let helper :: Kind -> Kind -> Kind
helper Kind
lhs Kind
ty =
                  Kind -> Name -> Kind -> Kind
InfixT Kind
lhs ''(:&) Kind
ty
             in (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Kind -> Kind -> Kind
helper Kind
t1 Cxt
rest

  -- Roughly:
  -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes))
  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
    Name -> [Clause] -> Dec
FunD
      'sqlSelectColCount
      [ [Pat] -> Body -> [Dec] -> Clause
Clause
          [Pat
WildP]
          ( Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
              Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'sqlSelectColCount) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
                Exp -> Exp
ParensE (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
                  Exp -> Kind -> Exp
AppTypeE
                    (Name -> Exp
ConE 'Proxy)
                    Kind
joinedTypes
          )
          -- `where` clause.
          []
      ]

-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect`
-- instance.
sqlSelectProcessRowDec :: RecordInfo -> Q Dec
sqlSelectProcessRowDec :: RecordInfo -> Q Dec
sqlSelectProcessRowDec RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
sqlConstructorName :: Name
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
sqlConstructorName :: RecordInfo -> Name
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
  -- Binding statements and field expressions (used in record construction) to
  -- fill out the body of the main generated `do` expression.
  --
  -- Each statement is like:
  --     Value fooName' <- takeColumns @(SqlExpr (Value Text))
  -- A corresponding field expression would be:
  --     fooName = fooName'
  --
  -- See `sqlSelectProcessRowPat` for the left-hand side of the patterns.
  ([Stmt]
statements, [(Name, Exp)]
fieldExps) <-
    [(Stmt, (Name, Exp))] -> ([Stmt], [(Name, Exp)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Stmt, (Name, Exp))] -> ([Stmt], [(Name, Exp)]))
-> Q [(Stmt, (Name, Exp))] -> Q ([Stmt], [(Name, Exp)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((Name, Kind), (Name, Kind))]
-> (((Name, Kind), (Name, Kind)) -> Q (Stmt, (Name, Exp)))
-> Q [(Stmt, (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([(Name, Kind)] -> [(Name, Kind)] -> [((Name, Kind), (Name, Kind))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, Kind)]
fields [(Name, Kind)]
sqlFields) (\((Name
fieldName', Kind
fieldType), (Name
_, Kind
sqlType')) -> do
      Name
valueName <- String -> Q Name
newName (Name -> String
nameBase Name
fieldName')
      Pat
pattern <- Kind -> Name -> Q Pat
sqlSelectProcessRowPat Kind
fieldType Name
valueName
      (Stmt, (Name, Exp)) -> Q (Stmt, (Name, Exp))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Pat -> Exp -> Stmt
BindS
            Pat
pattern
            (Exp -> Kind -> Exp
AppTypeE (Name -> Exp
VarE 'takeColumns) Kind
sqlType')
        , (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
fieldName', Name -> Exp
VarE Name
valueName)
        ))

  Name
colsName <- String -> Q Name
newName String
"columns"
  Name
processName <- String -> Q Name
newName String
"process"

  -- Roughly:
  -- sqlSelectProcessRow $colsName =
  --   first ((fromString "Failed to parse $name: ") <>)
  --         (evalStateT $processName $colsName)
  --   where $processName = do $statements
  --                           pure $name {$fieldExps}
  Exp
bodyExp <- [e|
    first (fromString ("Failed to parse " ++ $(lift $ nameBase name) ++ ": ") <>)
          (evalStateT $(varE processName) $(varE colsName))
    |]

  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
    Name -> [Clause] -> Dec
FunD
      'sqlSelectProcessRow
      [ [Pat] -> Body -> [Dec] -> Clause
Clause
          [Name -> Pat
VarP Name
colsName]
          (Exp -> Body
NormalB Exp
bodyExp)
          -- `where` clause
          [ Pat -> Body -> [Dec] -> Dec
ValD
              (Name -> Pat
VarP Name
processName)
              ( Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
                  [Stmt] -> Exp
DoE
#if MIN_VERSION_template_haskell(2,17,0)
                    Nothing
#endif
                    ([Stmt]
statements [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) (Name -> [(Name, Exp)] -> Exp
RecConE Name
constructorName [(Name, Exp)]
fieldExps)])
              )
              []
          ]
      ]

-- | Get the left-hand side pattern of a statement in a @do@ block for binding
-- to the result of `sqlSelectProcessRow`.
--
-- * A type of @'Entity' x@ gives a pattern of @var@.
-- * A type of @'Maybe' ('Entity' x)@ gives a pattern of @var@.
-- * A type of @x@ gives a pattern of @'Value' var@.
-- * If there exists an instance @'SqlSelect' sql x@, then a type of @x@ gives a pattern of @var@.
--
-- This function should match `sqlFieldType`.
sqlSelectProcessRowPat :: Type -> Name -> Q Pat
sqlSelectProcessRowPat :: Kind -> Name -> Q Pat
sqlSelectProcessRowPat Kind
fieldType Name
var = do
  Maybe Kind
maybeSqlType <- Kind -> Q (Maybe Kind)
reifySqlSelectType Kind
fieldType

  case Maybe Kind
maybeSqlType of
    Just Kind
_ -> Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP Name
var
    Maybe Kind
Nothing -> case Kind
fieldType of
        -- Entity x -> var
        AppT (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True)) Kind
_innerType -> Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP Name
var
        -- Maybe (Entity x) -> var
        (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Maybe -> Bool
True))
          `AppT` ((ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True))
                  `AppT` Kind
_innerType) -> Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP Name
var
        -- x -> Value var
#if MIN_VERSION_template_haskell(2,18,0)
        _ -> pure $ ConP 'Value [] [VarP var]
#else
        Kind
_ -> Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Pat] -> Pat
ConP 'Value [Name -> Pat
VarP Name
var]
#endif

-- Given a type, find the corresponding SQL type.
--
-- If there exists an instance `SqlSelect sql ty`, then the SQL type for `ty`
-- is `sql`.
--
-- This function definitely works for records and instances generated by this
-- module, and might work for instances outside of it.
reifySqlSelectType :: Type -> Q (Maybe Type)
reifySqlSelectType :: Kind -> Q (Maybe Kind)
reifySqlSelectType Kind
originalType = do
  -- Here we query the compiler for Instances of `SqlSelect a $(originalType)`;
  -- the API for this is super weird, it interprets a list of types as being
  -- applied as successive arguments to the typeclass name.
  --
  -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/21825
  --
  -- >>> reifyInstances ''SqlSelect [VarT (mkName "a"), ConT ''MyRecord]
  -- [ InstanceD Nothing
  --             []
  --             (AppT (AppT (ConT Database.Esqueleto.Internal.Internal.SqlSelect)
  --                         (ConT Ghci3.SqlMyRecord))
  --                   (ConT Ghci3.MyRecord))
  --             []
  -- ]
  Name
tyVarName <- String -> Q Name
newName String
"a"
  [Dec]
instances <- Name -> Cxt -> Q [Dec]
reifyInstances ''SqlSelect [Name -> Kind
VarT Name
tyVarName, Kind
originalType]

  -- Given the original type (`originalType`) and an instance type for a
  -- `SqlSelect` instance, get the SQL type which corresponds to the original
  -- type.
  let extractSqlRecord :: Type -> Type -> Maybe Type
      extractSqlRecord :: Kind -> Kind -> Maybe Kind
extractSqlRecord Kind
originalTy Kind
instanceTy =
        case Kind
instanceTy of
          (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''SqlSelect -> Bool
True))
            `AppT` Kind
sqlTy
            `AppT` (Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
(==) Kind
originalTy -> Bool
True) -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
sqlTy
          Kind
_ -> Maybe Kind
forall a. Maybe a
Nothing

      -- Filter `instances` to the instances which match `originalType`.
      filteredInstances :: [Type]
      filteredInstances :: Cxt
filteredInstances =
        ((Dec -> Maybe Kind) -> [Dec] -> Cxt)
-> [Dec] -> (Dec -> Maybe Kind) -> Cxt
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Dec -> Maybe Kind) -> [Dec] -> Cxt
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Dec]
instances
          (\case InstanceD Maybe Overlap
_overlap
                           Cxt
_constraints
                           (Kind -> Kind -> Maybe Kind
extractSqlRecord Kind
originalType -> Just Kind
sqlRecord)
                           [Dec]
_decs ->
                             Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
sqlRecord
                 Dec
_ -> Maybe Kind
forall a. Maybe a
Nothing)

  Maybe Kind -> Q (Maybe Kind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Kind -> Q (Maybe Kind)) -> Maybe Kind -> Q (Maybe Kind)
forall a b. (a -> b) -> a -> b
$ Cxt -> Maybe Kind
forall a. [a] -> Maybe a
listToMaybe Cxt
filteredInstances

-- | Statefully parse some number of columns from a list of `PersistValue`s,
-- where the number of columns to parse is determined by `sqlSelectColCount`
-- for @a@.
--
-- This is used to implement `sqlSelectProcessRow` for records created with
-- `deriveEsqueletoRecord`.
takeColumns ::
  forall a b.
  SqlSelect a b =>
  StateT [PersistValue] (Either Text) b
takeColumns :: StateT [PersistValue] (Either Text) b
takeColumns = ([PersistValue] -> Either Text (b, [PersistValue]))
-> StateT [PersistValue] (Either Text) b
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (\[PersistValue]
pvs ->
  let targetColCount :: Int
targetColCount =
        Proxy a -> Int
forall a r. SqlSelect a r => Proxy a -> Int
sqlSelectColCount (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
      ([PersistValue]
target, [PersistValue]
other) =
        Int -> [PersistValue] -> ([PersistValue], [PersistValue])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
targetColCount [PersistValue]
pvs
   in if [PersistValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PersistValue]
target Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
targetColCount
        then do
          b
value <- [PersistValue] -> Either Text b
forall a r. SqlSelect a r => [PersistValue] -> Either Text r
sqlSelectProcessRow [PersistValue]
target
          (b, [PersistValue]) -> Either Text (b, [PersistValue])
forall a b. b -> Either a b
Right (b
value, [PersistValue]
other)
        else Text -> Either Text (b, [PersistValue])
forall a b. a -> Either a b
Left Text
"Insufficient columns when trying to parse a column")

-- | Get an error message for a non-record constructor.
-- This module does not yet support non-record constructors, so we'll tell the
-- user what sort of constructor they provided that we can't use, along with
-- the name of that constructor. This turns out to require recursion, but you
-- can't win every battle.
nonRecordConstructorMessage :: Con -> String
nonRecordConstructorMessage :: Con -> String
nonRecordConstructorMessage Con
con =
  case Con
con of
    (RecC {}) -> String -> String
forall a. HasCallStack => String -> a
error String
"Record constructors are not an error"
    (NormalC {}) -> String -> String
helper String
"non-record data constructor"
    (InfixC {}) -> String -> String
helper String
"infix constructor"
    (ForallC {}) -> String -> String
helper String
"constructor qualified by type variables / class contexts"
    (GadtC {}) -> String -> String
helper String
"GADT constructor"
    (RecGadtC {}) -> String -> String
helper String
"record GADT constructor"
  where
    helper :: String -> String
helper String
constructorType =
      String
"Esqueleto records can only be derived for record constructors, but "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (Con -> Name
constructorName Con
con)
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is a "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
constructorType

    constructorName :: Con -> Name
constructorName Con
constructor =
      case Con
constructor of
        (RecC Name
name [VarBangType]
_) -> Name
name
        (NormalC Name
name [BangType]
_fields) -> Name
name
        (InfixC BangType
_ty1 Name
name BangType
_ty2) -> Name
name
        (ForallC [TyVarBndr]
_vars Cxt
_constraints Con
innerConstructor) -> Con -> Name
constructorName Con
innerConstructor
        -- If there's GADTs where multiple constructors are declared with the
        -- same type signature you're evil and furthermore this diagnostic will
        -- only show you the first name.
        (GadtC [Name]
names [BangType]
_fields Kind
_ret) -> [Name] -> Name
forall a. [a] -> a
head [Name]
names
        (RecGadtC [Name]
names [VarBangType]
_fields Kind
_ret) -> [Name] -> Name
forall a. [a] -> a
head [Name]
names

makeToAliasInstance :: RecordInfo -> Q Dec
makeToAliasInstance :: RecordInfo -> Q Dec
makeToAliasInstance info :: RecordInfo
info@RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
sqlConstructorName :: Name
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
sqlConstructorName :: RecordInfo -> Name
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
  Dec
toAliasDec' <- RecordInfo -> Q Dec
toAliasDec RecordInfo
info
  let overlap :: Maybe a
overlap = Maybe a
forall a. Maybe a
Nothing
      instanceConstraints :: [a]
instanceConstraints = []
      instanceType :: Kind
instanceType =
        (Name -> Kind
ConT ''ToAlias)
          Kind -> Kind -> Kind
`AppT` (Name -> Kind
ConT Name
sqlName)
  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
overlap Cxt
forall a. [a]
instanceConstraints Kind
instanceType [Dec
toAliasDec']

toAliasDec :: RecordInfo -> Q Dec
toAliasDec :: RecordInfo -> Q Dec
toAliasDec RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
sqlConstructorName :: Name
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
sqlConstructorName :: RecordInfo -> Name
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
  ([Stmt]
statements, [FieldPat]
fieldPatterns, [(Name, Exp)]
fieldExps) <-
    [(Stmt, FieldPat, (Name, Exp))]
-> ([Stmt], [FieldPat], [(Name, Exp)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Stmt, FieldPat, (Name, Exp))]
 -> ([Stmt], [FieldPat], [(Name, Exp)]))
-> Q [(Stmt, FieldPat, (Name, Exp))]
-> Q ([Stmt], [FieldPat], [(Name, Exp)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Kind)]
-> ((Name, Kind) -> Q (Stmt, FieldPat, (Name, Exp)))
-> Q [(Stmt, FieldPat, (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, Kind)]
sqlFields (\(Name
fieldName', Kind
_) -> do
      Name
fieldPatternName <- String -> Q Name
newName (Name -> String
nameBase Name
fieldName')
      Name
boundValueName <- String -> Q Name
newName (Name -> String
nameBase Name
fieldName')
      (Stmt, FieldPat, (Name, Exp)) -> Q (Stmt, FieldPat, (Name, Exp))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Pat -> Exp -> Stmt
BindS
            (Name -> Pat
VarP Name
boundValueName)
            (Name -> Exp
VarE 'toAlias Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
fieldPatternName)
        , (Name
fieldName', Name -> Pat
VarP Name
fieldPatternName)
        , (Name
fieldName', Name -> Exp
VarE Name
boundValueName)
        ))

  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
    Name -> [Clause] -> Dec
FunD
      'toAlias
      [ [Pat] -> Body -> [Dec] -> Clause
Clause
          [ Name -> [FieldPat] -> Pat
RecP Name
sqlName [FieldPat]
fieldPatterns
          ]
          ( Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
              [Stmt] -> Exp
DoE
#if MIN_VERSION_template_haskell(2,17,0)
                Nothing
#endif
                ([Stmt]
statements [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) (Name -> [(Name, Exp)] -> Exp
RecConE Name
sqlName [(Name, Exp)]
fieldExps)])
          )
          -- `where` clause.
          []
      ]

makeToAliasReferenceInstance :: RecordInfo -> Q Dec
makeToAliasReferenceInstance :: RecordInfo -> Q Dec
makeToAliasReferenceInstance info :: RecordInfo
info@RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
sqlConstructorName :: Name
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
sqlConstructorName :: RecordInfo -> Name
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
  Dec
toAliasReferenceDec' <- RecordInfo -> Q Dec
toAliasReferenceDec RecordInfo
info
  let overlap :: Maybe a
overlap = Maybe a
forall a. Maybe a
Nothing
      instanceConstraints :: [a]
instanceConstraints = []
      instanceType :: Kind
instanceType =
        (Name -> Kind
ConT ''ToAliasReference)
          Kind -> Kind -> Kind
`AppT` (Name -> Kind
ConT Name
sqlName)
  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
overlap Cxt
forall a. [a]
instanceConstraints Kind
instanceType [Dec
toAliasReferenceDec']

toAliasReferenceDec :: RecordInfo -> Q Dec
toAliasReferenceDec :: RecordInfo -> Q Dec
toAliasReferenceDec RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
sqlConstructorName :: Name
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
sqlConstructorName :: RecordInfo -> Name
constructorName :: RecordInfo -> Name
kind :: RecordInfo -> Maybe Kind
typeVarBinders :: RecordInfo -> [TyVarBndr]
constraints :: RecordInfo -> Cxt
sqlName :: RecordInfo -> Name
name :: RecordInfo -> Name
..} = do
  Name
identInfo <- String -> Q Name
newName String
"identInfo"

  ([Stmt]
statements, [FieldPat]
fieldPatterns, [(Name, Exp)]
fieldExps) <-
    [(Stmt, FieldPat, (Name, Exp))]
-> ([Stmt], [FieldPat], [(Name, Exp)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Stmt, FieldPat, (Name, Exp))]
 -> ([Stmt], [FieldPat], [(Name, Exp)]))
-> Q [(Stmt, FieldPat, (Name, Exp))]
-> Q ([Stmt], [FieldPat], [(Name, Exp)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Kind)]
-> ((Name, Kind) -> Q (Stmt, FieldPat, (Name, Exp)))
-> Q [(Stmt, FieldPat, (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, Kind)]
sqlFields (\(Name
fieldName', Kind
_) -> do
      Name
fieldPatternName <- String -> Q Name
newName (Name -> String
nameBase Name
fieldName')
      Name
boundValueName <- String -> Q Name
newName (Name -> String
nameBase Name
fieldName')
      (Stmt, FieldPat, (Name, Exp)) -> Q (Stmt, FieldPat, (Name, Exp))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Pat -> Exp -> Stmt
BindS
            (Name -> Pat
VarP Name
boundValueName)
            (Name -> Exp
VarE 'toAliasReference Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
identInfo Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
fieldPatternName)
        , (Name
fieldName', Name -> Pat
VarP Name
fieldPatternName)
        , (Name
fieldName', Name -> Exp
VarE Name
boundValueName)
        ))

  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
    Name -> [Clause] -> Dec
FunD
      'toAliasReference
      [ [Pat] -> Body -> [Dec] -> Clause
Clause
          [ Name -> Pat
VarP Name
identInfo
          , Name -> [FieldPat] -> Pat
RecP Name
sqlName [FieldPat]
fieldPatterns
          ]
          ( Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
              [Stmt] -> Exp
DoE
#if MIN_VERSION_template_haskell(2,17,0)
                Nothing
#endif
                ([Stmt]
statements [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Exp -> Stmt
NoBindS (Exp -> Stmt) -> Exp -> Stmt
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) (Name -> [(Name, Exp)] -> Exp
RecConE Name
sqlName [(Name, Exp)]
fieldExps)])
          )
          -- `where` clause.
          []
      ]