persistent-template 1.2.0.2 → 1.2.0.3
raw patch · 2 files changed
+80/−51 lines, 2 filesdep +th-orphans
Dependencies added: th-orphans
Files
- Database/Persist/TH.hs +78/−50
- persistent-template.cabal +2/−1
Database/Persist/TH.hs view
@@ -17,6 +17,7 @@ , MkPersistSettings , mpsBackend , mpsGeneric+ , mpsPrefixFields , mkPersistSettings , sqlSettings , sqlOnlySettings@@ -50,9 +51,10 @@ ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object , Value (Object), (.:), (.:?) )-import Control.Applicative (pure, (<*>))+import Control.Applicative (pure, (<*>), liftA2) import Control.Monad.Logger (MonadLogger) import Database.Persist.Sql (sqlType)+import Language.Haskell.TH.Instances () -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist).@@ -87,16 +89,16 @@ where defsOrig = parse ps s -getSqlType :: [EntityDef ()] -> EntityDef () -> EntityDef SqlTypeExp+getSqlType :: [EntityDef ()] -> EntityDef () -> EntityDef DelayedSqlTypeExp getSqlType allEntities ent = ent { entityFields = map go $ entityFields ent } where- go :: FieldDef () -> FieldDef SqlTypeExp+ go :: FieldDef () -> FieldDef DelayedSqlTypeExp go field = do field- { fieldSqlType = final+ { fieldSqlType = DSTE final , fieldEmbedded = mEmbedded (fieldType field) } where@@ -120,7 +122,7 @@ mEmbedded (FTTypeCon Just{} _) = Nothing mEmbedded (FTTypeCon Nothing n) = let name = HaskellName n in- find ((name ==) . entityHaskell) allEntities + find ((name ==) . entityHaskell) allEntities mEmbedded (FTList x) = mEmbedded x mEmbedded (FTApp x y) = maybe (mEmbedded y) Just (mEmbedded x) @@ -134,6 +136,13 @@ typedNothing = SigE (ConE 'Nothing) mtyp st = VarE 'sqlType `AppE` typedNothing ++data DelayedSqlTypeExp = DSTE { unDSTE :: SqlTypeExp }+instance Lift DelayedSqlTypeExp where+ lift (DSTE SqlString') = return $ ConE 'SqlString'+ lift (DSTE SqlInt64') = return $ ConE 'SqlInt64'+ lift (DSTE (SqlTypeExp e)) = liftA2 AppE (return $ ConE 'SqlTypeExp) (lift e)+ data SqlTypeExp = SqlTypeExp Exp | SqlString' | SqlInt64'@@ -144,7 +153,7 @@ -- | Create data types and appropriate 'PersistEntity' instances for the given -- 'EntityDef's. Works well with the persist quasi-quoter.-mkPersist :: MkPersistSettings -> [EntityDef SqlType] -> Q [Dec]+mkPersist :: MkPersistSettings -> [EntityDef SqlTypeExp] -> Q [Dec] mkPersist mps ents' = do x <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents y <- fmap mconcat $ mapM (mkEntity mps) ents@@ -174,6 +183,8 @@ -- ^ Create generic types that can be used with multiple backends. Good for -- reusable code, but makes error messages harder to understand. Default: -- True.+ , mpsPrefixFields :: Bool+ -- ^ Prefix field names with the model name. Default: True. } -- | Create an @MkPersistSettings@ with default values.@@ -182,6 +193,7 @@ mkPersistSettings t = MkPersistSettings { mpsBackend = t , mpsGeneric = True -- FIXME switch default to False in the future+ , mpsPrefixFields = True } -- | Use the 'SqlPersist' backend.@@ -194,8 +206,10 @@ sqlOnlySettings :: MkPersistSettings sqlOnlySettings = sqlSettings { mpsGeneric = False } -recName :: Text -> Text -> Text-recName dt f = lowerFirst dt ++ upperFirst f+recName :: MkPersistSettings -> Text -> Text -> Text+recName mps dt f+ | mpsPrefixFields mps = lowerFirst dt ++ upperFirst f+ | otherwise = lowerFirst f lowerFirst :: Text -> Text lowerFirst t =@@ -215,7 +229,7 @@ $ map (mkName . unpack) $ entityDerives t where mkCol x FieldDef {..} =- (mkName $ unpack $ recName x $ unHaskellName fieldHaskell,+ (mkName $ unpack $ recName mps x $ unHaskellName fieldHaskell, if fieldStrict then IsStrict else NotStrict, pairToType mps backend (fieldType, nullable fieldAttrs) )@@ -232,12 +246,14 @@ | otherwise = [RecC name cols] sumCon fd = NormalC- (sumConstrName t fd)+ (sumConstrName mps t fd) [(NotStrict, pairToType mps backend (fieldType fd, NotNullable))] -sumConstrName :: EntityDef a -> FieldDef b -> Name-sumConstrName t FieldDef {..} = mkName $ unpack $ concat- [ unHaskellName $ entityHaskell t+sumConstrName :: MkPersistSettings -> EntityDef a -> FieldDef b -> Name+sumConstrName mps t FieldDef {..} = mkName $ unpack $ concat+ [ if mpsPrefixFields mps+ then unHaskellName $ entityHaskell t+ else "" , upperFirst $ unHaskellName fieldHaskell , "Sum" ]@@ -334,8 +350,8 @@ in [Clause [WildP] (NormalB err) []] degen x = x -mkToPersistFields :: String -> EntityDef a -> Q Dec-mkToPersistFields constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do+mkToPersistFields :: MkPersistSettings -> String -> EntityDef a -> Q Dec+mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do clauses <- if isSum then sequence $ zipWith goSum fields [1..]@@ -354,7 +370,7 @@ goSum :: FieldDef a -> Int -> Q Clause goSum fd idx = do- let name = sumConstrName ed fd+ let name = sumConstrName mps ed fd enull <- [|SomePersistField PersistNull|] let beforeCount = idx - 1 afterCount = fieldCount - idx@@ -425,8 +441,8 @@ isNotNull PersistNull = False isNotNull _ = True -mkFromPersistValues :: EntityDef a -> Q [Clause]-mkFromPersistValues t@(EntityDef { entitySum = False }) = do+mkFromPersistValues :: MkPersistSettings -> EntityDef a -> Q [Clause]+mkFromPersistValues mps t@(EntityDef { entitySum = False }) = do nothing <- [|Left $(liftT $ "Invalid fromPersistValues input. Entity: " `mappend` entName)|] let cons' = ConE $ mkName $ unpack $ entName xs <- mapM (const $ newName "x") $ entityFields t@@ -450,7 +466,7 @@ entName = unHaskellName $ entityHaskell t go ap' x y = InfixE (Just x) ap' (Just y) -mkFromPersistValues t@(EntityDef { entitySum = True }) = do+mkFromPersistValues mps t@(EntityDef { entitySum = True }) = do nothing <- [|Left $(liftT $ "Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] clauses <- mkClauses [] $ entityFields t return $ clauses `mappend` [Clause [WildP] (NormalB nothing) []]@@ -465,7 +481,7 @@ , [VarP x] , map (const null') after ]- constr = ConE $ sumConstrName t field+ constr = ConE $ sumConstrName mps t field fmap' <- [|fmap|] fs <- [|fromPersistValue $(return $ VarE x)|] let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x@@ -478,8 +494,8 @@ lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens sa sbt afb s = fmap (sbt s) (afb $ sa s) -mkLensClauses :: EntityDef a -> Q [Clause]-mkLensClauses t = do+mkLensClauses :: MkPersistSettings -> EntityDef a -> Q [Clause]+mkLensClauses mps t = do lens' <- [|lens|] getId <- [|entityKey|] setId <- [|\(Entity _ value) key -> Entity key value|]@@ -497,11 +513,11 @@ else return $ idClause : map (toClause lens' getVal dot keyName valName xName) (entityFields t) where toClause lens' getVal dot keyName valName xName f = Clause- [ConP (mkName $ unpack $ unHaskellName (entityHaskell t) ++ upperFirst (unHaskellName $ fieldHaskell f)) []]+ [ConP (filterConName mps t f) []] (NormalB $ lens' `AppE` getter `AppE` setter) [] where- fieldName = mkName $ unpack $ recName (unHaskellName $ entityHaskell t) (unHaskellName $ fieldHaskell f)+ fieldName = mkName $ unpack $ recName mps (unHaskellName $ entityHaskell t) (unHaskellName $ fieldHaskell f) getter = InfixE (Just $ VarE fieldName) dot (Just getVal) setter = LamE [ ConP 'Entity [VarP keyName, VarP valName]@@ -512,7 +528,7 @@ [(fieldName, VarE xName)] toSumClause lens' keyName valName xName f = Clause- [ConP (mkName $ unpack $ unHaskellName (entityHaskell t) ++ upperFirst (unHaskellName $ fieldHaskell f)) []]+ [ConP (filterConName mps t f) []] (NormalB $ lens' `AppE` getter `AppE` setter) [] where@@ -520,7 +536,7 @@ getter = LamE [ ConP 'Entity [WildP, VarP valName] ] $ CaseE (VarE valName)- $ Match (ConP (sumConstrName t f) [VarP xName]) (NormalB $ VarE xName) []+ $ Match (ConP (sumConstrName mps t f) [VarP xName]) (NormalB $ VarE xName) [] -- FIXME It would be nice if the types expressed that the Field is -- a sum type and therefore could result in Maybe.@@ -529,16 +545,16 @@ [ ConP 'Entity [VarP keyName, WildP] , VarP xName ]- $ ConE 'Entity `AppE` VarE keyName `AppE` (ConE (sumConstrName t f) `AppE` VarE xName)+ $ ConE 'Entity `AppE` VarE keyName `AppE` (ConE (sumConstrName mps t f) `AppE` VarE xName) -mkEntity :: MkPersistSettings -> EntityDef SqlType -> Q [Dec]+mkEntity :: MkPersistSettings -> EntityDef SqlTypeExp -> Q [Dec] mkEntity mps t = do t' <- lift t let nameT = unHaskellName $ entityHaskell t let nameS = unpack nameT let clazz = ConT ''PersistEntity `AppT` genericDataType mps (unHaskellName $ entityHaskell t) (VarT $ mkName "backend")- tpf <- mkToPersistFields nameS t- fpv <- mkFromPersistValues t+ tpf <- mkToPersistFields mps nameS t+ fpv <- mkFromPersistValues mps t utv <- mkUniqueToValues $ entityUniques t puk <- mkUniqueKeys t @@ -546,7 +562,7 @@ { fieldHaskell = HaskellName "Id" , fieldDB = entityID t , fieldType = FTTypeCon Nothing $ unHaskellName (entityHaskell t) ++ "Id"- , fieldSqlType = SqlInt64+ , fieldSqlType = SqlInt64' , fieldEmbedded = Nothing , fieldAttrs = [] , fieldStrict = True@@ -560,7 +576,7 @@ genericDataType mps nameT $ mpsBackend mps | otherwise = id - lensClauses <- mkLensClauses t+ lensClauses <- mkLensClauses mps t return $ addSyn [ dataTypeDec mps t@@ -585,8 +601,14 @@ , FunD 'persistFieldDef (map snd fields) , TySynInstD ''PersistEntityBackend+#if MIN_VERSION_template_haskell(2,9,0)+ (TySynEqn+ [genericDataType mps (unHaskellName $ entityHaskell t) $ VarT $ mkName "backend"]+ (backendDataType mps))+#else [genericDataType mps (unHaskellName $ entityHaskell t) $ VarT $ mkName "backend"] (backendDataType mps)+#endif , FunD 'persistIdField [Clause [] (NormalB $ ConE $ mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") []] , FunD 'fieldLens lensClauses ]@@ -628,15 +650,6 @@ where entityName = (unpack $ unHaskellName $ entityHaskell e) -updateConName :: Text -> Text -> PersistUpdate -> Text-updateConName name s pu = concat- [ name- , upperFirst s- , case pu of- Assign -> ""- _ -> pack $ show pu- ]- -- | Apply the given list of functions to the same @EntityDef@s. -- -- This function is useful for cases such as:@@ -669,7 +682,7 @@ where getDeps :: EntityDef a -> [Dep] getDeps def =- concatMap getDeps' $ entityFields def+ concatMap getDeps' $ entityFields $ fixEntityDef def where getDeps' :: FieldDef a -> [Dep] getDeps' FieldDef {..} =@@ -696,13 +709,12 @@ mkStmt dep = NoBindS $ dcw `AppE` ListE- [ filt `AppE` ConE (mkName $ unpack filtName)+ [ filt `AppE` ConE filtName `AppE` (left `AppE` val (depSourceNull dep)) `AppE` eq ] where- filtName = unHaskellName (depSourceTable dep) ++- upperFirst (unHaskellName $ depSourceField dep)+ filtName = filterConName' mps (depSourceTable dep) (depSourceField dep) val (Nullable ByMaybeAttr) = just `AppE` VarE key val _ = VarE key @@ -861,6 +873,8 @@ lift' () = [|()|] instance Lift' SqlTypeExp where lift' = lift+instance Lift' DelayedSqlTypeExp where+ lift' = lift pack' :: String -> Text pack' = pack@@ -935,7 +949,7 @@ -- forall . typ ~ FieldType => EntFieldName -- -- EntFieldName = FieldDef ....-mkField :: MkPersistSettings -> EntityDef a -> FieldDef SqlType -> Q (Con, Clause)+mkField :: MkPersistSettings -> EntityDef a -> FieldDef SqlTypeExp -> Q (Con, Clause) mkField mps et cd = do let con = ForallC []@@ -948,10 +962,7 @@ [] return (con, cla) where- name = mkName $ unpack $ concat- [ unHaskellName $ entityHaskell et- , upperFirst $ unHaskellName $ fieldHaskell cd- ]+ name = filterConName mps et cd maybeTyp = if nullable (fieldAttrs cd) == Nullable ByMaybeAttr then ConT ''Maybe `AppT` typ@@ -965,6 +976,23 @@ else mpsBackend mps) `AppT` genericDataType mps ft (VarT $ mkName "backend") Nothing -> ftToType $ fieldType cd++filterConName :: MkPersistSettings+ -> EntityDef sqlType1+ -> FieldDef sqlType2+ -> Name+filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field)++filterConName' :: MkPersistSettings+ -> HaskellName -- ^ table+ -> HaskellName -- ^ field+ -> Name+filterConName' mps entity field = mkName $ unpack $ concat+ [ if mpsPrefixFields mps || field == HaskellName "Id"+ then unHaskellName entity+ else ""+ , upperFirst $ unHaskellName field+ ] ftToType :: FieldType -> Type ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 1.2.0.2+version: 1.2.0.3 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -20,6 +20,7 @@ , monad-control >= 0.2 && < 0.4 , text >= 0.5 && < 1.0 , transformers >= 0.2 && < 0.4+ , th-orphans , containers , aeson , monad-logger