module Database.Groundhog.TH.Settings
( PersistDefinitions(..)
, PersistDefinition(..)
, THEntityDef(..)
, THEmbeddedDef(..)
, THPrimitiveDef(..)
, THConstructorDef(..)
, THFieldDef(..)
, THUniqueDef(..)
, THUniqueKeyDef(..)
, THAutoKeyDef(..)
, PSEntityDef(..)
, PSEmbeddedDef(..)
, PSPrimitiveDef(..)
, PSConstructorDef(..)
, PSFieldDef(..)
, PSUniqueDef(..)
, PSUniqueKeyDef(..)
, PSAutoKeyDef(..)
) where
import Database.Groundhog.Core (UniqueType(..), ReferenceActionType(..))
import Database.Groundhog.Generic (PSFieldDef(..))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..))
import Control.Applicative
import Control.Monad (forM, mzero)
import Data.Aeson
import qualified Data.HashMap.Strict as H
data PersistDefinitions = PersistDefinitions {definitions :: [PersistDefinition]} deriving Show
data PersistDefinition = PSEntityDef' PSEntityDef
| PSEmbeddedDef' PSEmbeddedDef
| PSPrimitiveDef' PSPrimitiveDef
deriving Show
data THEntityDef = THEntityDef {
thDataName :: Name
, thDbEntityName :: String
, thEntitySchema :: Maybe String
, thAutoKey :: Maybe THAutoKeyDef
, thUniqueKeys :: [THUniqueKeyDef]
, thTypeParams :: [TyVarBndr]
, thConstructors :: [THConstructorDef]
} deriving Show
data THAutoKeyDef = THAutoKeyDef {
thAutoKeyConstrName :: String
, thAutoKeyIsDef :: Bool
} deriving Show
data THEmbeddedDef = THEmbeddedDef {
thEmbeddedName :: Name
, thEmbeddedConstructorName :: Name
, thDbEmbeddedName :: String
, thEmbeddedTypeParams :: [TyVarBndr]
, thEmbeddedFields :: [THFieldDef]
} deriving Show
data THPrimitiveDef = THPrimitiveDef {
thPrimitiveName :: Name
, thPrimitiveDbName :: String
, thPrimitiveStringEnumRepresentation :: Bool
} deriving Show
data THConstructorDef = THConstructorDef {
thConstrName :: Name
, thPhantomConstrName :: String
, thDbConstrName :: String
, thDbAutoKeyName :: Maybe String
, thConstrFields :: [THFieldDef]
, thConstrUniques :: [THUniqueDef]
} deriving Show
data THFieldDef = THFieldDef {
thFieldName :: String
, thDbFieldName :: String
, thDbTypeName :: Maybe String
, thExprName :: String
, thFieldType :: Type
, thEmbeddedDef :: Maybe [PSFieldDef String]
, thDefaultValue :: Maybe String
, thReferenceParent :: Maybe (Maybe (Maybe String, String, [String]), Maybe ReferenceActionType, Maybe ReferenceActionType)
} deriving Show
data THUniqueDef = THUniqueDef {
thUniqueName :: String
, thUniqueType :: UniqueType
, thUniqueFields :: [Either String String]
} deriving Show
data THUniqueKeyDef = THUniqueKeyDef {
thUniqueKeyName :: String
, thUniqueKeyPhantomName :: String
, thUniqueKeyConstrName :: String
, thUniqueKeyDbName :: String
, thUniqueKeyFields :: [THFieldDef]
, thUniqueKeyMakeEmbedded :: Bool
, thUniqueKeyIsDef :: Bool
} deriving Show
data PSEntityDef = PSEntityDef {
psDataName :: String
, psDbEntityName :: Maybe String
, psEntitySchema :: Maybe String
, psAutoKey :: Maybe (Maybe PSAutoKeyDef)
, psUniqueKeys :: Maybe [PSUniqueKeyDef]
, psConstructors :: Maybe [PSConstructorDef]
} deriving Show
data PSEmbeddedDef = PSEmbeddedDef {
psEmbeddedName :: String
, psDbEmbeddedName :: Maybe String
, psEmbeddedFields :: Maybe [PSFieldDef String]
} deriving Show
data PSPrimitiveDef = PSPrimitiveDef {
psPrimitiveName :: String
, psPrimitiveDbName :: Maybe String
, psPrimitiveStringEnumRepresentation :: Maybe Bool
} deriving Show
data PSConstructorDef = PSConstructorDef {
psConstrName :: String
, psPhantomConstrName :: Maybe String
, psDbConstrName :: Maybe String
, psDbAutoKeyName :: Maybe (Maybe String)
, psConstrFields :: Maybe [PSFieldDef String]
, psConstrUniques :: Maybe [PSUniqueDef]
} deriving Show
data PSUniqueDef = PSUniqueDef {
psUniqueName :: String
, psUniqueType :: Maybe UniqueType
, psUniqueFields :: [Either String String]
} deriving Show
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 Show
data PSAutoKeyDef = PSAutoKeyDef {
psAutoKeyConstrName :: Maybe String
, psAutoKeyIsDef :: Maybe Bool
} deriving Show
instance Lift PersistDefinition where
lift (PSEntityDef' e) = [| PSEntityDef' e |]
lift (PSEmbeddedDef' e) = [| PSEmbeddedDef' e |]
lift (PSPrimitiveDef' e) = [| PSPrimitiveDef' e |]
instance Lift PSPrimitiveDef where
lift (PSPrimitiveDef {..}) = [| PSPrimitiveDef $(lift psPrimitiveName) $(lift psPrimitiveDbName) $(lift psPrimitiveStringEnumRepresentation) |]
instance Lift PersistDefinitions where
lift (PersistDefinitions {..}) = [| PersistDefinitions $(lift definitions) |]
instance Lift PSEntityDef where
lift (PSEntityDef {..}) = [| PSEntityDef $(lift psDataName) $(lift psDbEntityName) $(lift psEntitySchema) $(lift psAutoKey) $(lift psUniqueKeys) $(lift psConstructors) |]
instance Lift PSEmbeddedDef where
lift (PSEmbeddedDef {..}) = [| PSEmbeddedDef $(lift psEmbeddedName) $(lift psDbEmbeddedName) $(lift psEmbeddedFields) |]
instance Lift PSConstructorDef where
lift (PSConstructorDef {..}) = [| PSConstructorDef $(lift psConstrName) $(lift psPhantomConstrName) $(lift psDbConstrName) $(lift psDbAutoKeyName) $(lift psConstrFields) $(lift psConstrUniques) |]
instance Lift PSUniqueDef where
lift (PSUniqueDef name typ fields) = [| PSUniqueDef $(lift name) $(lift typ) $(lift fields) |]
instance Lift UniqueType where
lift UniqueConstraint = [| UniqueConstraint |]
lift UniqueIndex = [| UniqueIndex |]
lift (UniquePrimary x) = [| UniquePrimary $(lift x) |]
instance Lift ReferenceActionType where
lift NoAction = [| NoAction |]
lift Restrict = [| Restrict |]
lift Cascade = [| Cascade |]
lift SetNull = [| SetNull |]
lift SetDefault = [| SetDefault |]
instance Lift (PSFieldDef String) where
lift (PSFieldDef {..}) = [| PSFieldDef $(lift psFieldName) $(lift psDbFieldName) $(lift psDbTypeName) $(lift psExprName) $(lift psEmbeddedDef) $(lift psDefaultValue) $(lift psReferenceParent) |]
instance Lift PSUniqueKeyDef where
lift (PSUniqueKeyDef {..}) = [| PSUniqueKeyDef $(lift psUniqueKeyName) $(lift psUniqueKeyPhantomName) $(lift psUniqueKeyConstrName) $(lift psUniqueKeyDbName) $(lift psUniqueKeyFields) $(lift psUniqueKeyMakeEmbedded) $(lift psUniqueKeyIsDef) |]
instance Lift PSAutoKeyDef where
lift (PSAutoKeyDef {..}) = [| PSAutoKeyDef $(lift psAutoKeyConstrName) $(lift psAutoKeyIsDef) |]
instance FromJSON PersistDefinitions where
parseJSON value = PersistDefinitions <$> case value of
Object v -> do
defs <- v .:? "definitions"
case defs of
Just defs'@(Array _) -> parseJSON defs'
Just _ -> mzero
Nothing -> fmap (\a -> [a]) $ parseJSON value
defs@(Array _) -> parseJSON defs
_ -> mzero
instance FromJSON PersistDefinition where
parseJSON obj@(Object v) = case () of
_ | H.member "entity" v -> PSEntityDef' <$> parseJSON obj
_ | H.member "embedded" v -> PSEmbeddedDef' <$> parseJSON obj
_ | H.member "primitive" v -> PSPrimitiveDef' <$> parseJSON obj
_ -> mzero
parseJSON _ = mzero
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
x <- v .:? "representation"
let representation = case x of
Nothing -> pure True
Just "showread" -> pure True
Just "enum" -> pure False
Just r -> fail $ "parseJSON: representation expected [\"showread\",\"enum\"], but got " ++ r
PSPrimitiveDef <$> v .: "primitive" <*> v .:? "dbName" <*> pure representation
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 $ \f -> case f of
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 -> return 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 -> return 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 where
mkRefSettings v = do
ref <- v .:? "reference"
(parent, onDel, onUpd) <- case ref of
Just (Object r) -> (,,) <$> parentRef <*> r .:? "onDelete" <*> r .:? "onUpdate" where
parentRef = optional ((,,) <$> r .:? "schema" <*> r .: "table" <*> r .: "columns")
_ -> pure (Nothing, Nothing, Nothing)
(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"