Skip to content
This repository
Browse code

Merge pull request #20 from mgsloan/THFix

Fix bug with code generated for constructors that lack a lens field
  • Loading branch information...
commit c3202a55d3e58f752658356d3a48345cb16ea1a9 2 parents 81216f5 + c36d377
Edward Kmett authored August 17, 2012
47  src/Control/Lens/TH.hs
@@ -260,33 +260,38 @@ commonFieldDescs = toList . Prelude.foldr walk mempty where
260 260
     Just (FieldDesc _ _ bds') -> at nm .~ Just (FieldDesc nm ty (bds `Set.union` bds')) $ m
261 261
     Nothing                   -> at nm .~ Just d                                        $ m
262 262
 
263  
-errorClause :: Name -> Name -> Name -> ClauseQ
264  
-errorClause lensName fieldName conName
265  
-  = clause [] (normalB (return (VarE 'error) `appE` litE (stringL err))) []
266  
-  where
267  
-    err = show lensName ++ ": no matching field "
268  
-       ++ show fieldName ++ " in constructor "
269  
-       ++ show conName
270  
-
271 263
 makeFieldLensBody :: Name -> Name -> [Con] -> Maybe Name -> Q Dec
272 264
 makeFieldLensBody lensName fieldName cons maybeMethodName = case maybeMethodName of
273 265
     Just methodName -> do
274 266
        go <- newName "go"
275  
-       funD lensName [ clause [] (normalB (infixApp (varE methodName) (varE (mkName ".")) (varE go))) [funD go (map clauses cons)]]
  267
+       let expr = infixApp (varE methodName) (varE (mkName ".")) (varE go)
  268
+       funD lensName [ clause [] (normalB expr) [funD go (map clauses cons)] ]
276 269
     Nothing -> funD lensName (map clauses cons)
277 270
   where
278  
-    clauses (RecC conName fields) = case List.findIndex (\(n,_,_) -> n == fieldName) fields of
279  
-      Just i -> do
280  
-        names <- for fields $ \(n,_,_) -> newName (nameBase n)
281  
-        f     <- newName "f"
282  
-        x     <- newName "y"
283  
-        clause [varP f, conP conName $ map varP names] (normalB
284  
-               (appsE [ return (VarE 'fmap)
285  
-                      , lamE [varP x] $ appsE $ conE conName : map varE (element i .~ x $ names)
286  
-                      , varE f `appE` varE (names^.element i)
287  
-                      ])) []
288  
-      Nothing -> errorClause lensName fieldName conName
289  
-    clauses con = errorClause lensName fieldName (con^.name)
  271
+    clauses con = do
  272
+      let errorPats
  273
+            = [wildP, conP (con^.name) (replicate (lengthOf conFields con) wildP)]
  274
+          errorBody
  275
+            = normalB . appE (varE 'error) . litE . stringL
  276
+            $ show lensName ++ ": no matching field "
  277
+           ++ show fieldName ++ " in constructor "
  278
+           ++ show (con^.name)
  279
+          errorClause = clause errorPats errorBody []
  280
+      case con of
  281
+        (RecC conName fields) ->
  282
+          case List.findIndex (\(n,_,_) -> n == fieldName) fields of
  283
+            Just i -> do
  284
+              f     <- newName "f"
  285
+              x     <- newName "y"
  286
+              names <- for fields $ \(n,_,_) -> newName (nameBase n)
  287
+              let expr = appsE 
  288
+                       [ return (VarE 'fmap)
  289
+                       , lamE [varP x] $ appsE $ conE conName : map varE (element i .~ x $ names)
  290
+                       , varE f `appE` varE (names^.element i)
  291
+                       ]
  292
+              clause [varP f, conP conName $ map varP names] (normalB expr) []
  293
+            Nothing -> errorClause
  294
+        _ -> errorClause
290 295
 
291 296
 -- TODO: When there are constructors with missing fields, turn that field into a _traversal_ not a lens.
292 297
 -- TODO: When the supplied mapping function maps multiple different fields to the same name, try to unify them into a Traversal.
9  src/Language/Haskell/TH/Lens.hs
@@ -20,6 +20,7 @@ module Language.Haskell.TH.Lens
20 20
   , SubstType(..)
21 21
   , typeVars      -- :: HasTypeVars t => Simple Traversal t Name
22 22
   , substTypeVars -- :: HasTypeVars t => Map Name Name -> t -> t
  23
+  , conFields
23 24
   ) where
24 25
 
25 26
 import Control.Applicative
@@ -34,6 +35,7 @@ import Data.Monoid
34 35
 import Data.Set as Set hiding (toList,map)
35 36
 import Data.Set.Lens
36 37
 import Language.Haskell.TH
  38
+import Language.Haskell.TH.Syntax
37 39
 
38 40
 -- | Has a 'Name'
39 41
 class HasName t where
@@ -111,3 +113,10 @@ instance SubstType t => SubstType [t] where
111 113
 instance SubstType Pred where
112 114
   substType m (ClassP n ts) = ClassP n (substType m ts)
113 115
   substType m (EqualP l r)  = substType m (EqualP l r)
  116
+
  117
+conFields :: Simple Traversal Con StrictType
  118
+conFields f (NormalC n tys)     = NormalC n <$> traverse f tys
  119
+conFields f (RecC n tys)        = RecC n <$> traverse sans_var tys
  120
+  where sans_var (fn,s,t) = (\(s', t') -> (fn,s',t')) <$> f (s, t)
  121
+conFields f (InfixC l n r)      = InfixC <$> f l <*> pure n <*> f r
  122
+conFields f (ForallC bds ctx c) = ForallC bds ctx <$> conFields f c
2  tests/templates.hs
@@ -20,7 +20,7 @@ makeLenses ''Quux
20 20
 -- quartz :: Lens (Quux a b) (Quux a' b') Double Double
21 21
 
22 22
 data Quark a = Qualified  { _gaffer :: a }
23  
-             | Unqualified { _gaffer :: a, tape :: a }
  23
+             | Unqualified { _gaffer :: a, _tape :: a }
24 24
 makeLenses ''Quark
25 25
 -- gaffer :: Simple Lens (Quark a) a
26 26
 

0 notes on commit c3202a5

Please sign in to comment.
Something went wrong with that request. Please try again.