{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}

module Database.Persist.TH.Classy where

import Control.Lens (Lens')
import qualified Data.Char as Char
import qualified Data.Text as T
import Data.Traversable (forM)
import Database.Persist
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax

-- | Generate something like:
--
--     class HasName ev a | ev -> a where
--       name :: Lens' ev a
mkClassyClass ::
     String -- ^ like "name"
  -> Q [Dec]
mkClassyClass name
      -- | like "Name"
 =
  let nameCapitalized =
        case name of
          "" -> ""
          (x:xs) -> Char.toUpper x : xs
      -- | like "HasName"
      hasName = "Has" <> nameCapitalized
   in return
        [ ClassD
            []
            (mkName hasName)
            [PlainTV (mkName "ev"), PlainTV (mkName "a")]
            [FunDep [mkName "ev"] [mkName "a"]]
            [ SigD
                (mkName name)
                (AppT
                   (AppT (ConT (mkName "Lens'")) (VarT (mkName "ev")))
                   (VarT (mkName "a")))
            ]
        ]

-- | Generate something like:
--
-- instance HasName Person String where
--   name = (lens personName) (\ x y -> x {personName = y})
mkClassyInstances :: [EntityDef] -> Q [Dec]
mkClassyInstances defs = do
  concat <$> mapM mkClassyInstance defs

mkClassyInstance :: EntityDef -> Q [Dec]
mkClassyInstance EntityDef {..} = do
  forM entityFields $ \FieldDef {..} ->
    case fieldType of
      FTTypeCon tmodule tname -> do
        let _unused = ()
              -- | like "Person"
            instanceTypeName =
              ConT (mkName (T.unpack (unHaskellName entityHaskell)))
              -- | like "person"
            instanceTypeNameLowerFirstChar =
              case T.unpack (unHaskellName entityHaskell) of
                "" -> ""
                (x:xs) -> Char.toLower x : xs
              -- | like "Name"
            fieldUpperFirstChar =
              case T.unpack (unHaskellName fieldHaskell) of
                "" -> ""
                (x:xs) -> Char.toUpper x : xs
              -- | like "HasName"
            instanceHasName = mkName ("Has" <> fieldUpperFirstChar)
              -- | like "personName"
            fieldLongName =
              mkName (instanceTypeNameLowerFirstChar ++ fieldUpperFirstChar)
            fieldClause =
              Clause
                []
                (NormalB
                   (AppE
                      (AppE (VarE (mkName "lens")) (VarE fieldLongName))
                      (LamE
                         [VarP (mkName "x"), VarP (mkName "y")]
                         (RecUpdE
                            (VarE (mkName "x"))
                            [(fieldLongName, VarE (mkName "y"))]))))
                []
            field =
              FunD
                (mkName (T.unpack (unHaskellName fieldHaskell)))
                [fieldClause]
            fieldTName =
              let tnameAndModule = case tmodule of
                    Nothing -> tname
                    Just t -> t <> "." <> tname
                  nonMaybe = ConT (mkName (T.unpack tnameAndModule))
               in case FieldAttrMaybe `elem` fieldAttrs of
                    False -> nonMaybe
                    True -> AppT (ConT (mkName "Maybe")) nonMaybe
        return $
          InstanceD
            Nothing
            []
            ((AppT (AppT (ConT instanceHasName) instanceTypeName) fieldTName))
            [field]