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

module Database.Esqueleto.Record
  ( deriveEsqueletoRecord
  ) where

import Control.Monad.Trans.State.Strict (StateT(..), evalStateT)
import Data.Proxy (Proxy(..))
import Database.Esqueleto.Experimental
       (Entity, PersistValue, SqlExpr, Value(..), (:&)(..))
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 Name
originalName = do
  RecordInfo
info <- Name -> Q RecordInfo
getRecordInfo 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
instanceDec <- RecordInfo -> Q Dec
makeSqlSelectInstance RecordInfo
info
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Dec
recordDec
    , Dec
instanceDec
    ]

-- | 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@-prefixed 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 original record's field names and types, derived from the
    -- constructors.
    RecordInfo -> [(Name, Kind)]
fields :: [(Name, Type)]
  , -- | The generated @Sql@-prefixed 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 :: Name -> Q RecordInfo
getRecordInfo :: Name -> Q RecordInfo
getRecordInfo 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 = Name -> Name
makeSqlName Name
name

  [(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)
forall a. (a, Kind) -> Q (a, 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, Kind)]
-> [(Name, Kind)]
-> RecordInfo
RecordInfo {Cxt
[(Name, Kind)]
[TyVarBndr]
Maybe Kind
Name
sqlFields :: [(Name, Kind)]
sqlName :: Name
fields :: [(Name, Kind)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
name :: Name
sqlFields :: [(Name, Kind)]
fields :: [(Name, Kind)]
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 :: (a, Kind) -> Q (a, Kind)
toSqlField (a
fieldName', Kind
ty) = do
      Kind
sqlTy <- Kind -> Q Kind
sqlFieldType Kind
ty
      (a, Kind) -> Q (a, Kind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
fieldName', Kind
sqlTy)

-- | Create a new name by prefixing @Sql@ to a given name.
makeSqlName :: Name -> Name
makeSqlName :: Name -> Name
makeSqlName Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"Sql" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 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)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
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 -> Name
makeSqlName Name
constructorName) ((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)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
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)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
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)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
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)]
constructorName :: Name
kind :: Maybe Kind
typeVarBinders :: [TyVarBndr]
constraints :: Cxt
sqlName :: Name
name :: Name
sqlFields :: RecordInfo -> [(Name, Kind)]
fields :: RecordInfo -> [(Name, Kind)]
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