Hello community, here is the log from the commit of package ghc-microlens-th for openSUSE:Factory checked in at 2018-05-30 12:10:42 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-microlens-th (Old) and /work/SRC/openSUSE:Factory/.ghc-microlens-th.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-microlens-th" Wed May 30 12:10:42 2018 rev:5 rq:607836 version:0.4.2.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-microlens-th/ghc-microlens-th.changes 2017-09-15 21:57:43.431380042 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-microlens-th.new/ghc-microlens-th.changes 2018-05-30 12:26:22.240202604 +0200 @@ -1,0 +2,9 @@ +Mon May 14 17:02:11 UTC 2018 - psim...@suse.com + +- Update microlens-th to version 0.4.2.1. + * Fixed [lens bug #799](https://github.com/ekmett/lens/issues/799) (`makeFields` instances violate coverage condition). + * We now depend on `th-abstraction` (like `lens` itself). + * Associated types are now supported. + * Bumped the upper bound of template-haskell again. + +------------------------------------------------------------------- Old: ---- microlens-th-0.4.1.1.tar.gz New: ---- microlens-th-0.4.2.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-microlens-th.spec ++++++ --- /var/tmp/diff_new_pack.ovsUK9/_old 2018-05-30 12:26:22.820182982 +0200 +++ /var/tmp/diff_new_pack.ovsUK9/_new 2018-05-30 12:26:22.824182847 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-microlens-th # -# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2018 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -17,8 +17,9 @@ %global pkg_name microlens-th +%bcond_with tests Name: ghc-%{pkg_name} -Version: 0.4.1.1 +Version: 0.4.2.1 Release: 0 Summary: Automatic generation of record lenses for microlens License: BSD-3-Clause @@ -30,6 +31,8 @@ BuildRequires: ghc-microlens-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-template-haskell-devel +BuildRequires: ghc-th-abstraction-devel +BuildRequires: ghc-transformers-devel %description This package lets you automatically generate lenses for data types; code was @@ -61,6 +64,9 @@ %install %ghc_lib_install +%check +%cabal_test + %post devel %ghc_pkg_recache @@ -68,7 +74,7 @@ %ghc_pkg_recache %files -f %{name}.files -%doc LICENSE +%license LICENSE %files devel -f %{name}-devel.files %doc CHANGELOG.md ++++++ microlens-th-0.4.1.1.tar.gz -> microlens-th-0.4.2.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/microlens-th-0.4.1.1/CHANGELOG.md new/microlens-th-0.4.2.1/CHANGELOG.md --- old/microlens-th-0.4.1.1/CHANGELOG.md 2017-01-05 20:05:54.000000000 +0100 +++ new/microlens-th-0.4.2.1/CHANGELOG.md 2018-03-24 14:20:06.000000000 +0100 @@ -1,3 +1,20 @@ +# 0.4.2.1 + +* Fixed [lens bug #799](https://github.com/ekmett/lens/issues/799) (`makeFields` instances violate coverage condition). + +# 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. + +# 0.4.1.2 + +Skipped (the tarball got corrupted). + # 0.4.1.1 * Bumped the upper bound of template-haskell, as requested by @ocharles. @@ -8,7 +25,7 @@ # 0.4.0.1 -* Ported a lens commit that (probably) makes lens generation deterministic. See [this issue](https://github.com/aelve/microlens/issues/83). +* Ported a lens commit that (probably) makes lens generation deterministic. See [issue #83](https://github.com/aelve/microlens/issues/83). # 0.4.0.0 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/microlens-th-0.4.1.1/microlens-th.cabal new/microlens-th-0.4.2.1/microlens-th.cabal --- old/microlens-th-0.4.1.1/microlens-th.cabal 2017-01-05 20:05:54.000000000 +0100 +++ new/microlens-th-0.4.2.1/microlens-th.cabal 2018-03-24 14:20:40.000000000 +0100 @@ -1,5 +1,5 @@ name: microlens-th -version: 0.4.1.1 +version: 0.4.2.1 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.13 + , template-haskell >=2.7 && <2.14 + , th-abstraction >=0.2.1 && <0.3 if flag(inlining) cpp-options: -DINLINING @@ -46,3 +48,14 @@ hs-source-dirs: src default-language: Haskell2010 + +test-suite templates + type: exitcode-stdio-1.0 + main-is: templates.hs + other-modules: T799 + ghc-options: -Wall -threaded + hs-source-dirs: test + + build-depends: base, microlens, microlens-th + + default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/microlens-th-0.4.1.1/src/Lens/Micro/TH.hs new/microlens-th-0.4.2.1/src/Lens/Micro/TH.hs --- old/microlens-th-0.4.1.1/src/Lens/Micro/TH.hs 2017-01-05 20:05:54.000000000 +0100 +++ new/microlens-th-0.4.2.1/src/Lens/Micro/TH.hs 2018-03-24 14:34:47.000000000 +0100 @@ -1,9 +1,16 @@ -{-# LANGUAGE -CPP, -TemplateHaskell, -RankNTypes, -FlexibleContexts - #-} +{-# LANGUAGE CPP #-} +{-# 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) @@ -59,6 +66,7 @@ import Control.Monad +import Control.Monad.Trans.State import Data.Char import Data.Data import Data.Either @@ -72,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 @@ -164,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 @@ -180,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 {- | @@ -372,7 +385,7 @@ y = ... @ -(There's a minor drawback, tho: you can't perform type-changing updates with these lenses.) +(There's a minor drawback, though: you can't perform type-changing updates with these lenses.) If you only want to make lenses for some fields, you can prefix them with underscores – the rest would be untouched. If no fields are prefixed with underscores, lenses would be created for all fields. @@ -601,7 +614,7 @@ A modification of 'lensRules' used by 'makeLensesFor' (the only difference is that a simple lookup function is used for 'lensField'). -} lensRulesFor - :: [(String, String)] -- ^ \[(fieldName, lensName)\] + :: [(String, String)] -- ^ @[(fieldName, lensName)]@ -> LensRules lensRulesFor fields = lensRules & lensField .~ mkNameLookup fields @@ -814,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 @@ -872,8 +863,31 @@ -- 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 -> @@ -881,11 +895,11 @@ 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] @@ -926,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) @@ -941,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 @@ -1045,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]) @@ -1089,23 +1074,29 @@ 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) -> [] @@ -1135,10 +1126,43 @@ 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 d _ -> isTypeFamily d; _ -> False) + <$> reify nm + go ty = or <$> traverse go (children ty) + +#if MIN_VERSION_template_haskell(2,11,0) + isTypeFamily OpenTypeFamilyD{} = True + isTypeFamily ClosedTypeFamilyD{} = True +#elif MIN_VERSION_template_haskell(2,9,0) + isTypeFamily (FamilyD TypeFam _ _ _) = True + isTypeFamily ClosedTypeFamilyD{} = True +#else + isTypeFamily (FamilyD TypeFam _ _ _) = True +#endif + isTypeFamily _ = False + + 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 @@ -1304,7 +1328,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) } {- | @@ -1315,10 +1339,17 @@ | 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. @@ -1335,7 +1366,6 @@ $ nub -- stable order $ toListOf typeVars t - ------------------------------------------------------------------------ -- Support for generating inline pragmas ------------------------------------------------------------------------ @@ -1364,9 +1394,3 @@ inlinePragma _ = [] #endif - --- Control.Lens.Internal.TH - --- Apply arguments to a type constructor. -conAppsT :: Name -> [Type] -> Type -conAppsT conName = foldl AppT (ConT conName) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/microlens-th-0.4.1.1/test/T799.hs new/microlens-th-0.4.2.1/test/T799.hs --- old/microlens-th-0.4.1.1/test/T799.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/microlens-th-0.4.2.1/test/T799.hs 2018-03-24 14:21:25.000000000 +0100 @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- | Test 'makeFields' on a field whose type has a data family. Unlike for +-- type families, for data families we do not generate type equality +-- constraints, as they are not needed to avoid the issue in #754. +-- +-- This tests that the fix for #799 is valid by putting this in a module in +-- which UndecidableInstances is not enabled. +module T799 where + +import Lens.Micro +import Lens.Micro.TH + +data family DF a +newtype instance DF Int = FooInt Int + +data Bar = Bar { _barFoo :: DF Int } +makeFields ''Bar + +checkBarFoo :: Lens' Bar (DF Int) +checkBarFoo = foo diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/microlens-th-0.4.1.1/test/templates.hs new/microlens-th-0.4.2.1/test/templates.hs --- old/microlens-th-0.4.1.1/test/templates.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/microlens-th-0.4.2.1/test/templates.hs 2018-03-24 14:21:41.000000000 +0100 @@ -0,0 +1,484 @@ +{-# 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 <ekm...@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 +import T799 () + +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"
