Permalink
Browse files

new types for alternative sum type implementations

no actual implementation yet
  • Loading branch information...
gregwebs committed Jul 29, 2012
1 parent b899e92 commit 5d8e8ebaeac562af45b24c778fd803491253f69f
@@ -53,6 +53,7 @@ import Data.Aeson
, Value (Object), (.:), (.:?)
)
import Control.Applicative (pure, (<*>))
+import Data.Maybe (isNothing)
-- | Converts a quasi-quoted syntax into a list of entity definitions, to be
-- used as input to the template haskell generation code (mkPersist).
@@ -147,9 +148,9 @@ dataTypeDec t =
cols = map (mkCol $ unHaskellName $ entityHaskell t) $ entityFields t
backend = mkName "backend"
- constrs
- | entitySum t = map sumCon $ entityFields t
- | otherwise = [RecC name cols]
+ constrs = case entitySum t of
+ Just UseForeignKeys -> map sumCon $ entityFields t
+ Nothing -> [RecC name cols]
sumCon fd@(FieldDef _ _ ty _) = NormalC
(sumConstrName t fd)
@@ -229,9 +230,10 @@ degen x = x
mkToPersistFields :: String -> EntityDef -> Q Dec
mkToPersistFields constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do
clauses <-
- if isSum
- then sequence $ zipWith goSum fields [1..]
- else fmap return go
+ case isSum of
+ Just UseForeignKeys ->
+ sequence $ zipWith goSum fields [1..]
+ Nothing -> fmap return go
return $ FunD (mkName "toPersistFields") clauses
where
go :: Q Clause
@@ -328,7 +330,7 @@ mkHalfDefined constr count' =
(replicate count' $ VarE $ mkName "undefined")) []]
mkFromPersistValues :: EntityDef -> Q [Clause]
-mkFromPersistValues t@(EntityDef { entitySum = False }) = do
+mkFromPersistValues t@(EntityDef { entitySum = Nothing }) = do
nothing <- [|Left $(liftT "Invalid fromPersistValues input")|]
let cons' = ConE $ mkName $ unpack $ unHaskellName $ entityHaskell t
xs <- mapM (const $ newName "x") $ entityFields t
@@ -344,7 +346,7 @@ mkFromPersistValues t@(EntityDef { entitySum = False }) = do
]
where
go ap' x y = InfixE (Just x) ap' (Just y)
-mkFromPersistValues t@(EntityDef { entitySum = True }) = do
+mkFromPersistValues t@(EntityDef { entitySum = Just UseForeignKeys }) = do
nothing <- [|Left $(liftT "Invalid fromPersistValues input")|]
clauses <- mkClauses [] $ entityFields t
return $ clauses `mappend` [Clause [WildP] (NormalB nothing) []]
@@ -397,10 +399,11 @@ mkEntity mps t = do
, tpf
, FunD (mkName "fromPersistValues") fpv
, mkHalfDefined
- (if entitySum t
- then sumConstrName t (head $ entityFields t)
- else mkName nameS)
- (if entitySum t then 1 else length $ entityFields t)
+ (case entitySum t of
+ Just UseForeignKeys ->
+ sumConstrName t (head $ entityFields t)
+ Nothing -> mkName nameS)
+ (if isNothing (entitySum t) then length $ entityFields t else 1)
, toFieldNames
, utv
, puk
@@ -566,11 +569,13 @@ mkDeleteCascade defs = do
]
mkUniqueKeys :: EntityDef -> Q Dec
-mkUniqueKeys def | entitySum def =
- return $ FunD (mkName "persistUniqueKeys") [Clause [WildP] (NormalB $ ListE []) []]
-mkUniqueKeys def = do
- c <- clause
- return $ FunD (mkName "persistUniqueKeys") [c]
+mkUniqueKeys def =
+ case entitySum def of
+ Just UseForeignKeys ->
+ return $ FunD (mkName "persistUniqueKeys") [Clause [WildP] (NormalB $ ListE []) []]
+ Nothing -> do
+ c <- clause
+ return $ FunD (mkName "persistUniqueKeys") [c]
where
clause = do
xs <- forM (entityFields def) $ \(FieldDef x _ _ _) -> do
@@ -682,6 +687,9 @@ instance Lift FieldDef where
lift (FieldDef a b c d) = [|FieldDef $(lift a) $(lift b) $(lift c) $(liftTs d)|]
instance Lift UniqueDef where
lift (UniqueDef a b c) = [|UniqueDef $(lift a) $(lift b) $(lift c)|]
+instance Lift SumImplementation where
+ lift (UseForeignKeys) = [|UseForeignKeys|]
+ lift (UseEntityFields) = [|UseEntityFields|]
pack' :: String -> Text
pack' = pack
@@ -30,31 +30,58 @@ import qualified Data.Text as T
import Init
#if WITH_MONGODB
-mkPersist persistSettings [persistLowerCase|
+mkPersist persistSettings [persistUpperCase|
#else
share [mkPersist sqlSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase|
#endif
Bicycle
- brand T.Text
+ make T.Text
+ deriving Show Eq
Car
make T.Text
model T.Text
+ deriving Show Eq
+Vehicle
bicycle BicycleId
car CarId
deriving Show Eq
++Transport
+ bicycle Bicycle
+ car Car
+ deriving Show Eq
|]
specs :: Spec
specs = describe "sum types" $ do
- it "works" $ asIO $ runConn $ do
+ it "sum models" $ asIO $ runConn $ do
#ifndef WITH_MONGODB
- _ <- runMigrationSilent sumTypeMigrate
+ _ <- liftIO $ runMigrationSilent sumTypeMigrate
#endif
car1 <- insert $ Car "Ford" "Thunderbird"
car2 <- insert $ Car "Kia" "Rio"
bike1 <- insert $ Bicycle "Shwinn"
+ return ()
+{-
+ vc1 <- insert $ TransportCarSum car1
+ vc2 <- insert $ TransportCarSum car2
+ vb1 <- insert $ TransportBicycleSum bike1
+
+ x1 <- get vc1
+ liftIO $ x1 @?= Just (TransportCarSum car1)
+
+ x2 <- get vc2
+ liftIO $ x2 @?= Just (TransportCarSum car2)
+
+ x3 <- get vb1
+ liftIO $ x3 @?= Just (TransportBicycleSum bike1)
+ -}
+
+ it "sum ids" $ asIO $ runConn $ do
+ car1 <- insert $ Car "Ford" "Thunderbird"
+ car2 <- insert $ Car "Kia" "Rio"
+ bike1 <- insert $ Bicycle "Shwinn"
+
vc1 <- insert $ VehicleCarSum car1
vc2 <- insert $ VehicleCarSum car2
vb1 <- insert $ VehicleBicycleSum bike1
@@ -5,6 +5,7 @@ module Database.Persist.EntityDef
, Attr
-- * Defs
, EntityDef (..)
+ , SumImplementation (..)
, FieldDef (..)
, FieldType (..)
, UniqueDef (..)
@@ -16,6 +17,9 @@ module Database.Persist.EntityDef
import Data.Text (Text, stripSuffix, pack)
import Data.Map (Map)
+data SumImplementation = UseForeignKeys | UseEntityFields
+ deriving (Show, Eq, Read, Ord)
+
data EntityDef = EntityDef
{ entityHaskell :: HaskellName
, entityDB :: DBName
@@ -25,7 +29,7 @@ data EntityDef = EntityDef
, entityUniques :: [UniqueDef]
, entityDerives :: [Text]
, entityExtra :: Map Text [ExtraLine]
- , entitySum :: Bool
+ , entitySum :: Maybe SumImplementation
}
deriving (Show, Eq, Read, Ord)
@@ -111,7 +111,9 @@ mkColumns allDefs val =
go fd p =
Column
(fieldDB fd)
- (nullable (fieldAttrs fd) || entitySum t)
+ (nullable (fieldAttrs fd) || case entitySum t of
+ Just UseForeignKeys -> True
+ Nothing -> False)
(maybe (sqlType p) SqlOther $ listToMaybe $ mapMaybe (T.stripPrefix "sqltype=") $ fieldAttrs fd)
(def $ fieldAttrs fd)
(maxLen $ fieldAttrs fd)
@@ -194,8 +194,11 @@ mkEntityDef ps name entattribs lines =
where
(isSum, name') =
case T.uncons name of
- Just ('+', x) -> (True, x)
- _ -> (False, name)
+ Just ('+', x) ->
+ case T.uncons x of
+ Just ('>', y) -> (Just UseEntityFields, y)
+ _ -> (Just UseForeignKeys, x)
+ _ -> (Nothing, name)
(attribs, extras) = splitExtras lines
idName [] = "id"
idName (t:ts) =

0 comments on commit 5d8e8eb

Please sign in to comment.