Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

Experimentation with a better lifting model. #150

Closed
wants to merge 3 commits into from

2 participants

@scshunt

--DO NOT MERGE--

The purpose of this is just to let me run automated tests on these modifications to the lifting system, to see whether this preserves the functionality for IDs and embeddings, and in particular passes the tests. I'm unfamiliar, in particular, if introducing Maybes to those areas of code will break things (although the non-Maybe version could be restored easily).

@gregwebs
Owner

You can run the automated tests locally that are in persistent-test. There are some instructions in the README.

@scshunt scshunt Fix mistaken lift.
This is a bit of a fragile approach. I guess I see why the previous approach was
used. I can't honestly say which is better.
8ef52f5
@scshunt

Oh, ok. Well, hopefully this run will be more enlightening than my stupid screwups :)

@gregwebs
Owner

The build made it farther, but a similar error occurred.

@scshunt

After some experimentation, I'm firmly of the opinion that a) the approach in my previous patch is wrong and b) I don't know how to fix it. I'll upload my progress and someone can try to fix the bugs that come up.

@gregwebs
Owner

thanks! The test suite is passing now which is encouraging.

@scshunt

Yeah, but parts of yesod break if I try to build with it. Bug in the testsuite, I guess.

@gregwebs
Owner

The code in question has changed a lot since this patch was created. I think some of the idea about improving SqlTypeExp was incorporated.

@gregwebs gregwebs closed this
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Sep 3, 2013
  1. @scshunt

    Experimentation with a better lifting model.

    scshunt authored
    --DO NOT MERGE--
  2. @scshunt

    Fix mistaken lift.

    scshunt authored
    This is a bit of a fragile approach. I guess I see why the previous approach was
    used. I can't honestly say which is better.
Commits on Sep 23, 2013
  1. @scshunt

    durdle a bit

    scshunt authored
This page is out of date. Refresh to see the latest.
Showing with 55 additions and 48 deletions.
  1. +55 −48 persistent-template/Database/Persist/TH.hs
