{-|
Expression construction.
-}
module Hasql.TH.Construction.Exp where

import Hasql.TH.Prelude hiding (sequence_, string, list)
import Language.Haskell.TH.Syntax
import qualified Hasql.TH.Prelude as Prelude
import qualified Hasql.Encoders as Encoders
import qualified Hasql.Decoders as Decoders
import qualified Hasql.Statement as Statement
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Unsafe as ByteString
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Vector.Generic as Vector
import qualified TemplateHaskell.Compat.V0208 as Compat


-- * Helpers
-------------------------

appList :: Exp -> [Exp] -> Exp
appList :: Exp -> [Exp] -> Exp
appList = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE 

byteString :: ByteString -> Exp
byteString :: ByteString -> Exp
byteString ByteString
x =
  Exp -> [Exp] -> Exp
appList
    (Name -> Exp
VarE 'unsafeDupablePerformIO)
    [
      Exp -> [Exp] -> Exp
appList
        (Name -> Exp
VarE 'ByteString.unsafePackAddressLen)
        [
          Lit -> Exp
LitE (Integer -> Lit
IntegerL (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
ByteString.length ByteString
x))),
          Lit -> Exp
LitE ([Word8] -> Lit
StringPrimL (ByteString -> [Word8]
ByteString.unpack ByteString
x))
        ]
    ]

integral :: Integral a => a -> Exp
integral :: a -> Exp
integral a
x = Lit -> Exp
LitE (Integer -> Lit
IntegerL (a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x))

list :: (a -> Exp) -> [a] -> Exp
list :: (a -> Exp) -> [a] -> Exp
list a -> Exp
renderer [a]
x = [Exp] -> Exp
ListE ((a -> Exp) -> [a] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map a -> Exp
renderer [a]
x)

string :: String -> Exp
string :: String -> Exp
string String
x = Lit -> Exp
LitE (String -> Lit
StringL String
x)

char :: Char -> Exp
char :: Char -> Exp
char Char
x = Lit -> Exp
LitE (Char -> Lit
CharL Char
x)

sequence_ :: [Exp] -> Exp
sequence_ :: [Exp] -> Exp
sequence_ = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
andThen Exp
pureUnit

pureUnit :: Exp
pureUnit :: Exp
pureUnit = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Prelude.pure) ([Maybe Exp] -> Exp
TupE [])

andThen :: Exp -> Exp -> Exp
andThen :: Exp -> Exp -> Exp
andThen Exp
exp1 Exp
exp2 = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(*>)) Exp
exp1) Exp
exp2

tuple :: Int -> Exp
tuple :: Int -> Exp
tuple = Name -> Exp
ConE (Name -> Exp) -> (Int -> Name) -> Int -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Name
tupleDataName

splitTupleAt :: Int -> Int -> Exp
splitTupleAt :: Int -> Int -> Exp
splitTupleAt Int
arity Int
position = let
  nameByIndex :: a -> Name
nameByIndex a
index = OccName -> NameFlavour -> Name
Name (String -> OccName
OccName (Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: a -> String
forall a. Show a => a -> String
show a
index)) NameFlavour
NameS
  names :: [Name]
