content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE DeriveLift #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Database.Groundhog.TH.Settings
    ( PersistDefinitions (..),
      THEntityDef (..),
      THEmbeddedDef (..),
      THPrimitiveDef (..),
      THConstructorDef (..),
      THFieldDef (..),
      THUniqueDef (..),
      THUniqueKeyDef (..),
      THAutoKeyDef (..),
      PSEntityDef (..),
      PSEmbeddedDef (..),
      PSPrimitiveDef (..),
      PSConstructorDef (..),
      PSFieldDef (..),
      PSUniqueDef (..),
      PSUniqueKeyDef (..),
      PSAutoKeyDef (..),
    )
  where
  
  import Control.Applicative
  import Control.Monad (forM, mzero, when)
  import Data.Aeson
  import Data.Aeson.Types (Pair)
  import qualified Data.Foldable as Fold
  import qualified Data.HashMap.Strict as H
  import Data.Maybe (catMaybes)
  import Data.Text (Text)
  import Database.Groundhog.Core (ReferenceActionType (..), UniqueType (..))
  import Database.Groundhog.Generic (PSFieldDef (..))
  import Language.Haskell.TH
  import Language.Haskell.TH.Syntax (Lift (..))
  
  data PersistDefinitions = PersistDefinitions {psEntities :: [PSEntityDef], psEmbeddeds :: [PSEmbeddedDef], psPrimitives :: [PSPrimitiveDef]}
    deriving (Show, Lift)
  
  -- data SomeData a = U1 { foo :: Int} | U2 { bar :: Maybe String, asc :: Int64, add :: a} | U3 deriving (Show, Eq)
  
  data THEntityDef = THEntityDef
    { thDataName :: Name, -- SomeData
      thDbEntityName :: String, -- SQLSomeData
      thEntitySchema :: Maybe String,
      thAutoKey :: Maybe THAutoKeyDef,
      thUniqueKeys :: [THUniqueKeyDef],
  #if MIN_VERSION_template_haskell(2, 17, 0)
      thTypeParams :: [TyVarBndr ()],
  #else
      thTypeParams :: [TyVarBndr],
  #endif
      thConstructors :: [THConstructorDef]
    }
    deriving (Eq, Show)
  
  data THAutoKeyDef = THAutoKeyDef
    { thAutoKeyConstrName :: String,
      thAutoKeyIsDef :: Bool
    }
    deriving (Eq, Show)
  
  data THEmbeddedDef = THEmbeddedDef
    { thEmbeddedName :: Name,
      thEmbeddedConstructorName :: Name,
      -- | It is used only to set polymorphic part of name of its container
      thDbEmbeddedName :: String,
  #if MIN_VERSION_template_haskell(2, 17, 0)
      thEmbeddedTypeParams :: [TyVarBndr ()],
  #else
      thEmbeddedTypeParams :: [TyVarBndr],
  #endif
      thEmbeddedFields :: [THFieldDef]
    }
    deriving (Eq, Show)
  
  data THPrimitiveDef = THPrimitiveDef
    { thPrimitiveName :: Name,
      -- | It is used only to set polymorphic part of name of its container
      thPrimitiveDbName :: String,
      -- | Name of a pair of functions converting the value to and from a type that is an instance of `PrimitivePersistField`
      thPrimitiveConverter :: Name
    }
    deriving (Eq, Show)
  
  data THConstructorDef = THConstructorDef
    { thConstrName :: Name, -- U2
      thPhantomConstrName :: String, -- U2Constructor
      thDbConstrName :: String, -- SQLU2
      thDbAutoKeyName :: Maybe String, -- u2_id
      thConstrFields :: [THFieldDef],
      thConstrUniques :: [THUniqueDef]
    }
    deriving (Eq, Show)
  
  data THFieldDef = THFieldDef
    { -- | name in the record, bar
      thFieldName :: String,
      -- | column name, SQLbar
      thDbFieldName :: String,
      -- | column type, inet, NUMERIC(5, 2), VARCHAR(50), etc.
      thDbTypeName :: Maybe String,
      -- | name of constructor in the Field GADT, BarField
      thExprName :: String,
      thFieldType :: Type,
      thEmbeddedDef :: Maybe [PSFieldDef String],
      -- | default value in the database
      thDefaultValue :: Maybe String,
      thReferenceParent :: Maybe (Maybe ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType),
      -- | name of a pair of functions
      thFieldConverter :: Maybe Name
    }
    deriving (Eq, Show)
  
  data THUniqueDef = THUniqueDef
    { thUniqueName :: String,
      thUniqueType :: UniqueType,
      -- | Either name of field, i.e, thFieldName, or expression
      thUniqueFields :: [Either String String]
    }
    deriving (Eq, Show)
  
  data THUniqueKeyDef = THUniqueKeyDef
    { thUniqueKeyName :: String,
      thUniqueKeyPhantomName :: String,
      thUniqueKeyConstrName :: String,
      -- | It is used only to set polymorphic part of name of its container
      -- | It should repeat fields from THUniqueDef but it may give different settings for them. It is done to allow foreign key fields to be different from parent fields of the entity. These fields are used for creating a the key constructor and instances for it. For example, it can have a default value, or even a different type (INT8 may reference INT4).
      thUniqueKeyDbName :: String,
      thUniqueKeyFields :: [THFieldDef],
      -- | If True, make it an instance of Embedded
      thUniqueKeyMakeEmbedded :: Bool,
      thUniqueKeyIsDef :: Bool
    }
    deriving (Eq, Show)
  
  data PSEntityDef = PSEntityDef
    { psDataName :: String, -- SomeData
      psDbEntityName :: Maybe String, -- SQLSomeData
      psEntitySchema :: Maybe String,
      psAutoKey :: Maybe (Maybe PSAutoKeyDef), -- SomeDataKey. Nothing - default key. Just Nothing - no autokey. Just (Just _) - specify autokey settings
      psUniqueKeys :: Maybe [PSUniqueKeyDef],
      psConstructors :: Maybe [PSConstructorDef]
    }
    deriving (Eq, Show, Lift)
  
  data PSEmbeddedDef = PSEmbeddedDef
    { psEmbeddedName :: String,
      -- | It is used only to set polymorphic part of name of its container
      psDbEmbeddedName :: Maybe String,
      psEmbeddedFields :: Maybe [PSFieldDef String]
    }
    deriving (Eq, Show, Lift)
  
  data PSPrimitiveDef = PSPrimitiveDef
    { psPrimitiveName :: String,
      -- | It is used only to set polymorphic part of name of its container
      psPrimitiveDbName :: Maybe String,
      -- | Name of a pair of functions converting the value to and from a type that is an instance of `PrimitivePersistField`
      psPrimitiveConverter :: String
    }
    deriving (Eq, Show, Lift)
  
  data PSConstructorDef = PSConstructorDef
    { psConstrName :: String, -- U2
      psPhantomConstrName :: Maybe String, -- U2Constructor
      psDbConstrName :: Maybe String, -- SQLU2
      psDbAutoKeyName :: Maybe String, -- u2_id
      psConstrFields :: Maybe [PSFieldDef String],
      psConstrUniques :: Maybe [PSUniqueDef]
    }
    deriving (Eq, Show, Lift)
  
  data PSUniqueDef = PSUniqueDef
    { psUniqueName :: String,
      psUniqueType :: Maybe UniqueType,
      psUniqueFields :: [Either String String]
    }
    deriving (Eq, Show, Lift)
  
  data PSUniqueKeyDef = PSUniqueKeyDef
    { psUniqueKeyName :: String,
      psUniqueKeyPhantomName :: Maybe String,
      psUniqueKeyConstrName :: Maybe String,
      psUniqueKeyDbName :: Maybe String,
      psUniqueKeyFields :: Maybe [PSFieldDef String],
      psUniqueKeyMakeEmbedded :: Maybe Bool,
      psUniqueKeyIsDef :: Maybe Bool
    }
    deriving (Eq, Show, Lift)
  
  data PSAutoKeyDef = PSAutoKeyDef
    { psAutoKeyConstrName :: Maybe String,
      psAutoKeyIsDef :: Maybe Bool
    }
    deriving (Eq, Show, Lift)
  
  deriving instance Lift a => Lift (PSFieldDef a)
  
  deriving instance Lift UniqueType
  
  deriving instance Lift ReferenceActionType
  
  instance FromJSON PersistDefinitions where
    {- it allows omitting parts of the settings file. All these forms are possible:
          definitions:
            - entity:name
          ---
            - entity:name
          ---
            entity: name
    -}
    parseJSON value =
      case value of
        Object v -> do
          defs <- v .:? "definitions"
          case defs of
            Just (Array arr) -> Fold.foldrM go initial arr
            Nothing -> go value initial
            Just _ -> mzero
        Array arr -> Fold.foldrM go initial arr
        _ -> mzero
      where
        initial = PersistDefinitions [] [] []
        go obj p@PersistDefinitions {..} = flip (withObject "definition") obj $ \v -> case () of
          _ | H.member "entity" v -> (\x -> p {psEntities = x : psEntities}) <$> parseJSON obj
          _ | H.member "embedded" v -> (\x -> p {psEmbeddeds = x : psEmbeddeds}) <$> parseJSON obj
          _ | H.member "primitive" v -> (\x -> p {psPrimitives = x : psPrimitives}) <$> parseJSON obj
          _ -> fail $ "Invalid definition: " ++ show obj
  
  instance FromJSON PSEntityDef where
    parseJSON = withObject "entity" $ \v ->
      PSEntityDef <$> v .: "entity" <*> v .:? "dbName" <*> v .:? "schema" <*> optional (v .: "autoKey") <*> v .:? "keys" <*> v .:? "constructors"
  
  instance FromJSON PSEmbeddedDef where
    parseJSON = withObject "embedded" $ \v ->
      PSEmbeddedDef <$> v .: "embedded" <*> v .:? "dbName" <*> v .:? "fields"
  
  instance FromJSON PSPrimitiveDef where
    parseJSON = withObject "primitive" $ \v -> do
      when (H.member "representation" v) $ fail $ "parseJSON: field 'representation' is deprecated. Use 'converter' instead: " ++ show v
      PSPrimitiveDef <$> v .: "primitive" <*> v .:? "dbName" <*> v .: "converter"
  
  instance FromJSON PSConstructorDef where
    parseJSON = withObject "constructor" $ \v ->
      PSConstructorDef <$> v .: "name" <*> v .:? "phantomName" <*> v .:? "dbName" <*> v .:? "keyDbName" <*> v .:? "fields" <*> v .:? "uniques"
  
  instance FromJSON PSUniqueDef where
    parseJSON = withObject "unique" $ \v -> do
      fields <- v .: "fields"
      fields' <- forM fields $ \case
        Object expr -> Right <$> expr .: "expr"
        field -> Left <$> parseJSON field
      PSUniqueDef <$> v .: "name" <*> v .:? "type" <*> pure fields'
  
  instance FromJSON UniqueType where
    parseJSON o = do
      x <- parseJSON o
      let vals = [("constraint", UniqueConstraint), ("index", UniqueIndex), ("primary", UniquePrimary False)]
      case lookup x vals of
        Just a -> pure a
        Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x
  
  instance FromJSON ReferenceActionType where
    parseJSON o = do
      x <- parseJSON o
      let vals = [("no action", NoAction), ("restrict", Restrict), ("cascade", Cascade), ("set null", SetNull), ("set default", SetDefault)]
      case lookup x vals of
        Just a -> pure a
        Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x
  
  instance FromJSON (PSFieldDef String) where
    parseJSON = withObject "field" $ \v ->
      PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "exprName" <*> v .:? "embeddedType" <*> v .:? "default" <*> mkRefSettings v <*> v .:? "converter"
      where
        mkRefSettings v = do
          ref <- v .:? "reference"
          (parent, onDel, onUpd) <- case ref of
            Just (Object r) -> (,,) <$> optional parentRef <*> r .:? "onDelete" <*> r .:? "onUpdate"
              where
                parentRef = (,) <$> ((,) <$> r .:? "schema" <*> r .: "table") <*> r .: "columns"
            _ -> pure (Nothing, Nothing, Nothing)
          -- this temporary solution uses onDelete and onUpdate both from inside reference object (preferred) and from field level (for compatibility)
          (onDel', onUpd') <- (,) <$> v .:? "onDelete" <*> v .:? "onUpdate"
          pure $ case (parent, onDel <|> onDel', onUpd <|> onUpd') of
            (Nothing, Nothing, Nothing) -> Nothing
            refSettings -> Just refSettings
  
  instance FromJSON PSUniqueKeyDef where
    parseJSON = withObject "unique key" $ \v ->
      PSUniqueKeyDef <$> v .: "name" <*> v .:? "keyPhantom" <*> v .:? "constrName" <*> v .:? "dbName" <*> v .:? "fields" <*> v .:? "mkEmbedded" <*> v .:? "default"
  
  instance FromJSON PSAutoKeyDef where
    parseJSON = withObject "autogenerated key" $ \v ->
      PSAutoKeyDef <$> v .:? "constrName" <*> v .:? "default"
  
  (.=?) :: ToJSON a => Text -> Maybe a -> Maybe Pair
  name .=? value = (name .=) <$> value
  
  (.=:) :: ToJSON a => Text -> Maybe [a] -> Maybe Pair
  name .=: value = case value of
    Just (_ : _) -> Just $ name .= value
    _ -> Nothing
  
  instance ToJSON PSEntityDef where
    toJSON PSEntityDef {..} = object $ catMaybes [Just $ "entity" .= psDataName, "dbName" .=? psDbEntityName, "schema" .=? psEntitySchema, "autoKey" .=? psAutoKey, "keys" .=: psUniqueKeys, "constructors" .=: psConstructors]
  
  instance ToJSON PSConstructorDef where
    toJSON PSConstructorDef {..} = object $ catMaybes [Just $ "name" .= psConstrName, "phantomName" .=? psPhantomConstrName, "dbName" .=? psDbConstrName, "keyDbName" .=? psDbAutoKeyName, "fields" .=: psConstrFields, "uniques" .=: psConstrUniques]
  
  instance ToJSON PSUniqueDef where
    toJSON PSUniqueDef {..} = object $ catMaybes [Just $ "name" .= psUniqueName, "type" .=? psUniqueType, "fields" .=? fields]
      where
        fields =
          if null psUniqueFields
            then Nothing
            else Just $ map (either toJSON (\x -> object ["expr" .= x])) psUniqueFields
  
  instance ToJSON UniqueType where
    toJSON a = toJSON $ case a of
      UniqueConstraint -> "constraint" :: String
      UniqueIndex -> "index"
      UniquePrimary _ -> "primary"
  
  instance ToJSON ReferenceActionType where
    toJSON a = toJSON $ case a of
      NoAction -> "no action" :: String
      Restrict -> "restrict"
      Cascade -> "cascade"
      SetNull -> "set null"
      SetDefault -> "set default"
  
  instance ToJSON (PSFieldDef String) where
    toJSON PSFieldDef {..} = object $ catMaybes [Just $ "name" .= psFieldName, "dbName" .=? psDbFieldName, "type" .=? psDbTypeName, "exprName" .=? psExprName, "embeddedType" .=: psEmbeddedDef, "default" .=? psDefaultValue, "reference" .=? (psReferenceParent >>= mkRefSettings)]
      where
        mkRefSettings (parent, onDel, onUpd) = if null fields then Nothing else Just $ object fields
          where
            fields = catMaybes $ parent' ++ ["onDelete" .=? onDel, "onUpdate" .=? onUpd]
            parent' = case parent of
              Nothing -> []
              Just ((schema, table), columns) -> ["schema" .=? schema, Just $ "table" .= table, Just $ "columns" .= columns]
  
  instance ToJSON PSUniqueKeyDef where
    toJSON PSUniqueKeyDef {..} = object $ catMaybes [Just $ "name" .= psUniqueKeyName, "keyPhantom" .=? psUniqueKeyPhantomName, "constrName" .=? psUniqueKeyConstrName, "dbName" .=? psUniqueKeyDbName, "mkEmbedded" .=? psUniqueKeyMakeEmbedded, "default" .=? psUniqueKeyIsDef, "fields" .=: psUniqueKeyFields]
  
  instance ToJSON PSAutoKeyDef where
    toJSON PSAutoKeyDef {..} = object $ catMaybes ["constrName" .=? psAutoKeyConstrName, "default" .=? psAutoKeyIsDef]
  