View
103 persistent-template/Database/Persist/TH.hs
@@ -20,6 +20,8 @@ module Database.Persist.TH
, mkPersistSettings
, sqlSettings
, sqlOnlySettings
+ , liftEntitySqlType
+ , liftFieldSqlType
-- * Various other TH functions
, mkMigrate
, mkSave
@@ -36,6 +38,7 @@ import Database.Persist.Quasi
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Data.Char (toLower, toUpper)
+import Data.Maybe (isJust)
import Control.Monad (forM, (<=<), mzero)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.IO.Class (MonadIO)
@@ -43,14 +46,13 @@ import qualified System.IO as SIO
import Data.Text (pack, Text, append, unpack, concat, uncons, cons)
import qualified Data.Text.IO as TIO
import Data.List (foldl', find)
-import Data.Maybe (isJust)
import Data.Monoid (mappend, mconcat)
import qualified Data.Map as M
import Data.Aeson
( ToJSON (toJSON), FromJSON (parseJSON), (.=), object
, Value (Object), (.:), (.:?)
)
-import Control.Applicative (pure, (<*>), liftA2)
+import Control.Applicative (pure, (<*>))
import Control.Monad.Logger (MonadLogger)
import Database.Persist.Sql (sqlType)
import Language.Haskell.TH.Instances ()
@@ -88,36 +90,23 @@ parseSqlType ps s =
where
defsOrig = parse ps s
-getSqlType :: [EntityDef ()] -> EntityDef () -> EntityDef DelayedSqlTypeExp
+getSqlType :: [EntityDef ()] -> EntityDef () -> EntityDef SqlTypeExp
getSqlType allEntities ent =
ent
{ entityFields = map go $ entityFields ent
}
where
- go :: FieldDef () -> FieldDef DelayedSqlTypeExp
+ go :: FieldDef () -> FieldDef SqlTypeExp
go field = do
field
- { fieldSqlType = DSTE final
+ { 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
+ | isJust (mEmbedded ft) = SqlTypeExp $ ConE 'SqlString
+ | isJust (stripId ft) = SqlTypeExp $ ConE 'SqlInt64
+ | otherwise = SqlTypeExp st
mEmbedded (FTTypeCon Just{} _) = Nothing
mEmbedded (FTTypeCon Nothing n) = let name = HaskellName n in
@@ -125,30 +114,16 @@ getSqlType allEntities ent =
mEmbedded (FTList x) = mEmbedded x
mEmbedded (FTApp x y) = maybe (mEmbedded y) Just (mEmbedded x)
- isReference =
- case stripId $ fieldType field of
- Just{} -> True
- Nothing -> False
+ ft = fieldType field
- typ = ftToType $ fieldType field
+ typ = ftToType ft
mtyp = (ConT ''Maybe `AppT` typ)
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'
+newtype SqlTypeExp = SqlTypeExp { unSqlTypeExp :: Exp }
instance Lift SqlTypeExp where
- lift (SqlTypeExp e) = return e
- lift SqlString' = [|SqlString|]
- lift SqlInt64' = [|SqlInt64|]
+ lift (SqlTypeExp e) = [|SqlTypeExp $(lift e)|]
-- | Create data types and appropriate 'PersistEntity' instances for the given
-- 'EntityDef's. Works well with the persist quasi-quoter.
@@ -541,7 +516,7 @@ mkLensClauses t = do
mkEntity :: MkPersistSettings -> EntityDef SqlTypeExp -> Q [Dec]
mkEntity mps t = do
- t' <- lift t
+ t' <- liftEntitySqlType t
let nameT = unHaskellName $ entityHaskell t
let nameS = unpack nameT
let clazz = ConT ''PersistEntity `AppT` genericDataType mps (unHaskellName $ entityHaskell t) (VarT $ mkName "backend")
@@ -554,7 +529,7 @@ mkEntity mps t = do
{ fieldHaskell = HaskellName "Id"
, fieldDB = entityID t
, fieldType = FTTypeCon Nothing $ unHaskellName (entityHaskell t) ++ "Id"
- , fieldSqlType = SqlInt64'
+ , fieldSqlType = SqlTypeExp $ ConE 'SqlInt64
, fieldEmbedded = Nothing
, fieldAttrs = []
, fieldStrict = True
@@ -809,7 +784,7 @@ derivePersistField s = do
-- 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 SqlTypeExp] -> Q [Dec]
mkMigrate fun allDefs = do
body' <- body
return
@@ -832,14 +807,14 @@ mkMigrate fun allDefs = do
_ -> do
defsName <- newName "defs"
defsStmt <- do
- defs' <- mapM lift defs
+ defs' <- mapM liftEntitySqlType defs
let defsExp = ListE defs'
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 SqlTypeExp -> Q Stmt
toStmt defsExp ed = do
- u <- lift ed
+ u <- liftEntitySqlType ed
m <- [|migrate|]
return $ NoBindS $ m `AppE` defsExp `AppE` u
@@ -875,8 +850,6 @@ instance Lift' () where
lift' () = [|()|]
instance Lift' SqlTypeExp where
lift' = lift
-instance Lift' DelayedSqlTypeExp where
- lift' = lift
pack' :: String -> Text
pack' = pack
@@ -945,6 +918,40 @@ instance Lift SqlType where
lift SqlBlob = [|SqlBlob|]
lift (SqlOther a) = [|SqlOther $(liftT a)|]
+-- | NEEDS COMMENTING
+liftEntitySqlType :: EntityDef SqlTypeExp -> Q Exp
+liftEntitySqlType (EntityDef a b c d e f g h i) = do
+ es <- mapM liftFieldSqlType e
+ [|EntityDef
+ $(lift a)
+ $(lift b)
+ $(lift c)
+ $(liftTs d)
+ $(return $ ListE es)
+ $(lift f)
+ $(liftTs g)
+ $(liftMap h)
+ $(lift i)
+ :: EntityDef SqlType
+ |]
+
+-- | NEEDS COMMENTING
+liftFieldSqlType :: FieldDef SqlTypeExp -> Q Exp
+liftFieldSqlType (FieldDef a b c d e f g) =
+ [|FieldDef
+ a
+ b
+ c
+ ($(liftSqlType d) :: SqlType)
+ $(liftTs e)
+ f
+ $(lift' g)
+ :: FieldDef SqlType
+ |]
+
+liftSqlType :: SqlTypeExp -> Q Exp
+liftSqlType = return . unSqlTypeExp
+
-- Ent
-- fieldName FieldType
--
@@ -957,7 +964,7 @@ mkField mps et cd = do
[]
[EqualP (VarT $ mkName "typ") maybeTyp]
$ NormalC name []
- bod <- lift cd
+ bod <- liftFieldSqlType cd
let cla = Clause
[ConP name []]
(NormalB bod)
Something went wrong with that request. Please try again.