Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: ekmett/lens
...
head fork: ekmett/lens
  • 4 commits
  • 2 files changed
  • 0 commit comments
  • 1 contributor
Showing with 16 additions and 32 deletions.
  1. +11 −10 src/Control/Lens/TH.hs
  2. +5 −22 tests/templates.hs
View
21 src/Control/Lens/TH.hs
@@ -830,33 +830,34 @@ mkFields (FieldRules prefix' raw' nice' clas') rs
hasClassAndInstance :: FieldRules -> Name -> Q [Dec]
hasClassAndInstance cfg src = do
- TyConI (DataD _ _ _ [RecC _ rs] _) <- reify src
+ c <- newName "c"
+ e <- newName "e"
+ TyConI (DataD _ _ vs [RecC _ rs] _) <- reify src
fmap concat . forM (mkFields cfg rs) $ \(Field field _ fullLensName className lensName) -> do
classHas <- classD
(return [])
className
[ PlainTV c, PlainTV e ]
[ FunDep [c] [e] ]
- [ sigD lensName (appsT (conT ''Lens') [varT c, varT e])]
-
- VarI _ (AppT _ fieldType) _ _ <- reify field
-
+ [ sigD lensName (conT ''Lens' `appsT` [varT c, varT e])]
+ fieldType <- do
+ VarI _ t _ _ <- reify field
+ case t of
+ AppT _ fieldType -> return fieldType
+ ForallT _ [] (AppT _ fieldType) -> return fieldType
+ _ -> error "Cannot get fieldType"
instanceHas <- instanceD
(return [])
- (conT className `appsT` [conT src, return fieldType])
+ (conT className `appsT` [conT src `appsT` map (varT.view name) vs, return fieldType])
[
#ifdef INLINING
inlinePragma lensName,
#endif
funD lensName [ clause [] (normalB (global fullLensName)) [] ]
]
-
classAlreadyExists <- isJust `fmap` lookupTypeName (show className)
return (if classAlreadyExists then [instanceHas] else [classHas, instanceHas])
- where c = mkName "c"
- e = mkName "e"
-
-- | Make fields with the specified 'FieldRules'.
makeFieldsWith :: FieldRules -> Name -> Q [Dec]
makeFieldsWith c n = liftA2 (++) (verboseLenses c n) (hasClassAndInstance c n)
View
27 tests/templates.hs
@@ -95,38 +95,21 @@ data Foo = Foo { _fooX, _fooY :: Int }
makeClassy ''Foo
-data Dude = Dude
+data Dude a = Dude
{ _dudeLevel :: Int
, _dudeAlias :: String
, _dudeLife :: ()
+ , _dudeThing :: a
}
-data Lebowski = Lebowski
+data Lebowski a = Lebowski
{ _lebowskiAlias :: String
, _lebowskiLife :: Int
, _lebowskiMansion :: String
+ , _lebowskiThing :: Maybe a
}
+
makeFields ''Dude
makeFields ''Lebowski
--- class HasLevel c e | c -> e where
--- level :: Lens' c e
--- instance HasLevel Dude Int where
--- level = _dudeLevelLens
--- class HasAlias c e | c -> e where
--- alias :: Lens' c e
--- instance HasAlias Dude String where
--- alias = _dudeAliasLens
--- class HasLife c e | c -> e where
--- life :: Lens' c e
--- instance HasLife Dude () where
--- life = _dudeLifeLens
--- instance HasAlias Lebowski String where
--- alias = _lebowskiAliasLens
--- instance HasLife Lebowski Int where
--- life = _lebowskiLifeLens
--- class HasMansion c e | c -> e where
--- mansion :: Lens' c e
--- instance HasMansion Lebowski String where
--- mansion = _lebowskiMansionLens
main :: IO ()
main = putStrLn "test/templates.hs: ok"

No commit comments for this range

Something went wrong with that request. Please try again.