module Database.PostgreSQL.Query.TH.Common
  ( cName
  , cArgs
  , cFieldNames
  , lookupVNameErr
  , dataConstructors
  ) where

import Language.Haskell.TH

-- | Return constructor name
cName :: (Monad m) => Con -> m Name
cName :: Con -> m Name
cName (NormalC Name
n [BangType]
_) = Name -> m Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
cName (RecC Name
n [VarBangType]
_) = Name -> m Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
cName Con
_ = [Char] -> m Name
forall a. HasCallStack => [Char] -> a
error [Char]
"Constructor must be simple"

-- | Return count of constructor fields
cArgs :: (Monad m) => Con -> m Int
cArgs :: Con -> m Int
cArgs (NormalC Name
_ [BangType]
n) = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
n
cArgs (RecC Name
_ [VarBangType]
n) = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
n
cArgs Con
_ = [Char] -> m Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Constructor must be simple"

-- | Get field names from record constructor
cFieldNames :: Con -> [Name]
cFieldNames :: Con -> [Name]
cFieldNames (RecC Name
_ [VarBangType]
vst) = (VarBangType -> Name) -> [VarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
a, Bang
_, Type
_) -> Name
a) [VarBangType]
vst
cFieldNames Con
_ = [Char] -> [Name]
forall a. HasCallStack => [Char] -> a
error [Char]
"Constructor must be a record (product type with field names)"


lookupVNameErr :: String -> Q Name
lookupVNameErr :: [Char] -> Q Name
lookupVNameErr [Char]
name =
    [Char] -> Q (Maybe Name)
lookupValueName [Char]
name Q (Maybe Name) -> (Maybe Name -> Q Name) -> Q Name
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    Q Name -> (Name -> Q Name) -> Maybe Name -> Q Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Q Name
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Name) -> [Char] -> Q Name
forall a b. (a -> b) -> a -> b
$ [Char]
"could not find identifier: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name)
          Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return


dataConstructors :: Info -> [Con]
dataConstructors :: Info -> [Con]
dataConstructors = \case
  TyConI Dec
d ->
#if MIN_VERSION_template_haskell(2,11,0)
    let DataD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Type
_ [Con]
cs [DerivClause]
_ = Dec
d
#else
    let DataD _ _ _ cs _ = d
#endif
    in [Con]
cs
  Info
x -> [Char] -> [Con]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Con]) -> [Char] -> [Con]
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected type constructor, " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Info -> [Char]
forall a. Show a => a -> [Char]
show Info
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" got"