Permalink
Browse files

Partial fieldLens for sum types

  • Loading branch information...
1 parent 44ee839 commit cb79b816489977bbc665d20f2b86b57438f0b70d @snoyberg snoyberg committed Feb 20, 2013
@@ -440,7 +440,7 @@ mkLensClauses t = do
(NormalB $ lens' `AppE` getId `AppE` setId)
[]
if entitySum t
- then return [idClause]
+ then return $ idClause : map (toSumClause lens' getVal dot keyName valName xName) (entityFields t)
else return $ idClause : map (toClause lens' getVal dot keyName valName xName) (entityFields t)
where
toClause lens' getVal dot keyName valName xName f = Clause
@@ -458,6 +458,27 @@ mkLensClauses t = do
(VarE valName)
[(fieldName, VarE xName)]
+ toSumClause lens' getVal dot keyName valName xName f = Clause
+ [ConP (mkName $ unpack $ unHaskellName (entityHaskell t) ++ upperFirst (unHaskellName $ fieldHaskell f)) []]
+ (NormalB $ lens' `AppE` getter `AppE` setter)
+ []
+ where
+ fieldName = mkName $ unpack $ recName (unHaskellName $ entityHaskell t) (unHaskellName $ fieldHaskell f)
+ getter = LamE
+ [ ConP 'Entity [WildP, VarP valName]
+ ] $ CaseE (VarE valName)
+ [ Match (ConP (sumConstrName 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.
+ , Match WildP (NormalB $ VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type")) []
+ ]
+ setter = LamE
+ [ ConP 'Entity [VarP keyName, WildP]
+ , VarP xName
+ ]
+ $ ConE 'Entity `AppE` VarE keyName `AppE` (ConE (sumConstrName t f) `AppE` VarE xName)
+
mkEntity :: MkPersistSettings -> EntityDef -> Q [Dec]
mkEntity mps t = do
t' <- lift t
@@ -1,5 +1,5 @@
name: persistent-template
-version: 1.1.2.3
+version: 1.1.2.4
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@@ -101,7 +101,7 @@ library
, vector
, unordered-containers
, monad-logger >= 0.2.3
- , hashable < 1.2
+ , hashable
-- actually just a mongoDB dependency
-- fixes build warning on current build server
, cereal

0 comments on commit cb79b81

Please sign in to comment.