new types for alternative sum type implementations

no actual implementation yet
yesodweb · Jul 29, 2012 · 5d8e8ebaeac562af45b24c778fd803491253f69f · 5d8e8eb
1 parent b899e92
commit 5d8e8ebaeac562af45b24c778fd803491253f69f
diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs
@@ -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
diff --git a/persistent-test/SumTypeTest.hs b/persistent-test/SumTypeTest.hs
@@ -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
diff --git a/persistent/Database/Persist/EntityDef.hs b/persistent/Database/Persist/EntityDef.hs
@@ -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)
 
diff --git a/persistent/Database/Persist/GenericSql/Internal.hs b/persistent/Database/Persist/GenericSql/Internal.hs
@@ -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)
diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs
@@ -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) =