{-|
module Internal.     : Data.Basic.TH.Types
Description : Data types and utility function used during TH generation phase
License     : MIT

This module Internal.defines functions that are used to generate Template Haskell code from AST. For AST
description take a look at 'Data.Basic.TH.Types'.
-}
module Internal.Data.Basic.TH.Generator where

import Internal.Interlude
import Cases
import Internal.Data.Basic.TH.Types
import Data.List (nub, (\\))
import qualified Internal.Data.Basic.Types as BT
import qualified Internal.Data.Basic as B
import qualified Internal.Data.Basic.Foreign as F
import Language.Haskell.TH.Syntax as TH
import qualified Database.HsSqlPpp.Syntax as SQL
import Internal.Data.Basic.TH.Helper
import Internal.Data.Basic.Virtual
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.FromRow
import GHC.Generics (Generic)

-- | Generates a data constructor for an entity
--
-- > data Post = Post { _ostId     :: Key
-- >                  , _ostName   :: Text
-- >                  , _ostUserId :: Key } deriving (Show, Read, Generic)
--
dataConstructor :: EntityInfo -> TH.Dec
dataConstructor info = DataD [] entityName [] Nothing [RecC entityName fields] [ConT ''Show, ConT ''Read, ConT ''Generic]
  where entityName = _entityInfoName info
        fields = (\c -> (c ^. columnInfoName, Bang SourceUnpack SourceStrict, finalType c)) <$> (info ^. entityInfoColumnMap)

