diff --git a/Database/Groundhog/TH.hs b/Database/Groundhog/TH.hs --- a/Database/Groundhog/TH.hs +++ b/Database/Groundhog/TH.hs @@ -24,6 +24,11 @@ , firstChar -- * Utility functions , mkTHEntityDef + , mkTHEmbeddedDef + , mkTHPrimitiveDef + , applyEntitySettings + , applyEmbeddedSettings + , applyPrimitiveSettings ) where import Database.Groundhog.Core (delim, UniqueType(..)) @@ -37,7 +42,7 @@ import Control.Monad (forM, forM_, when, unless, liftM2) import Data.Char (isUpper, isLower, isSpace, isDigit, toUpper, toLower) import Data.List (nub, (\\)) -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) +import Data.Maybe (fromMaybe, isJust, isNothing) import Data.String import Data.Text.Encoding (encodeUtf8) import Data.Yaml as Y (decodeHelper, ParseException(..)) @@ -49,9 +54,9 @@ -- | Codegenerator will create a function with this name that will run 'migrate' for each non-polymorphic entity in definition , migrationFunction :: Maybe String -- | Functions that produce Haskell code for the entities. In most cases when overriding, the default functions that produce mappings are not replaced but kept along with custom code. Example: @['defaultMkEntityDecs', mkMyDecs]@. - , mkEntityDecs :: [THEntityDef -> Q [Dec]] - , mkEmbeddedDecs :: [THEmbeddedDef -> Q [Dec]] - , mkPrimitiveDecs :: [THPrimitiveDef -> Q [Dec]] + , mkEntityDecs :: [[THEntityDef] -> Q [Dec]] + , mkEmbeddedDecs :: [[THEmbeddedDef] -> Q [Dec]] + , mkPrimitiveDecs :: [[THPrimitiveDef] -> Q [Dec]] } defaultCodegenConfig :: CodegenConfig @@ -188,11 +193,9 @@ -- The default names of auxiliary datatypes and names used in database are generated using the naming style and can be changed via configuration. -- The datatypes and their generation options are defined via YAML configuration parsed by quasiquoter 'groundhog'. mkPersist :: CodegenConfig -> PersistDefinitions -> Q [Dec] -mkPersist CodegenConfig{..} (PersistDefinitions defs) = do - let duplicates = notUniqueBy id $ flip map defs $ \a -> case a of - PSEntityDef' e -> psDataName e - PSEmbeddedDef' e -> psEmbeddedName e - PSPrimitiveDef' e -> psPrimitiveName e +mkPersist CodegenConfig{..} PersistDefinitions{..} = do + let duplicates = notUniqueBy id $ + map psDataName psEntities ++ map psEmbeddedName psEmbeddeds ++ map psPrimitiveName psPrimitives unless (null duplicates) $ fail $ "All definitions must be unique. Found duplicates: " ++ show duplicates let getDecl name = do info <- reify $ mkName name @@ -203,18 +206,14 @@ _ -> error $ "Unknown declaration type: " ++ name ++ " " ++ show x _ -> error $ "Only datatypes can be processed: " ++ name - entities <- catMaybes <$> forM defs (\d -> case d of - PSEntityDef' e -> Just . either error id . validateEntity . applyEntitySettings namingStyle e . mkTHEntityDef namingStyle <$> getDecl (psDataName e) - _ -> return Nothing) - embeddeds <- catMaybes <$> forM defs (\d -> case d of - PSEmbeddedDef' e -> Just . either error id . validateEmbedded . applyEmbeddedSettings e . mkTHEmbeddedDef namingStyle <$> getDecl (psEmbeddedName e) - _ -> return Nothing) - primitives <- catMaybes <$> forM defs (\d -> case d of - PSPrimitiveDef' e -> Just . applyPrimitiveSettings e . mkTHPrimitiveDef namingStyle <$> getDecl (psPrimitiveName e) - _ -> return Nothing) - decs <- fmap concat $ sequence $ (mkEntityDecs <*> entities) ++ ( mkEmbeddedDecs <*> embeddeds) ++ (mkPrimitiveDecs <*> primitives) - migrateFunc <- maybe (return []) (\name -> mkMigrateFunction name entities) migrationFunction - return $ migrateFunc ++ decs + entities <- forM psEntities $ \e -> + either error id . validateEntity . applyEntitySettings namingStyle e . mkTHEntityDef namingStyle <$> getDecl (psDataName e) + embeddeds <- forM psEmbeddeds $ \e -> + either error id . validateEmbedded . applyEmbeddedSettings e . mkTHEmbeddedDef namingStyle <$> getDecl (psEmbeddedName e) + primitives <- forM psPrimitives $ \e -> + applyPrimitiveSettings e . mkTHPrimitiveDef namingStyle <$> getDecl (psPrimitiveName e) + let mkEntityDecs' = maybe id (\name -> (mkMigrateFunction name:)) migrationFunction $ mkEntityDecs + fmap concat $ sequence $ map ($ entities) mkEntityDecs' ++ map ($ embeddeds) mkEmbeddedDecs ++ map ($ primitives) mkPrimitiveDecs applyEntitySettings :: NamingStyle -> PSEntityDef -> THEntityDef -> THEntityDef applyEntitySettings style PSEntityDef{..} def@(THEntityDef{..}) = @@ -225,10 +224,9 @@ , thConstructors = thConstructors' } where thAutoKey' = maybe thAutoKey (liftM2 applyAutoKeySettings thAutoKey) psAutoKey - thConstructors' = maybe thConstructors'' (f thConstructors'') $ psConstructors where - thConstructors'' = maybe id (\_ -> zipWith putAutoKey [0..]) thAutoKey' thConstructors - putAutoKey cNum cDef@(THConstructorDef{..}) = cDef {thDbAutoKeyName = Just $ mkDbConstrAutoKeyName style (nameBase thDataName) (nameBase thConstrName) cNum} + thConstructors'' = map checkAutoKey thConstructors + checkAutoKey cDef@(THConstructorDef{..}) = cDef {thDbAutoKeyName = thAutoKey' >> thDbAutoKeyName} mkUniqueKey' = mkUniqueKey style (nameBase thDataName) (head thConstructors') f = foldr $ replaceOne "constructor" psConstrName (nameBase . thConstrName) applyConstructorSettings @@ -257,7 +255,7 @@ applyConstructorSettings PSConstructorDef{..} def@(THConstructorDef{..}) = def { thPhantomConstrName = fromMaybe thPhantomConstrName psPhantomConstrName , thDbConstrName = fromMaybe thDbConstrName psDbConstrName - , thDbAutoKeyName = fromMaybe thDbAutoKeyName psDbAutoKeyName + , thDbAutoKeyName = psDbAutoKeyName <|> thDbAutoKeyName , thConstrFields = maybe thConstrFields (f thConstrFields) psConstrFields , thConstrUniques = maybe thConstrUniques (map convertUnique) psConstrUniques } where @@ -321,7 +319,7 @@ [] -> return () ys -> fail $ "Constraints must have at least one field: " ++ show ys when (isNothing (thDbAutoKeyName cdef) /= isNothing (thAutoKey def)) $ - fail $ "Presence of autokey definitions should be the same in entity and constructors definitions " ++ show (thDataName def) + fail $ "Presence of autokey definitions should be the same in entity and constructors definitions " ++ show (thDataName def) ++ ": " ++ show (thDbAutoKeyName cdef) ++ " - " ++ show (thAutoKey def) -- check that unique keys = [] for multiple constructor datatype if length constrs > 1 && not (null $ thUniqueKeys def) @@ -371,7 +369,7 @@ InfixC{} -> error $ "Types with infix constructors are not supported" ++ show dName ForallC{} -> error $ "Types with existential quantification are not supported" ++ show dName where - mkConstr' name params = THConstructorDef name (apply mkPhantomName) (apply mkDbConstrName) Nothing params [] where + mkConstr' name params = THConstructorDef name (apply mkPhantomName) (apply mkDbConstrName) (Just $ apply mkDbConstrAutoKeyName) params [] where apply f = f dName' (nameBase name) cNum mkField :: String -> StrictType -> Int -> THFieldDef @@ -591,8 +589,8 @@ Right (Left err) -> fail err Right (Right result') -> lift (result' :: PersistDefinitions) -defaultMkEntityDecs :: THEntityDef -> Q [Dec] -defaultMkEntityDecs def = do +defaultMkEntityDecs :: [THEntityDef] -> Q [Dec] +defaultMkEntityDecs = fmap concat . mapM (\def -> do --runIO (print def) decs <- fmap concat $ sequence $ map ($ def) [ mkEntityPhantomConstructors @@ -611,10 +609,10 @@ , mkEntityNeverNullInstance ] --runIO $ putStrLn $ pprint decs - return decs + return decs) -defaultMkEmbeddedDecs :: THEmbeddedDef -> Q [Dec] -defaultMkEmbeddedDecs def = do +defaultMkEmbeddedDecs :: [THEmbeddedDef] -> Q [Dec] +defaultMkEmbeddedDecs = fmap concat . mapM (\def -> do --runIO (print def) decs <- fmap concat $ sequence $ map ($ def) [ mkEmbeddedPersistFieldInstance @@ -622,14 +620,14 @@ , mkEmbeddedInstance ] -- runIO $ putStrLn $ pprint decs - return decs + return decs) -defaultMkPrimitiveDecs :: THPrimitiveDef -> Q [Dec] -defaultMkPrimitiveDecs def = do +defaultMkPrimitiveDecs :: [THPrimitiveDef] -> Q [Dec] +defaultMkPrimitiveDecs = fmap concat . mapM (\def -> do --runIO (print def) decs <- fmap concat $ sequence $ map ($ def) [ mkPrimitivePersistFieldInstance , mkPrimitivePrimitivePersistFieldInstance ] -- runIO $ putStrLn $ pprint decs - return decs + return decs) diff --git a/Database/Groundhog/TH/CodeGen.hs b/Database/Groundhog/TH/CodeGen.hs --- a/Database/Groundhog/TH/CodeGen.hs +++ b/Database/Groundhog/TH/CodeGen.hs @@ -387,7 +387,7 @@ let name = mkName $ thPhantomConstrName c phantom <- [t| ConstructorMarker $(return entity) |] let constr = ForallC (thTypeParams def) [EqualP (VarT v) phantom] $ NormalC name [] - dataD (cxt []) name [PlainTV v] [return constr] [] + return $ DataD [] name [PlainTV v] [constr] [] mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec] mkEntityPhantomConstructorInstances def = sequence $ zipWith f [0..] $ thConstructors def where @@ -406,7 +406,7 @@ let name = mkName $ thUniqueKeyPhantomName u phantom <- [t| UniqueMarker $(return entity) |] let constr = ForallC (thTypeParams def) [EqualP (VarT v) phantom] $ NormalC name [] - sequence [dataD (cxt []) name [PlainTV v] [return constr] []] + return [DataD [] name [PlainTV v] [constr] []] else return [] mkPersistEntityInstance :: THEntityDef -> Q [Dec] diff --git a/Database/Groundhog/TH/Settings.hs b/Database/Groundhog/TH/Settings.hs --- a/Database/Groundhog/TH/Settings.hs +++ b/Database/Groundhog/TH/Settings.hs @@ -3,7 +3,6 @@ module Database.Groundhog.TH.Settings ( PersistDefinitions(..) - , PersistDefinition(..) , THEntityDef(..) , THEmbeddedDef(..) , THPrimitiveDef(..) @@ -29,13 +28,13 @@ import Control.Applicative import Control.Monad (forM, mzero) 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) -data PersistDefinitions = PersistDefinitions {definitions :: [PersistDefinition]} deriving Show -data PersistDefinition = PSEntityDef' PSEntityDef - | PSEmbeddedDef' PSEmbeddedDef - | PSPrimitiveDef' PSPrimitiveDef - deriving Show +data PersistDefinitions = PersistDefinitions {psEntities :: [PSEntityDef], psEmbeddeds :: [PSEmbeddedDef], psPrimitives :: [PSPrimitiveDef]} deriving Show -- data SomeData a = U1 { foo :: Int} | U2 { bar :: Maybe String, asc :: Int64, add :: a} | U3 deriving (Show, Eq) @@ -47,12 +46,12 @@ , thUniqueKeys :: [THUniqueKeyDef] , thTypeParams :: [TyVarBndr] , thConstructors :: [THConstructorDef] -} deriving Show +} deriving (Eq, Show) data THAutoKeyDef = THAutoKeyDef { thAutoKeyConstrName :: String , thAutoKeyIsDef :: Bool -} deriving Show +} deriving (Eq, Show) data THEmbeddedDef = THEmbeddedDef { thEmbeddedName :: Name @@ -60,13 +59,13 @@ , thDbEmbeddedName :: String -- ^ It is used only to set polymorphic part of name of its container , thEmbeddedTypeParams :: [TyVarBndr] , thEmbeddedFields :: [THFieldDef] -} deriving Show +} deriving (Eq, Show) data THPrimitiveDef = THPrimitiveDef { thPrimitiveName :: Name , thPrimitiveDbName :: String -- ^ It is used only to set polymorphic part of name of its container , thPrimitiveStringEnumRepresentation :: Bool -- ^ Store in database as string using Show/Read instances (True) or as integer using Enum instance (False). -} deriving Show +} deriving (Eq, Show) data THConstructorDef = THConstructorDef { thConstrName :: Name -- U2 @@ -75,7 +74,7 @@ , thDbAutoKeyName :: Maybe String -- u2_id , thConstrFields :: [THFieldDef] , thConstrUniques :: [THUniqueDef] -} deriving Show +} deriving (Eq, Show) data THFieldDef = THFieldDef { thFieldName :: String -- bar @@ -85,14 +84,14 @@ , thFieldType :: Type , thEmbeddedDef :: Maybe [PSFieldDef String] , thDefaultValue :: Maybe String - , thReferenceParent :: Maybe (Maybe (Maybe String, String, [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) -} deriving Show + , thReferenceParent :: Maybe (Maybe ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) +} deriving (Eq, Show) data THUniqueDef = THUniqueDef { thUniqueName :: String , thUniqueType :: UniqueType , thUniqueFields :: [Either String String] -- ^ Either name of field, i.e, thFieldName, or expression -} deriving Show +} deriving (Eq, Show) data THUniqueKeyDef = THUniqueKeyDef { thUniqueKeyName :: String @@ -103,7 +102,7 @@ , thUniqueKeyFields :: [THFieldDef] , thUniqueKeyMakeEmbedded :: Bool -- ^ If True, make it an instance of Embedded , thUniqueKeyIsDef :: Bool -} deriving Show +} deriving (Eq, Show) data PSEntityDef = PSEntityDef { psDataName :: String -- SomeData @@ -112,34 +111,34 @@ , psAutoKey :: Maybe (Maybe PSAutoKeyDef) -- SomeDataKey. Nothing - default key. Just Nothing - no autokey. Just (Just _) - specify autokey settings , psUniqueKeys :: Maybe [PSUniqueKeyDef] , psConstructors :: Maybe [PSConstructorDef] -} deriving Show +} deriving (Eq, Show) data PSEmbeddedDef = PSEmbeddedDef { psEmbeddedName :: String , psDbEmbeddedName :: Maybe String -- ^ It is used only to set polymorphic part of name of its container , psEmbeddedFields :: Maybe [PSFieldDef String] -} deriving Show +} deriving (Eq, Show) data PSPrimitiveDef = PSPrimitiveDef { psPrimitiveName :: String , psPrimitiveDbName :: Maybe String -- ^ It is used only to set polymorphic part of name of its container , psPrimitiveStringEnumRepresentation :: Maybe Bool -- ^ Store in database as string using Show/Read instances (True) or as integer using Enum instance (False). -} deriving Show +} deriving (Eq, Show) data PSConstructorDef = PSConstructorDef { psConstrName :: String -- U2 , psPhantomConstrName :: Maybe String -- U2Constructor , psDbConstrName :: Maybe String -- SQLU2 - , psDbAutoKeyName :: Maybe (Maybe String) -- u2_id + , psDbAutoKeyName :: Maybe String -- u2_id , psConstrFields :: Maybe [PSFieldDef String] , psConstrUniques :: Maybe [PSUniqueDef] -} deriving Show +} deriving (Eq, Show) data PSUniqueDef = PSUniqueDef { psUniqueName :: String , psUniqueType :: Maybe UniqueType , psUniqueFields :: [Either String String] -} deriving Show +} deriving (Eq, Show) data PSUniqueKeyDef = PSUniqueKeyDef { psUniqueKeyName :: String @@ -149,23 +148,18 @@ , psUniqueKeyFields :: Maybe [PSFieldDef String] , psUniqueKeyMakeEmbedded :: Maybe Bool , psUniqueKeyIsDef :: Maybe Bool -} deriving Show +} deriving (Eq, 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 |] +} deriving (Eq, Show) instance Lift PSPrimitiveDef where lift (PSPrimitiveDef {..}) = [| PSPrimitiveDef $(lift psPrimitiveName) $(lift psPrimitiveDbName) $(lift psPrimitiveStringEnumRepresentation) |] instance Lift PersistDefinitions where - lift (PersistDefinitions {..}) = [| PersistDefinitions $(lift definitions) |] + lift (PersistDefinitions {..}) = [| PersistDefinitions $(lift psEntities) $(lift psEmbeddeds) $(lift psPrimitives) |] instance Lift PSEntityDef where lift (PSEntityDef {..}) = [| PSEntityDef $(lift psDataName) $(lift psDbEntityName) $(lift psEntitySchema) $(lift psAutoKey) $(lift psUniqueKeys) $(lift psConstructors) |] @@ -209,23 +203,22 @@ --- entity: name -} - parseJSON value = PersistDefinitions <$> case value of + parseJSON value = (case value of Object v -> do defs <- v .:? "definitions" case defs of - Just defs'@(Array _) -> parseJSON defs' + Just (Array arr) -> Fold.foldrM go initial arr + Nothing -> go value initial Just _ -> mzero - Nothing -> fmap (\a -> [a]) $ parseJSON value - defs@(Array _) -> parseJSON defs - _ -> 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 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 -> @@ -279,8 +272,8 @@ 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") + 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" @@ -295,3 +288,51 @@ 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] diff --git a/groundhog-th.cabal b/groundhog-th.cabal --- a/groundhog-th.cabal +++ b/groundhog-th.cabal @@ -1,5 +1,5 @@ name: groundhog-th -version: 0.6.0 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Boris Lykah @@ -17,7 +17,7 @@ library build-depends: base >= 4 && < 5 , bytestring >= 0.9 - , groundhog >= 0.6 && < 0.7 + , groundhog >= 0.7 && < 0.8 , template-haskell , time >= 1.1.4 , containers >= 0.2