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

module Database.Esqueleto.Record
  ( deriveEsqueletoRecord
  , deriveEsqueletoRecordWith

  , DeriveEsqueletoRecordSettings(..)
  , defaultDeriveEsqueletoRecordSettings
  , takeColumns
  , takeMaybeColumns
  ) 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.ToMaybe (ToMaybe(..))
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, isJust)

-- | 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' ('Maybe' 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' ('Maybe' 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' ('Maybe' 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
sqlMaybeNameModifier :: String -> String
    -- ^ Function applied to the Haskell record's type name and constructor
    -- name to produce the 'ToMaybe' record's type name and constructor name.
    --
    -- @since 3.5.11.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
  , DeriveEsqueletoRecordSettings -> String -> String
sqlMaybeFieldModifier :: String -> String
    -- ^ Function applied to the Haskell record's field names to produce the
    -- 'ToMaybe' SQL record's field names.
    --
    -- @since 3.5.11.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
  { sqlNameModifier :: String -> String
sqlNameModifier = (String
"Sql" String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  , sqlMaybeNameModifier :: String -> String
sqlMaybeNameModifier = (String
"SqlMaybe" String -> String -> String
forall a. [a] -> [a] -> [a]
++)
  , sqlFieldModifier :: String -> String
sqlFieldModifier = String -> String
forall a. a -> a
id
  , sqlMaybeFieldModifier :: String -> String
sqlMaybeFieldModifier = 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
  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.
  recordDec <- makeSqlRecord info
  sqlSelectInstanceDec <- makeSqlSelectInstance info
  sqlMaybeRecordDec <- makeSqlMaybeRecord info
  toMaybeInstanceDec <- makeToMaybeInstance info
  sqlMaybeToMaybeInstanceDec <- makeSqlMaybeToMaybeInstance info
  sqlMaybeRecordSelectInstanceDec <- makeSqlMaybeRecordSelectInstance info
  toAliasInstanceDec <- makeToAliasInstance info
  sqlMaybeToAliasInstanceDec <- makeSqlMaybeToAliasInstance info
  toAliasReferenceInstanceDec <- makeToAliasReferenceInstance info
  sqlMaybeToAliasReferenceInstanceDec <- makeSqlMaybeToAliasReferenceInstance info
  pure
    [ recordDec
    , sqlSelectInstanceDec
    , sqlMaybeRecordDec
    , toMaybeInstanceDec
    , sqlMaybeToMaybeInstanceDec
    , sqlMaybeRecordSelectInstanceDec
    , toAliasInstanceDec
    , sqlMaybeToAliasInstanceDec
    , toAliasReferenceInstanceDec
    , sqlMaybeToAliasReferenceInstanceDec
    ]

-- | 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 generated SQL 'ToMaybe' record's name.
    RecordInfo -> Name
sqlMaybeName :: 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,21,0)
    RecordInfo -> [TyVarBndr BndrVis]
typeVarBinders :: [TyVarBndr BndrVis]
#elif MIN_VERSION_template_haskell(2,17,0)
    typeVarBinders :: [TyVarBndr ()]
#else
    typeVarBinders :: [TyVarBndr]
#endif
  , -- | The original record's kind, I think.
    RecordInfo -> Maybe Type
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 generated SQL 'ToMaybe' record's constructor name.
    RecordInfo -> Name
sqlMaybeConstructorName :: Name
  , -- | The original record's field names and types, derived from the
    -- constructors.
    RecordInfo -> [(Name, Type)]
fields :: [(Name, Type)]
  , -- | The generated SQL record's field names and types, computed
    -- with 'sqlFieldType'.
    RecordInfo -> [(Name, Type)]
sqlFields :: [(Name, Type)]
  , -- | The generated SQL 'ToMaybe' record's field names and types, computed
    -- with 'sqlMaybeFieldType'.
    RecordInfo -> [(Name, Type)]
sqlMaybeFields :: [(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 <- Name -> Q Info
reify Name
name
  (constraints, typeVarBinders, kind, constructors) <-
        case dec of
          DataD Cxt
constraints' Name
_name [TyVarBndr BndrVis]
typeVarBinders' Maybe Type
kind' [Con]
constructors' [DerivClause]
_derivingClauses ->
            (Cxt, [TyVarBndr BndrVis], Maybe Type, [Con])
-> Q (Cxt, [TyVarBndr BndrVis], Maybe Type, [Con])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt
constraints', [TyVarBndr BndrVis]
typeVarBinders', Maybe Type
kind', [Con]
constructors')
          NewtypeD Cxt
constraints' Name
_name [TyVarBndr BndrVis]
typeVarBinders' Maybe Type
kind' Con
constructor' [DerivClause]
_derivingClauses ->
            (Cxt, [TyVarBndr BndrVis], Maybe Type, [Con])
-> Q (Cxt, [TyVarBndr BndrVis], Maybe Type, [Con])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt
constraints', [TyVarBndr BndrVis]
typeVarBinders', Maybe Type
kind', [Con
constructor'])
          Dec
_ -> String -> Q (Cxt, [TyVarBndr BndrVis], Maybe Type, [Con])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Cxt, [TyVarBndr BndrVis], Maybe Type, [Con]))
-> String -> Q (Cxt, [TyVarBndr BndrVis], Maybe Type, [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"
  constructor <- case constructors of
                  (Con
c : [Con]
_) -> Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
c
                  [] -> String -> Q Con
forall a. String -> Q a
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 =
        case [Con] -> Con
forall a. HasCallStack => [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 = Con -> [(Name, Type)]
getFields Con
constructor
      sqlName = DeriveEsqueletoRecordSettings -> Name -> Name
makeSqlName DeriveEsqueletoRecordSettings
settings Name
name
      sqlMaybeName = DeriveEsqueletoRecordSettings -> Name -> Name
makeSqlMaybeName DeriveEsqueletoRecordSettings
settings Name
name
      sqlConstructorName = DeriveEsqueletoRecordSettings -> Name -> Name
makeSqlName DeriveEsqueletoRecordSettings
settings Name
constructorName
      sqlMaybeConstructorName = DeriveEsqueletoRecordSettings -> Name -> Name
makeSqlMaybeName DeriveEsqueletoRecordSettings
settings Name
constructorName

  sqlFields <- mapM toSqlField fields
  sqlMaybeFields <- mapM toSqlMaybeField fields

  pure RecordInfo {..}
  where
    getFields :: Con -> [(Name, Type)]
    getFields :: Con -> [(Name, Type)]
getFields (RecC Name
_name [VarBangType]
fields) = [(Name
fieldName', Type
fieldType') | (Name
fieldName', Bang
_bang, Type
fieldType') <- [VarBangType]
fields]
    getFields Con
con = String -> [(Name, Type)]
forall a. HasCallStack => String -> a
error (String -> [(Name, Type)]) -> String -> [(Name, Type)]
forall a b. (a -> b) -> a -> b
$ Con -> String
nonRecordConstructorMessage Con
con

    toSqlField :: (Name, Type) -> Q (Name, Type)
toSqlField (Name
fieldName', Type
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
      sqlTy <- Type -> Q Type
sqlFieldType Type
ty
      pure (modifier fieldName', sqlTy)

    toSqlMaybeField :: (Name, Type) -> Q (Name, Type)
toSqlMaybeField (Name
fieldName', Type
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
sqlMaybeFieldModifier DeriveEsqueletoRecordSettings
settings (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
      sqlTy <- Type -> Q Type
sqlMaybeFieldType Type
ty
      pure (modifier fieldName', 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

-- | Create a new name by prefixing @SqlMaybe@ to a given name.
makeSqlMaybeName :: DeriveEsqueletoRecordSettings -> Name -> Name
makeSqlMaybeName :: DeriveEsqueletoRecordSettings -> Name -> Name
makeSqlMaybeName DeriveEsqueletoRecordSettings
settings Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DeriveEsqueletoRecordSettings -> String -> String
sqlMaybeNameModifier 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 :: Type -> Q Type
sqlFieldType Type
fieldType = do
  maybeSqlType <- Type -> Q (Maybe Type)
reifySqlSelectType Type
fieldType

  pure $
    flip fromMaybe maybeSqlType $
      case fieldType of
        -- Entity x -> SqlExpr (Entity x)
        AppT (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True)) Type
_innerType -> Type -> Type -> Type
AppT (Name -> Type
ConT ''SqlExpr) Type
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` Type
_innerType) -> Type -> Type -> Type
AppT (Name -> Type
ConT ''SqlExpr) Type
fieldType

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

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

  pure $ maybe convertFieldType convertSqlType maybeSqlType
 where
    convertSqlType :: Type -> Type
convertSqlType = ((Name -> Type
ConT ''ToMaybeT) Type -> Type -> Type
`AppT`)
    convertFieldType :: Type
convertFieldType = case Type
fieldType of
        -- Entity x -> SqlExpr (Entity x) -> SqlExpr (Maybe (Entity x))
        AppT (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True)) Type
_innerType ->
          (Name -> Type
ConT ''SqlExpr) Type -> Type -> Type
`AppT` ((Name -> Type
ConT ''Maybe) Type -> Type -> Type
`AppT` Type
fieldType)

        -- Maybe (Entity x) -> SqlExpr (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` Type
_innerType) ->
                    (Name -> Type
ConT ''SqlExpr) Type -> Type -> Type
`AppT` Type
fieldType

        -- Maybe x -> SqlExpr (Value (Maybe x)) -> SqlExpr (Value (Maybe x))
        inner :: Type
inner@((ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Maybe -> Bool
True)) `AppT` Type
_inner) -> (Name -> Type
ConT ''SqlExpr) Type -> Type -> Type
`AppT` ((Name -> Type
ConT ''Value) Type -> Type -> Type
`AppT` Type
inner)

        -- x -> SqlExpr (Value x) -> SqlExpr (Value (Maybe x))
        Type
_ -> (Name -> Type
ConT ''SqlExpr)
                Type -> Type -> Type
`AppT` ((Name -> Type
ConT ''Value)
                        Type -> Type -> Type
`AppT` ((Name -> Type
ConT ''Maybe) Type -> Type -> Type
`AppT` Type
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, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = do
  let newConstructor :: Con
newConstructor = Name -> [VarBangType] -> Con
RecC Name
sqlConstructorName ((Name, Type) -> VarBangType
forall {a} {c}. (a, c) -> (a, Bang, c)
makeField ((Name, Type) -> VarBangType) -> [(Name, Type)] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
`map` [(Name, Type)]
sqlFields)
      derivingClauses :: [a]
derivingClauses = []
  Dec -> Q Dec
forall a. a -> Q a
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 BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
constraints Name
sqlName [TyVarBndr BndrVis]
typeVarBinders Maybe Type
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, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = do
  sqlSelectColsDec' <- RecordInfo -> Q [Dec]
sqlSelectColsDec RecordInfo
info
  sqlSelectColCountDec' <- sqlSelectColCountDec info
  sqlSelectProcessRowDec' <- sqlSelectProcessRowDec info
  let overlap = Maybe a
forall a. Maybe a
Nothing
      instanceConstraints = []
  instanceType <- [t| SqlSelect $(conT sqlName) $(conT name) |]

  pure $ InstanceD overlap instanceConstraints instanceType (sqlSelectColsDec' ++ sqlSelectColCountDec' ++ [ sqlSelectProcessRowDec'])

-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance.
sqlSelectColsDec :: RecordInfo -> Q [Dec]
sqlSelectColsDec :: RecordInfo -> Q [Dec]
sqlSelectColsDec RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = do
  -- Pairs of record field names and local variable names.
  fieldNames <- [(Name, Type)]
-> ((Name, Type) -> 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, Type)]
sqlFields (\(Name
name', Type
_type) -> do
    var <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name'
    pure (name', var))

  -- Patterns binding record fields to local variables.
  let 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 =
        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 b a. (b -> a -> b) -> b -> [a] -> b
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

  identInfo <- newName "identInfo"
  [d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlName fieldPatterns) ->
        sqlSelectCols $(varE identInfo) $(pure joinedFields)
    |]

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

  [d| $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP 'sqlSelectColCount) = \ _ -> sqlSelectColCount (Proxy @($(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
joinedTypes))) |]

-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect`
-- instance.
sqlSelectProcessRowDec :: RecordInfo -> Q Dec
sqlSelectProcessRowDec :: RecordInfo -> Q Dec
sqlSelectProcessRowDec RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = 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.
  (statements, 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, Type), (Name, Type))]
-> (((Name, Type), (Name, Type)) -> 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, Type)] -> [(Name, Type)] -> [((Name, Type), (Name, Type))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, Type)]
fields [(Name, Type)]
sqlFields) (\((Name
fieldName', Type
fieldType), (Name
_, Type
sqlType')) -> do
      valueName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
fieldName')
      pattern <- sqlSelectProcessRowPat fieldType valueName
      pure
        ( BindS
            pattern
            (AppTypeE (VarE 'takeColumns) sqlType')
        , (mkName $ nameBase fieldName', VarE valueName)
        ))

  colsName <- newName "columns"
  processName <- newName "process"

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

  pure $
    FunD
      'sqlSelectProcessRow
      [ Clause
          [VarP colsName]
          (NormalB bodyExp)
          -- `where` clause
          [ ValD
              (VarP processName)
              ( NormalB $
                  DoE
#if MIN_VERSION_template_haskell(2,17,0)
                    Nothing
#endif
                    (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE constructorName 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 :: Type -> Name -> Q Pat
sqlSelectProcessRowPat Type
fieldType Name
var = do
  maybeSqlType <- Type -> Q (Maybe Type)
reifySqlSelectType Type
fieldType

  case maybeSqlType of
    Just Type
_ -> Pat -> Q Pat
forall a. a -> Q a
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 Type
Nothing -> case Type
fieldType of
        -- Entity x -> var
        AppT (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Entity -> Bool
True)) Type
_innerType -> Pat -> Q Pat
forall a. a -> Q a
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` Type
_innerType) -> Pat -> Q Pat
forall a. a -> Q a
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
        Type
_ -> [p| Value $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
var) |]

-- 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 :: Type -> Q (Maybe Type)
reifySqlSelectType Type
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))
  --             []
  -- ]
  tyVarName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
  instances <- reifyInstances ''SqlSelect [VarT tyVarName, 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 Type
originalTy Type
instanceTy =
        case Type
instanceTy of
          (ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''SqlSelect -> Bool
True))
            `AppT` Type
sqlTy
            `AppT` (Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
(==) Type
originalTy -> Bool
True) -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
sqlTy
          Type
_ -> Maybe Type
forall a. Maybe a
Nothing

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

  pure $ listToMaybe 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 :: forall a b. SqlSelect a b => 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 (forall t. Proxy t
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 a. [a] -> 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
          value <- [PersistValue] -> Either Text b
forall a r. SqlSelect a r => [PersistValue] -> Either Text r
sqlSelectProcessRow [PersistValue]
target
          Right (value, 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 Specificity]
_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 Type
_ret) -> [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
names
        (RecGadtC [Name]
names [VarBangType]
_fields Type
_ret) -> [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
names

makeToAliasInstance :: RecordInfo -> Q Dec
makeToAliasInstance :: RecordInfo -> Q Dec
makeToAliasInstance RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = Name -> [(Name, Type)] -> Q Dec
makeToAliasInstanceFor Name
sqlName [(Name, Type)]
sqlFields

makeSqlMaybeToAliasInstance :: RecordInfo -> Q Dec
makeSqlMaybeToAliasInstance :: RecordInfo -> Q Dec
makeSqlMaybeToAliasInstance RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = Name -> [(Name, Type)] -> Q Dec
makeToAliasInstanceFor Name
sqlMaybeName [(Name, Type)]
sqlMaybeFields

makeToAliasInstanceFor :: Name -> [(Name, Type)] -> Q Dec
makeToAliasInstanceFor :: Name -> [(Name, Type)] -> Q Dec
makeToAliasInstanceFor Name
name [(Name, Type)]
fields = do
  toAliasDec' <- Name -> [(Name, Type)] -> Q Dec
toAliasDec Name
name [(Name, Type)]
fields
  let overlap = Maybe a
forall a. Maybe a
Nothing
      instanceConstraints = []
      instanceType = (Name -> Type
ConT ''ToAlias) Type -> Type -> Type
`AppT` (Name -> Type
ConT Name
name)
  pure $ InstanceD overlap instanceConstraints instanceType [toAliasDec']

toAliasDec :: Name -> [(Name, Type)] -> Q Dec
toAliasDec :: Name -> [(Name, Type)] -> Q Dec
toAliasDec Name
name [(Name, Type)]
fields = do
  (statements, fieldPatterns, 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, Type)]
-> ((Name, Type) -> 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, Type)]
fields (\(Name
fieldName', Type
_) -> do
      fieldPatternName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
fieldName')
      boundValueName <- newName (nameBase fieldName')
      pure
        ( BindS
            (VarP boundValueName)
            (VarE 'toAlias `AppE` VarE fieldPatternName)
        , (fieldName', VarP fieldPatternName)
        , (fieldName', VarE boundValueName)
        ))

  pure $
    FunD
      'toAlias
      [ Clause
          [ RecP name fieldPatterns
          ]
          ( NormalB $
              DoE
#if MIN_VERSION_template_haskell(2,17,0)
                Nothing
#endif
                (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE name fieldExps)])
          )
          -- `where` clause.
          []
      ]

makeToAliasReferenceInstance :: RecordInfo -> Q Dec
makeToAliasReferenceInstance :: RecordInfo -> Q Dec
makeToAliasReferenceInstance RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = Name -> [(Name, Type)] -> Q Dec
makeToAliasReferenceInstanceFor Name
sqlName [(Name, Type)]
sqlFields

makeSqlMaybeToAliasReferenceInstance :: RecordInfo -> Q Dec
makeSqlMaybeToAliasReferenceInstance :: RecordInfo -> Q Dec
makeSqlMaybeToAliasReferenceInstance RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} =
  Name -> [(Name, Type)] -> Q Dec
makeToAliasReferenceInstanceFor Name
sqlMaybeName [(Name, Type)]
sqlMaybeFields

makeToAliasReferenceInstanceFor :: Name -> [(Name, Type)] -> Q Dec
makeToAliasReferenceInstanceFor :: Name -> [(Name, Type)] -> Q Dec
makeToAliasReferenceInstanceFor Name
name [(Name, Type)]
fields = do
  toAliasReferenceDec' <- Name -> [(Name, Type)] -> Q Dec
toAliasReferenceDec Name
name [(Name, Type)]
fields
  let overlap = Maybe a
forall a. Maybe a
Nothing
      instanceConstraints = []
      instanceType = (Name -> Type
ConT ''ToAliasReference) Type -> Type -> Type
`AppT` (Name -> Type
ConT Name
name)
  pure $ InstanceD overlap instanceConstraints instanceType [toAliasReferenceDec']

toAliasReferenceDec :: Name -> [(Name, Type)] -> Q Dec
toAliasReferenceDec :: Name -> [(Name, Type)] -> Q Dec
toAliasReferenceDec Name
name [(Name, Type)]
fields = do
  identInfo <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"identInfo"

  (statements, fieldPatterns, fieldExps) <-
    unzip3 <$> forM fields (\(Name
fieldName', Type
_) -> do
      fieldPatternName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
fieldName')
      boundValueName <- newName (nameBase fieldName')
      pure
        ( BindS
            (VarP boundValueName)
            (VarE 'toAliasReference `AppE` VarE identInfo `AppE` VarE fieldPatternName)
        , (fieldName', VarP fieldPatternName)
        , (fieldName', VarE boundValueName)
        ))

  pure $
    FunD
      'toAliasReference
      [ Clause
          [ VarP identInfo
          , RecP name fieldPatterns
          ]
          ( NormalB $
              DoE
#if MIN_VERSION_template_haskell(2,17,0)
                Nothing
#endif
                (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE name fieldExps)])
          )
          -- `where` clause.
          []
      ]

-- | Generates the declaration for an @SqlMaybe@-prefixed record, given the original
-- record's information.
makeSqlMaybeRecord :: RecordInfo -> Q Dec
makeSqlMaybeRecord :: RecordInfo -> Q Dec
makeSqlMaybeRecord  RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = do
  let newConstructor :: Con
newConstructor = Name -> [VarBangType] -> Con
RecC Name
sqlMaybeConstructorName ((Name, Type) -> VarBangType
forall {a} {c}. (a, c) -> (a, Bang, c)
makeField ((Name, Type) -> VarBangType) -> [(Name, Type)] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
`map` [(Name, Type)]
sqlMaybeFields)
      derivingClauses :: [a]
derivingClauses = []
  Dec -> Q Dec
forall a. a -> Q a
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 BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
constraints Name
sqlMaybeName [TyVarBndr BndrVis]
typeVarBinders Maybe Type
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 a `ToMaybe` instance for the given record.
makeToMaybeInstance :: RecordInfo -> Q Dec
makeToMaybeInstance :: RecordInfo -> Q Dec
makeToMaybeInstance info :: RecordInfo
info@RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = do
  toMaybeTDec' <- Name -> Name -> Q [Dec]
toMaybeTDec Name
sqlName Name
sqlMaybeName 
  toMaybeDec' <- toMaybeDec info
  let overlap = Maybe a
forall a. Maybe a
Nothing
      instanceConstraints = []
      instanceType = (Name -> Type
ConT ''ToMaybe) Type -> Type -> Type
`AppT` (Name -> Type
ConT Name
sqlName)

  pure $ InstanceD overlap instanceConstraints instanceType (toMaybeTDec' ++ toMaybeDec')

-- | Generates a `ToMaybe` instance for the SqlMaybe of the given record.
makeSqlMaybeToMaybeInstance :: RecordInfo -> Q Dec
makeSqlMaybeToMaybeInstance :: RecordInfo -> Q Dec
makeSqlMaybeToMaybeInstance RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = do
  sqlMaybeToMaybeTDec' <- Name -> Name -> Q [Dec]
toMaybeTDec Name
sqlMaybeName Name
sqlMaybeName
  let toMaybeIdDec = Name -> [Clause] -> Dec
FunD 'toMaybe [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB (Name -> Exp
VarE 'id)) []]
      overlap = Maybe a
forall a. Maybe a
Nothing
      instanceConstraints = []
      instanceType = (Name -> Type
ConT ''ToMaybe) Type -> Type -> Type
`AppT` (Name -> Type
ConT Name
sqlMaybeName)
  pure $ InstanceD overlap instanceConstraints instanceType (toMaybeIdDec:sqlMaybeToMaybeTDec')

-- | Generates a `type ToMaybeT ... = ...` declaration for the given names.
toMaybeTDec :: Name -> Name -> Q [Dec]
toMaybeTDec :: Name -> Name -> Q [Dec]
toMaybeTDec Name
nameLeft Name
nameRight =
  [d| type instance ToMaybeT $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
nameLeft) = $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
nameRight) |]

-- | Generates a `toMaybe value = ...` declaration for the given record.
toMaybeDec :: RecordInfo -> Q [Dec]
toMaybeDec :: RecordInfo -> Q [Dec]
toMaybeDec RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = do
  (fieldPatterns, fieldExps) <-
    [(FieldPat, (Name, Exp))] -> ([FieldPat], [(Name, Exp)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(FieldPat, (Name, Exp))] -> ([FieldPat], [(Name, Exp)]))
-> Q [(FieldPat, (Name, Exp))] -> Q ([FieldPat], [(Name, Exp)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((Name, Type), (Name, Type))]
-> (((Name, Type), (Name, Type)) -> Q (FieldPat, (Name, Exp)))
-> Q [(FieldPat, (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([(Name, Type)] -> [(Name, Type)] -> [((Name, Type), (Name, Type))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, Type)]
sqlFields [(Name, Type)]
sqlMaybeFields) (\((Name
fieldName', Type
_), (Name
maybeFieldName', Type
_)) -> do
        fieldPatternName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
fieldName')
        pure
            ( (fieldName', VarP fieldPatternName)
            , (maybeFieldName', VarE 'toMaybe `AppE` VarE fieldPatternName)
            ))

  [d| $(varP 'toMaybe) = \ $(pure $ RecP sqlName fieldPatterns) ->
        $(pure $ RecConE sqlMaybeName fieldExps)
    |]

-- | Generates an `SqlSelect` instance for the given record and its
-- @Sql@-prefixed variant.
makeSqlMaybeRecordSelectInstance :: RecordInfo -> Q Dec
makeSqlMaybeRecordSelectInstance :: RecordInfo -> Q Dec
makeSqlMaybeRecordSelectInstance info :: RecordInfo
info@RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = do
  sqlSelectColsDec' <- RecordInfo -> Q [Dec]
sqlMaybeSelectColsDec RecordInfo
info
  sqlSelectColCountDec' <- sqlMaybeSelectColCountDec info
  sqlSelectProcessRowDec' <- sqlMaybeSelectProcessRowDec info
  let overlap = Maybe a
forall a. Maybe a
Nothing
      instanceConstraints = []
  instanceType <- [t| SqlSelect $(conT sqlMaybeName) (Maybe $(conT name)) |]
  pure $ InstanceD overlap instanceConstraints instanceType (sqlSelectColsDec' ++ sqlSelectColCountDec' ++ [sqlSelectProcessRowDec'])

-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance.
sqlMaybeSelectColsDec :: RecordInfo -> Q [Dec]
sqlMaybeSelectColsDec :: RecordInfo -> Q [Dec]
sqlMaybeSelectColsDec RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = do
  -- Pairs of record field names and local variable names.
  fieldNames <- [(Name, Type)]
-> ((Name, Type) -> 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, Type)]
sqlMaybeFields (\(Name
name', Type
_type) -> do
    var <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name'
    pure (name', var))

  -- Patterns binding record fields to local variables.
  let 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 =
        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 b a. (b -> a -> b) -> b -> [a] -> b
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

  identInfo <- newName "identInfo"
  [d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlMaybeName fieldPatterns) ->
        sqlSelectCols $(varE identInfo) $(pure joinedFields)
    |]

-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect`
-- instance for a SqlMaybe.
sqlMaybeSelectProcessRowDec :: RecordInfo -> Q Dec
sqlMaybeSelectProcessRowDec :: RecordInfo -> Q Dec
sqlMaybeSelectProcessRowDec RecordInfo {Cxt
[(Name, Type)]
[TyVarBndr BndrVis]
Maybe Type
Name
name :: RecordInfo -> Name
sqlName :: RecordInfo -> Name
sqlMaybeName :: RecordInfo -> Name
constraints :: RecordInfo -> Cxt
typeVarBinders :: RecordInfo -> [TyVarBndr BndrVis]
kind :: RecordInfo -> Maybe Type
constructorName :: RecordInfo -> Name
sqlConstructorName :: RecordInfo -> Name
sqlMaybeConstructorName :: RecordInfo -> Name
fields :: RecordInfo -> [(Name, Type)]
sqlFields :: RecordInfo -> [(Name, Type)]
sqlMaybeFields :: RecordInfo -> [(Name, Type)]
name :: Name
sqlName :: Name
sqlMaybeName :: Name
constraints :: Cxt
typeVarBinders :: [TyVarBndr BndrVis]
kind :: Maybe Type
constructorName :: Name
sqlConstructorName :: Name
sqlMaybeConstructorName :: Name
fields :: [(Name, Type)]
sqlFields :: [(Name, Type)]
sqlMaybeFields :: [(Name, Type)]
..} = do
  -- See sqlSelectProcessRowDec, which is similar but does not have special handling for Maybe
  (statements, 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, Type), (Name, Type))]
-> (((Name, Type), (Name, Type)) -> 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, Type)] -> [(Name, Type)] -> [((Name, Type), (Name, Type))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, Type)]
fields [(Name, Type)]
sqlMaybeFields) (\((Name
fieldName', Type
fieldType), (Name
_, Type
sqlType')) -> do
      valueName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
fieldName')
      pattern <- sqlSelectProcessRowPat fieldType valueName
      pure
        ( BindS
            pattern
            (AppTypeE (VarE 'takeColumns) sqlType')
        , (valueName, wrapJust fieldType $ VarE valueName)
        ))

  colsName <- newName "columns"
  processName <- newName "process"

  bodyExp <- [e|
    first (fromString ("Failed to parse " ++ $(lift $ nameBase sqlMaybeName) ++ ": ") <>)
          (evalStateT $(varE processName) $(varE colsName))
    |]

  pure $
    FunD
      'sqlSelectProcessRow
      [ Clause
          [VarP colsName]
          (NormalB bodyExp)
          -- `where`
          [ ValD
              (VarP processName)
              (NormalB $
                  DoE
#if MIN_VERSION_template_haskell(2,17,0)
                    Nothing
#endif
                    (statements ++ [
                      NoBindS $ AppE (VarE 'pure) (
                        CondE
                          (AppE
                            (VarE 'or)
                            (ListE $ fmap (\(Name
n, Exp
_) -> Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'isJust) (Name -> Exp
VarE Name
n)) fieldExps))
                          (case snd <$> fieldExps of
                              [] -> Name -> Exp
ConE Name
constructorName
                              Exp
x:[Exp]
xs ->  (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                                (\Exp
a Exp
b -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
a) (Name -> Exp
VarE '(<*>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
b))
                                (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
constructorName) (Name -> Exp
VarE '(<$>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
x))
                                [Exp]
xs)
                          (ConE 'Nothing)
                        )
                      ]
                    )
              )
              []
          ]
      ]
  where
    wrapJust :: Type -> Exp -> Exp
wrapJust Type
x = case Type
x of
      ((ConT (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) ''Maybe -> Bool
True)) `AppT` Type
_inner) -> Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Just)
      Type
_ -> Exp -> Exp
forall a. a -> a
id

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

  [d| $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP 'sqlSelectColCount) = \_ -> sqlSelectColCount (Proxy @($(Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
joinedTypes))) |]

-- | 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`.
takeMaybeColumns ::
  forall a b.
  (SqlSelect a (ToMaybeT b)) =>
  StateT [PersistValue] (Either Text) (ToMaybeT b)
takeMaybeColumns :: forall a b.
SqlSelect a (ToMaybeT b) =>
StateT [PersistValue] (Either Text) (ToMaybeT b)
takeMaybeColumns = ([PersistValue] -> Either Text (ToMaybeT b, [PersistValue]))
-> StateT [PersistValue] (Either Text) (ToMaybeT 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 (forall t. Proxy t
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 a. [a] -> 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
          value <- [PersistValue] -> Either Text (ToMaybeT b)
forall a r. SqlSelect a r => [PersistValue] -> Either Text r
sqlSelectProcessRow [PersistValue]
target
          Right (value, other)
        else Text -> Either Text (ToMaybeT b, [PersistValue])
forall a b. a -> Either a b
Left Text
"Insufficient columns when trying to parse a column")