diff --git a/benchmarks/plated.hs b/benchmarks/plated.hs deleted file mode 100644 --- a/benchmarks/plated.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -import Control.Applicative -import Control.Lens -import Control.DeepSeq -import Criterion.Main -import Data.Data -import Data.Data.Lens as Data -#ifdef BENCHMARK_UNIPLATE -import qualified Data.Generics.Uniplate.Direct as Uni -import Data.Generics.Uniplate.Direct ((|*)) -import qualified Data.Generics.Uniplate.DataOnly as UniDataOnly -#endif -import GHC.Generics -import GHC.Generics.Lens as Generic - -data Expr = Val !Int - | Var String - | Neg !Expr - | Add !Expr !Expr - | Sub !Expr !Expr - | Mul !Expr !Expr - | Div !Expr !Expr - deriving (Eq,Show,Data,Typeable,Generic) - -instance NFData Expr where - rnf (Neg a) = rnf a - rnf (Add a b) = rnf a `seq` rnf b - rnf (Sub a b) = rnf a `seq` rnf b - rnf (Mul a b) = rnf a `seq` rnf b - rnf (Div a b) = rnf a `seq` rnf b - rnf (Val i) = rnf i - rnf (Var s) = rnf s - -instance Plated Expr where - plate f (Neg a) = Neg <$> f a - plate f (Add a b) = Add <$> f a <*> f b - plate f (Sub a b) = Sub <$> f a <*> f b - plate f (Mul a b) = Mul <$> f a <*> f b - plate f (Div a b) = Div <$> f a <*> f b - plate _ t = pure t - {-# INLINE plate #-} - -#ifdef BENCHMARK_UNIPLATE -instance Uni.Uniplate Expr where - uniplate (Neg a) = Uni.plate Neg |* a - uniplate (Add a b) = Uni.plate Add |* a |* b - uniplate (Sub a b) = Uni.plate Sub |* a |* b - uniplate (Mul a b) = Uni.plate Mul |* a |* b - uniplate (Div a b) = Uni.plate Div |* a |* b - uniplate (Val i) = Uni.plate (Val i) - uniplate (Var s) = Uni.plate (Var s) - {-# INLINE uniplate #-} -#endif - -main :: IO () -main = defaultMain - [ bench "universe" $ nf (map universe) testsExpr - , bench "universeOf plate" $ nf (map (universeOf plate)) testsExpr - , bench "universeOf Generic.tinplate" $ nf (map (universeOf Generic.tinplate)) testsExpr - , bench "universeOf Data.tinplate" $ nf (map (universeOf Data.tinplate)) testsExpr - , bench "universeOf Data.template" $ nf (map (universeOf Data.template)) testsExpr - , bench "universeOf Data.uniplate" $ nf (map (universeOf Data.uniplate)) testsExpr - , bench "universeOf (cloneTraversal plate)" $ nf (map (universeOf (cloneTraversal plate))) testsExpr -#ifdef BENCHMARK_UNIPLATE - , bench "Direct.universe" $ nf (map Uni.universe) testsExpr - , bench "DataOnly.universe" $ nf (map UniDataOnly.universe) testsExpr -#endif - ] - -testsExpr :: [Expr] -testsExpr = [Val 3,Val 2,Val 6,Neg (Neg (Var "dus")),Mul (Div (Add (Val 4) (Var "kxm")) (Sub (Mul (Div (Var "") (Var "")) (Var "w")) (Var "ed"))) (Var "whpd"),Val 6,Val 4,Val 2,Var "a",Val 1,Div (Var "") (Val 0),Var "",Var "",Val (-3),Val 3,Sub (Var "") (Val 2),Neg (Var "dlp"),Div (Val 0) (Var "sd"),Val (-2),Val (-3),Var "g",Mul (Val 3) (Var "i"),Val 1,Var "ul",Div (Add (Var "") (Var "")) (Mul (Div (Val 0) (Neg (Val 0))) (Neg (Neg (Mul (Var "") (Val 0))))),Var "z",Sub (Neg (Add (Var "") (Val 0))) (Var ""),Neg (Sub (Mul (Val 0) (Val 2)) (Val 5)),Val 0,Val 0,Mul (Val (-4)) (Sub (Val 5) (Neg (Div (Div (Val 0) (Sub (Neg (Sub (Val (-3)) (Mul (Mul (Var "ap") (Val 3)) (Add (Add (Add (Var "owre") (Add (Add (Var "avj") (Val 3)) (Var "vhi"))) (Mul (Val 2) (Var "hak"))) (Val 2))))) (Var "nf"))) (Add (Sub (Val 5) (Sub (Var "pkjyh") (Val 2))) (Var "lsiu"))))),Var "u",Val 1,Neg (Add (Add (Var "") (Val 1)) (Sub (Add (Add (Val (-3)) (Mul (Val 1) (Var "pfe"))) (Var "yv")) (Mul (Var "") (Var "jfq")))),Val 2,Div (Div (Div (Div (Var "xrgykq") (Mul (Var "kyfu") (Val 2))) (Sub (Var "v") (Val 0))) (Sub (Val 6) (Val 2))) (Val 3),Var "",Var "",Add (Var "ob") (Sub (Mul (Neg (Val 2)) (Val 6)) (Add (Mul (Val 6) (Sub (Add (Var "wue") (Mul (Var "hgsuj") (Neg (Div (Var "hr") (Var "ozvsb"))))) (Sub (Var "j") (Div (Var "yeyhvq") (Val (-6)))))) (Var "b"))),Div (Add (Div (Div (Neg (Val 4)) (Var "")) (Var "yfx")) (Div (Sub (Var "") (Sub (Var "np") (Mul (Val 3) (Var "mxr")))) (Mul (Var "m") (Var "kkhbf")))) (Neg (Sub (Var "yie") (Val 1))),Neg (Var ""),Var "liuh",Var "pbqg",Var "",Neg (Div (Sub (Add (Val (-1)) (Var "onynvr")) (Neg (Var "tqjsay"))) (Add (Val 4) (Var "yorkb"))),Val 1,Add (Mul (Neg (Div (Val (-1)) (Var "u"))) (Sub (Var "") (Neg (Val 1)))) (Var "h"),Var "",Add (Mul (Sub (Var "em") (Val 0)) (Add (Val (-2)) (Val 1))) (Var ""),Add (Mul (Add (Div (Add (Val 0) (Mul (Mul (Var "e") (Add (Val 1) (Var ""))) (Neg (Neg (Div (Add (Div (Neg (Val 1)) (Div (Val (-1)) (Mul (Add (Div (Val (-1)) (Mul (Mul (Val 1) (Val 1)) (Mul (Var "t") (Val (-1))))) (Val 1)) (Val 1)))) (Add (Neg (Add (Val 0) (Var "k"))) (Mul (Neg (Div (Sub (Sub (Var "u") (Val 1)) (Val 1)) (Sub (Neg (Var "")) (Sub (Var "b") (Val (-1)))))) (Neg (Var ""))))) (Val 0)))))) (Val 0)) (Var "a")) (Var "")) (Val (-1)),Var "xijsnp",Div (Var "h") (Neg (Val 5)),Div (Var "dmzlh") (Add (Val 6) (Val (-2))),Neg (Add (Val 0) (Var "")),Add (Add (Add (Sub (Val 4) (Var "nfse")) (Var "o")) (Add (Val 2) (Div (Var "mtqdx") (Val (-3))))) (Val 3),Neg (Var "c"),Var "sr",Mul (Add (Sub (Neg (Val 1)) (Sub (Div (Add (Sub (Add (Sub (Sub (Var "gd") (Mul (Var "v") (Var "d"))) (Var "")) (Val 1)) (Add (Val 2) (Var ""))) (Var "kk")) (Div (Var "fw") (Add (Val 1) (Var "f")))) (Var ""))) (Val 2)) (Add (Neg (Div (Var "") (Val 0))) (Add (Var "") (Add (Var "s") (Add (Mul (Var "") (Val (-1))) (Val 1))))),Val 1,Var "",Sub (Var "vbnzahx") (Val (-5)),Var "nl",Val 0,Add (Mul (Neg (Mul (Var "") (Var "mvil"))) (Var "")) (Neg (Var "zxl")),Val (-3),Var "",Var "e",Add (Div (Sub (Val 0) (Add (Val 5) (Val 7))) (Mul (Var "") (Var "qz"))) (Val 4),Add (Val (-1)) (Neg (Var "lk")),Add (Add (Var "u") (Mul (Val 1) (Var "h"))) (Sub (Mul (Div (Val 1) (Div (Var "t") (Neg (Var "")))) (Var "")) (Mul (Val 1) (Neg (Div (Neg (Var "")) (Var ""))))),Val 0,Val 0,Val (-7),Mul (Var "") (Val 0),Mul (Add (Val (-6)) (Add (Val 2) (Sub (Div (Var "z") (Var "gbb")) (Var "vddnpsl")))) (Add (Add (Add (Var "") (Sub (Div (Val 3) (Neg (Div (Add (Var "cfvgz") (Add (Sub (Var "htd") (Sub (Var "mhbl") (Var "un"))) (Val 3))) (Val (-3))))) (Var ""))) (Val 5)) (Neg (Mul (Val 0) (Var "sufvvj")))),Sub (Div (Neg (Add (Add (Neg (Add (Var "") (Val 0))) (Var "")) (Sub (Val 0) (Val 0)))) (Val 0)) (Add (Neg (Div (Div (Add (Sub (Add (Add (Neg (Var "")) (Val 0)) (Val 0)) (Add (Neg (Add (Neg (Var "")) (Neg (Val 0)))) (Val 0))) (Div (Val 0) (Val 0))) (Val 0)) (Val 0))) (Var "")),Var "",Sub (Div (Val 0) (Div (Add (Val 1) (Neg (Div (Neg (Var "y")) (Val 0)))) (Var ""))) (Sub (Div (Var "t") (Var "")) (Neg (Var "s"))),Mul (Div (Sub (Var "") (Var "")) (Add (Val 0) (Sub (Div (Var "yr") (Neg (Var "o"))) (Val 1)))) (Var "u"),Var "odmn",Div (Var "uddqy") (Val 3),Var "",Sub (Val 2) (Neg (Val (-1))),Div (Mul (Var "sox") (Val (-3))) (Val (-3)),Var "qv",Var "xmbnts",Var "j",Mul (Val 6) (Mul (Var "fryndq") (Neg (Val 6))),Var "",Var "",Val (-1),Val 7,Add (Var "dg") (Val 1),Neg (Val 1),Val 0,Var "xnm",Sub (Div (Div (Var "miwi") (Var "mbh")) (Val 3)) (Val 3),Neg (Val (-4)),Var "ndubxoa",Var ""] diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,6 +1,6 @@ name: lens category: Data, Lenses -version: 2.6 +version: 2.6.1 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs --- a/src/Control/Lens/TH.hs +++ b/src/Control/Lens/TH.hs @@ -36,7 +36,7 @@ , lensClass , lensFlags , LensFlag(..) - , simpleLenses, partialLenses, handleSingletons, singletonIso, singletonRequired, createClass, createInstance, classRequired + , simpleLenses, partialLenses, handleSingletons, singletonIso, singletonRequired, createClass, createInstance, classRequired, singletonAndField ) where import Control.Applicative @@ -419,31 +419,29 @@ clauses = map buildClause conList plainClause ps d = clause ps d [] buildClause (con, fields) = do - y <- newName "y" let allFields :: [Name] allFields = con^..conNamedFields._1 conName = con^.name conWild = conP conName (replicate (length allFields) wildP) - case isTraversal of - True | List.null fields - -> plainClause [wildP, y `asP` conWild] (normalB . appE (varE 'pure) $ varE y) - False | length fields /= 1 - -> plainClause [wildP, conWild] . normalB . appE (varE 'error) . litE . stringL + if not isTraversal && length fields /= 1 + then plainClause [wildP, conWild] . normalB . appE (varE 'error) . litE . stringL $ show lensName ++ ": expected a single matching field in " ++ show conName ++ ", found " ++ show (length fields) - _ -> do + else do vars <- for allFields $ \field -> if field `List.elem` fields then fmap Left $ (,) <$> newName (nameBase field) <*> newName (nameBase field ++ "'") else Right <$> newName (nameBase field) - f <- newName "f" + f <- newName "_f" let cpats = map (varP . either fst id) vars -- Deconstruction cvals = map (varE . either snd id) vars -- Reconstruction fpats = map (varP . snd) $ lefts vars -- Lambda patterns fvals = map (appE (varE f) . varE . fst) $ lefts vars -- Functor applications + recon = appsE $ conE conName : cvals - expr = uInfixE (lamE fpats . appsE $ conE conName : cvals) (varE '(<$>)) - $ List.foldl1 (\l r -> uInfixE l (varE '(<*>)) r) fvals + expr = if List.null fields + then appE (varE 'pure) recon + else uInfixE (lamE fpats recon) (varE '(<$>)) $ List.foldl1 (\l r -> uInfixE l (varE '(<*>)) r) fvals plainClause [varP f, conP conName cpats] (normalB expr) makeFieldLenses :: LensRules @@ -482,11 +480,19 @@ . groupBy ((==) `on` fst) . sortBy (comparing fst) . concat <$> mapM (getLensFields $ view lensField cfg) cons + -- varMultiSet knows how many usages of the type variables there are. + let varMultiSet = List.concatMap (toListOf (conFields._2.typeVars)) cons + varSet = Set.fromList $ map (view name) tyArgs + -- if not (cfg^.partialLenses) && not (cfg^.BuildTraversals) bodies <- for lensFields $ \(lensName, fields) -> do - (tyArgs', cty) <- unifyTypes tyArgs $ map (view _3) fields - let bds = setOf typeVars cty - m <- freshMap $ Set.difference (setOf typeVars tyArgs') bds + let fieldTypes = map (view _3) fields + -- All of the polymorphic variables not involved in these fields + otherVars = varMultiSet List.\\ fieldTypes^..typeVars + -- New type variable binders, and the type to represent the selected fields + (tyArgs', cty) <- unifyTypes tyArgs fieldTypes + -- Map for the polymorphic variables that are only involved in these fields, to new names for them. + m <- freshMap . Set.difference varSet $ Set.fromList otherVars x <- newName "x" let aty | isJust maybeClassName = VarT x | otherwise = appArgs (ConT tyConName) tyArgs' @@ -511,6 +517,7 @@ isTraversal <- do let notSingular = filter ((/= 1) . length . snd) conList + showCon (c, fs) = pprint (view name c) ++ " { " ++ concat (intersperse ", " $ map pprint fs) ++ " }" case (cfg^.buildTraversals, cfg^.partialLenses) of (True, True) -> fail "Cannot makeLensesWith both of the flags buildTraversals and partialLenses." (False, True) -> return False @@ -523,8 +530,9 @@ , if length conList == 1 then "The following constructor failed this criterion for the " ++ pprint lensName ++ " lens:" else "The following constructors failed this criterion for the " ++ pprint lensName ++ " lens:" - ] ++ map (\(c, fs) -> pprint (view name c) ++ " { " ++ concat (intersperse ", " $ map pprint fs) ++ " }") conList + ] ++ map showCon conList + --TODO: consider detecting simpleLenses, and generating signatures involving "Simple"? let decl = SigD lensName . ForallT tvs' qs . apps (if isTraversal then ConT ''Traversal else ConT ''Lens) diff --git a/tests/doctests.hs b/tests/doctests.hs deleted file mode 100644 --- a/tests/doctests.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Main where - -import Test.DocTest -import System.Directory -import System.FilePath -import Control.Applicative -import Control.Monad -import Data.List - -main :: IO () -main = getSources >>= \sources -> doctest $ - "-isrc" - : "-idist/build/autogen" - : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" - : sources - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "src" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/tests/properties.hs b/tests/properties.hs deleted file mode 100644 --- a/tests/properties.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Main where - -import Control.Applicative -import Control.Monad -import Control.Lens -import Data.Functor.Identity -import System.Exit -import Test.QuickCheck -import Test.QuickCheck.All -import Test.QuickCheck.Function -import Data.Text.Strict.Lens - -setter_id :: Eq a => Simple Setter a b -> a -> Bool -setter_id l a = runIdentity (l Identity a) == a - -setter_composition :: Eq a => Simple Setter a b -> a -> Fun b b -> Fun b b -> Bool -setter_composition l a (Fun _ f) (Fun _ g) = mapOf l f (mapOf l g a) == mapOf l (f . g) a - -lens_set_view :: Eq a => Simple Lens a b -> a -> Bool -lens_set_view l a = set l (view l a) a == a - -lens_view_set :: Eq b => Simple Lens a b -> a -> b -> Bool -lens_view_set l a b = view l (set l b a) == b - -setter_set_set :: Eq a => Simple Setter a b -> a -> b -> b -> Bool -setter_set_set l a b c = set l c (set l b a) == set l c a - -iso_hither :: Eq a => Simple Iso a b -> a -> Bool -iso_hither l a = a ^.l.from l == a - -iso_yon :: Eq b => Simple Iso a b -> b -> Bool -iso_yon l b = b^.from l.l == b - -isSetter :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Function b) - => Simple Setter a b -> Property -isSetter l = setter_id l .&. setter_composition l .&. setter_set_set l - -isTraversal :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Function b) - => Simple Traversal a b -> Property -isTraversal l = isSetter l - -isLens :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Eq b, Function b) - => Simple Lens a b -> Property -isLens l = lens_set_view l .&. lens_view_set l .&. isTraversal l - -isIso :: (Arbitrary a, Arbitrary b, CoArbitrary a, CoArbitrary b, Show a, Show b, Eq a, Eq b, Function a, Function b) - => Simple Iso a b -> Property -isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l) - --- an illegal lens -bad :: Simple Lens (Int,Int) Int -bad f (a,b) = (,) b <$> f a - -badIso :: Simple Iso Int Bool -badIso = iso even fromEnum - --- Control.Lens.Type -prop_1 = isLens (_1 :: Simple Lens (Int,Double,()) Int) -prop_2 = isLens (_2 :: Simple Lens (Int,Bool) Bool) -prop_3 = isLens (_3 :: Simple Lens (Int,Bool,()) ()) -prop_4 = isLens (_4 :: Simple Lens (Int,Bool,(),Maybe Int) (Maybe Int)) -prop_5 = isLens (_5 :: Simple Lens ((),(),(),(),Int) Int) - -prop_2_2 = isLens (_2._2 :: Simple Lens (Int,(Int,Bool),Double) Bool) - -prop_illegal_lens = expectFailure $ isLens bad -prop_illegal_traversal = expectFailure $ isTraversal bad -prop_illegal_setter = expectFailure $ isSetter bad -prop_illegal_iso = expectFailure $ isIso badIso - --- Control.Lens.Setter -prop_mapped = isSetter (mapped :: Simple Setter [Int] Int) -prop_mapped_mapped = isSetter (mapped.mapped :: Simple Setter [Maybe Int] Int) - -prop_both = isTraversal (both :: Simple Traversal (Int,Int) Int) -prop_value (Fun _ k :: Fun Int Bool) = isTraversal (value k :: Simple Traversal (Int,Int) Int) -prop_traverseLeft = isTraversal (traverseLeft :: Simple Traversal (Either Int Bool) Int) -prop_traverseRight = isTraversal (traverseRight:: Simple Traversal (Either Int Bool) Bool) - --- Data.Text.Lens -prop_text s = s^.packed.from packed == s - -main :: IO () -main = do - b <- $quickCheckAll - unless b $ exitWith (ExitFailure 1) diff --git a/tests/templates.hs b/tests/templates.hs deleted file mode 100644 --- a/tests/templates.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-} --- | The commented code summarizes what will be auto-generated below -module Main where - -import Control.Lens --- import Test.QuickCheck (quickCheck) - --- newtype Foo a = Foo a --- makeIso ''Foo --- foo :: Iso a b (Foo a) (Foo b) - -data Bar a b c = Bar { _baz :: (a, b) } -makeLenses ''Bar --- baz :: Lens (Bar a b c) (Bar a' b' c) (a,b) (a',b') - -data Quux a b = Quux { _quaffle :: Int, _quartz :: Double } -makeLenses ''Quux --- quaffle :: Lens (Quux a b) (Quux a' b') Int Int --- quartz :: Lens (Quux a b) (Quux a' b') Double Double - -data Quark a = Qualified { _gaffer :: a } - | Unqualified { _gaffer :: a, _tape :: a } -makeLenses ''Quark --- gaffer :: Simple Lens (Quark a) a - -data LensCrafted a = Still { _still :: a } - | Works { _still :: a } -makeLenses ''LensCrafted --- still :: Lens (LensCrafted a) (LensCrafted b) a b - -data Mono = Mono { _monoFoo :: Int, _monoBar :: Int } -makeClassy ''Mono --- class HasMono t where --- mono :: Simple Lens t Mono --- instance HasMono Mono where --- mono = id --- monoFoo :: HasMono t => Simple Lens t Int --- monoBar :: HasMono t => Simple Lens t Int - -data Nucleosis = Nucleosis { _nuclear :: Mono } -makeClassy ''Nucleosis --- class HasNucleosis t where --- nucleosis :: Simple Lens t Nucleosis --- instance HasNucleosis Nucleosis --- nuclear :: HasNucleosis t => Simple Lens t Mono - -instance HasMono Nucleosis where - mono = nuclear - -main :: IO () -main = putStrLn "test/templates.hs: ok"