Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Fix bug with code generated for constructors that lack a lens field

  • Loading branch information...
commit b445d512952492051488a1eeaceaaec78cca724c 1 parent 111bc9d
@mgsloan mgsloan authored
View
45 src/Control/Lens/TH.hs
@@ -260,33 +260,36 @@ commonFieldDescs = toList . Prelude.foldr walk mempty where
Just (FieldDesc _ _ bds') -> at nm .~ Just (FieldDesc nm ty (bds `Set.union` bds')) $ m
Nothing -> at nm .~ Just d $ m
-errorClause :: Name -> Name -> Name -> ClauseQ
-errorClause lensName fieldName conName
- = clause [] (normalB (return (VarE 'error) `appE` litE (stringL err))) []
- where
- err = show lensName ++ ": no matching field "
- ++ show fieldName ++ " in constructor "
- ++ show conName
-
makeFieldLensBody :: Name -> Name -> [Con] -> Maybe Name -> Q Dec
makeFieldLensBody lensName fieldName cons maybeMethodName = case maybeMethodName of
Just methodName -> do
go <- newName "go"
- funD lensName [ clause [] (normalB (infixApp (varE methodName) (varE (mkName ".")) (varE go))) [funD go (map clauses cons)]]
+ let expr = infixApp (varE methodName) (varE (mkName ".")) (varE go)
+ funD lensName [ clause [] (normalB expr) [funD go (map clauses cons)] ]
Nothing -> funD lensName (map clauses cons)
where
- clauses (RecC conName fields) = case List.findIndex (\(n,_,_) -> n == fieldName) fields of
- Just i -> do
- names <- for fields $ \(n,_,_) -> newName (nameBase n)
- f <- newName "f"
- x <- newName "y"
- clause [varP f, conP conName $ map varP names] (normalB
- (appsE [ return (VarE 'fmap)
- , lamE [varP x] $ appsE $ conE conName : map varE (element i .~ x $ names)
- , varE f `appE` varE (names^.element i)
- ])) []
- Nothing -> errorClause lensName fieldName conName
- clauses con = errorClause lensName fieldName (con^.name)
+ clauses con = do
+ f <- newName "f"
+ let errorExp = clause [varP f, conP (con^.name) (replicate (lengthOf conFields con) wildP)]
+ ( normalB . appE (varE 'error) . litE . stringL
+ $ show lensName ++ ": no matching field "
+ ++ show fieldName ++ " in constructor "
+ ++ show (con^.name)
+ ) []
+ case con of
+ (RecC conName fields) ->
+ case List.findIndex (\(n,_,_) -> n == fieldName) fields of
+ Just i -> do
+ x <- newName "y"
+ names <- for fields $ \(n,_,_) -> newName (nameBase n)
+ let expr = appsE
+ [ return (VarE 'fmap)
+ , lamE [varP x] $ appsE $ conE conName : map varE (element i .~ x $ names)
+ , varE f `appE` varE (names^.element i)
+ ]
+ clause [varP f, conP conName $ map varP names] (normalB expr) []
+ Nothing -> errorExp
+ _ -> errorExp
-- TODO: When there are constructors with missing fields, turn that field into a _traversal_ not a lens.
-- TODO: When the supplied mapping function maps multiple different fields to the same name, try to unify them into a Traversal.
View
9 src/Language/Haskell/TH/Lens.hs
@@ -20,6 +20,7 @@ module Language.Haskell.TH.Lens
, SubstType(..)
, typeVars -- :: HasTypeVars t => Simple Traversal t Name
, substTypeVars -- :: HasTypeVars t => Map Name Name -> t -> t
+ , conFields
) where
import Control.Applicative
@@ -34,6 +35,7 @@ import Data.Monoid
import Data.Set as Set hiding (toList,map)
import Data.Set.Lens
import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
-- | Has a 'Name'
class HasName t where
@@ -111,3 +113,10 @@ instance SubstType t => SubstType [t] where
instance SubstType Pred where
substType m (ClassP n ts) = ClassP n (substType m ts)
substType m (EqualP l r) = substType m (EqualP l r)
+
+conFields :: Simple Traversal Con StrictType
+conFields f (NormalC n tys) = NormalC n <$> traverse f tys
+conFields f (RecC n tys) = RecC n <$> traverse sans_var tys
+ where sans_var (fn,s,t) = (\(s', t') -> (fn,s',t')) <$> f (s, t)
+conFields f (InfixC l n r) = InfixC <$> f l <*> pure n <*> f r
+conFields f (ForallC bds ctx c) = ForallC bds ctx <$> conFields f c
View
2  tests/templates.hs
@@ -20,7 +20,7 @@ makeLenses ''Quux
-- quartz :: Lens (Quux a b) (Quux a' b') Double Double
data Quark a = Qualified { _gaffer :: a }
- | Unqualified { _gaffer :: a, tape :: a }
+ | Unqualified { _gaffer :: a, _tape :: a }
makeLenses ''Quark
-- gaffer :: Simple Lens (Quark a) a
Please sign in to comment.
Something went wrong with that request. Please try again.