diff --git a/Database/Groundhog/TH.hs b/Database/Groundhog/TH.hs --- a/Database/Groundhog/TH.hs +++ b/Database/Groundhog/TH.hs @@ -27,12 +27,12 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax (StrictType, VarStrictType, Lift(..)) import Language.Haskell.TH.Quote +import Control.Applicative ((<$>)) import Control.Monad (forM, forM_, when, unless, liftM2) -import Data.ByteString.Char8 (pack) +import Data.ByteString.UTF8 (fromString) import Data.Char (isUpper, isLower, isSpace, isDigit, toUpper, toLower) -import Data.Either (lefts) import Data.List (nub, (\\)) -import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) import Data.Yaml as Y(decodeHelper, ParseException(..)) import qualified Text.Libyaml as Y @@ -178,22 +178,32 @@ -- 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 $ map (either psDataName psEmbeddedName) defs + let duplicates = notUniqueBy id $ flip map defs $ \a -> case a of + PSEntityDef' e -> psDataName e + PSEmbeddedDef' e -> psEmbeddedName e + PSPrimitiveDef' e -> psPrimitiveName e unless (null duplicates) $ fail $ "All definitions must be unique. Found duplicates: " ++ show duplicates - defs' <- forM defs $ \def -> do - let name = mkName $ either psDataName psEmbeddedName def - info <- reify name - return $ case info of - TyConI x -> case x of - d@DataD{} -> case def of - Left ent -> either error Left $ validateEntity $ applyEntitySettings namingStyle ent $ mkTHEntityDefWith namingStyle d - Right emb -> either error Right $ validateEmbedded $ applyEmbeddedSettings emb $ mkTHEmbeddedDefWith namingStyle d - NewtypeD{} -> error "Newtypes are not supported" - _ -> error $ "Unknown declaration type: " ++ show name ++ " " ++ show x - _ -> error $ "Only datatypes can be processed: " ++ show name - decs <- mapM (either mkEntityDecs mkEmbeddedDecs) defs' - migrateFunc <- maybe (return []) (\name -> mkMigrateFunction name (lefts defs')) migrationFunction - return $ migrateFunc ++ concat decs + let getDecl name = do + info <- reify $ mkName name + return $ case info of + TyConI x -> case x of + d@DataD{} -> d + NewtypeD{} -> error "Newtypes are not supported" + _ -> 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 . concat) $ sequence [mapM mkEntityDecs entities, mapM mkEmbeddedDecs embeddeds, mapM mkPrimitiveDecs primitives] + migrateFunc <- maybe (return []) (\name -> mkMigrateFunction name entities) migrationFunction + return $ migrateFunc ++ decs applyEntitySettings :: NamingStyle -> PSEntityDef -> THEntityDef -> THEntityDef applyEntitySettings style PSEntityDef{..} def@(THEntityDef{..}) = @@ -260,6 +270,12 @@ } where f = foldr $ replaceOne "field" psFieldName thFieldName applyFieldSettings +applyPrimitiveSettings :: PSPrimitiveDef -> THPrimitiveDef -> THPrimitiveDef +applyPrimitiveSettings PSPrimitiveDef{..} def@(THPrimitiveDef{..}) = + def { thPrimitiveDbName = fromMaybe thPrimitiveDbName psPrimitiveDbName + , thPrimitiveStringRepresentation = fromMaybe thPrimitiveStringRepresentation psPrimitiveStringRepresentation + } + mkFieldsForUniqueKey :: NamingStyle -> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef] mkFieldsForUniqueKey style dName uniqueKey cDef = zipWith (setSelector . findField) (thUniqueFields uniqueDef) [0..] where findField name = findOne "field" id thFieldName name $ thConstrFields cDef @@ -331,8 +347,8 @@ mapM_ validateField fields return def -mkTHEntityDefWith :: NamingStyle -> Dec -> THEntityDef -mkTHEntityDefWith NamingStyle{..} (DataD _ dName typeVars cons _) = +mkTHEntityDef :: NamingStyle -> Dec -> THEntityDef +mkTHEntityDef NamingStyle{..} (DataD _ dName typeVars cons _) = THEntityDef dName (mkDbEntityName dName') Nothing (Just $ THAutoKeyDef (mkEntityKeyName dName') True) [] typeVars constrs where constrs = zipWith mkConstr [0..] cons dName' = nameBase dName @@ -353,10 +369,10 @@ mkVarField cName (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) Nothing (apply mkExprFieldName) t Nothing Nothing Nothing where apply f = f dName' cName cNum fName' fNum fName' = nameBase fName -mkTHEntityDefWith _ _ = error "Only datatypes can be processed" +mkTHEntityDef _ _ = error "Only datatypes can be processed" -mkTHEmbeddedDefWith :: NamingStyle -> Dec -> THEmbeddedDef -mkTHEmbeddedDefWith (NamingStyle{..}) (DataD _ dName typeVars cons _) = +mkTHEmbeddedDef :: NamingStyle -> Dec -> THEmbeddedDef +mkTHEmbeddedDef (NamingStyle{..}) (DataD _ dName typeVars cons _) = THEmbeddedDef dName cName (mkDbEntityName dName') typeVars fields where dName' = nameBase dName @@ -375,8 +391,14 @@ mkVarField cName' (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) Nothing (mkExprSelectorName dName' cName' fName' fNum) t Nothing Nothing Nothing where apply f = f dName' cName' 0 fName' fNum fName' = nameBase fName -mkTHEmbeddedDefWith _ _ = error "Only datatypes can be processed" +mkTHEmbeddedDef _ _ = error "Only datatypes can be processed" +mkTHPrimitiveDef :: NamingStyle -> Dec -> THPrimitiveDef +mkTHPrimitiveDef (NamingStyle{..}) (DataD _ dName _ _ _) = + THPrimitiveDef dName (mkDbEntityName dName') True where + dName' = nameBase dName +mkTHPrimitiveDef _ _ = error "Only datatypes can be processed" + firstLetter :: (Char -> Char) -> String -> String firstLetter f s = f (head s):tail s @@ -504,6 +526,23 @@ -- # Street is not mentioned so it will have default settings. -- |] -- @ +-- +-- We can also make our types instances of `PrimitivePersistField` to store them in one column. +-- +-- @ +--data WeekDay = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday +-- deriving (Eq, Show, Enum) +--data Point = Point Int Int +-- deriving (Eq, Show, Read) +-- +--mkPersist defaultCodegenConfig [groundhog| +--definitions: +-- - primitive: WeekDay +-- representation: enum # Its column will have integer type. The conversion will use Enum instance. +-- - primitive: Point +-- representation: showread # Its column will have string type. The conversion will use Show/Read instances. If representation is omitted, showread will be used by default. +-- |] +-- @ -- | Converts quasiquoted settings into the datatype used by mkPersist. groundhog :: QuasiQuoter @@ -515,13 +554,13 @@ -- | Parses configuration stored in the file -- --- > mkPersist suffixNamingStyle [groundhogFile|../groundhog.yaml|] +-- > mkPersist defaultCodegenConfig [groundhogFile|../groundhog.yaml|] groundhogFile :: QuasiQuoter groundhogFile = quoteFile groundhog parseDefinitions :: String -> Q Exp parseDefinitions s = do - result <- runIO $ decodeHelper (Y.decode $ pack s) + result <- runIO $ decodeHelper (Y.decode $ fromString s) case result of Left err -> case err of InvalidYaml (Just (Y.YamlParseException problem context mark)) -> fail $ unlines @@ -564,6 +603,16 @@ [ mkEmbeddedPersistFieldInstance def , mkEmbeddedPurePersistFieldInstance def , mkEmbeddedInstance def + ] +-- runIO $ putStrLn $ pprint decs + return decs + +mkPrimitiveDecs :: THPrimitiveDef -> Q [Dec] +mkPrimitiveDecs def = do + --runIO (print def) + decs <- fmap concat $ sequence + [ mkPrimitivePersistFieldInstance def + , mkPrimitivePrimitivePersistFieldInstance def ] -- runIO $ putStrLn $ pprint 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 @@ -19,6 +19,8 @@ , mkEntitySinglePersistFieldInstance , mkPersistEntityInstance , mkEntityNeverNullInstance + , mkPrimitivePersistFieldInstance + , mkPrimitivePrimitivePersistFieldInstance , mkMigrateFunction ) where @@ -219,7 +221,8 @@ fromPrim' <- funD 'fromPrimitivePersistValue [clause [wildP] (normalB $ conE conName) []] let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) let decs = [toPrim', fromPrim'] - sequence $ [return $ InstanceD context (AppT (ConT ''PrimitivePersistField) keyType) decs + sequence [ return $ InstanceD context (AppT (ConT ''PrimitivePersistField) keyType) decs + , return $ InstanceD context (AppT (ConT ''NeverNull) keyType) [] , mkDefaultPurePersistFieldInstance context keyType , mkDefaultSinglePersistFieldInstance context keyType] _ -> return [] @@ -311,6 +314,7 @@ fromPrim' <- funD 'fromPrimitivePersistValue [clause [varP proxy, varP x] (normalB [| $(conE conName) (fromPrimitivePersistValue $(varE proxy) $(varE x)) |]) []] let decs = [toPrim', fromPrim'] sequence [ return $ InstanceD context (AppT (ConT ''PrimitivePersistField) uniqKeyType) decs + , return $ InstanceD context (AppT (ConT ''NeverNull) uniqKeyType) decs , mkDefaultPurePersistFieldInstance context uniqKeyType , mkDefaultSinglePersistFieldInstance context uniqKeyType] else mkPurePersistFieldInstance uniqKeyType conName (thUniqueKeyFields unique) context @@ -589,7 +593,7 @@ _ -> error "mkEntityPersistFieldInstance: key has no unique type" funD 'toPersistValues $ [ clause [] body [] ] - fromPersistValue' <- do + fromPersistValues' <- do let body = normalB $ case uniqInfo of _ | isOne -> [| singleFromPersistValue |] Just u -> [| fromPersistValuesUnique $(snd u) |] @@ -599,7 +603,7 @@ dbType' <- funD 'dbType $ [clause [] (normalB [| dbType . (undefined :: a -> DefaultKey a) |]) []] let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - let decs = [persistName', toPersistValues', fromPersistValue', dbType'] + let decs = [persistName', toPersistValues', fromPersistValues', dbType'] return $ [InstanceD context (AppT (ConT ''PersistField) entity) decs] mkEntitySinglePersistFieldInstance :: THEntityDef -> Q [Dec] @@ -628,6 +632,49 @@ return $ if isOne then [InstanceD context (AppT (ConT ''NeverNull) entity) []] else [] + +mkPrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec] +mkPrimitivePersistFieldInstance def = do + let prim = ConT (thPrimitiveName def) + persistName' <- do + let body = normalB $ stringE $ nameBase $ thPrimitiveName def + funD 'persistName $ [ clause [wildP] body [] ] + fromPersistValues' <- funD 'fromPersistValues [clause [] (normalB [| primFromPersistValue |]) []] + toPersistValues' <- funD 'toPersistValues [clause [] (normalB [| primToPersistValue |]) []] + dbType' <- do + let typ = if thPrimitiveStringRepresentation def + then [| DbTypePrimitive DbString False Nothing Nothing |] + else [| DbTypePrimitive DbInt32 False Nothing Nothing |] + funD 'dbType $ [ clause [wildP] (normalB typ) [] ] + let decs = [persistName', toPersistValues', fromPersistValues', dbType'] + return [ InstanceD [] (AppT (ConT ''PersistField) prim) decs + , InstanceD [] (AppT (ConT ''NeverNull) prim) [] + ] + +mkPrimitivePrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec] +mkPrimitivePrimitivePersistFieldInstance def = do + let prim = ConT (thPrimitiveName def) + toPrim' <- do + proxy <- newName "p" + x <- newName "x" + let value = if thPrimitiveStringRepresentation def + then [| show $(varE x) |] + else [| fromEnum $(varE x) |] + body = [| toPrimitivePersistValue $(varE proxy) $value |] + funD 'toPrimitivePersistValue [clause [varP proxy, varP x] (normalB body) []] + fromPrim' <- do + proxy <- newName "p" + x <- newName "x" + let value = [| fromPrimitivePersistValue $(varE proxy) $(varE x) |] + body = if thPrimitiveStringRepresentation def + then [| read $value |] + else [| toEnum $value |] + funD 'fromPrimitivePersistValue [clause [varP proxy, varP x] (normalB body) []] + let context = [] + let decs = [toPrim', fromPrim'] + sequence $ [return $ InstanceD context (AppT (ConT ''PrimitivePersistField) prim) decs + , mkDefaultPurePersistFieldInstance context prim + , mkDefaultSinglePersistFieldInstance context prim] mkMigrateFunction :: String -> [THEntityDef] -> Q [Dec] mkMigrateFunction name defs = do 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,8 +3,10 @@ module Database.Groundhog.TH.Settings ( PersistDefinitions(..) + , PersistDefinition(..) , THEntityDef(..) , THEmbeddedDef(..) + , THPrimitiveDef(..) , THConstructorDef(..) , THFieldDef(..) , THUniqueDef(..) @@ -12,6 +14,7 @@ , THAutoKeyDef(..) , PSEntityDef(..) , PSEmbeddedDef(..) + , PSPrimitiveDef(..) , PSConstructorDef(..) , PSFieldDef(..) , PSUniqueDef(..) @@ -27,7 +30,11 @@ import Control.Monad (mzero) import Data.Yaml -data PersistDefinitions = PersistDefinitions {definitions :: [Either PSEntityDef PSEmbeddedDef]} deriving Show +data PersistDefinitions = PersistDefinitions {definitions :: [PersistDefinition]} deriving Show +data PersistDefinition = PSEntityDef' PSEntityDef + | PSEmbeddedDef' PSEmbeddedDef + | PSPrimitiveDef' PSPrimitiveDef + deriving Show -- data SomeData a = U1 { foo :: Int} | U2 { bar :: Maybe String, asc :: Int64, add :: a} | U3 deriving (Show, Eq) @@ -54,6 +61,12 @@ , thEmbeddedFields :: [THFieldDef] } deriving Show +data THPrimitiveDef = THPrimitiveDef { + thPrimitiveName :: Name + , thPrimitiveDbName :: String -- used only to set polymorphic part of name of its container + , thPrimitiveStringRepresentation :: Bool -- store in database as string using Show/Read instances or as integer using Enum instance +} deriving Show + data THConstructorDef = THConstructorDef { thConstrName :: Name -- U2 , thPhantomConstrName :: String -- U2Constructor @@ -105,6 +118,12 @@ , psEmbeddedFields :: Maybe [PSFieldDef] } deriving Show +data PSPrimitiveDef = PSPrimitiveDef { + psPrimitiveName :: String + , psPrimitiveDbName :: Maybe String -- used only to set polymorphic part of name of its container + , psPrimitiveStringRepresentation :: Maybe Bool -- store in database as string using Show/Read instances or as integer using Enum instance +} deriving Show + data PSConstructorDef = PSConstructorDef { psConstrName :: String -- U2 , psPhantomConstrName :: Maybe String -- U2Constructor @@ -135,6 +154,14 @@ , 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 psPrimitiveStringRepresentation) |] + instance Lift PersistDefinitions where lift (PersistDefinitions {..}) = [| PersistDefinitions $(lift definitions) |] @@ -190,16 +217,10 @@ defs@(Array _) -> parseJSON defs _ -> mzero -instance FromJSON (Either PSEntityDef PSEmbeddedDef) where - parseJSON obj@(Object v) = do - entity <- v .:? "entity" - embedded <- v .:? "embedded" - case (entity, embedded) of - (Just _, Nothing) -> fmap Left $ parseJSON obj - (Nothing, Just _) -> fmap Right $ parseJSON obj - (Just entName, Just embName) -> fail $ "Record has both entity name " ++ entName ++ " and embedded name " ++ embName - (Nothing, Nothing) -> fail "Record must have either entity name or embedded name" - parseJSON _ = mzero +instance FromJSON PersistDefinition where + parseJSON obj = PSEntityDef' <$> parseJSON obj + <|> PSEmbeddedDef' <$> parseJSON obj + <|> PSPrimitiveDef' <$> parseJSON obj instance FromJSON PSEntityDef where parseJSON (Object v) = PSEntityDef <$> v .: "entity" <*> v .:? "dbName" <*> v .:? "schema" <*> optional (v .: "autoKey") <*> v .:? "keys" <*> v .:? "constructors" @@ -207,6 +228,17 @@ instance FromJSON PSEmbeddedDef where parseJSON (Object v) = PSEmbeddedDef <$> v .: "embedded" <*> v .:? "dbName" <*> v .:? "fields" + parseJSON _ = mzero + +instance FromJSON PSPrimitiveDef where + parseJSON (Object 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 parseJSON _ = mzero instance FromJSON PSConstructorDef where 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.4.0.2 +version: 0.4.0.3 license: BSD3 license-file: LICENSE author: Boris Lykah @@ -19,6 +19,7 @@ , time >= 1.1.4 , containers >= 0.2 , yaml >= 0.8.1 + , utf8-string >= 0.3 && < 0.4 exposed-modules: Database.Groundhog.TH Database.Groundhog.TH.Settings Database.Groundhog.TH.CodeGen