diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -3,6 +3,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} -- | This module provides utilities for creating backends. Regular users do not -- need to use this module. @@ -37,25 +39,23 @@ , lensPTH ) where -import Prelude hiding ((++), take, concat, splitAt) -import qualified Prelude as P +import Prelude hiding ((++), take, concat, splitAt, exp) import Database.Persist -import Database.Persist.Sql (Migration, SqlPersistT, migrate, SqlBackend, PersistFieldSql) +import Database.Persist.Sql (Migration, migrate, SqlBackend, PersistFieldSql) import Database.Persist.Quasi import Language.Haskell.TH.Lib (varE) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Data.Char (toLower, toUpper) import Control.Monad (forM, (<=<), mzero) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.IO.Class (MonadIO) import qualified System.IO as SIO -import Data.Text (pack, Text, append, unpack, concat, uncons, cons) +import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripPrefix, stripSuffix) import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.IO as TIO -import Data.List (foldl', find) -import Data.Maybe (isJust) +import Data.List (foldl') +import Data.Maybe (isJust, listToMaybe, mapMaybe) import Data.Monoid (mappend, mconcat) +import Text.Read (readPrec, lexP, step, prec, parens, Lexeme(Ident)) import qualified Data.Map as M import qualified Data.HashMap.Strict as HM import Data.Aeson @@ -65,15 +65,17 @@ ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import Control.Applicative (pure, (<*>)) -import Control.Monad.Logger (MonadLogger) +import Control.Applicative (pure, (<$>), (<*>)) import Database.Persist.Sql (sqlType) +import Data.Proxy (Proxy (Proxy)) +import Web.PathPieces (PathPiece, toPathPiece, fromPathPiece) +import GHC.Generics (Generic) -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist). persistWith :: PersistSettings -> QuasiQuoter persistWith ps = QuasiQuoter - { quoteExp = parseSqlType ps . pack + { quoteExp = parseReferences ps . pack } -- | Apply 'persistWith' to 'upperCaseSettings'. @@ -94,72 +96,145 @@ h <- qRunIO $ SIO.openFile fp SIO.ReadMode qRunIO $ SIO.hSetEncoding h SIO.utf8_bom s <- qRunIO $ TIO.hGetContents h - parseSqlType ps s + parseReferences ps s -parseSqlType :: PersistSettings -> Text -> Q Exp -parseSqlType ps s = - lift $ map (getSqlType defsOrig) defsOrig +-- calls parse to Quasi.parse individual entities in isolation +-- afterwards, sets references to other entities +parseReferences :: PersistSettings -> Text -> Q Exp +parseReferences ps s = lift $ + map (mkEntityDefSqlTypeExp entityMap) entsWithEmbeds where - defsOrig = parse ps s + -- every EntityDef could reference each-other (as an EmbedRef) + -- let Haskell tie the knot + entityMap = M.fromList $ map (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) entsWithEmbeds + entsWithEmbeds = map setEmbedEntity rawEnts + setEmbedEntity ent = ent + { entityFields = map (setEmbedField entityMap) $ entityFields ent + } + rawEnts = parse ps s -getSqlType :: [EntityDef ()] -> EntityDef () -> EntityDef SqlTypeExp -getSqlType allEntities ent = - ent - { entityFields = map go $ entityFields ent - } - where - go :: FieldDef () -> FieldDef SqlTypeExp - go field = do - field - { fieldSqlType = final - , fieldEmbedded = mEmbedded (fieldType field) - } - where - -- In the case of embedding, there won't be any datatype created yet. - -- We just use SqlString, as the data will be serialized to JSON. - final - | isJust (mEmbedded (fieldType field)) = SqlString' - | isReference = SqlInt64' - | otherwise = - case fieldType field of - -- In the case of lists, we always serialize to a string - -- value (via JSON). - -- - -- Normally, this would be determined automatically by - -- SqlTypeExp. However, there's one corner case: if there's - -- a list of entity IDs, the datatype for the ID has not - -- yet been created, so the compiler will fail. This extra - -- clause works around this limitation. - FTList _ -> SqlString' - _ -> SqlTypeExp st - mEmbedded (FTTypeCon Just{} _) = Nothing - mEmbedded (FTTypeCon Nothing n) = let name = HaskellName n in - find ((name ==) . entityHaskell) allEntities - mEmbedded (FTList x) = mEmbedded x - mEmbedded (FTApp x y) = maybe (mEmbedded y) Just (mEmbedded x) +stripId :: FieldType -> Maybe Text +stripId (FTTypeCon Nothing t) = stripSuffix "Id" t +stripId _ = Nothing - isReference = - case stripId $ fieldType field of - Just{} -> True - Nothing -> False +foreignReference :: FieldDef -> Maybe HaskellName +foreignReference field = case fieldReference field of + ForeignRef ref -> Just ref + _ -> Nothing - typ = ftToType $ fieldType field - mtyp = (ConT ''Maybe `AppT` typ) - typedNothing = SigE (ConE 'Nothing) mtyp - st = VarE 'sqlType `AppE` typedNothing -data SqlTypeExp = SqlTypeExp Exp - | SqlString' - | SqlInt64' +-- fieldSqlType at parse time can be an Exp +-- This helps delay setting fieldSqlType until lift time +data EntityDefSqlTypeExp = EntityDefSqlTypeExp EntityDef [SqlTypeExp] + deriving Show + +data SqlTypeExp = SqlTypeExp FieldType + | SqlType' SqlType + deriving Show + instance Lift SqlTypeExp where - lift (SqlTypeExp e) = return e - lift SqlString' = [|SqlString|] - lift SqlInt64' = [|SqlInt64|] + lift (SqlType' t) = lift t + lift (SqlTypeExp ftype) = return st + where + typ = ftToType ftype + mtyp = (ConT ''Proxy `AppT` typ) + typedNothing = SigE (ConE 'Proxy) mtyp + st = VarE 'sqlType `AppE` typedNothing +data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp] + +instance Lift FieldsSqlTypeExp where + lift (FieldsSqlTypeExp fields sqlTypeExps) = + lift $ zipWith FieldSqlTypeExp fields sqlTypeExps + +data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp +instance Lift FieldSqlTypeExp where + lift (FieldSqlTypeExp (FieldDef{..}) sqlTypeExp) = + [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) $(liftTs fieldAttrs) fieldStrict fieldReference|] + +instance Lift EntityDefSqlTypeExp where + lift (EntityDefSqlTypeExp (EntityDef{..}) sqlTypeExps) = + [|EntityDef + $(lift entityHaskell) + $(lift entityDB) + $(lift entityID) + $(liftTs entityAttrs) + $(lift (FieldsSqlTypeExp entityFields sqlTypeExps)) + $(lift entityPrimary) + $(lift entityUniques) + $(lift entityForeigns) + $(liftTs entityDerives) + $(liftMap entityExtra) + $(lift entitySum) + |] + +instance Lift ReferenceDef where + lift NoReference = [|NoReference|] + lift (ForeignRef name) = [|ForeignRef name|] + lift (EmbedRef em) = [|EmbedRef em|] + +instance Lift EmbedEntityDef where + lift (EmbedEntityDef name fields) = [|EmbedEntityDef name fields|] + +instance Lift EmbedFieldDef where + lift (EmbedFieldDef name em) = [|EmbedFieldDef name em|] + +type EntityMap = M.Map HaskellName EmbedEntityDef +mEmbedded :: EntityMap -> FieldType -> Maybe EmbedEntityDef +mEmbedded _ (FTTypeCon Just{} _) = Nothing +mEmbedded ents (FTTypeCon Nothing n) = let name = HaskellName n in + M.lookup name ents +mEmbedded ents (FTList x) = mEmbedded ents x +mEmbedded ents (FTApp x y) = maybe (mEmbedded ents y) Just (mEmbedded ents x) + +setEmbedField :: EntityMap -> FieldDef -> FieldDef +setEmbedField allEntities field = field + { fieldReference = case fieldReference field of + NoReference -> case mEmbedded allEntities (fieldType field) of + Nothing -> case stripId $ fieldType field of + Nothing -> NoReference + Just name -> if M.member (HaskellName name) allEntities + then ForeignRef $ HaskellName name + else NoReference + Just em -> EmbedRef em + existing@_ -> existing + } + +mkEntityDefSqlTypeExp :: EntityMap -> EntityDef -> EntityDefSqlTypeExp +mkEntityDefSqlTypeExp allEntities ent = EntityDefSqlTypeExp ent + $ (map getSqlType $ entityFields ent) + where + getSqlType field = maybe + (defaultSqlTypeExp field) + (SqlType' . SqlOther) + (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ fieldAttrs field) + + + -- In the case of embedding, there won't be any datatype created yet. + -- We just use SqlString, as the data will be serialized to JSON. + defaultSqlTypeExp field + | isJust (mEmbedded allEntities ftype) = SqlType' SqlString + | isReference = SqlType' SqlInt64 + | otherwise = + case ftype of + -- In the case of lists, we always serialize to a string + -- value (via JSON). + -- + -- Normally, this would be determined automatically by + -- SqlTypeExp. However, there's one corner case: if there's + -- a list of entity IDs, the datatype for the ID has not + -- yet been created, so the compiler will fail. This extra + -- clause works around this limitation. + FTList _ -> SqlType' SqlString + _ -> SqlTypeExp ftype + where + isReference = isJust (foreignReference field) + ftype = fieldType field + -- | 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] -> Q [Dec] mkPersist mps ents' = do x <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents y <- fmap mconcat $ mapM (mkEntity mps) ents @@ -170,7 +245,7 @@ -- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'. -- For example, strip out any fields marked as MigrationOnly. -fixEntityDef :: EntityDef a -> EntityDef a +fixEntityDef :: EntityDef -> EntityDef fixEntityDef ed = ed { entityFields = filter keepField $ entityFields ed } where @@ -221,11 +296,11 @@ -> MkPersistSettings mkPersistSettings t = MkPersistSettings { mpsBackend = t - , mpsGeneric = True -- FIXME switch default to False in the future + , mpsGeneric = False , mpsPrefixFields = True , mpsEntityJSON = Just EntityJSON - { entityToJSON = 'keyValueEntityToJSON - , entityFromJSON = 'keyValueEntityFromJSON + { entityToJSON = 'entityIdToJSON + , entityFromJSON = 'entityIdFromJSON } , mpsGenerateLenses = False } @@ -234,18 +309,20 @@ sqlSettings :: MkPersistSettings sqlSettings = mkPersistSettings $ ConT ''SqlBackend --- | Same as 'sqlSettings', but set 'mpsGeneric' to @False@. +-- | Same as 'sqlSettings'. -- -- Since 1.1.1 sqlOnlySettings :: MkPersistSettings -sqlOnlySettings = sqlSettings { mpsGeneric = False } +sqlOnlySettings = sqlSettings +{-# DEPRECATED sqlOnlySettings "use sqlSettings" #-} -recNameNoUnderscore :: MkPersistSettings -> Text -> Text -> Text +recNameNoUnderscore :: MkPersistSettings -> HaskellName -> HaskellName -> Text recNameNoUnderscore mps dt f - | mpsPrefixFields mps = lowerFirst dt ++ upperFirst f - | otherwise = lowerFirst f + | mpsPrefixFields mps = lowerFirst (unHaskellName dt) ++ upperFirst ft + | otherwise = lowerFirst ft + where ft = unHaskellName f -recName :: MkPersistSettings -> Text -> Text -> Text +recName :: MkPersistSettings -> HaskellName -> HaskellName -> Text recName mps dt f = addUnderscore $ recNameNoUnderscore mps dt f where @@ -265,22 +342,22 @@ Just (a, b) -> cons (toUpper a) b Nothing -> t -dataTypeDec :: MkPersistSettings -> EntityDef a -> Dec +dataTypeDec :: MkPersistSettings -> EntityDef -> Dec dataTypeDec mps t = DataD [] nameFinal paramsFinal constrs $ map (mkName . unpack) $ entityDerives t where - mkCol x FieldDef {..} = - (mkName $ unpack $ recName mps x $ unHaskellName fieldHaskell, + mkCol x fd@FieldDef {..} = + (mkName $ unpack $ recName mps x fieldHaskell, if fieldStrict then IsStrict else NotStrict, - pairToType mps backend (fieldType, nullable fieldAttrs) + pairToType mps backend (fd, nullable fieldAttrs) ) (nameFinal, paramsFinal) | mpsGeneric mps = (nameG, [PlainTV backend]) | otherwise = (name, []) nameG = mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Generic" name = mkName $ unpack $ unHaskellName $ entityHaskell t - cols = map (mkCol $ unHaskellName $ entityHaskell t) $ entityFields t + cols = map (mkCol $ entityHaskell t) $ entityFields t backend = mkName "backend" constrs @@ -289,9 +366,9 @@ sumCon fd = NormalC (sumConstrName mps t fd) - [(NotStrict, pairToType mps backend (fieldType fd, NotNullable))] + [(NotStrict, pairToType mps backend (fd, NotNullable))] -sumConstrName :: MkPersistSettings -> EntityDef a -> FieldDef b -> Name +sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name sumConstrName mps t FieldDef {..} = mkName $ unpack $ concat [ if mpsPrefixFields mps then unHaskellName $ entityHaskell t @@ -300,28 +377,16 @@ , "Sum" ] -readMay :: Read a => String -> Maybe a -readMay s = - case reads s of - (x, _):_ -> Just x - [] -> Nothing - -entityUpdates :: EntityDef a -> [(HaskellName, FieldType, IsNullable, PersistUpdate)] -entityUpdates = - concatMap go . entityFields - where - go FieldDef {..} = map (\a -> (fieldHaskell, fieldType, nullable fieldAttrs, a)) [minBound..maxBound] - -uniqueTypeDec :: MkPersistSettings -> EntityDef a -> Dec +uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec uniqueTypeDec mps t = DataInstD [] ''Unique - [genericDataType mps (unHaskellName $ entityHaskell t) $ VarT backend] + [genericDataType mps (entityHaskell t) backendT] (map (mkUnique mps backend t) $ entityUniques t) [] where backend = mkName "backend" -mkUnique :: MkPersistSettings -> Name -> EntityDef a -> UniqueDef -> Con +mkUnique :: MkPersistSettings -> Name -> EntityDef -> UniqueDef -> Con mkUnique mps backend t (UniqueDef (HaskellName constr) _ fields attrs) = NormalC (mkName $ unpack constr) types where @@ -330,15 +395,15 @@ force = "!force" `elem` attrs - go :: (FieldType, IsNullable) -> (Strict, Type) + go :: (FieldDef, IsNullable) -> (Strict, Type) go (_, Nullable _) | not force = error nullErrMsg - go (ft, y) = (NotStrict, pairToType mps backend (ft, y)) + go (fd, y) = (NotStrict, pairToType mps backend (fd, y)) - lookup3 :: Text -> [FieldDef a] -> (FieldType, IsNullable) + lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable) lookup3 s [] = error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr - lookup3 x (FieldDef {..}:rest) - | x == unHaskellName fieldHaskell = (fieldType, nullable fieldAttrs) + lookup3 x (fd@FieldDef {..}:rest) + | x == unHaskellName fieldHaskell = (fd, nullable fieldAttrs) | otherwise = lookup3 x rest nullErrMsg = @@ -353,46 +418,43 @@ pairToType :: MkPersistSettings -> Name -- ^ backend - -> (FieldType, IsNullable) + -> (FieldDef, IsNullable) -> Type -pairToType mps backend (s, Nullable ByMaybeAttr) = - ConT ''Maybe `AppT` idType mps backend s -pairToType mps backend (s, _) = idType mps backend s +pairToType mps backend (fd, Nullable ByMaybeAttr) = + ConT ''Maybe `AppT` idType mps backend fd +pairToType mps backend (fd, _) = idType mps backend fd backendDataType :: MkPersistSettings -> Type backendDataType mps - | mpsGeneric mps = VarT $ mkName "backend" + | mpsGeneric mps = backendT | otherwise = mpsBackend mps genericDataType :: MkPersistSettings - -> Text -- ^ entity name + -> HaskellName -- ^ entity name -> Type -- ^ backend -> Type -genericDataType mps typ' backend +genericDataType mps (HaskellName typ') backend | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend | otherwise = ConT $ mkName $ unpack typ' -idType :: MkPersistSettings -> Name -> FieldType -> Type -idType mps backend typ = - case stripId typ of +idType :: MkPersistSettings -> Name -> FieldDef -> Type +idType mps backend fd = + case foreignReference fd of Just typ' -> - ConT ''KeyBackend - `AppT` backend' + ConT ''Key `AppT` genericDataType mps typ' (VarT backend) Nothing -> ftToType typ where - backend' - | mpsGeneric mps = VarT backend - | otherwise = mpsBackend mps + typ = fieldType fd degen :: [Clause] -> [Clause] degen [] = let err = VarE 'error `AppE` LitE (StringL "Degenerate case, should never happen") - in [Clause [WildP] (NormalB err) []] + in [normalClause [WildP] err] degen x = x -mkToPersistFields :: MkPersistSettings -> String -> EntityDef a -> Q Dec +mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do clauses <- if isSum @@ -406,11 +468,11 @@ let pat = ConP (mkName constr) $ map VarP xs sp <- [|SomePersistField|] let bod = ListE $ map (AppE sp . VarE) xs - return $ Clause [pat] (NormalB bod) [] + return $ normalClause [pat] bod fieldCount = length fields - goSum :: FieldDef a -> Int -> Q Clause + goSum :: FieldDef -> Int -> Q Clause goSum fd idx = do let name = sumConstrName mps ed fd enull <- [|SomePersistField PersistNull|] @@ -420,12 +482,12 @@ after = replicate afterCount enull x <- newName "x" sp <- [|SomePersistField|] - let body = NormalB $ ListE $ mconcat + let body = ListE $ mconcat [ before , [sp `AppE` VarE x] , after ] - return $ Clause [ConP name [VarP x]] body [] + return $ normalClause [ConP name [VarP x]] body mkToFieldNames :: [UniqueDef] -> Q Dec @@ -436,19 +498,9 @@ go (UniqueDef constr _ names _) = do names' <- lift names return $ - Clause + normalClause [RecP (mkName $ unpack $ unHaskellName constr) []] - (NormalB names') - [] - -mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec -mkToUpdate name pairs = do - pairs' <- mapM go pairs - return $ FunD (mkName name) $ degen pairs' - where - go (constr, pu) = do - pu' <- lift pu - return $ Clause [RecP (mkName constr) []] (NormalB pu') [] + names' mkUniqueToValues :: [UniqueDef] -> Q Dec mkUniqueToValues pairs = do @@ -461,57 +513,30 @@ let pat = ConP (mkName $ unpack $ unHaskellName constr) $ map VarP xs tpv <- [|toPersistValue|] let bod = ListE $ map (AppE tpv . VarE) xs - return $ Clause [pat] (NormalB bod) [] - -mkToFieldName :: String -> [(String, String)] -> Dec -mkToFieldName func pairs = - FunD (mkName func) $ degen $ map go pairs - where - go (constr, name) = - Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) [] - -mkToValue :: String -> [String] -> Dec -mkToValue func = FunD (mkName func) . degen . map go - where - go constr = - let x = mkName "x" - in Clause [ConP (mkName constr) [VarP x]] - (NormalB $ VarE 'toPersistValue `AppE` VarE x) - [] + return $ normalClause [pat] bod isNotNull :: PersistValue -> Bool isNotNull PersistNull = False isNotNull _ = True -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 - mkPersistValues <- mapM (mkPersistValue . unHaskellName . fieldHaskell) $ entityFields t - let xs' = map (\(pv, x) -> pv `AppE` VarE x) $ zip mkPersistValues xs - let pat = ListP $ map VarP xs - ap' <- [|(<*>)|] - just <- [|Right|] - let cons'' = just `AppE` cons' - return - [ Clause [pat] (NormalB $ foldl (go ap') cons'' xs') [] - , Clause [WildP] (NormalB nothing) [] - ] +mapLeft :: (a -> c) -> Either a b -> Either c b +mapLeft _ (Right r) = Right r +mapLeft f (Left l) = Left (f l) + +fieldError :: Text -> Text -> Text +fieldError fieldName err = "field " `mappend` fieldName `mappend` ": " `mappend` err + +mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause] +mkFromPersistValues _ t@(EntityDef { entitySum = False }) = + fromValues t "fromPersistValues" entE $ entityFields t where - mkPersistValue fieldName = [|\persistValue -> - case fromPersistValue persistValue of - Right r -> Right r - Left err -> Left $ - "field " `mappend` $(liftT fieldName) `mappend` ": " `mappend` err - |] + entE = ConE $ mkName $ unpack entName entName = unHaskellName $ entityHaskell t - go ap' x y = InfixE (Just x) ap' (Just y) 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) []] + return $ clauses `mappend` [normalClause [WildP] nothing] where entName = unHaskellName $ entityHaskell t mkClauses _ [] = return [] @@ -536,43 +561,40 @@ lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s) -mkLensClauses :: MkPersistSettings -> EntityDef a -> Q [Clause] +mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause] mkLensClauses mps t = do lens' <- [|lensPTH|] getId <- [|entityKey|] setId <- [|\(Entity _ value) key -> Entity key value|] getVal <- [|entityVal|] dot <- [|(.)|] - keyName <- newName "key" + keyVar <- newName "key" valName <- newName "value" xName <- newName "x" - let idClause = Clause - [ConP (mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") []] - (NormalB $ lens' `AppE` getId `AppE` setId) - [] + let idClause = normalClause + [ConP (keyIdName t) []] + (lens' `AppE` getId `AppE` setId) if entitySum t - then return $ idClause : map (toSumClause lens' keyName valName xName) (entityFields t) - else return $ idClause : map (toClause lens' getVal dot keyName valName xName) (entityFields t) + then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields t) + else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields t) where - toClause lens' getVal dot keyName valName xName f = Clause + toClause lens' getVal dot keyVar valName xName f = normalClause [ConP (filterConName mps t f) []] - (NormalB $ lens' `AppE` getter `AppE` setter) - [] + (lens' `AppE` getter `AppE` setter) where - fieldName = mkName $ unpack $ recName mps (unHaskellName $ entityHaskell t) (unHaskellName $ fieldHaskell f) + fieldName = mkName $ unpack $ recName mps (entityHaskell t) (fieldHaskell f) getter = InfixE (Just $ VarE fieldName) dot (Just getVal) setter = LamE - [ ConP 'Entity [VarP keyName, VarP valName] + [ ConP 'Entity [VarP keyVar, VarP valName] , VarP xName ] - $ ConE 'Entity `AppE` VarE keyName `AppE` RecUpdE + $ ConE 'Entity `AppE` VarE keyVar `AppE` RecUpdE (VarE valName) [(fieldName, VarE xName)] - toSumClause lens' keyName valName xName f = Clause + toSumClause lens' keyVar valName xName f = normalClause [ConP (filterConName mps t f) []] - (NormalB $ lens' `AppE` getter `AppE` setter) - [] + (lens' `AppE` getter `AppE` setter) where emptyMatch = Match WildP (NormalB $ VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type")) [] getter = LamE @@ -584,52 +606,236 @@ -- a sum type and therefore could result in Maybe. : if length (entityFields t) > 1 then [emptyMatch] else [] setter = LamE - [ ConP 'Entity [VarP keyName, WildP] + [ ConP 'Entity [VarP keyVar, WildP] , VarP xName ] - $ ConE 'Entity `AppE` VarE keyName `AppE` (ConE (sumConstrName mps t f) `AppE` VarE xName) + $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps t f) `AppE` VarE xName) -mkEntity :: MkPersistSettings -> EntityDef SqlType -> Q [Dec] + + +-- | declare the key type and associated instances +-- a PathPiece instance is only generated for a Key with one field +mkKeyTypeDec :: MkPersistSettings -> EntityDef -> Q (Dec, [Dec]) +mkKeyTypeDec mps t = do + (instDecs, i) <- + if mpsGeneric mps + then if not useNewtype + then do pfDec <- pfInstD + return (pfDec, [''Generic]) + else do gi <- genericInstances + return (gi, []) + else if not useNewtype + then do pfDec <- pfInstD + return (pfDec, [''Show, ''Read, ''Eq, ''Ord, ''Generic]) + else return ([], [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]) + + let kd = if useNewtype + then NewtypeInstD [] k [recordType] dec i + else DataInstD [] k [recordType] [dec] i + return (kd, instDecs) + where + dec = RecC (keyConName t) keyFields + k = ''Key + recordType = genericDataType mps (entityHaskell t) backendT + pfInstD = -- FIXME: generate a PersistMap instead of PersistList + [d|instance PersistField (Key $(pure recordType)) where + toPersistValue = PersistList . keyToValues + fromPersistValue (PersistList l) = keyFromValues l + fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got + instance PersistFieldSql (Key $(pure recordType)) where + sqlType _ = SqlString + instance ToJSON (Key $(pure recordType)) + instance FromJSON (Key $(pure recordType)) + |] + + keyStringL = StringL . keyString + genericInstances = + -- truly unfortunate that TH doesn't support standalone deriving + -- https://ghc.haskell.org/trac/ghc/ticket/8100 + [d|instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) where + showsPrec i x = showParen (i > app_prec) $ + (showString $ $(pure $ LitE $ keyStringL t) `mappend` " ") . + showsPrec i ($(return $ VarE $ unKeyName t) x) + where app_prec = (10::Int) + instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType)) where + readPrec = parens $ (prec app_prec $ do + Ident $(pure $ LitP $ keyStringL t) <- lexP + m <- step readPrec + return ($(pure $ ConE $ keyConName t) m)) + where app_prec = (10::Int) + instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType)) where + x == y = + ($(return $ VarE $ unKeyName t) x) == + ($(return $ VarE $ unKeyName t) y) + x /= y = + ($(return $ VarE $ unKeyName t) x) == + ($(return $ VarE $ unKeyName t) y) + instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType)) where + compare x y = compare + ($(return $ VarE $ unKeyName t) x) + ($(return $ VarE $ unKeyName t) y) + instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType)) where + toPathPiece = toPathPiece . $(return $ VarE $ unKeyName t) + fromPathPiece = fmap $(return $ ConE $ keyConName t) . fromPathPiece + instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType)) where + toPersistValue = toPersistValue . $(return $ VarE $ unKeyName t) + fromPersistValue = fmap $(return $ ConE $ keyConName t) . fromPersistValue + instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType)) where + sqlType = sqlType . fmap $(return $ VarE $ unKeyName t) + instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType)) where + toJSON = toJSON . $(return $ VarE $ unKeyName t) + instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType)) where + parseJSON = fmap $(return $ ConE $ keyConName t) . parseJSON + |] + + useNewtype = length keyFields < 2 + keyFields = case entityPrimary t of + Nothing -> [backendKeyVar] + Just pdef -> map primaryKeyVar $ (primaryFields pdef) + primaryKeyVar fd = (keyFieldName t fd, NotStrict, ftToType $ fieldType fd) + + backendKeyVar = (unKeyName t, NotStrict, backendKeyType) + backendKeyType + | mpsGeneric mps = ConT ''BackendKey `AppT` backendT + | otherwise = ConT ''BackendKey `AppT` mpsBackend mps + +keyIdName :: EntityDef -> Name +keyIdName = mkName . unpack . keyIdText + +keyIdText :: EntityDef -> Text +keyIdText t = (unHaskellName $ entityHaskell t) `mappend` "Id" + +unKeyName :: EntityDef -> Name +unKeyName t = mkName $ "un" `mappend` keyString t + +backendT :: Type +backendT = VarT $ mkName "backend" + +keyConName :: EntityDef -> Name +keyConName = mkName . keyString + +keyString :: EntityDef -> String +keyString = unpack . keyText + +keyText :: EntityDef -> Text +keyText t = unHaskellName (entityHaskell t) ++ "Key" + +keyFieldName :: EntityDef -> FieldDef -> Name +keyFieldName t fd = mkName $ unpack $ lowerFirst (keyText t) `mappend` (unDBName $ fieldDB fd) + +mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec +mkKeyToValues mps t = do + (p, e) <- case entityPrimary t of + Nothing -> + ([],) <$> [|backendKeyToValues . $(return $ VarE $ unKeyName t)|] + Just pdef -> + newName "record" >>= return . toValuesPrimary pdef + return $ FunD 'keyToValues $ return $ normalClause p e + where + toValuesPrimary pdef recordName = + ( [VarP recordName] + , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName t fd) `AppE` VarE recordName)) $ primaryFields pdef + ) + +normalClause :: [Pat] -> Exp -> Clause +normalClause p e = Clause p (NormalB e) [] + +mkKeyFromValues :: MkPersistSettings -> EntityDef -> Q Dec +mkKeyFromValues _mps t = do + clauses <- case entityPrimary t of + Nothing -> do + e <- [|fmap $(return keyConE) . backendKeyFromValues|] + return $ [normalClause [] e] + Just pdef -> + fromValues t "keyFromValues" keyConE (primaryFields pdef) + return $ FunD 'keyFromValues clauses + where + keyConE = ConE (keyConName t) + +fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause] +fromValues t funName conE fields = do + x <- newName "x" + let funMsg = entityText t `mappend` ": " `mappend` funName `mappend` " failed on: " + patternMatchFailure <- + [|Left $ mappend $(liftT funMsg) (pack $ show $(return $ VarE x))|] + suc <- patternSuccess fields + return [ suc, normalClause [VarP x] patternMatchFailure ] + where + patternSuccess [] = do + rightE <- [|Right|] + return $ normalClause [ListP []] (rightE `AppE` conE) + patternSuccess fieldsNE = do + x1 <- newName "x1" + restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fieldsNE] + (fpv1:mkPersistValues) <- mapM mkPvFromFd fieldsNE + fmapE <- [|(<$>)|] + let conApp = infixFromPersistValue fmapE fpv1 conE x1 + applyE <- [|(<*>)|] + let applyFromPersistValue = infixFromPersistValue applyE + + return $ normalClause + [ListP $ map VarP (x1:restNames)] + (foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues)) + where + infixFromPersistValue applyE fpv exp name = + UInfixE exp applyE (fpv `AppE` VarE name) + mkPvFromFd = mkPersistValue . unHaskellName . fieldHaskell + mkPersistValue fieldName = [|mapLeft (fieldError $(liftT fieldName)) . fromPersistValue|] + + +mkEntity :: MkPersistSettings -> EntityDef -> Q [Dec] mkEntity mps t = do t' <- lift t - let nameT = unHaskellName $ entityHaskell t + let entName = entityHaskell t + let nameT = unHaskellName entName let nameS = unpack nameT - let clazz = ConT ''PersistEntity `AppT` genericDataType mps (unHaskellName $ entityHaskell t) (VarT $ mkName "backend") + let clazz = ConT ''PersistEntity `AppT` genericDataType mps entName backendT tpf <- mkToPersistFields mps nameS t fpv <- mkFromPersistValues mps t utv <- mkUniqueToValues $ entityUniques t puk <- mkUniqueKeys t fkc <- mapM (mkForeignKeysComposite mps t) $ entityForeigns t + + let primaryField = FieldDef + { fieldHaskell = HaskellName "Id" + , fieldDB = entityID t + , fieldType = FTTypeCon Nothing $ keyIdText t + , fieldSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") $ entityPrimary t + -- the primary field is actually a reference to the entity + , fieldReference = ForeignRef entName + , fieldAttrs = [] + , fieldStrict = True + } - fields <- mapM (mkField mps t) $ FieldDef - { fieldHaskell = HaskellName "Id" - , fieldDB = entityID t - , fieldType = FTTypeCon Nothing $ unHaskellName (entityHaskell t) ++ "Id" - , fieldSqlType = SqlInt64 - , fieldEmbedded = Nothing - , fieldAttrs = [] - , fieldStrict = True - } - : entityFields t + fields <- mapM (mkField mps t) $ primaryField : entityFields t toFieldNames <- mkToFieldNames $ entityUniques t + (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps t + keyToValues' <- mkKeyToValues mps t + keyFromValues' <- mkKeyFromValues mps t + let addSyn -- FIXME maybe remove this | mpsGeneric mps = (:) $ TySynD (mkName nameS) [] $ - genericDataType mps nameT $ mpsBackend mps + genericDataType mps entName $ mpsBackend mps | otherwise = id lensClauses <- mkLensClauses mps t lenses <- mkLenses mps t + let instanceConstraint = if not (mpsGeneric mps) then [] else + [ClassP ''PersistStore [backendT]] return $ addSyn $ dataTypeDec mps t : mconcat fkc `mappend` - ([ TySynD (mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") [] $ - ConT ''KeyBackend `AppT` mpsBackend mps `AppT` ConT (mkName nameS) - , InstanceD [] clazz $ + ([ TySynD (keyIdName t) [] $ + ConT ''Key `AppT` ConT (mkName nameS) + , InstanceD instanceConstraint clazz $ [ uniqueTypeDec mps t - , FunD 'entityDef [Clause [WildP] (NormalB t') []] + , keyTypeDec + , keyToValues' + , keyFromValues' + , FunD 'entityDef [normalClause [WildP] t'] , tpf , FunD 'fromPersistValues fpv , toFieldNames @@ -638,7 +844,7 @@ , DataInstD [] ''EntityField - [ genericDataType mps nameT $ VarT $ mkName "backend" + [ genericDataType mps entName backendT , VarT $ mkName "typ" ] (map fst fields) @@ -648,22 +854,25 @@ ''PersistEntityBackend #if MIN_VERSION_template_haskell(2,9,0) (TySynEqn - [genericDataType mps (unHaskellName $ entityHaskell t) $ VarT $ mkName "backend"] + [genericDataType mps entName backendT] (backendDataType mps)) #else - [genericDataType mps (unHaskellName $ entityHaskell t) $ VarT $ mkName "backend"] + [genericDataType mps entName backendT] (backendDataType mps) #endif - , FunD 'persistIdField [Clause [] (NormalB $ ConE $ mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") []] + , FunD 'persistIdField [normalClause [] (ConE $ keyIdName t)] , FunD 'fieldLens lensClauses ] - ] `mappend` lenses) + ] `mappend` lenses) `mappend` keyInstanceDecs -mkLenses :: MkPersistSettings -> EntityDef a -> Q [Dec] +entityText :: EntityDef -> Text +entityText = unHaskellName . entityHaskell + +mkLenses :: MkPersistSettings -> EntityDef -> Q [Dec] mkLenses mps _ | not (mpsGenerateLenses mps) = return [] mkLenses _ ent | entitySum ent = return [] mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do - let lensName' = recNameNoUnderscore mps (unHaskellName $ entityHaskell ent) (unHaskellName $ fieldHaskell field) + let lensName' = recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field) lensName = mkName $ unpack lensName' fieldName = mkName $ unpack $ "_" ++ lensName' needleN <- newName "needle" @@ -682,9 +891,9 @@ -- values backend1 = mkName "backend" backend2 = mkName "backend" - aT = pairToType mps backend1 (fieldType field, nullable $ fieldAttrs field) - bT = pairToType mps backend2 (fieldType field, nullable $ fieldAttrs field) - mkST backend = genericDataType mps (unHaskellName $ entityHaskell ent) (VarT backend) + aT = pairToType mps backend1 (field, nullable $ fieldAttrs field) + bT = pairToType mps backend2 (field, nullable $ fieldAttrs field) + mkST backend = genericDataType mps (entityHaskell ent) (VarT backend) sT = mkST backend1 tT = mkST backend2 t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2 @@ -699,29 +908,30 @@ (NormalB $ VarE 'fmap `AppE` setter `AppE` (f `AppE` needle)) - [ FunD needleN [Clause [] (NormalB $ VarE fieldName `AppE` a) []] - , FunD setterN $ return $ Clause + [ FunD needleN [normalClause [] (VarE fieldName `AppE` a)] + , FunD setterN $ return $ normalClause [VarP yN] - (NormalB $ RecUpdE a + (RecUpdE a [ (fieldName, y) ]) - [] ] ] -mkForeignKeysComposite :: MkPersistSettings -> EntityDef a -> ForeignDef -> Q [Dec] +mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec] mkForeignKeysComposite mps t fdef = do - let fieldName f = mkName $ unpack $ recName mps (unHaskellName $ entityHaskell t) (unHaskellName f) - let fname=fieldName $ foreignConstraintNameHaskell fdef - let reftablename=mkName $ unpack $ unHaskellName $ foreignRefTableHaskell fdef - let tablename=mkName $ unpack $ unHaskellName $ entityHaskell t - entName <- newName "entname" + let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f + let fname = fieldName $ foreignConstraintNameHaskell fdef + let reftableString = unpack $ unHaskellName $ foreignRefTableHaskell fdef + let reftableKeyName = mkName $ reftableString `mappend` "Key" + let tablename = mkName $ unpack $ entityText t + recordName <- newName "record" - let flds = map (\(a,_,_,_) -> VarE (fieldName a)) $ foreignFields fdef - let xs = ListE $ map (\a -> AppE (VarE 'toPersistValue) ((AppE a (VarE entName)))) flds - let fn = FunD fname [Clause [VarP entName] (NormalB (AppE (ConE 'Key) (AppE (ConE 'PersistList) xs))) []] + let fldsE = map (\(a,_,_,_) -> VarE (fieldName a) `AppE` VarE recordName) $ + foreignFields fdef + let mkKeyE = foldl' AppE (ConE reftableKeyName) fldsE + let fn = FunD fname [normalClause [VarP recordName] mkKeyE] - let t2 = ConT ''KeyBackend `AppT` ConT ''SqlBackend `AppT` ConT reftablename + let t2 = ConT ''Key `AppT` ConT (mkName reftableString) let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2 return [sig, fn] @@ -740,7 +950,7 @@ -- fromPersistValue x = Left $ "Expected PersistMap, received: " ++ show x -- sqlType _ = SqlString -- @ -persistFieldFromEntity :: MkPersistSettings -> EntityDef a -> Q [Dec] +persistFieldFromEntity :: MkPersistSettings -> EntityDef -> Q [Dec] persistFieldFromEntity mps e = do ss <- [|SqlString|] obj <- [|\ent -> PersistMap $ zip (map pack columnNames) (map toPersistValue $ toPersistFields ent)|] @@ -756,19 +966,18 @@ compose <- [|(<=<)|] getPersistMap' <- [|getPersistMap|] return - [ persistFieldInstanceD typ - [ FunD 'toPersistValue [ Clause [] (NormalB obj) [] ] + [ persistFieldInstanceD (mpsGeneric mps) typ + [ FunD 'toPersistValue [ normalClause [] obj ] , FunD 'fromPersistValue - [ Clause [] (NormalB $ InfixE (Just fpv) compose $ Just getPersistMap') [] + [ normalClause [] (InfixE (Just fpv) compose $ Just getPersistMap') ] ] - , persistFieldSqlInstanceD typ + , persistFieldSqlInstanceD (mpsGeneric mps) typ [ sqlTypeFunD ss ] ] where - typ = genericDataType mps (pack entityName) $ VarT $ mkName "backend" - entityName = (unpack $ unHaskellName $ entityHaskell e) + typ = genericDataType mps (entityHaskell e) backendT entFields = entityFields e columnNames = map (unpack . unHaskellName . fieldHaskell) entFields @@ -777,38 +986,38 @@ -- This function is useful for cases such as: -- -- >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|] -share :: [[EntityDef a] -> Q [Dec]] -> [EntityDef a] -> Q [Dec] +share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec] share fs x = fmap mconcat $ mapM ($ x) fs -- | Save the @EntityDef@s passed in under the given name. -mkSave :: String -> [EntityDef SqlType] -> Q [Dec] +mkSave :: String -> [EntityDef] -> Q [Dec] mkSave name' defs' = do let name = mkName name' defs <- lift defs' return [ SigD name $ ListT `AppT` (ConT ''EntityDef `AppT` ConT ''SqlType) - , FunD name [Clause [] (NormalB defs) []] + , FunD name [normalClause [] defs] ] data Dep = Dep - { depTarget :: Text + { depTarget :: HaskellName , depSourceTable :: HaskellName , depSourceField :: HaskellName , depSourceNull :: IsNullable } -- | Generate a 'DeleteCascade' instance for the given @EntityDef@s. -mkDeleteCascade :: MkPersistSettings -> [EntityDef a] -> Q [Dec] +mkDeleteCascade :: MkPersistSettings -> [EntityDef] -> Q [Dec] mkDeleteCascade mps defs = do let deps = concatMap getDeps defs mapM (go deps) defs where - getDeps :: EntityDef a -> [Dep] + getDeps :: EntityDef -> [Dep] getDeps def = concatMap getDeps' $ entityFields $ fixEntityDef def where - getDeps' :: FieldDef a -> [Dep] - getDeps' FieldDef {..} = - case stripId fieldType of + getDeps' :: FieldDef -> [Dep] + getDeps' field@FieldDef {..} = + case foreignReference field of Just f -> return Dep { depTarget = f @@ -817,9 +1026,9 @@ , depSourceNull = nullable fieldAttrs } Nothing -> [] - go :: [Dep] -> EntityDef a -> Q Dec + go :: [Dep] -> EntityDef -> Q Dec go allDeps EntityDef{entityHaskell = name} = do - let deps = filter (\x -> depTarget x == unHaskellName name) allDeps + let deps = filter (\x -> depTarget x == name) allDeps key <- newName "key" let del = VarE 'delete let dcw = VarE 'deleteCascadeWhere @@ -846,21 +1055,21 @@ stmts = map mkStmt deps `mappend` [NoBindS $ del `AppE` VarE key] - let entityT = genericDataType mps (unHaskellName name) $ VarT $ mkName "backend" + let entityT = genericDataType mps name backendT return $ InstanceD - [ ClassP ''PersistQuery [VarT $ mkName "m"] - , EqualP (ConT ''PersistEntityBackend `AppT` entityT) (ConT ''PersistMonadBackend `AppT` VarT (mkName "m")) + [ ClassP ''PersistQuery [VarT $ mkName "backend"] + , EqualP (ConT ''PersistEntityBackend `AppT` entityT) (VarT $ mkName "backend") ] - (ConT ''DeleteCascade `AppT` entityT `AppT` VarT (mkName "m")) + (ConT ''DeleteCascade `AppT` entityT `AppT` VarT (mkName "backend")) [ FunD 'deleteCascade - [Clause [VarP key] (NormalB $ DoE stmts) []] + [normalClause [VarP key] (DoE stmts)] ] -mkUniqueKeys :: EntityDef a -> Q Dec +mkUniqueKeys :: EntityDef -> Q Dec mkUniqueKeys def | entitySum def = - return $ FunD 'persistUniqueKeys [Clause [WildP] (NormalB $ ListE []) []] + return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])] mkUniqueKeys def = do c <- clause return $ FunD 'persistUniqueKeys [c] @@ -874,7 +1083,7 @@ let pat = ConP (mkName $ unpack $ unHaskellName $ entityHaskell def) (map (VarP . snd) xs) - return $ Clause [pat] (NormalB $ ListE pcs) [] + return $ normalClause [pat] (ListE pcs) go :: [(HaskellName, Name)] -> UniqueDef -> Exp go xs (UniqueDef name _ cols _) = @@ -887,16 +1096,26 @@ sqlTypeFunD :: Exp -> Dec sqlTypeFunD st = FunD 'sqlType - [ Clause [WildP] (NormalB st) [] ] + [ normalClause [WildP] st ] -persistFieldInstanceD :: Type -> [Dec] -> Dec -persistFieldInstanceD typ = - InstanceD [] (ConT ''PersistField `AppT` typ) +typeInstanceD :: Name + -> Bool -- ^ include PersistStore backend constraint + -> Type -> [Dec] -> Dec +typeInstanceD clazz hasBackend typ = + InstanceD ctx (ConT clazz `AppT` typ) + where + ctx + | hasBackend = [ClassP ''PersistStore [VarT $ mkName "backend"]] + | otherwise = [] -persistFieldSqlInstanceD :: Type -> [Dec] -> Dec -persistFieldSqlInstanceD typ = - InstanceD [] (ConT ''PersistFieldSql `AppT` typ) +persistFieldInstanceD :: Bool -- ^ include PersistStore backend constraint + -> Type -> [Dec] -> Dec +persistFieldInstanceD = typeInstanceD ''PersistField +persistFieldSqlInstanceD :: Bool -- ^ include PersistStore backend constraint + -> Type -> [Dec] -> Dec +persistFieldSqlInstanceD = typeInstanceD ''PersistFieldSql + -- | Automatically creates a valid 'PersistField' instance for any datatype -- that has valid 'Show' and 'Read' instances. Can be very convenient for -- 'Enum' types. @@ -912,15 +1131,15 @@ (x, _):_ -> Right x [] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s'|] return - [ persistFieldInstanceD (ConT $ mkName s) + [ persistFieldInstanceD False (ConT $ mkName s) [ FunD 'toPersistValue - [ Clause [] (NormalB tpv) [] + [ normalClause [] tpv ] , FunD 'fromPersistValue - [ Clause [] (NormalB $ fpv `AppE` LitE (StringL s)) [] + [ normalClause [] (fpv `AppE` LitE (StringL s)) ] ] - , persistFieldSqlInstanceD (ConT $ mkName s) + , persistFieldSqlInstanceD False (ConT $ mkName s) [ sqlTypeFunD ss ] ] @@ -946,15 +1165,15 @@ Left e -> Left $ pack "JSON decoding error for " ++ pack dt ++ pack ": " ++ pack e ++ pack ". On Input: " ++ decodeUtf8 bs' Right x -> Right x|] return - [ persistFieldInstanceD (ConT $ mkName s) + [ persistFieldInstanceD False (ConT $ mkName s) [ FunD 'toPersistValue - [ Clause [] (NormalB tpv) [] + [ normalClause [] tpv ] , FunD 'fromPersistValue - [ Clause [] (NormalB $ fpv `AppE` LitE (StringL s)) [] + [ normalClause [] (fpv `AppE` LitE (StringL s)) ] ] - , persistFieldSqlInstanceD (ConT $ mkName s) + , persistFieldSqlInstanceD False (ConT $ mkName s) [ sqlTypeFunD ss ] ] @@ -963,22 +1182,17 @@ -- defined here. One thing to be aware of is dependencies: if you have entities -- with foreign references, make sure to place those definitions after the -- entities they reference. -mkMigrate :: Lift' a => String -> [EntityDef a] -> Q [Dec] +mkMigrate :: String -> [EntityDef] -> Q [Dec] mkMigrate fun allDefs = do body' <- body return [ SigD (mkName fun) typ - , FunD (mkName fun) [Clause [] (NormalB body') []] + , FunD (mkName fun) [normalClause [] body'] ] where defs = filter isMigrated allDefs isMigrated def = not $ "no-migrate" `elem` entityAttrs def - typ = ForallT [PlainTV $ mkName "m"] - [ ClassP ''MonadBaseControl [ConT ''IO, VarT $ mkName "m"] - , ClassP ''MonadIO [VarT $ mkName "m"] - , ClassP ''MonadLogger [VarT $ mkName "m"] - ] - $ ConT ''Migration `AppT` (ConT ''SqlPersistT `AppT` VarT (mkName "m")) + typ = ConT ''Migration body :: Q Exp body = case defs of @@ -991,13 +1205,13 @@ return $ LetS [ValD (VarP defsName) (NormalB defsExp) []] stmts <- mapM (toStmt $ VarE defsName) defs return (DoE $ defsStmt : stmts) - toStmt :: Lift' a => Exp -> EntityDef a -> Q Stmt + toStmt :: Exp -> EntityDef -> Q Stmt toStmt defsExp ed = do u <- lift ed m <- [|migrate|] return $ NoBindS $ m `AppE` defsExp `AppE` u -instance Lift' a => Lift (EntityDef a) where +instance Lift EntityDef where lift (EntityDef a b c d e f g h i j k) = [|EntityDef $(lift a) @@ -1012,8 +1226,8 @@ $(liftMap j) $(lift k) |] -instance Lift' a => Lift (FieldDef a) where - lift (FieldDef a b c d e f g) = [|FieldDef a b c $(lift' d) $(liftTs e) f $(lift' g)|] +instance Lift FieldDef where + lift (FieldDef a b c d e f g) = [|FieldDef a b c $(lift' d) $(liftTs e) f g|] instance Lift UniqueDef where lift (UniqueDef a b c d) = [|UniqueDef $(lift a) $(lift b) $(lift c) $(liftTs d)|] instance Lift PrimaryDef where @@ -1029,7 +1243,7 @@ instance Lift' a => Lift' (Maybe a) where lift' Nothing = [|Nothing|] lift' (Just a) = [|Just $(lift' a)|] -instance Lift' a => Lift' (EntityDef a) where +instance Lift' EntityDef where lift' = lift instance Lift' () where lift' () = [|()|] @@ -1099,7 +1313,6 @@ lift SqlDay = [|SqlDay|] lift SqlTime = [|SqlTime|] lift SqlDayTime = [|SqlDayTime|] - lift SqlDayTimeZoned = [|SqlDayTimeZoned|] lift SqlBlob = [|SqlBlob|] lift (SqlOther a) = [|SqlOther $(liftT a)|] @@ -1109,17 +1322,16 @@ -- forall . typ ~ FieldType => EntFieldName -- -- EntFieldName = FieldDef .... -mkField :: MkPersistSettings -> EntityDef a -> FieldDef SqlType -> Q (Con, Clause) +mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause) mkField mps et cd = do let con = ForallC [] [EqualP (VarT $ mkName "typ") maybeTyp] $ NormalC name [] bod <- lift cd - let cla = Clause + let cla = normalClause [ConP name []] - (NormalB bod) - [] + bod return (con, cla) where name = filterConName mps et cd @@ -1128,18 +1340,15 @@ then ConT ''Maybe `AppT` typ else typ typ = - case stripId $ fieldType cd of + case foreignReference cd of Just ft -> - ConT ''KeyBackend - `AppT` (if mpsGeneric mps - then VarT $ mkName "backend" - else mpsBackend mps) - `AppT` genericDataType mps ft (VarT $ mkName "backend") + ConT ''Key + `AppT` genericDataType mps ft backendT Nothing -> ftToType $ fieldType cd filterConName :: MkPersistSettings - -> EntityDef sqlType1 - -> FieldDef sqlType2 + -> EntityDef + -> FieldDef -> Name filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field) @@ -1164,7 +1373,7 @@ (++) :: Text -> Text -> Text (++) = append -mkJSON :: MkPersistSettings -> EntityDef a -> Q [Dec] +mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec] mkJSON _ def | not ("json" `elem` entityAttrs def) = return [] mkJSON mps def = do pureE <- [|pure|] @@ -1181,33 +1390,25 @@ $ entityFields def let conName = mkName $ unpack $ unHaskellName $ entityHaskell def - typ = genericDataType mps (unHaskellName $ entityHaskell def) $ VarT $ mkName "backend" - toJSONI = InstanceD - [] - (ConT ''ToJSON `AppT` typ) - [toJSON'] - toJSON' = FunD 'toJSON $ return $ Clause + typ = genericDataType mps (entityHaskell def) backendT + toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] + toJSON' = FunD 'toJSON $ return $ normalClause [ConP conName $ map VarP xs] - (NormalB $ objectE `AppE` ListE pairs) - [] + (objectE `AppE` ListE pairs) pairs = zipWith toPair (entityFields def) xs toPair f x = InfixE (Just (packE `AppE` LitE (StringL $ unpack $ unHaskellName $ fieldHaskell f))) dotEqualE (Just $ VarE x) - fromJSONI = InstanceD - [] - (ConT ''FromJSON `AppT` typ) - [parseJSON'] + fromJSONI = typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON'] parseJSON' = FunD 'parseJSON - [ Clause [ConP 'Object [VarP obj]] - (NormalB $ foldl' + [ normalClause [ConP 'Object [VarP obj]] + (foldl' (\x y -> InfixE (Just x) apE' (Just y)) (pureE `AppE` ConE conName) pulls ) - [] - , Clause [WildP] (NormalB mzeroE) [] + , normalClause [WildP] mzeroE ] pulls = map toPull $ entityFields def toPull f = InfixE @@ -1217,10 +1418,49 @@ case mpsEntityJSON mps of Nothing -> return [toJSONI, fromJSONI] Just entityJSON -> do - entityJSONIs <- [d| + entityJSONIs <- if mpsGeneric mps + then [d| + instance PersistStore backend => ToJSON (Entity $(pure typ)) where + toJSON = $(varE (entityToJSON entityJSON)) + instance PersistStore backend => FromJSON (Entity $(pure typ)) where + parseJSON = $(varE (entityFromJSON entityJSON)) + |] + else [d| instance ToJSON (Entity $(pure typ)) where toJSON = $(varE (entityToJSON entityJSON)) instance FromJSON (Entity $(pure typ)) where parseJSON = $(varE (entityFromJSON entityJSON)) |] return $ toJSONI : fromJSONI : entityJSONIs + +-- entityUpdates :: EntityDef -> [(HaskellName, FieldType, IsNullable, PersistUpdate)] +-- entityUpdates = +-- concatMap go . entityFields +-- where +-- go FieldDef {..} = map (\a -> (fieldHaskell, fieldType, nullable fieldAttrs, a)) [minBound..maxBound] + +-- mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec +-- mkToUpdate name pairs = do +-- pairs' <- mapM go pairs +-- return $ FunD (mkName name) $ degen pairs' +-- where +-- go (constr, pu) = do +-- pu' <- lift pu +-- return $ normalClause [RecP (mkName constr) []] pu' + + +-- mkToFieldName :: String -> [(String, String)] -> Dec +-- mkToFieldName func pairs = +-- FunD (mkName func) $ degen $ map go pairs +-- where +-- go (constr, name) = +-- normalClause [RecP (mkName constr) []] (LitE $ StringL name) + +-- mkToValue :: String -> [String] -> Dec +-- mkToValue func = FunD (mkName func) . degen . map go +-- where +-- go constr = +-- let x = mkName "x" +-- in normalClause [ConP (mkName constr) [VarP x]] +-- (VarE 'toPersistValue `AppE` VarE x) + diff --git a/persistent-template.cabal b/persistent-template.cabal --- a/persistent-template.cabal +++ b/persistent-template.cabal @@ -1,5 +1,5 @@ name: persistent-template -version: 1.3.2.2 +version: 2.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -17,15 +17,17 @@ library build-depends: base >= 4 && < 5 , template-haskell - , persistent >= 1.3 && < 1.4 + , persistent >= 2.0 && < 2.1 , monad-control >= 0.2 && < 0.4 , bytestring >= 0.9 , text >= 0.5 , transformers >= 0.2 && < 0.5 , containers - , aeson + , aeson >= 0.7 && < 0.8 , monad-logger , unordered-containers + , tagged + , path-pieces exposed-modules: Database.Persist.TH ghc-options: -Wall if impl(ghc >= 7.4) @@ -38,7 +40,7 @@ build-depends: base >= 4 && < 5 , persistent-template - , aeson + , aeson >= 0.7 && < 0.8 , hspec >= 1.3 , text , persistent diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, GADTs #-} {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} import Test.Hspec import Test.Hspec.QuickCheck @@ -73,11 +75,11 @@ decode "{\"name\":\"Michael\",\"age\":27,\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just (Person "Michael" (Just 27) $ Address "Narkis" "Maalot" Nothing) describe "JSON serialization for Entity" $ do - let key = Key (PersistInt64 0) + let key = PersonKey 0 prop "to/from is idempotent" $ \person -> decode (encode (Entity key person)) == Just (Entity key (person :: Person)) it "decode" $ - decode "{\"key\": 0, \"value\": {\"name\":\"Michael\",\"age\":27,\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}}" `shouldBe` Just + decode "{\"id\": 0, \"name\":\"Michael\",\"age\":27,\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just (Entity key (Person "Michael" (Just 27) $ Address "Narkis" "Maalot" Nothing)) it "lens operations" $ do let street1 = "street1"