microlens-th 0.4.1.3 → 0.4.2
raw patch · 4 files changed
+620/−105 lines, 4 filesdep +microlens-thdep +th-abstractiondep +transformersdep ~basedep ~microlensPVP ok
version bump matches the API change (PVP)
Dependencies added: microlens-th, th-abstraction, transformers
Dependency ranges changed: base, microlens
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- microlens-th.cabal +13/−1
- src/Lens/Micro/TH.hs +119/−104
- test/templates.hs +483/−0
CHANGELOG.md view
@@ -1,3 +1,8 @@+# 0.4.2++* We now depend on `th-abstraction` (like `lens` itself).+* Associated types are now supported.+ # 0.4.1.3 * Bumped the upper bound of template-haskell again.
microlens-th.cabal view
@@ -1,5 +1,5 @@ name: microlens-th-version: 0.4.1.3+version: 0.4.2 synopsis: Automatic generation of record lenses for microlens description: This package lets you automatically generate lenses for data types; code was extracted from the lens package, and therefore generated lenses are fully compatible with ones generated by lens (and can be used both from lens and microlens).@@ -33,8 +33,10 @@ build-depends: base >=4.5 && <5 , microlens >=0.4.0 && <0.5 , containers >=0.4.0 && <0.6+ , transformers -- lens has >=2.4, but GHC 7.4 shipped with 2.7 , template-haskell >=2.7 && <2.14+ , th-abstraction >=0.2.1 && <0.3 if flag(inlining) cpp-options: -DINLINING@@ -46,3 +48,13 @@ hs-source-dirs: src default-language: Haskell2010++test-suite templates+ type: exitcode-stdio-1.0+ main-is: templates.hs+ ghc-options: -Wall -threaded+ hs-source-dirs: test++ build-depends: base, microlens, microlens-th++ default-language: Haskell2010
src/Lens/Micro/TH.hs view
@@ -2,7 +2,16 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} +#ifdef TRUSTWORTHY+# if MIN_VERSION_template_haskell(2,12,0)+{-# LANGUAGE Safe #-}+# else+{-# LANGUAGE Trustworthy #-}+# endif+#endif+ #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706) #endif@@ -57,6 +66,7 @@ import Control.Monad+import Control.Monad.Trans.State import Data.Char import Data.Data import Data.Either@@ -70,6 +80,7 @@ import Lens.Micro import Lens.Micro.Internal (phantom) import Language.Haskell.TH+import qualified Language.Haskell.TH.Datatype as D #if __GLASGOW_HASKELL__ < 710 import Control.Applicative@@ -162,13 +173,6 @@ -- Utilities --- This is like @rewrite@ from uniplate.-rewrite :: (Data a, Data b) => (a -> Maybe a) -> b -> b-rewrite f mbA = case cast mbA of- Nothing -> gmapT (rewrite f) mbA- Just a -> let a' = gmapT (rewrite f) a- in fromJust . cast $ fromMaybe a' (f a')- -- @fromSet@ wasn't always there, and we need compatibility with -- containers-0.4 to compile on GHC 7.4. fromSet :: (k -> v) -> Set.Set k -> Map.Map k v@@ -178,6 +182,17 @@ fromSet f x = Map.fromDistinctAscList [ (k,f k) | k <- Set.toAscList x ] #endif +-- like 'rewrite' from uniplate+rewrite :: (Data a, Data b) => (a -> Maybe a) -> b -> b+rewrite f mbA = case cast mbA of+ Nothing -> gmapT (rewrite f) mbA+ Just a -> let a' = gmapT (rewrite f) a+ in fromJust . cast $ fromMaybe a' (f a')++-- like 'children' from uniplate+children :: Data a => a -> [a]+children = catMaybes . gmapQ cast+ -- Control.Lens.TH {- |@@ -812,57 +827,35 @@ -- Compute the field optics for the type identified by the given type name. -- Lenses will be computed when possible, Traversals otherwise. makeFieldOptics :: LensRules -> Name -> DecsQ-makeFieldOptics rules tyName =- do info <- reify tyName- case info of- TyConI dec -> makeFieldOpticsForDec rules dec- _ -> fail "makeFieldOptics: Expected type constructor name"-+makeFieldOptics rules = (`evalStateT` Set.empty) . makeFieldOpticsForDatatype rules <=< D.reifyDatatype -makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ-makeFieldOpticsForDec rules dec = case dec of-#if MIN_VERSION_template_haskell(2,11,0)- DataD _ tyName vars _ cons _ ->- makeFieldOpticsForDec' rules tyName (mkS tyName vars) cons- NewtypeD _ tyName vars _ con _ ->- makeFieldOpticsForDec' rules tyName (mkS tyName vars) [con]- DataInstD _ tyName args _ cons _ ->- makeFieldOpticsForDec' rules tyName (tyName `conAppsT` args) cons- NewtypeInstD _ tyName args _ con _ ->- makeFieldOpticsForDec' rules tyName (tyName `conAppsT` args) [con]-#else- DataD _ tyName vars cons _ ->- makeFieldOpticsForDec' rules tyName (mkS tyName vars) cons- NewtypeD _ tyName vars con _ ->- makeFieldOpticsForDec' rules tyName (mkS tyName vars) [con]- DataInstD _ tyName args cons _ ->- makeFieldOpticsForDec' rules tyName (tyName `conAppsT` args) cons- NewtypeInstD _ tyName args con _ ->- makeFieldOpticsForDec' rules tyName (tyName `conAppsT` args) [con]-#endif- _ -> fail "makeFieldOptics: Expected data or newtype type-constructor"- where- mkS tyName vars = tyName `conAppsT` map VarT (vars ^.. typeVars)+type HasFieldClasses = StateT (Set Name) Q +addFieldClassName :: Name -> HasFieldClasses ()+addFieldClassName n = modify $ Set.insert n --- Compute the field optics for a deconstructed Dec+-- | Compute the field optics for a deconstructed datatype Dec -- When possible build an Iso otherwise build one optic per field.-makeFieldOpticsForDec' :: LensRules -> Name -> Type -> [Con] -> DecsQ-makeFieldOpticsForDec' rules tyName s cons =- do fieldCons <- traverse normalizeConstructor cons- let allFields = fieldCons ^.. folded._2.folded._1.folded- let defCons = over normFieldLabels (expandName allFields) fieldCons- allDefs = setOf (normFieldLabels . folded) defCons- perDef <- sequenceA (fromSet (buildScaffold rules s defCons) allDefs)+makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec]+makeFieldOpticsForDatatype rules info =+ do perDef <- liftState $ do+ fieldCons <- traverse normalizeConstructor cons+ let allFields = toListOf (folded . _2 . folded . _1 . folded) fieldCons+ let defCons = over normFieldLabels (expandName allFields) fieldCons+ allDefs = setOf (normFieldLabels . folded) defCons+ sequenceA (fromSet (buildScaffold rules s defCons) allDefs) let defs = Map.toList perDef case _classyLenses rules tyName of Just (className, methodName) -> makeClassyDriver rules className methodName s defs- Nothing -> do decss <- traverse (makeFieldOptic rules) defs+ Nothing -> do decss <- traverse (makeFieldOptic rules) defs return (concat decss) where+ tyName = D.datatypeName info+ s = D.datatypeType info+ cons = D.datatypeCons info -- Traverse the field labels of a normalized constructor normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b@@ -870,20 +863,43 @@ -- Map a (possibly missing) field's name to zero-to-many optic definitions expandName :: [Name] -> Maybe Name -> [DefName]- expandName allFields (Just n) = _fieldToDef rules tyName allFields n- expandName _ _ = []+ expandName allFields = concatMap (_fieldToDef rules tyName allFields) . maybeToList +normalizeConstructor ::+ D.ConstructorInfo ->+ Q (Name, [(Maybe Name, Type)]) -- ^ constructor name, field name, field type++normalizeConstructor con =+ return (D.constructorName con,+ zipWith checkForExistentials fieldNames (D.constructorFields con))+ where+ fieldNames =+ case D.constructorVariant con of+ D.RecordConstructor xs -> fmap Just xs+ D.NormalConstructor -> repeat Nothing+ D.InfixConstructor -> repeat Nothing++ -- Fields mentioning existentially quantified types are not+ -- elligible for TH generated optics.+ checkForExistentials _ fieldtype+ | any (\tv -> D.tvName tv `Set.member` used) unallowable+ = (Nothing, fieldtype)+ where+ used = setOf typeVars fieldtype+ unallowable = D.constructorVars con+ checkForExistentials fieldname fieldtype = (fieldname, fieldtype)+ makeClassyDriver :: LensRules -> Name -> Name -> Type {- ^ Outer 's' type -} -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->- DecsQ+ HasFieldClasses [Dec] makeClassyDriver rules className methodName s defs = sequenceA (cls ++ inst) where- cls | _generateClasses rules = [makeClassyClass className methodName s defs]+ cls | _generateClasses rules = [liftState $ makeClassyClass className methodName s defs] | otherwise = [] inst = [makeClassyInstance rules className methodName s defs]@@ -924,11 +940,11 @@ Name -> Type {- ^ Outer 's' type -} -> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->- DecQ+ HasFieldClasses Dec makeClassyInstance rules className methodName s defs = do methodss <- traverse (makeFieldOptic rules') defs - instanceD (cxt[]) (return instanceHead)+ liftState $ instanceD (cxt[]) (return instanceHead) $ valD (varP methodName) (normalB (varE 'id)) [] : map return (concat methodss) @@ -939,38 +955,9 @@ , _generateClasses = False } --- Normalized the Con type into a uniform positional representation,--- eliminating the variance between records, infix constructors, and normal--- constructors.--- --- For 'GadtC' and 'RecGadtC', the leftmost name is chosen.-normalizeConstructor ::- Con ->- Q (Name, [(Maybe Name, Type)]) -- constructor name, field name, field type--normalizeConstructor (RecC n xs) =- return (n, [ (Just fieldName, ty) | (fieldName,_,ty) <- xs])--normalizeConstructor (NormalC n xs) =- return (n, [ (Nothing, ty) | (_,ty) <- xs])--normalizeConstructor (InfixC (_,ty1) n (_,ty2)) =- return (n, [ (Nothing, ty1), (Nothing, ty2) ])--normalizeConstructor (ForallC _ _ con) =- do con' <- normalizeConstructor con- return (set (_2 . mapped . _1) Nothing con')--#if MIN_VERSION_template_haskell(2,11,0)-normalizeConstructor (GadtC ns xs _) =- return (head ns, [ (Nothing, ty) | (_,ty) <- xs])- -normalizeConstructor (RecGadtC ns xs _) =- return (head ns, [ (Just fieldName, ty) | (fieldName,_,ty) <- xs])-#endif- data OpticType = GetterType | LensType -- or IsoType + -- Compute the positional location of the fields involved in -- each constructor for a given optic definition as well as the -- type of clauses to generate and the type to annotate the declaration@@ -1043,10 +1030,10 @@ -- [(_,1,[0])] -> True -- _ -> False - data OpticStab = OpticStab Name Type Type Type Type | OpticSa Cxt Name Type Type + stabToType :: OpticStab -> Type stabToType (OpticStab c s t a b) = quantifyType [] (c `conAppsT` [s,t,a,b]) stabToType (OpticSa cx c s a ) = quantifyType cx (c `conAppsT` [s,a])@@ -1087,24 +1074,30 @@ fixedTypeVars = setOf typeVars fixedFields unfixedTypeVars = setOf typeVars s Set.\\ fixedTypeVars - -- Build the signature and definition for a single field optic. -- In the case of a singleton constructor irrefutable matches are -- used to enable the resulting lenses to be used on a bottom value. makeFieldOptic :: LensRules -> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) ->- DecsQ-makeFieldOptic rules (defName, (opticType, defType, cons)) =- do cls <- mkCls- sequenceA (cls ++ sig ++ def)+ HasFieldClasses [Dec]+makeFieldOptic rules (defName, (opticType, defType, cons)) = do+ locals <- get+ addName+ liftState $ do+ cls <- mkCls locals+ sequenceA (cls ++ sig ++ def) where- mkCls = case defName of- MethodName c n | _generateClasses rules ->- do classExists <- isJust <$> lookupTypeName (show c)- return (if classExists then [] else [makeFieldClass defType c n])- _ -> return []+ mkCls locals = case defName of+ MethodName c n | _generateClasses rules ->+ do classExists <- isJust <$> lookupTypeName (show c)+ return (if classExists || Set.member c locals then [] else [makeFieldClass defType c n])+ _ -> return [] + addName = case defName of+ MethodName c _ -> addFieldClassName c+ _ -> return ()+ sig = case defName of _ | not (_generateSigs rules) -> [] TopName n -> [sigD n (return (stabToType defType))]@@ -1133,11 +1126,33 @@ s = mkName "s" a = mkName "a" +-- | Build an instance for a field. If the field’s type contains any type+-- families, will produce an equality constraint to avoid a type family+-- application in the instance head. makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ-makeFieldInstance defType className =- instanceD (cxt [])- (return (className `conAppsT` [stabToS defType, stabToA defType]))+makeFieldInstance defType className decs =+ containsTypeFamilies a >>= pickInstanceDec+ where+ s = stabToS defType+ a = stabToA defType + containsTypeFamilies = go <=< D.resolveTypeSynonyms+ where+ go (ConT nm) = (\i -> case i of FamilyI{} -> True; _ -> False)+ <$> reify nm+ go ty = or <$> traverse go (children ty)++ pickInstanceDec hasFamilies+ | hasFamilies = do+ placeholder <- VarT <$> newName "a"+ mkInstanceDec+ [return (D.equalPred placeholder a)]+ [s, placeholder]+ | otherwise = mkInstanceDec [] [s, a]++ mkInstanceDec context headTys =+ instanceD (cxt context) (return (className `conAppsT` headTys)) decs+ ------------------------------------------------------------------------ -- Optic clause generators ------------------------------------------------------------------------@@ -1302,7 +1317,7 @@ -- Type Name -> Field Names -> Target Field Name -> Definition Names , _fieldToDef :: Name -> [Name] -> Name -> [DefName] -- Type Name -> (Class Name, Top Method)- , _classyLenses :: Name -> Maybe (Name,Name)+ , _classyLenses :: Name -> Maybe (Name, Name) } {- |@@ -1313,11 +1328,18 @@ | MethodName Name Name -- ^ 'makeFields'-style class name and method name deriving (Show, Eq, Ord) + ------------------------------------------------------------------------ -- Miscellaneous utility functions ------------------------------------------------------------------------ +liftState :: Monad m => m a -> StateT s m a+liftState act = StateT (\s -> liftM (flip (,) s) act) +-- Apply arguments to a type constructor.+conAppsT :: Name -> [Type] -> Type+conAppsT conName = foldl AppT (ConT conName)+ -- Template Haskell wants type variables declared in a forall, so -- we find all free type variables in a given type and declare them. quantifyType :: Cxt -> Type -> Type@@ -1333,7 +1355,6 @@ $ nub -- stable order $ toListOf typeVars t - ------------------------------------------------------------------------ -- Support for generating inline pragmas ------------------------------------------------------------------------@@ -1362,9 +1383,3 @@ inlinePragma _ = [] #endif---- Control.Lens.Internal.TH---- Apply arguments to a type constructor.-conAppsT :: Name -> [Type] -> Type-conAppsT conName = foldl AppT (ConT conName)
+ test/templates.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Main (templates)+-- Copyright : (C) 2012-14 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- This test suite validates that we are able to generate usable lenses with+-- template haskell.+--+-- The commented code summarizes what will be auto-generated below+-----------------------------------------------------------------------------+module Main where++import Lens.Micro+import Lens.Micro.TH++data Bar a b c = Bar { _baz :: (a, b) }+makeLenses ''Bar++-- should actually be Iso+checkBaz :: Lens (Bar a b c) (Bar a' b' c') (a, b) (a', b')+checkBaz = baz++data Quux a b = Quux { _quaffle :: Int, _quartz :: Double }+makeLenses ''Quux++checkQuaffle :: Lens (Quux a b) (Quux a' b') Int Int+checkQuaffle = quaffle++checkQuartz :: Lens (Quux a b) (Quux a' b') Double Double+checkQuartz = quartz++data Quark a = Qualified { _gaffer :: a }+ | Unqualified { _gaffer :: a, _tape :: a }+makeLenses ''Quark++checkGaffer :: Lens' (Quark a) a+checkGaffer = gaffer++checkTape :: Traversal' (Quark a) a+checkTape = tape++data Hadron a b = Science { _a1 :: a, _a2 :: a, _c :: b }+makeLenses ''Hadron++checkA1 :: Lens' (Hadron a b) a+checkA1 = a1++checkA2 :: Lens' (Hadron a b) a+checkA2 = a2++checkC :: Lens (Hadron a b) (Hadron a b') b b'+checkC = c++data Perambulation a b+ = Mountains { _terrain :: a, _altitude :: b }+ | Beaches { _terrain :: a, _dunes :: a }+makeLenses ''Perambulation++checkTerrain :: Lens' (Perambulation a b) a+checkTerrain = terrain++checkAltitude :: Traversal (Perambulation a b) (Perambulation a b') b b'+checkAltitude = altitude++checkDunes :: Traversal' (Perambulation a b) a+checkDunes = dunes++makeLensesFor [("_terrain", "allTerrain"), ("_dunes", "allTerrain")] ''Perambulation++checkAllTerrain :: Traversal (Perambulation a b) (Perambulation a' b) a a'+checkAllTerrain = allTerrain++data LensCrafted a = Still { _still :: a }+ | Works { _still :: a }+makeLenses ''LensCrafted++checkStill :: Lens (LensCrafted a) (LensCrafted b) a b+checkStill = still++data Task a = Task+ { taskOutput :: a -> IO ()+ , taskState :: a+ , taskStop :: IO ()+ }++makeLensesFor [("taskOutput", "outputLens"), ("taskState", "stateLens"), ("taskStop", "stopLens")] ''Task++checkOutputLens :: Lens' (Task a) (a -> IO ())+checkOutputLens = outputLens++checkStateLens :: Lens' (Task a) a+checkStateLens = stateLens++checkStopLens :: Lens' (Task a) (IO ())+checkStopLens = stopLens++data Mono a = Mono { _monoFoo :: a, _monoBar :: Int }+makeClassy ''Mono+-- class HasMono t where+-- mono :: Simple Lens t Mono+-- instance HasMono Mono where+-- mono = id++checkMono :: HasMono t a => Lens' t (Mono a)+checkMono = mono++checkMono' :: Lens' (Mono a) (Mono a)+checkMono' = mono++checkMonoFoo :: HasMono t a => Lens' t a+checkMonoFoo = monoFoo++checkMonoBar :: HasMono t a => Lens' t Int+checkMonoBar = monoBar++data Nucleosis = Nucleosis { _nuclear :: Mono Int }+makeClassy ''Nucleosis+-- class HasNucleosis t where+-- nucleosis :: Simple Lens t Nucleosis+-- instance HasNucleosis Nucleosis++checkNucleosis :: HasNucleosis t => Lens' t Nucleosis+checkNucleosis = nucleosis++checkNucleosis' :: Lens' Nucleosis Nucleosis+checkNucleosis' = nucleosis++checkNuclear :: HasNucleosis t => Lens' t (Mono Int)+checkNuclear = nuclear++instance HasMono Nucleosis Int where+ mono = nuclear++-- Dodek's example+data Foo = Foo { _fooX, _fooY :: Int }+makeClassy ''Foo++checkFoo :: HasFoo t => Lens' t Foo+checkFoo = foo++checkFoo' :: Lens' Foo Foo+checkFoo' = foo++checkFooX :: HasFoo t => Lens' t Int+checkFooX = fooX++checkFooY :: HasFoo t => Lens' t Int+checkFooY = fooY++data Dude a = Dude+ { dudeLevel :: Int+ , dudeAlias :: String+ , dudeLife :: ()+ , dudeThing :: a+ }+makeFields ''Dude++checkLevel :: HasLevel t a => Lens' t a+checkLevel = level++checkLevel' :: Lens' (Dude a) Int+checkLevel' = level++checkAlias :: HasAlias t a => Lens' t a+checkAlias = alias++checkAlias' :: Lens' (Dude a) String+checkAlias' = alias++checkLife :: HasLife t a => Lens' t a+checkLife = life++checkLife' :: Lens' (Dude a) ()+checkLife' = life++checkThing :: HasThing t a => Lens' t a+checkThing = thing++checkThing' :: Lens' (Dude a) a+checkThing' = thing++data Lebowski a = Lebowski+ { _lebowskiAlias :: String+ , _lebowskiLife :: Int+ , _lebowskiMansion :: String+ , _lebowskiThing :: Maybe a+ }+makeFields ''Lebowski++checkAlias2 :: Lens' (Lebowski a) String+checkAlias2 = alias++checkLife2 :: Lens' (Lebowski a) Int+checkLife2 = life++checkMansion :: HasMansion t a => Lens' t a+checkMansion = mansion++checkMansion' :: Lens' (Lebowski a) String+checkMansion' = mansion++checkThing2 :: Lens' (Lebowski a) (Maybe a)+checkThing2 = thing++type family Fam a+type instance Fam Int = String++data FamRec a = FamRec+ { _famRecThing :: Fam a+ , _famRecUniqueToFamRec :: Fam a+ }+makeFields ''FamRec++checkFamRecThing :: Lens' (FamRec a) (Fam a)+checkFamRecThing = thing++checkFamRecUniqueToFamRec :: Lens' (FamRec a) (Fam a)+checkFamRecUniqueToFamRec = uniqueToFamRec++checkFamRecView :: FamRec Int -> String+checkFamRecView = (^. thing)++data AbideConfiguration a = AbideConfiguration+ { _acLocation :: String+ , _acDuration :: Int+ , _acThing :: a+ }+makeLensesWith abbreviatedFields ''AbideConfiguration++checkLocation :: HasLocation t a => Lens' t a+checkLocation = location++checkLocation' :: Lens' (AbideConfiguration a) String+checkLocation' = location++checkDuration :: HasDuration t a => Lens' t a+checkDuration = duration++checkDuration' :: Lens' (AbideConfiguration a) Int+checkDuration' = duration++checkThing3 :: Lens' (AbideConfiguration a) a+checkThing3 = thing++dudeDrink :: String+dudeDrink = (Dude 9 "El Duderino" () "white russian") ^. thing+lebowskiCarpet :: Maybe String+lebowskiCarpet = (Lebowski "Mr. Lebowski" 0 "" (Just "carpet")) ^. thing+abideAnnoyance :: String+abideAnnoyance = (AbideConfiguration "the tree" 10 "the wind") ^. thing++{- we don't provide declareX+~~~~~~~~~~~~~++declareLenses [d|+ data Quark1 a = Qualified1 { gaffer1 :: a }+ | Unqualified1 { gaffer1 :: a, tape1 :: a }+ |]+-- data Quark1 a = Qualified1 a | Unqualified1 a a++checkGaffer1 :: Lens' (Quark1 a) a+checkGaffer1 = gaffer1++checkTape1 :: Traversal' (Quark1 a) a+checkTape1 = tape1++declarePrisms [d|+ data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }+ |]+-- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }++checkLit :: Int -> Exp+checkLit = Lit++checkVar :: String -> Exp+checkVar = Var++checkLambda :: String -> Exp -> Exp+checkLambda = Lambda++check_Lit :: Prism' Exp Int+check_Lit = _Lit++check_Var :: Prism' Exp String+check_Var = _Var++check_Lambda :: Prism' Exp (String, Exp)+check_Lambda = _Lambda+++declarePrisms [d|+ data Banana = Banana Int String+ |]+-- data Banana = Banana Int String++check_Banana :: Iso' Banana (Int, String)+check_Banana = _Banana++cavendish :: Banana+cavendish = _Banana # (4, "Cavendish")++data family Family a b c++#if __GLASGOW_HASKELL >= 706+declareLenses [d|+ data instance Family Int (a, b) a = FamilyInt { fm0 :: (b, a), fm1 :: Int }+ |]+-- data instance Family Int (a, b) a = FamilyInt a b+checkFm0 :: Lens (Family Int (a, b) a) (Family Int (a', b') a') (b, a) (b', a')+checkFm0 = fm0++checkFm1 :: Lens' (Family Int (a, b) a) Int+checkFm1 = fm1++#endif++class Class a where+ data Associated a+ method :: a -> Int++declareLenses [d|+ instance Class Int where+ data Associated Int = AssociatedInt { mochi :: Double }+ method = id+ |]++-- instance Class Int where+-- data Associated Int = AssociatedInt Double+-- method = id++checkMochi :: Iso' (Associated Int) Double+checkMochi = mochi++#if __GLASGOW_HASKELL__ >= 706+declareFields [d|+ data DeclaredFields f a+ = DeclaredField1 { declaredFieldsA0 :: f a , declaredFieldsB0 :: Int }+ | DeclaredField2 { declaredFieldsC0 :: String , declaredFieldsB0 :: Int }+ deriving (Show)+ |]++checkA0 :: HasA0 t a => Traversal' t a+checkA0 = a0++checkB0 :: HasB0 t a => Lens' t a+checkB0 = b0++checkC0 :: HasC0 t a => Traversal' t a+checkC0 = c0++checkA0' :: Traversal' (DeclaredFields f a) (f a)+checkA0' = a0++checkB0' :: Lens' (DeclaredFields f a) Int+checkB0' = b0++checkC0' :: Traversal' (DeclaredFields f a) String+checkC0' = c0+#endif++declareFields [d|+ data Aardvark = Aardvark { aardvarkAlbatross :: Int }+ data Baboon = Baboon { baboonAlbatross :: Int }+ |]++checkAardvark :: Lens' Aardvark Int+checkAardvark = albatross++checkBaboon :: Lens' Baboon Int+checkBaboon = albatross++-}++data Rank2Tests+ = C1 { _r2length :: forall a. [a] -> Int+ , _r2nub :: forall a. Eq a => [a] -> [a]+ }+ | C2 { _r2length :: forall a. [a] -> Int }++makeLenses ''Rank2Tests++checkR2length :: SimpleGetter Rank2Tests ([a] -> Int)+checkR2length = r2length++checkR2nub :: Eq a => SimpleFold Rank2Tests ([a] -> [a])+checkR2nub = r2nub++data PureNoFields = PureNoFieldsA | PureNoFieldsB { _pureNoFields :: Int }+makeLenses ''PureNoFields++{- we do not provide makePrisms+~~~~~~~~~~~~~~~~++data ReviewTest where ReviewTest :: a -> ReviewTest+makePrisms ''ReviewTest++-}++-- test FieldNamers++{- we do not provide namers+~~~~~~~~~~~~~~~~++data CheckUnderscoreNoPrefixNamer = CheckUnderscoreNoPrefixNamer+ { _fieldUnderscoreNoPrefix :: Int }+makeLensesWith (lensRules & lensField .~ underscoreNoPrefixNamer ) ''CheckUnderscoreNoPrefixNamer+checkUnderscoreNoPrefixNamer :: Lens' CheckUnderscoreNoPrefixNamer Int+checkUnderscoreNoPrefixNamer = fieldUnderscoreNoPrefix+++-- how can we test NOT generating a lens for some fields?++data CheckMappingNamer = CheckMappingNamer+ { fieldMappingNamer :: String }+makeLensesWith (lensRules & lensField .~ (mappingNamer (return . ("hogehoge_" ++)))) ''CheckMappingNamer+checkMappingNamer :: Lens' CheckMappingNamer String+checkMappingNamer = hogehoge_fieldMappingNamer++data CheckLookingupNamer = CheckLookingupNamer+ { fieldLookingupNamer :: Int }+makeLensesWith (lensRules & lensField .~ (lookingupNamer [("fieldLookingupNamer", "foobarFieldLookingupNamer")])) ''CheckLookingupNamer+checkLookingupNamer :: Lens' CheckLookingupNamer Int+checkLookingupNamer = foobarFieldLookingupNamer++data CheckUnderscoreNamer = CheckUnderscoreNamer+ { _hogeprefix_fieldCheckUnderscoreNamer :: Int }+makeLensesWith (defaultFieldRules & lensField .~ underscoreNamer) ''CheckUnderscoreNamer+checkUnderscoreNamer :: Lens' CheckUnderscoreNamer Int+checkUnderscoreNamer = fieldCheckUnderscoreNamer++data CheckCamelCaseNamer = CheckCamelCaseNamer+ { _checkCamelCaseNamerFieldCamelCaseNamer :: Int }+makeLensesWith (defaultFieldRules & lensField .~ camelCaseNamer) ''CheckCamelCaseNamer+checkCamelCaseNamer :: Lens' CheckCamelCaseNamer Int+checkCamelCaseNamer = fieldCamelCaseNamer++data CheckAbbreviatedNamer = CheckAbbreviatedNamer+ { _hogeprefixFieldAbbreviatedNamer :: Int }+makeLensesWith (defaultFieldRules & lensField .~ abbreviatedNamer ) ''CheckAbbreviatedNamer+checkAbbreviatedNamer :: Lens' CheckAbbreviatedNamer Int+checkAbbreviatedNamer = fieldAbbreviatedNamer++-}++-- test for associated types (#93)++data UserTable = UserTable+data OtherTable = OtherTable++class CRUDTable a where+ data TableRow a :: *++instance CRUDTable UserTable where+ data TableRow UserTable =+ UserRow {_username :: String, _email :: String} |+ UserRow2 {_username :: String, _email :: String}+ -- Other things here++instance CRUDTable OtherTable where+ data TableRow OtherTable =+ OtherRow {_foo :: Maybe Int, _bar :: Maybe Int}++makeLenses 'UserRow++checkUserName :: Lens' (TableRow UserTable) String+checkUserName = username++main :: IO ()+main = putStrLn "\ntest/templates.hs: ok"