{-# LANGUAGE TemplateHaskellQuotes #-}

{-
  This module containts template haskell code that generates HasField instances
  for generated persistent entities. For each @EntityDef@ provided, it
  generates:

    instance HasField "fieldKey" TableType FieldValue
    instance HasField "fieldKey" (Entity TableType) FieldValue
    instance HasField "id" (Entity TableType) (Key TableType)

  With these instances, you can access fields from persistent types much more
  easily. For example:

    longTableNameLongFieldName fetchEntity

  Becomes

    fetchEntity.longFieldName
-}
module Models.HasFieldTH (deriveHasFieldInstances) where

import Data.Char qualified as Char
import Data.Text qualified as Text
import Database.Persist qualified as Persist
import Database.Persist.Types qualified as PersistTypes
import GHC.Records (HasField (..))
import Language.Haskell.TH qualified as TH

import MoonBase


--------------------------------------------------------------------------------
-- Instances TH

-- | For a list of entities, generate Has field instances
deriveHasFieldInstances :: [Persist.EntityDef] -> TH.Q [TH.Dec]
deriveHasFieldInstances = fmap concat . traverse deriveHasFieldInstanceForEntity


-- | For an entity, generate HasField instances
deriveHasFieldInstanceForEntity :: Persist.EntityDef -> TH.Q [TH.Dec]
deriveHasFieldInstanceForEntity entityDef = do
  -- Get basic metadata about the entity
  let entityName = Persist.unEntityNameHS $ Persist.getEntityHaskellName entityDef
      entityPrefix = lowercaseFirst entityName
      entityFields = Persist.getEntityFields entityDef

      -- Helper function to creat the @HasField@ instance
      mkHasFieldInstanceType fieldKeyType modifyTableType fieldValType =
        TH.ConT ''HasField
          `TH.AppT` fieldKeyType
          `TH.AppT` modifyTableType (TH.ConT . TH.mkName $ Text.unpack entityName)
          `TH.AppT` fieldValType

  -- For every field, generate `TableType` and `Entity TableType` HasField instances
  fieldInstances <- forM entityFields $ \entityField -> do
    -- Get field name, type and accessor metadata
    let fieldName = Persist.unFieldNameHS $ Persist.fieldHaskell entityField
        fieldIsMaybe = elem PersistTypes.FieldAttrMaybe $ Persist.fieldAttrs entityField
        fieldType =
          toFieldType (Persist.fieldType entityField)
            & if fieldIsMaybe
              then TH.AppT (TH.ConT $ TH.mkName "Maybe")
              else id
        recordAccessor = entityPrefix <> uppercaseFirst fieldName
        recordAccessorVar = TH.VarE . TH.mkName $ Text.unpack recordAccessor
        fieldNameType = TH.LitT (TH.StrTyLit $ Text.unpack fieldName)

        -- Create the instance types
        hasFieldTableType =
          mkHasFieldInstanceType fieldNameType id fieldType
        hasFieldEntityType =
          mkHasFieldInstanceType fieldNameType (TH.ConT ''Persist.Entity `TH.AppT`) fieldType

    -- Create the getter for the entit y
    getEntityFieldDef <- [e|Persist.entityVal <&> $(pure recordAccessorVar)|]

    pure
      [ -- Translates to:
        -- instance HasField "field" (Entity TableType) FieldType where
        --   getField = fieldAccessor
        TH.InstanceD
          Nothing
          []
          hasFieldEntityType
          [ TH.FunD
              (TH.mkName "getField")
              [ TH.Clause [] (TH.NormalB getEntityFieldDef) []
              ]
          ]
      , -- Translates to:
        -- instance HasField "field" TableType FieldType where
        --   getField = fieldAccessor
        TH.InstanceD
          Nothing
          []
          hasFieldTableType
          [ TH.FunD
              (TH.mkName "getField")
              [ TH.Clause [] (TH.NormalB recordAccessorVar) []
              ]
          ]
      ]

  -- Create the HasField instance for the entity key
  getEntityIdDef <- [e|Persist.entityKey|]
  let hasFieldIdEntityType =
        mkHasFieldInstanceType
          (TH.LitT $ TH.StrTyLit "id")
          (TH.ConT ''Persist.Entity `TH.AppT`)
          (TH.ConT ''Persist.Key `TH.AppT` TH.ConT (TH.mkName $ Text.unpack entityName))
      idInstance =
        -- instance HasField "id" (Entity EntityType) FieldType where
        --   getField = fieldAccessor
        TH.InstanceD
          Nothing
          []
          hasFieldIdEntityType
          [ TH.FunD
              (TH.mkName "getField")
              [ TH.Clause [] (TH.NormalB getEntityIdDef) []
              ]
          ]

  pure $ idInstance : concat fieldInstances
 where
  -- Convert a persist type to a TH type
  toFieldType :: PersistTypes.FieldType -> TH.Type
  toFieldType = \case
    PersistTypes.FTTypeCon mbModule typ ->
      TH.ConT . TH.mkName . Text.unpack $ maybe "" (<> ".") mbModule <> typ
    PersistTypes.FTTypePromoted typ ->
      TH.PromotedT . TH.mkName . Text.unpack $ typ
    PersistTypes.FTList typ ->
      TH.AppT (TH.ConT $ TH.mkName "[]") (toFieldType typ)
    PersistTypes.FTApp typA typB ->
      TH.AppT (toFieldType typA) (toFieldType typB)


--------------------------------------------------------------------------------
-- Helpers

-- | Convert the first letter of the Text to lowercase
lowercaseFirst :: Text -> Text
lowercaseFirst t =
  case Text.uncons t of
    Just (firstLetter, rest) -> Text.cons (Char.toLower firstLetter) rest
    Nothing -> t


-- | Convert the first letter of the Text to uppercase
uppercaseFirst :: Text -> Text
uppercaseFirst t =
  case Text.uncons t of
    Just (firstLetter, rest) -> Text.cons (Char.toUpper firstLetter) rest
    Nothing -> t