names = Int -> Int -> [Int]
forall a. Enum a => a -> a -> [a]
enumFromTo Int
0 (Int -> Int
forall a. Enum a => a -> a
pred Int
arity) [Int] -> ([Int] -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
forall a. Show a => a -> Name
nameByIndex
  pats :: [Pat]
pats = [Name]
names [Name] -> ([Name] -> [Pat]) -> [Pat]
forall a b. a -> (a -> b) -> b
& (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP
  pat :: Pat
pat = [Pat] -> Pat
TupP [Pat]
pats
  exps :: [Exp]
exps = [Name]
names [Name] -> ([Name] -> [Exp]) -> [Exp]
forall a b. a -> (a -> b) -> b
& (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE
  body :: Exp
body = Int -> [Exp] -> ([Exp], [Exp])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
position [Exp]
exps ([Exp], [Exp]) -> (([Exp], [Exp]) -> Exp) -> Exp
forall a b. a -> (a -> b) -> b
& \ ([Exp]
a, [Exp]
b) -> [Exp] -> Exp
Compat.tupE [[Exp] -> Exp
Compat.tupE [Exp]
a, [Exp] -> Exp
Compat.tupE [Exp]
b]
  in [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
body

{-|
Given a list of divisible functor expressions,
constructs an expression, which composes them together into
a single divisible functor, parameterized by a tuple of according arity.
-}
contrazip :: [Exp] -> Exp
contrazip :: [Exp] -> Exp
contrazip = \ case
  Exp
_head : [] -> Exp
_head
  Exp
_head : [Exp]
_tail -> Exp -> [Exp] -> Exp
appList (Name -> Exp
VarE 'divide) [Int -> Int -> Exp
splitTupleAt (Int -> Int
forall a. Enum a => a -> a
succ ([Exp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
_tail)) Int
1, Exp
_head, [Exp] -> Exp
contrazip [Exp]
_tail]
  [] -> Exp -> Type -> Exp
SigE (Name -> Exp
VarE 'conquer)
    (let
      _fName :: Name
_fName = String -> Name
mkName String
"f"
      _fVar :: Type
_fVar = Name -> Type
VarT Name
_fName
      in [TyVarBndr] -> Cxt -> Type -> Type
ForallT [Name -> TyVarBndr
PlainTV Name
_fName] [Type -> Type -> Type
AppT (Name -> Type
ConT ''Divisible) (Name -> Type
VarT Name
_fName)]
          (Type -> Type -> Type
AppT (Name -> Type
VarT Name
_fName) (Int -> Type
TupleT Int
0)))

{-|
Given a list of applicative functor expressions,
constructs an expression, which composes them together into
a single applicative functor, parameterized by a tuple of according arity.

>>> $(return (cozip [])) :: Maybe ()
Just ()

>>> $(return (cozip (fmap (AppE (ConE 'Just) . LitE . IntegerL) [1,2,3]))) :: Maybe (Int, Int, Int)
Just (1,2,3)
-}
cozip :: [Exp] -> Exp
cozip :: [Exp] -> Exp
cozip = \ case
  Exp
_head : [] -> Exp
_head
  Exp
_head : [Exp]
_tail -> let
    _length :: Int
_length = [Exp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
_tail Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    in
      (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ Exp
a Exp
b -> Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(<*>)) Exp
a) Exp
b)
        (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fmap) (Int -> Exp
tuple Int
_length)) Exp
_head)
        [Exp]
_tail
  [] -> Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) ([Maybe Exp] -> Exp
TupE [])

{-|
Lambda expression, which destructures 'Fold'.
-}
foldLam :: (Exp -> Exp -> Exp -> Exp) -> Exp
foldLam :: (Exp -> Exp -> Exp -> Exp) -> Exp
foldLam Exp -> Exp -> Exp -> Exp
_body = let
  _stepVarName :: Name
_stepVarName = String -> Name
mkName String
"step"
  _initVarName :: Name
_initVarName = String -> Name
mkName String
"init"
  _extractVarName :: Name
_extractVarName = String -> Name
mkName String
"extract"
  in
    [Pat] -> Exp -> Exp
LamE
      [
        Name -> [Pat] -> Pat
ConP 'Fold
          [
            Name -> Pat
VarP Name
_stepVarName,
            Name -> Pat
VarP Name
_initVarName,
            Name -> Pat
VarP Name
_extractVarName
          ]
      ]
      (Exp -> Exp -> Exp -> Exp
_body (Name -> Exp
VarE Name
_stepVarName) (Name -> Exp
VarE Name
_initVarName) (Name -> Exp
VarE Name
_extractVarName))


-- * Statement
-------------------------

statement :: Exp -> Exp -> Exp -> Exp
statement :: Exp -> Exp -> Exp -> Exp
statement Exp
_sql Exp
_encoder Exp
_decoder =
  Exp -> [Exp] -> Exp
appList (Name -> Exp
ConE 'Statement.Statement) [Exp
_sql, Exp
_encoder, Exp
_decoder, Name -> Exp
ConE 'True]

noResultResultDecoder :: Exp
noResultResultDecoder :: Exp
noResultResultDecoder = Name -> Exp
VarE 'Decoders.noResult

rowsAffectedResultDecoder :: Exp
rowsAffectedResultDecoder :: Exp
rowsAffectedResultDecoder = Name -> Exp
VarE 'Decoders.rowsAffected

singleRowResultDecoder :: Exp -> Exp
singleRowResultDecoder :: Exp -> Exp
singleRowResultDecoder = 'Decoders.singleRow Name -> (Name -> Exp) -> Exp
forall a b. a -> (a -> b) -> b
& Name -> Exp
VarE Exp -> (Exp -> Exp -> Exp) -> Exp -> Exp
forall a b. a -> (a -> b) -> b
& Exp -> Exp -> Exp
AppE

rowMaybeResultDecoder :: Exp -> Exp
rowMaybeResultDecoder :: Exp -> Exp
rowMaybeResultDecoder = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Decoders.rowMaybe)

rowVectorResultDecoder :: Exp -> Exp
rowVectorResultDecoder :: Exp -> Exp
rowVectorResultDecoder = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Decoders.rowVector)

foldStatement :: Exp -> Exp -> Exp -> Exp
foldStatement :: Exp -> Exp -> Exp -> Exp
foldStatement Exp
_sql Exp
_encoder Exp
_rowDecoder =
  (Exp -> Exp -> Exp -> Exp) -> Exp
foldLam (\ Exp
_step Exp
_init Exp
_extract -> Exp -> Exp -> Exp -> Exp
statement Exp
_sql Exp
_encoder (Exp -> Exp -> Exp -> Exp -> Exp
foldResultDecoder Exp
_step Exp
_init Exp
_extract Exp
_rowDecoder))

foldResultDecoder :: Exp -> Exp -> Exp -> Exp -> Exp
foldResultDecoder :: Exp -> Exp -> Exp -> Exp -> Exp
foldResultDecoder Exp
_step Exp
_init Exp
_extract Exp
_rowDecoder =
  Exp -> [Exp] -> Exp
appList (Name -> Exp
VarE 'fmap) [Exp
_extract, Exp -> [Exp] -> Exp
appList (Name -> Exp
VarE 'Decoders.foldlRows) [Exp
_step, Exp
_init, Exp
_rowDecoder]]

unidimensionalParamEncoder :: Bool -> Exp -> Exp
unidimensionalParamEncoder :: Bool -> Exp -> Exp
unidimensionalParamEncoder Bool
nullable =
  Exp -> Exp
applyParamToEncoder (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Exp -> Exp
applyNullabilityToEncoder Bool
nullable

multidimensionalParamEncoder :: Bool -> Int -> Bool -> Exp -> Exp
multidimensionalParamEncoder :: Bool -> Int -> Bool -> Exp -> Exp
multidimensionalParamEncoder Bool
nullable Int
dimensionality Bool
arrayNull =
  Exp -> Exp
applyParamToEncoder (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Exp -> Exp
applyNullabilityToEncoder Bool
arrayNull (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Encoders.array) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
  Int -> Exp -> Exp
applyArrayDimensionalityToEncoder Int
dimensionality (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Exp -> Exp
applyNullabilityToEncoder Bool
nullable

applyParamToEncoder :: Exp -> Exp
applyParamToEncoder :: Exp -> Exp
applyParamToEncoder = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Encoders.param)

applyNullabilityToEncoder :: Bool -> Exp -> Exp
applyNullabilityToEncoder :: Bool -> Exp -> Exp
applyNullabilityToEncoder Bool
nullable = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (if Bool
nullable then 'Encoders.nullable else 'Encoders.nonNullable))

applyArrayDimensionalityToEncoder :: Int -> Exp -> Exp
applyArrayDimensionalityToEncoder :: Int -> Exp -> Exp
applyArrayDimensionalityToEncoder Int
levels =
  if Int
levels Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    then Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Encoders.dimension) (Name -> Exp
VarE 'Vector.foldl')) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Exp -> Exp
applyArrayDimensionalityToEncoder (Int -> Int
forall a. Enum a => a -> a
pred Int
levels)
    else Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Encoders.element)

rowDecoder :: [Exp] -> Exp
rowDecoder :: [Exp] -> Exp
rowDecoder = [Exp] -> Exp
cozip

unidimensionalColumnDecoder :: Bool -> Exp -> Exp
unidimensionalColumnDecoder :: Bool -> Exp -> Exp
unidimensionalColumnDecoder Bool
nullable =
  Exp -> Exp
applyColumnToDecoder (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Exp -> Exp
applyNullabilityToDecoder Bool
nullable

multidimensionalColumnDecoder :: Bool -> Int -> Bool -> Exp -> Exp
multidimensionalColumnDecoder :: Bool -> Int -> Bool -> Exp -> Exp
multidimensionalColumnDecoder Bool
nullable Int
dimensionality Bool
arrayNull =
  Exp -> Exp
applyColumnToDecoder (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Exp -> Exp
applyNullabilityToDecoder Bool
arrayNull (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Decoders.array) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
  Int -> Exp -> Exp
applyArrayDimensionalityToDecoder Int
dimensionality (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Bool -> Exp -> Exp
applyNullabilityToDecoder Bool
nullable

applyColumnToDecoder :: Exp -> Exp
applyColumnToDecoder :: Exp -> Exp
applyColumnToDecoder = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Decoders.column)

applyNullabilityToDecoder :: Bool -> Exp -> Exp
applyNullabilityToDecoder :: Bool -> Exp -> Exp
applyNullabilityToDecoder Bool
nullable = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (if Bool
nullable then 'Decoders.nullable else 'Decoders.nonNullable))

applyArrayDimensionalityToDecoder :: Int -> Exp -> Exp
applyArrayDimensionalityToDecoder :: Int -> Exp -> Exp
applyArrayDimensionalityToDecoder Int
levels =
  if Int
levels Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    then Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Decoders.dimension) (Name -> Exp
VarE 'Vector.replicateM)) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Exp -> Exp
applyArrayDimensionalityToDecoder (Int -> Int
forall a. Enum a => a -> a
pred Int
levels)
    else Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Decoders.element)