groundhog-th 0.4.0.2 → 0.4.0.3
raw patch · 4 files changed
+170/−41 lines, 4 filesdep +utf8-string
Dependencies added: utf8-string
Files
- Database/Groundhog/TH.hs +75/−26
- Database/Groundhog/TH/CodeGen.hs +50/−3
- Database/Groundhog/TH/Settings.hs +43/−11
- groundhog-th.cabal +2/−1
Database/Groundhog/TH.hs view
@@ -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
Database/Groundhog/TH/CodeGen.hs view
@@ -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
Database/Groundhog/TH/Settings.hs view
@@ -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
groundhog-th.cabal view
@@ -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 <lykahb@gmail.com>@@ -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