Templates.hs

{-# language TemplateHaskell, BlockArguments, RecordWildCards, OverloadedStrings #-}

module Templates where

import Language.Haskell.TH
import Data.Profunctor.Product.TH
import Opaleye
import Opaleye.Table
import Data.Maybe (fromMaybe)
import LocalQ
import qualified Data.List as List
import Data.String
import Database.PostgreSQL.Simple

data TableIdentifier = TableIdentifier {maybeNameOfSchema :: Maybe String, nameOfTable :: String}

data ColumnDescription = ColumnDescription {nameOfColumn :: String, typeOfColumn :: Name, haskellType :: Name}

instance IsString Name where
  fromString = mkName

addPrefix :: String -> TableIdentifier -> String
addPrefix prefix tableIdentifier = prefix ++ "__" ++ (getBasicName tableIdentifier)

getBasicName :: TableIdentifier -> String
getBasicName (TableIdentifier {..}) = "'" ++ maybe "" (++ "__") maybeNameOfSchema ++ nameOfTable ++ "'"

getNameOfPolymorphicRecord, getNameOfAdaptor
  , getNameOfReadRecord, getNameOfHaskellType, getNameOfSelectQuery
  , getNameOfDefinitionOfTable, getNameOfRunSelect :: IsString string => TableIdentifier -> string
getNameOfPolymorphicRecord = fromString . addPrefix "Polymorphic"
getNameOfAdaptor = fromString . addPrefix "adaptor"
getNameOfReadRecord = fromString . addPrefix "Read"
getNameOfHaskellType = fromString . addPrefix "Haskell"
getNameOfSelectQuery = fromString . addPrefix "select"
getNameOfDefinitionOfTable = fromString . addPrefix "table"
getNameOfRunSelect = fromString . addPrefix "runSelect"

constructPolymorphicRecord :: TableIdentifier -> [String] -> Dec
constructPolymorphicRecord tableIdentifier fieldNameStrings = DataD [ ] name
    fieldNameTyVarBndrs Nothing [RecC name fieldNameVarBangTypes] [DerivClause Nothing (fmap ConT instancesToDerive)]
  where
    name = getNameOfPolymorphicRecord tableIdentifier
    fieldNameTyVarBndrs = fmap (PlainTV . mkName) fieldNameStrings
    fieldNameVarBangTypes = fmap constructVarBangType fieldNameStrings
    instancesToDerive = [''Eq, ''Ord, ''Show]

    constructVarBangType nameString =
      ( mkName nameString
      , Bang NoSourceUnpackedness NoSourceStrictness
      , (VarT . mkName) nameString
      )

constructSpecializedRecord :: Name -> Name -> [Type] -> Dec
constructSpecializedRecord name nameOfOriginalType fieldTypes = TySynD name [ ] fullyAppliedTypeConstructor
  where
    fullyAppliedTypeConstructor = foldl AppT (ConT nameOfOriginalType) fieldTypes

constructReadRecord :: TableIdentifier -> [Type] -> Dec
constructReadRecord tableIdentifier fieldTypes = constructSpecializedRecord name nameOfOriginalType fieldTypes
  where
    name = getNameOfReadRecord tableIdentifier
    nameOfOriginalType = getNameOfPolymorphicRecord tableIdentifier

constructHaskellType :: TableIdentifier -> [Type] -> Dec
constructHaskellType tableIdentifier fieldTypes = constructSpecializedRecord name nameOfOriginalType fieldTypes
  where
    name = getNameOfHaskellType tableIdentifier
    nameOfOriginalType = getNameOfPolymorphicRecord tableIdentifier

applyType :: Type -> [Type] -> Type
applyType = foldl AppT

applyExpression :: Exp -> [Exp] -> Exp
applyExpression = foldl AppE

constructTable :: TableIdentifier -> [(String, Type)] -> (Dec, Dec)
constructTable tableIdentifier namesAndTypesOfColumns = (typeSignatureOfTable, definitionOfTable)
  where
    typesOfFields = fmap (AppT (ConT ''Field) . snd) namesAndTypesOfColumns
    typeOfRow = applyType ((ConT . getNameOfPolymorphicRecord) tableIdentifier) typesOfFields
    typeSignatureOfTable = SigD (getNameOfDefinitionOfTable tableIdentifier) (applyType (ConT ''Table) (replicate 2 typeOfRow))

    recordOfTableFields = applyExpression ((ConE . getNameOfPolymorphicRecord) tableIdentifier)
      [AppE (VarE 'requiredTableField) ((LitE . StringL) nameOfColumn) | nameOfColumn <- fmap fst namesAndTypesOfColumns]
    expressionOfTable = applyExpression (VarE 'tableWithSchema)
      [ (LitE . StringL . fromMaybe "public" . maybeNameOfSchema) tableIdentifier
      , (LitE . StringL . nameOfTable) tableIdentifier
      , AppE ((VarE . getNameOfAdaptor) tableIdentifier) recordOfTableFields
      ]
    definitionOfTable = ValD ((VarP . getNameOfDefinitionOfTable) tableIdentifier) (NormalB expressionOfTable) [ ]

arrow :: Type -> Type -> Type
arrow from to = AppT (AppT ArrowT from) to

constructRunSelect :: TableIdentifier -> [Type] -> (Dec, Dec)
constructRunSelect tableIdentifier haskellTypesOfColumns = (typeSignatureOfRunSelect, definitionOfRunSelect)
  where
    typeOfResult = AppT (ConT ''IO) (AppT (ConT ''[ ]) (applyType ((ConT . getNameOfPolymorphicRecord) tableIdentifier) haskellTypesOfColumns))
    typeSignatureOfRunSelect = SigD (getNameOfRunSelect tableIdentifier)
      (ConT ''Connection `arrow` typeOfResult)

    expressionOfRunSelect = applyExpression (VarE 'runSelect)
      [ VarE "connection"
      , AppE (VarE 'selectTable) ((VarE . getNameOfDefinitionOfTable) tableIdentifier)
      ]
    definitionOfRunSelect = FunD (getNameOfRunSelect tableIdentifier)
      [Clause [VarP "connection"] (NormalB expressionOfRunSelect) [ ]]

makeOpaleyeInterface :: TableIdentifier -> [ColumnDescription] -> Q [Dec]
makeOpaleyeInterface tableIdentifier columnDescriptions = runLocalQ do
    localize . pure . pure $ constructPolymorphicRecord tableIdentifier (fmap nameOfColumn columnDescriptions)
    localize . pure . pure $ constructReadRecord tableIdentifier (fmap (ConT . typeOfColumn) columnDescriptions)
    localize . pure . pure $ constructHaskellType tableIdentifier (fmap (ConT . haskellType) columnDescriptions)
    localize $ makeAdaptorAndInstance (getNameOfAdaptor tableIdentifier) (getNameOfPolymorphicRecord tableIdentifier)
    localize . pure . pure $ typeSignatureOfTable
    localize . pure . pure $ definitionOfTable
    localize . pure . pure $ typeSignatureOfRunSelect
    localize . pure . pure $ definitionOfRunSelect
  where
    (typeSignatureOfTable, definitionOfTable) = constructTable tableIdentifier
      (fmap (\ ColumnDescription {..} -> (nameOfColumn, ConT typeOfColumn)) columnDescriptions)
    (typeSignatureOfRunSelect, definitionOfRunSelect) = constructRunSelect tableIdentifier
      (fmap (ConT . haskellType) columnDescriptions)

This depends on LocalQ.