-- | Generates a fromRow instance for a entity.
--
-- > instance FromRow Post where
-- > fromRow = Post <$> field <*> field <*> field
--
-- fromRowInstance takes a name of the entity and a list of [a],
-- which is just used to count how many fields does the entity have - nothing
-- else. It generates something similar shown in a code snippet above - a
-- working FromRow instance for that datatype.
fromRowInstance :: TH.Name -> [a] -> TH.Dec
fromRowInstance entityName fields = InstanceD Nothing [] (AppT (ConT ''FromRow)
                                                                (ConT entityName))
                                     [ValD (VarP 'fromRow)
                                           (NormalB (addFields initial n)) []]
  where n = length fields
        initial = InfixE (Just (ConE entityName))
                         (VarE '(<$>))
                         (Just (VarE 'field))


-- | Generates field optics for all entities
fieldOptics :: [EntityInfo] -> [TH.Dec]
fieldOptics em = concat $ fieldOptic <$> columnNames
  where columnNames = nub $ _columnInfoText <$> concat (_entityInfoColumnMap <$> em)

-- | Generates field optics for a column
--
--
-- > name :: (FieldOptic "username" fun inType outType inVal outVal) => PolyOptic fun inType outType inVal outVal
-- > name = fieldOpticProxy (Proxy :: Proxy "username")
--
--
fieldOptic :: Text -> [Dec]
fieldOptic t = [SigD fieldName (
                           ForallT [PlainTV o]
                           [
                             AppT (ConT ''B.FieldOpticProxy)
                                  (AppT (AppT ArrowT
                                              (AppT (ConT ''Proxy)
                                                    (LitT (StrTyLit $ toS t))))
                                        (VarT o))
                           ]
                           (VarT o)),

                         ValD (VarP fieldName) (
                           NormalB (AppE (VarE 'B.fieldOpticProxy)
                                         (SigE (ConE 'Proxy)
                                               (AppT (ConT ''Proxy)
                                                     (LitT (StrTyLit $ toS t)))))) []
                       ]
  where fieldName = mkName $ toS $ camelize t
        o = mkName "o"


-- | Applies basic constraint depending on sql constraint
--   If columns is marked as primary or unique, add the 'Unique' haskell datatype
fieldConstraint :: SQL.Constraint -> Maybe [TH.Type]
fieldConstraint (SQL.UniqueConstraint _ name _) = Just [ConT 'BT.Unique `AppT` (LitT $ StrTyLit $ toS name)]
fieldConstraint (SQL.PrimaryKeyConstraint _ name _) = Just [ConT 'BT.Unique `AppT` (LitT $ StrTyLit $ toS name)]
fieldConstraint (SQL.CheckConstraint _ _ _) = Nothing -- @TODO dependent types? :)
fieldConstraint (SQL.ReferenceConstraint _ _ _ _ _ _ _) = Nothing -- @TODO foreign keys?


-- |  Generates a table field instance for a column
--
-- > instance TableField Post "user_id" where
-- >   type TableFieldType Post "user_id" = Key
-- >   tableFieldLens = ostUserId
--
tableField :: EntityInfo -> ColumnInfo -> Dec
tableField ei ci = InstanceD Nothing [] (
                                AppT (ConT ''BT.TableField `AppT` (ConT entityName))
                                     (LitT $ StrTyLit $ toS columnText)
                                ) [
                                TySynInstD ''BT.TableFieldType $ TySynEqn
                                  [ConT entityName, LitT $ StrTyLit $ toS columnText]
                                  columnType,
                                  FunD 'BT.tableFieldLens [Clause [] (NormalB $ VarE lensName) []]
                                ]
  where entityName = ei ^. entityInfoName
        columnType = finalType ci
        columnText = ci ^. columnInfoText
        lensName = mkName $ toS ((lowerFirst.standardizeName $ ei ^. entityInfoText) <> "_" <> columnText)

-- | Generates required table field instances for all entities
tableFields :: [EntityInfo] -> [TH.Dec]
tableFields eis = concat ((\ei -> tableField ei <$> ei ^. entityInfoColumnMap) <$> eis)

-- | Generates final type for the sql column
finalType :: ColumnInfo -> TH.Type
finalType ci
  | null (ci ^. columnInfoConstraints) = ConT ''Maybe `AppT` (ci ^. columnInfoType)
  | otherwise = foldr (applyConstraint ci) (ci ^. columnInfoType) (ci ^. columnInfoConstraints)

-- | Generates initial accessor for the table
--
-- > allPosts = allRows (Proxy :: Proxy "post")
--
initialAccessor :: EntityInfo -> [TH.Dec]
initialAccessor ei =
    [ SigD accessor
           (ForallT [PlainTV res]
                    [ConT ''B.AllRows `AppT` tableType `AppT` VarT res]
                    (VarT res))
    , FunD accessor
           [Clause []
                   (NormalB (AppE (VarE 'B.allRowsProxy)
                                  (SigE (ConE 'Proxy) (ConT ''Proxy `AppT` tableType))))
                   []] ]
    where sTableName = standardizeName (toS tableName)
          res = mkName "res"
          accessor = mkName $ toS $ "all" <> quasyPlural sTableName
          tableName = ei ^. entityInfoText
          tableType = ei ^. entityInfoType


-- | Generates foreign key optics
fkOptics :: [ForeignKeyConstraint] -> [Dec]
fkOptics = foldl' (\acc f -> fkOptic f <> acc) mempty

-- | Generates foreign key optic
--
-- > author :: ForeignKeyLensProxy (Proxy "blog_post_author_fkey" -> o) => o
-- > author = foreignKeyLens @"blog_post_author_fkey"
--
fkOptic :: ForeignKeyConstraint -> [Dec]
fkOptic fk = [
  SigD accName (ForallT [PlainTV o] [
                   AppT (ConT ''F.ForeignKeyLensProxy)
                        (AppT (ArrowT `AppT` (ConT ''Proxy `AppT` name))
                              (VarT o))] (VarT o)),
              ValD (VarP accName)
              (NormalB (AppE (VarE 'B.foreignKeyLensProxy)
                             (SigE (ConE 'Proxy) (ConT ''Proxy `AppT` name)))) []]
  where accName  = mkName $ toS $ (lowerFirst $ toS $ nameBase $ _entityInfoName (_fkFromT fk)) <> (toS $ nameBase $ _entityInfoName (_fkToT fk))
        o = mkName "o"
        name = LitT $ StrTyLit $ toS $ fk ^. fkName

-- | Generates virtual table optics
virtualTables :: [ForeignKeyConstraint] -> [Dec]
virtualTables = foldl' (\acc f -> acc <> virtualTable f) mempty

-- | Generates virtual table optic
--
-- > posts :: VirtualTable "blog_post_author_fkey" res
-- >    => Getter' (Entity ('FromDb c) (ForeignKeyTo "blog_post_author_fkey")) res
-- > posts = virtualTableLensProxy (Proxy :: Proxy "blog_post_author_fkey")
--
virtualTable :: ForeignKeyConstraint -> [Dec]
virtualTable fk = [
  SigD accName (ForallT [PlainTV o,PlainTV c_1] [
                    (ConT ''VirtualTable `AppT` name) `AppT` VarT o
                    ]
                  (AppT (AppT (ConT ''B.Getter')
                              (AppT (AppT (ConT ''BT.Entity)
                                          (PromotedT 'BT.FromDb `AppT` VarT c_1))
                                    (ConT ''BT.ForeignKeyTo `AppT` name)))
                        (VarT o))),
    ValD (VarP accName) (NormalB (AppE (VarE 'B.virtualTableLensProxy)
                                 (SigE (ConE 'Proxy) (ConT ''Proxy `AppT` name))))
    []]
  where accName  = mkName $ toS $ (lowerFirst $ toS $ nameBase $ _entityInfoName (_fkToT fk)) <> (toS $ nameBase $ _entityInfoName (_fkFromT fk))
        o = mkName "o"
        c_1 = mkName "c1"
        name = LitT $ StrTyLit $ toS $ fk ^. fkName


-- | Generates all constraint declarations from the 'ParseContext'
allConstraints :: ParseContext -> [Dec]
allConstraints ctx = concat ((uniqueConstraintInstance <$>  ctx ^. uqs) <>
   (primaryKeyInstance <$> ctx ^. pks) <>
   [foreignKeyConstraint <$> ctx ^. fks])

-- | Generates unique key constraint instance
--
-- > instance UniqueConstraint "blog_user_pkey" where
-- >    type UniqueTable "blog_user_pkey" = User
-- >    type UniqueFields "blog_user_pkey" = '["id"]
--
uniqueConstraintInstance :: UniqueKeyConstraint -> [Dec]
uniqueConstraintInstance uq = [
  InstanceD Nothing [] (
      AppT (ConT ''BT.UniqueConstraint) (LitT (StrTyLit keyName))
      ) [
      TySynInstD ''BT.UniqueTable (
          TySynEqn [LitT (StrTyLit keyName)] (ConT entityName)),
      TySynInstD ''BT.UniqueFields (
          TySynEqn [LitT (StrTyLit keyName)] (listToTypeLevel cols))]]
  where keyName = toS $ uq ^. uqName
        ei = uq ^. uqEntity
        entityName = ei ^. entityInfoName
        cols = (LitT . StrTyLit . toS) <$> (_columnInfoText <$> (uq ^. uqCols))

-- | Generates primary key instance
--
-- > instance PrimaryKeyConstraint "blog_user_pkey"
--
primaryKeyInstance :: PrimaryKeyConstraint -> [Dec]
primaryKeyInstance (PrimaryKeyConstraint name entity cols) = uniqueConstraintInstance (UniqueKeyConstraint name entity cols) <> [InstanceD Nothing [] (AppT (ConT ''BT.PrimaryKeyConstraint) (LitT (StrTyLit $ toS name))) []]


-- | Generates foreign key instance
--
-- > instance ForeignKeyConstraint "blog_post_author_fkey" where
-- > type ForeignKeyFrom "blog_post_author_fkey" = Post
-- > type ForeignKeyFromFields "blog_post_author_fkey" = '["author"]
-- > type ForeignKeyTo "blog_post_author_fkey" = User
-- > type ForeignKeyToFields "blog_post_author_fkey" = '["id"]
--
foreignKeyConstraint :: ForeignKeyConstraint -> Dec
foreignKeyConstraint (ForeignKeyConstraint name fromTableT fromCol toTableT toCol) = InstanceD Nothing [] (ConT ''BT.ForeignKeyConstraint `AppT` (LitT $ StrTyLit $ toS name)) [
        TySynInstD ''BT.ForeignKeyFrom $ TySynEqn [constraint] (fromTableT ^. entityInfoType),
        TySynInstD ''BT.ForeignKeyFromFields $ TySynEqn [constraint] (listToTypeLevel (LitT . StrTyLit . toS . _columnInfoText <$> fromCol)),
        TySynInstD ''BT.ForeignKeyTo $ TySynEqn [constraint] (toTableT ^. entityInfoType),
        TySynInstD ''BT.ForeignKeyToFields $ TySynEqn [constraint] (listToTypeLevel (LitT . StrTyLit . toS . _columnInfoText <$> toCol))
        ]
  where constraint = LitT $ StrTyLit $ toS name


-- | Generates a table instance for an entity from a 'ParseContext'
--
-- > instance Table Post where
-- >     type TableName Post = "blog_post"
-- >     type TableFields Post = ["id", "name", "author"]
-- >     type TableConstraints Post = '[]
-- >     type TablePrimaryKey Post = 'Nothing
-- >     type TableRequiredFields Post = ['DynamicDefault 'id, 'Required "name", 'Required "author"]
--
tableInstance :: ParseContext ->  EntityInfo -> [Dec]
tableInstance ctx ei = [
  InstanceD Nothing [] (ConT ''BT.Table `AppT` entityType) [
      TySynInstD ''BT.TableName $ TySynEqn [entityType] (LitT $ StrTyLit tableName),
      TySynInstD ''BT.TableFields $ TySynEqn [entityType] entityFields,
      TySynInstD ''BT.TableConstraints $ TySynEqn [entityType] entityConstraints,
      TySynInstD ''BT.TablePrimaryKey $ TySynEqn [entityType] primaryKey,
      TySynInstD ''BT.TableRequiredFields $ TySynEqn [entityType] tableRequirements,
      ValD (VarP 'BT.newEntity) (coerceBody ei) []
      ]
  ]
  where fieldNames = view columnInfoText <$> columns
        columns = ei ^. entityInfoColumnMap
        constraints = ei ^. entityInfoConstraintList
        entityType = ei ^. entityInfoType
        tableName = toS $ ei ^. entityInfoText
        entityFields = listToTypeLevel $ LitT . StrTyLit . toS <$> fieldNames
        entityConstraints = listToTypeLevel $ (concat.catMaybes) (fieldConstraint <$> constraints)
        primaryKey = maybe (ConT 'Nothing) (AppT (ConT 'Just) . LitT . StrTyLit . toS . _pkName) (getEntityPrimaryKey ctx ei)
        requiredFields = ei ^. entityInfoColumnMap \\ optionalCols
        tableRequirements = listToTypeLevel $ required requiredFields <> dynamicDefault optionalCols
        optionalCols = getOptionalColumns ctx ei
-- | Generates a empty entity
--
-- > newPost = Entity ('Fresh ['DynamicDefault "id", 'Required "name", 'Required "author"])
-- > newPost = Entity (Post 1 "" 1)
--
emptyEntity :: ParseContext -> EntityInfo -> [Dec]
emptyEntity ctx ei = [
  SigD fname (AppT (AppT (ConT ''BT.Entity)
                         (PromotedT 'BT.Fresh `AppT` listToTypeLevel reqs))
                   (ei ^. entityInfoType)),
    ValD (VarP fname) (coerceBody ei) []]
  where fname = mkName $ toS $ "new" <> standardizeName name
        name = ei ^. entityInfoText
        requiredFields = ei ^. entityInfoColumnMap \\  optionalCols
        reqs = required requiredFields <> dynamicDefault optionalCols
        optionalCols = getOptionalColumns ctx ei

-- | Applies 'Required' constraint to list of columns
required :: [ColumnInfo] -> [TH.Type]
required cs = f <$> cs
  where f ci = ConT 'BT.Required `AppT` (LitT $ StrTyLit $ toS $ ci ^. columnInfoText)

-- | Applies 'DynamicDefault' constraint to a list of columns
dynamicDefault :: [ColumnInfo] -> [TH.Type]
dynamicDefault cs = f <$> cs
  where f ci = ConT 'BT.DynamicDefault `AppT` (LitT $ StrTyLit $ toS $ ci ^. columnInfoText)

-- | Modifies column type depending on column constraints
applyConstraint :: ColumnInfo -> ColumnConstraint -> TH.Type -> TH.Type
applyConstraint _ NullConstraint t = AppT (ConT ''Maybe) t
applyConstraint _ _ t = t

-- | Generates coerce body. See 'NullValue' why this is needed
coerceBody :: EntityInfo -> TH.Body
coerceBody ei = NormalB (AppE (ConE 'BT.Entity ) (nullValue' n $ ConE name))
  where n = length $ ei ^. entityInfoColumnMap
        name = ei ^. entityInfoName

nullValue' :: Int -> TH.Exp -> TH.Exp
nullValue' 0 initial = initial
nullValue' n initial = AppE (nullValue' (n - 1) initial) (VarE 'nullValue)