{- This file is part of Vervis.
 -
 - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Vervis.Model.TH
    ( model
    , modelFile
    , makeEntities
    , makeEntitiesGeneric
    , makeEntitiesMigration
    )
where

import Prelude

import Control.Applicative ((<|>))
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import Database.Persist.Quasi (lowerCaseSettings)
import Database.Persist.TH
import Database.Persist.Types
import Language.Haskell.TH.Quote (QuasiQuoter)
import Language.Haskell.TH.Syntax (Q, Exp, Dec)

import Language.Haskell.TH.Quote.Local (decQuasiQuoter)

model :: QuasiQuoter
model = persistLowerCase

modelFile :: FilePath -> Q Exp
modelFile = persistFileWith lowerCaseSettings

-- | Declare datatypes and 'PeristEntity' instances. Use the SQL backend. If
-- Vervis moves to a different backend, or supports more backends, this
-- function can be changed accordingly to make all the models use the new
-- settings.
makeEntities :: [EntityDef] -> Q [Dec]
makeEntities = mkPersist sqlSettings

-- | Like 'makeEntities', but declares generic datatypes not tied to a specific
-- @persistent@ backend. It does also declare convenience type aliases for the
-- SQL backend.
makeEntitiesGeneric :: [EntityDef] -> Q [Dec]
makeEntitiesGeneric = mkPersist sqlSettings { mpsGeneric = True }

append :: [Text] -> Text -> EntityDef -> EntityDef
append entnames suffix entity =
    let upd = (<> suffix)

        updId = (<> "Id") . upd

        updateConEnt t =
            if t `elem` entnames
                then Just $ upd t
                else Nothing

        updateConId t =
            updId <$> lookup t (zip (map (<> "Id") entnames) entnames)

        updateCon t = fromMaybe t $ updateConEnt t <|> updateConId t

        updateType t@(FTTypeCon (Just _) _) = t
        updateType (FTTypeCon Nothing a) = FTTypeCon Nothing $ updateCon a
        updateType (FTApp a b) = FTApp (updateType a) (updateType b)
        updateType (FTList a) = FTList $ updateType a

        updateEnt (HaskellName t) = HaskellName $ fromMaybe t $ updateConEnt t

        updateEmbedField f = f
            { emFieldEmbed = updateEmbedEnt <$> emFieldEmbed f
            , emFieldCycle = updateEnt <$> emFieldCycle f
            }

        updateEmbedEnt e = EmbedEntityDef
            { embeddedHaskell = updateEnt $ embeddedHaskell e
            , embeddedFields  = map updateEmbedField $ embeddedFields e
            }

        updateComp c = c
            { compositeFields = map updateField $ compositeFields c
            }

        updateRef NoReference = NoReference
        updateRef (ForeignRef n t) = ForeignRef (updateEnt n) (updateType t)
        updateRef (EmbedRef e) = EmbedRef $ updateEmbedEnt e
        updateRef (CompositeRef c) = CompositeRef $ updateComp c
        updateRef SelfReference = SelfReference

        updateField f = f
            { fieldType      = updateType $ fieldType f
            , fieldReference = updateRef $ fieldReference f
            }

        updateName (HaskellName t) = HaskellName $ upd t

        updateForeign f = f
            { foreignRefTableHaskell = updateEnt $ foreignRefTableHaskell f
            }

    in  entity
            { entityHaskell  = updateName $ entityHaskell entity
            , entityId       = updateField $ entityId entity
            , entityFields   = map updateField $ entityFields entity
            , entityForeigns = map updateForeign $ entityForeigns entity
            }

-- | Like 'makeEntitiesGeneric', but appends the given suffix to the names of
-- all entities, only on the Haskell side. It appends to the type constructor
-- names and the data constructor names. Record field names (e.g. @personAge@)
-- and 'EntityField' values (e.g. @PersonAge@) should be automatically adjusted
-- based on that. Field types and references are updated too.
--
-- For example, the following model:
--
-- > Person
-- >    name Text
-- >    age  Int
-- > Book
-- >    author PersonId
--
-- Would have its Haskell datatypes looking more or less like this, given the
-- suffix text is, say, \"2016\":
--
-- > data Person2016Generic backend = Person2016
-- >    { person2016Name :: Text
-- >    , person2016Age  :: Int
-- >    }
-- > data Book2016Generic backend = Book2016
-- >    { book2016Author :: Person2016Id
-- >    }
makeEntitiesMigration :: Text -> [EntityDef] -> Q [Dec]
makeEntitiesMigration suffix entities =
    let names = map (unHaskellName . entityHaskell) entities
    in  makeEntitiesGeneric $ map (append names suffix) entities