optics-th (empty) → 0.1
raw patch · 9 files changed
+3257/−0 lines, 9 filesdep +basedep +containersdep +mtl
Dependencies added: base, containers, mtl, optics-core, optics-th, template-haskell, th-abstraction, transformers
Files
- LICENSE +62/−0
- optics-th.cabal +58/−0
- src/Language/Haskell/TH/Optics/Internal.hs +133/−0
- src/Optics/TH.hs +849/−0
- src/Optics/TH/Internal/Product.hs +838/−0
- src/Optics/TH/Internal/Sum.hs +497/−0
- src/Optics/TH/Internal/Utils.hs +57/−0
- tests/Optics/TH/Tests.hs +739/−0
- tests/Optics/TH/Tests/T799.hs +24/−0
+ LICENSE view
@@ -0,0 +1,62 @@+Copyright (c) 2017-2019, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Well-Typed LLP nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++This software incorporates code from the lens package (available from+https://hackage.haskell.org/package/lens) under the following license:+++Copyright 2012-2016 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ optics-th.cabal view
@@ -0,0 +1,58 @@+name: optics-th+version: 0.1+license: BSD3+license-file: LICENSE+build-type: Simple+maintainer: optics@well-typed.com+author: Andrzej Rybczak+cabal-version: >=1.10+tested-with: ghc ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1+synopsis: Optics construction using TemplateHaskell+category: Data, Optics, Lenses+description:+ This package is part of the @optics@ package family. It provides machinery to+ construct optics using @TemplateHaskell@.+ .+ See the @template-haskell-optics@ package for optics to work with @template-haskell@ types.++bug-reports: https://github.com/well-typed/optics/issues+source-repository head+ type: git+ location: https://github.com/well-typed/optics.git+ subdir: optics-th++library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall++ build-depends: base >= 4.9 && <5+ , containers >= 0.5.7.1 && <0.7+ , mtl >= 2.2.2 && <2.3+ , optics-core >= 0.1 && <1+ , template-haskell >= 2.11 && <2.15+ , th-abstraction >= 0.2.1 && <0.4+ , transformers >= 0.5 && <0.6++ exposed-modules: Optics.TH++ -- internal modules+ Optics.TH.Internal.Utils+ Optics.TH.Internal.Product+ Optics.TH.Internal.Sum++ other-modules: Language.Haskell.TH.Optics.Internal++test-suite optics-th-tests+ default-language: Haskell2010+ hs-source-dirs: tests+ ghc-options: -Wall++ build-depends: base+ , optics-core+ , optics-th++ type: exitcode-stdio-1.0+ main-is: Optics/TH/Tests.hs++ other-modules: Optics.TH.Tests.T799
+ src/Language/Haskell/TH/Optics/Internal.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE LambdaCase #-}+module Language.Haskell.TH.Optics.Internal+ (+ -- * Traversals+ HasTypeVars(..)+ , typeVars -- :: HasTypeVars t => Traversal' t Name+ , substTypeVars -- :: HasTypeVars t => Map Name Name -> t -> t++ -- * Prisms+ , _FamilyI+ , _ClosedTypeFamilyD+ , _OpenTypeFamilyD+ , _ForallT+ ) where++import Data.Map as Map hiding (map, toList)+import Data.Maybe (fromMaybe)+import Data.Set as Set hiding (map, toList)+import Language.Haskell.TH++import Data.Set.Optics+import Optics.Core++-- | Has a 'Name'+class HasName t where+ -- | Extract (or modify) the 'Name' of something+ name :: Lens' t Name++instance HasName TyVarBndr where+ name = lensVL $ \f -> \case+ PlainTV n -> PlainTV <$> f n+ KindedTV n k -> (`KindedTV` k) <$> f n++-- | Provides for the extraction of free type variables, and alpha renaming.+class HasTypeVars t where+ -- | When performing substitution into this traversal you're not allowed to+ -- substitute in a name that is bound internally or you'll violate the+ -- 'Traversal' laws, when in doubt generate your names with 'newName'.+ typeVarsEx :: Set Name -> Traversal' t Name++instance HasTypeVars TyVarBndr where+ typeVarsEx s = traversalVL $ \f b ->+ if view name b `Set.member` s+ then pure b+ else traverseOf name f b++instance HasTypeVars Name where+ typeVarsEx s = traversalVL $ \f n ->+ if n `Set.member` s+ then pure n+ else f n++instance HasTypeVars Type where+ typeVarsEx s = traversalVL $ \f -> \case+ VarT n -> VarT <$> traverseOf (typeVarsEx s) f n+ AppT l r -> AppT <$> traverseOf (typeVarsEx s) f l+ <*> traverseOf (typeVarsEx s) f r+ SigT t k -> (`SigT` k) <$> traverseOf (typeVarsEx s) f t+ ForallT bs ctx ty -> let s' = s `Set.union` setOf typeVars bs+ in ForallT bs <$> traverseOf (typeVarsEx s') f ctx+ <*> traverseOf (typeVarsEx s') f ty+ InfixT t1 n t2 -> InfixT <$> traverseOf (typeVarsEx s) f t1+ <*> pure n+ <*> traverseOf (typeVarsEx s) f t2+ UInfixT t1 n t2 -> UInfixT <$> traverseOf (typeVarsEx s) f t1+ <*> pure n+ <*> traverseOf (typeVarsEx s) f t2+ ParensT t -> ParensT <$> traverseOf (typeVarsEx s) f t+ t -> pure t++instance HasTypeVars t => HasTypeVars [t] where+ typeVarsEx s = traversed % typeVarsEx s+++-- | Traverse /free/ type variables+typeVars :: HasTypeVars t => Traversal' t Name+typeVars = typeVarsEx mempty++-- | Substitute using a map of names in for /free/ type variables+substTypeVars :: HasTypeVars t => Map Name Name -> t -> t+substTypeVars m = over typeVars $ \n -> fromMaybe n (n `Map.lookup` m)++-- | Provides substitution for types+class SubstType t where+ -- | Perform substitution for types+ substType :: Map Name Type -> t -> t++instance SubstType Type where+ substType m t@(VarT n) = fromMaybe t (n `Map.lookup` m)+ substType m (ForallT bs ctx ty) = ForallT bs (substType m' ctx) (substType m' ty)+ where m' = foldrOf typeVars Map.delete m bs+ substType m (SigT t k) = SigT (substType m t) k+ substType m (AppT l r) = AppT (substType m l) (substType m r)+ substType m (InfixT t1 n t2) = InfixT (substType m t1) n (substType m t2)+ substType m (UInfixT t1 n t2) = UInfixT (substType m t1) n (substType m t2)+ substType m (ParensT t) = ParensT (substType m t)+ substType _ t = t++instance SubstType t => SubstType [t] where+ substType = map . substType+++_FamilyI :: Prism' Info (Dec, [InstanceDec])+_FamilyI+ = prism' reviewer remitter+ where+ reviewer (x, y) = FamilyI x y+ remitter (FamilyI x y) = Just (x, y)+ remitter _ = Nothing++_ClosedTypeFamilyD :: Prism' Dec (TypeFamilyHead, [TySynEqn])+_ClosedTypeFamilyD+ = prism' reviewer remitter+ where+ reviewer (x, y) = ClosedTypeFamilyD x y+ remitter (ClosedTypeFamilyD x y) = Just (x, y)+ remitter _ = Nothing++_OpenTypeFamilyD :: Prism' Dec TypeFamilyHead+_OpenTypeFamilyD+ = prism' reviewer remitter+ where+ reviewer = OpenTypeFamilyD+ remitter (OpenTypeFamilyD x) = Just x+ remitter _ = Nothing++_ForallT :: Prism' Type ([TyVarBndr], Cxt, Type)+_ForallT+ = prism' reviewer remitter+ where+ reviewer (x, y, z) = ForallT x y z+ remitter (ForallT x y z) = Just (x, y, z)+ remitter _ = Nothing
+ src/Optics/TH.hs view
@@ -0,0 +1,849 @@+module Optics.TH+ (+ -- * Generation of field optics+ -- ** Labels+ makeFieldLabels+ , makeFieldLabelsFor+ , makeFieldLabelsWith+ , declareFieldLabels+ , declareFieldLabelsFor+ , declareFieldLabelsWith+ , fieldLabelsRules+ , fieldLabelsRulesFor+ -- ** Functions+ , makeLenses+ , makeLensesFor+ , makeLensesWith+ , declareLenses+ , declareLensesFor+ , declareLensesWith+ , lensRules+ , lensRulesFor+ -- ** Single class per data type+ , makeClassy+ , makeClassy_+ , makeClassyFor+ , declareClassy+ , declareClassyFor+ , classyRules+ , classyRules_+ , classyRulesFor+ -- ** Multiple classes per data type+ , makeFields+ , makeFieldsNoPrefix+ , declareFields+ , defaultFieldRules+ -- * Generation of constructor optics+ -- ** Labels+ , makePrismLabels+ -- ** Functions+ , makePrisms+ , declarePrisms+ -- ** Single class per data type+ , makeClassyPrisms+ -- * Generation rules for field optics+ , LensRules+ , simpleLenses+ , generateSignatures+ , generateUpdateableOptics+ , generateLazyPatterns+ , createClass+ , lensField+ , lensClass+ -- * Common rules+ , abbreviatedFieldLabels+ , underscoreFields+ , camelCaseFields+ , classUnderscoreNoPrefixFields+ , abbreviatedFields+ -- * Field namers+ , FieldNamer+ , ClassyNamer+ , DefName(..)+ , underscoreNoPrefixNamer+ , lookingupNamer+ , mappingNamer+ , underscoreNamer+ , camelCaseNamer+ , classUnderscoreNoPrefixNamer+ , abbreviatedNamer+ ) where++import Control.Monad.Trans.Class+import Control.Monad.Trans.State+import Control.Monad.Trans.Writer+import Data.Char (toLower, toUpper, isUpper)+import Data.List as List+import Data.Maybe (maybeToList)+import Data.Monoid+import Data.Set (Set)+import Language.Haskell.TH.Syntax hiding (lift)+import Language.Haskell.TH+import qualified Data.Set as Set++import Optics.Core hiding (cons)+import Optics.TH.Internal.Product+import Optics.TH.Internal.Sum++----------------------------------------+-- Labels++-- | Build field optics as instances of 'LabelOptic' class for use as overloaded+-- labels.+--+-- /e.g./+--+-- @+-- data Animal+-- = Cat { animalAge :: Int+-- , animalName :: String+-- }+-- | Dog { animalAge :: Int+-- , animalAbsurd :: forall a b. a -> b+-- }+-- makeFieldLabels ''Animal+-- @+--+-- will create+--+-- @+-- instance+-- (a ~ Int, b ~ Int+-- ) => LabelOptic "age" A_Lens Animal Animal a b where+-- labelOptic = lensVL $ \\f s -> case s of+-- Cat x1 x2 -> fmap (\\y -> Cat y x2) (f x1)+-- Dog x1 x2 -> fmap (\\y -> Dog y x2) (f x1)+--+-- instance+-- (a ~ String, b ~ String+-- ) => LabelOptic "name" An_AffineTraversal Animal Animal a b where+-- labelOptic = atraversalVL $ \\point f s -> case s of+-- Cat x1 x2 -> fmap (\\y -> Cat x1 y) (f x2)+-- Dog x1 x2 -> point (Dog x1 x2)+-- @+--+-- which can be used as @#age@ and @#name@ with language extension+-- OverloadedLabels.+--+-- /Note:/ if you wonder about the form of instances or why there is no label for+-- @animalAbsurd@, check documentation for 'LabelOptic'.+--+-- @+-- 'makeFieldOptics' = 'makeFieldLabelsWith' 'fieldLabelsRules'+-- @+makeFieldLabels :: Name -> DecsQ+makeFieldLabels = makeFieldLabelsWith fieldLabelsRules++-- | Derive field optics as labels, specifying explicit pairings of @(fieldName,+-- labelName)@.+--+-- If you map multiple fields to the same label and it is present in the same+-- constructor, 'Traversal' (or 'Fold' for a read only version) will be+-- generated.+--+-- /e.g./+--+-- @+-- 'makeFieldLabelsFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo+-- 'makeFieldLabelsFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar+-- @+makeFieldLabelsFor :: [(String, String)] -> Name -> DecsQ+makeFieldLabelsFor fields = makeFieldLabelsWith (fieldLabelsRulesFor fields)++-- | Make field optics as labels for all records in the given declaration+-- quote. All record syntax in the input will be stripped off.+--+-- /e.g./+--+-- @+-- declareLenses [d|+-- data Dog = Dog { name :: String, age :: Int }+-- deriving Show+-- |]+-- @+--+-- will create+--+-- @+-- data Dog = Dog String Int+-- deriving Show+-- instance LabelOptic "name" A_Lens Dog Dog ...+-- instance LabelOptic "age" A_Lens Dog Dog ...+-- @+declareFieldLabels :: DecsQ -> DecsQ+declareFieldLabels+ = declareFieldLabelsWith+ $ fieldLabelsRules+ & lensField .~ \_ _ n -> [TopName n]++-- | Similar to 'makeFieldLabelsFor', but takes a declaration quote.+declareFieldLabelsFor :: [(String, String)] -> DecsQ -> DecsQ+declareFieldLabelsFor fields+ = declareFieldLabelsWith+ $ fieldLabelsRulesFor fields+ & lensField .~ \_ _ n -> [TopName n]++-- Similar to 'makeFieldLabelsWith', but takes a declaration quote.+declareFieldLabelsWith :: LensRules -> DecsQ -> DecsQ+declareFieldLabelsWith rules = declareWith $ \dec -> do+ emit =<< liftDeclare (makeFieldLabelsForDec rules dec)+ return $ stripFields dec++-- | Rules for generation of 'LabelOptic' intances for use with+-- OverloadedLabels. Same as 'lensRules', but uses 'camelCaseNamer'.+--+-- /Note:/ if you don't want to prefix field names with the full name of the+-- data type, you can use 'abbreviatedNamer' instead.+fieldLabelsRules :: LensRules+fieldLabelsRules = LensRules+ { _simpleLenses = False+ , _generateSigs = True+ , _generateClasses = False+ , _allowIsos = True+ , _allowUpdates = True+ , _lazyPatterns = False+ , _classyLenses = const Nothing+ , _fieldToDef = camelCaseNamer+ }++-- | Construct a 'LensRules' value for generating 'LabelOptic' instances using+-- the given map from field names to definition names.+fieldLabelsRulesFor+ :: [(String, String)] {- ^ [(Field name, Label name)] -}+ -> LensRules+fieldLabelsRulesFor fields = fieldLabelsRules & lensField .~ lookingupNamer fields++----------------------------------------+-- Lenses++-- | Build field optics as top level functions with a sensible default+-- configuration.+--+-- /e.g./+--+-- @+-- data Animal+-- = Cat { _age :: 'Int'+-- , _name :: 'String'+-- }+-- | Dog { _age :: 'Int'+-- , _absurd :: forall a b. a -> b+-- }+-- 'makeLenses' ''Animal+-- @+--+-- will create+--+-- @+-- absurd :: forall a b. AffineFold Animal (a -> b)+-- absurd = afolding $ \\s -> case s of+-- Cat _ _ -> Nothing+-- Dog _ x -> Just x+--+-- age :: Lens' Animal Int+-- age = lensVL $ \\f s -> case s of+-- Cat x1 x2 -> fmap (\\y -> Cat y x2) (f x1)+-- Dog x1 x2 -> fmap (\\y -> Dog y x2) (f x1)+--+-- name :: AffineTraversal' Animal String+-- name = atraversalVL $ \\point f s -> case s of+-- Cat x1 x2 -> fmap (\\y -> Cat x1 y) (f x2)+-- Dog x1 x2 -> point (Dog x1 x2)+-- @+--+-- @+-- 'makeLenses' = 'makeLensesWith' 'lensRules'+-- @+makeLenses :: Name -> DecsQ+makeLenses = makeFieldOptics lensRules++-- | Derive field optics, specifying explicit pairings of @(fieldName,+-- opticName)@.+--+-- If you map multiple fields to the same optic and it is present in the same+-- constructor, 'Traversal' (or 'Fold' for a read only version) will be+-- generated.+--+-- /e.g./+--+-- @+-- 'makeLensesFor' [(\"_foo\", \"fooLens\"), (\"baz\", \"lbaz\")] ''Foo+-- 'makeLensesFor' [(\"_barX\", \"bar\"), (\"_barY\", \"bar\")] ''Bar+-- @+makeLensesFor :: [(String, String)] -> Name -> DecsQ+makeLensesFor fields = makeFieldOptics (lensRulesFor fields)++-- | Build field optics with a custom configuration.+makeLensesWith :: LensRules -> Name -> DecsQ+makeLensesWith = makeFieldOptics++-- | Make field optics for all records in the given declaration quote. All+-- record syntax in the input will be stripped off.+--+-- /e.g./+--+-- @+-- declareLenses [d|+-- data Foo = Foo { fooX, fooY :: 'Int' }+-- deriving 'Show'+-- |]+-- @+--+-- will create+--+-- @+-- data Foo = Foo 'Int' 'Int' deriving 'Show'+-- fooX, fooY :: 'Lens'' Foo Int+-- @+declareLenses :: DecsQ -> DecsQ+declareLenses+ = declareLensesWith+ $ lensRules+ & lensField .~ \_ _ n -> [TopName n]++-- | Similar to 'makeLensesFor', but takes a declaration quote.+declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ+declareLensesFor fields+ = declareLensesWith+ $ lensRulesFor fields+ & lensField .~ \_ _ n -> [TopName n]++-- | 'declareLenses' with custom 'LensRules'.+declareLensesWith :: LensRules -> DecsQ -> DecsQ+declareLensesWith rules = declareWith $ \dec -> do+ emit =<< lift (makeFieldOpticsForDec' rules dec)+ return $ stripFields dec++-- | Rules for making read-write field optics as top-level functions. It uses+-- 'underscoreNoPrefixNamer'.+lensRules :: LensRules+lensRules = LensRules+ { _simpleLenses = False+ , _generateSigs = True+ , _generateClasses = False+ , _allowIsos = True+ , _allowUpdates = True+ , _lazyPatterns = False+ , _classyLenses = const Nothing+ , _fieldToDef = underscoreNoPrefixNamer+ }++-- | Construct a 'LensRules' value for generating top-level functions using the+-- given map from field names to definition names.+lensRulesFor+ :: [(String, String)] {- ^ [(Field name, Optic name)] -}+ -> LensRules+lensRulesFor fields = lensRules & lensField .~ lookingupNamer fields++----------------------------------------+-- Classy++-- | Make lenses and traversals for a type, and create a class when the type has+-- no arguments.+--+-- /e.g./+--+-- @+-- data Foo = Foo { _fooX, _fooY :: 'Int' }+-- 'makeClassy' ''Foo+-- @+--+-- will create+--+-- @+-- class HasFoo c where+-- foo :: Lens' c Foo+-- fooX :: Lens' c Int+-- fooY :: Lens' c Int+-- fooX = foo % fooX+-- fooY = foo % fooY+--+-- instance HasFoo Foo where+-- foo = lensVL id+-- fooX = lensVL $ \\f s -> case s of+-- Foo x1 x2 -> fmap (\\y -> Foo y x2) (f x1)+-- fooY = lensVL $ \\f s -> case s of+-- Foo x1 x2 -> fmap (\\y -> Foo x1 y) (f x2)+-- @+--+-- @+-- 'makeClassy' = 'makeLensesWith' 'classyRules'+-- @+makeClassy :: Name -> DecsQ+makeClassy = makeFieldOptics classyRules++-- | Make lenses and traversals for a type, and create a class when the type has+-- no arguments. Works the same as 'makeClassy' except that (a) it expects that+-- record field names do not begin with an underscore, (b) all record fields are+-- made into lenses, and (c) the resulting lens is prefixed with an underscore.+makeClassy_ :: Name -> DecsQ+makeClassy_ = makeFieldOptics classyRules_++-- | Derive lenses and traversals, using a named wrapper class, and+-- specifying explicit pairings of @(fieldName, traversalName)@.+--+-- Example usage:+--+-- @+-- 'makeClassyFor' \"HasFoo\" \"foo\" [(\"_foo\", \"fooLens\"), (\"bar\", \"lbar\")] ''Foo+-- @+makeClassyFor :: String -> String -> [(String, String)] -> Name -> DecsQ+makeClassyFor clsName funName fields = makeFieldOptics $+ classyRulesFor (const (Just (clsName, funName))) fields++-- | For each record in the declaration quote, make lenses and traversals for+-- it, and create a class when the type has no arguments. All record syntax+-- in the input will be stripped off.+--+-- /e.g./+--+-- @+-- declareClassy [d|+-- data Foo = Foo { fooX, fooY :: 'Int' }+-- deriving 'Show'+-- |]+-- @+--+-- will create+--+-- @+-- data Foo = Foo 'Int' 'Int' deriving 'Show'+-- class HasFoo t where+-- foo :: 'Lens'' t Foo+-- instance HasFoo Foo where foo = 'id'+-- fooX, fooY :: HasFoo t => 'Lens'' t 'Int'+-- @+declareClassy :: DecsQ -> DecsQ+declareClassy+ = declareLensesWith+ $ classyRules+ & lensField .~ \_ _ n -> [TopName n]++-- | Similar to 'makeClassyFor', but takes a declaration quote.+declareClassyFor ::+ [(String, (String, String))] -> [(String, String)] -> DecsQ -> DecsQ+declareClassyFor classes fields+ = declareLensesWith+ $ classyRulesFor (`Prelude.lookup`classes) fields+ & lensField .~ \_ _ n -> [TopName n]++-- | Rules for making lenses and traversals that precompose another 'Lens'.+classyRules :: LensRules+classyRules = LensRules+ { _simpleLenses = True+ , _generateSigs = True+ , _generateClasses = True+ , _allowIsos = False -- generating Isos would hinder "subtyping"+ , _allowUpdates = True+ , _lazyPatterns = False+ , _classyLenses = \n ->+ case nameBase n of+ x:xs -> Just (mkName ("Has" ++ x:xs), mkName (toLower x:xs))+ [] -> Nothing+ , _fieldToDef = underscoreNoPrefixNamer+ }++-- | A 'LensRules' used by 'makeClassy_'.+classyRules_ :: LensRules+classyRules_+ = classyRules & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))]++-- | Rules for making lenses and traversals that precompose another 'Lens' using+-- a custom function for naming the class, main class method, and a mapping from+-- field names to definition names.+classyRulesFor+ :: (String -> Maybe (String, String)) {- ^ Type Name -> Maybe (Class Name, Method Name) -} ->+ [(String, String)] {- ^ [(Field Name, Method Name)] -} ->+ LensRules+classyRulesFor classFun fields = classyRules+ & lensClass .~ (over (mapped % each) mkName . classFun . nameBase)+ & lensField .~ lookingupNamer fields++----------------------------------------+-- Fields++-- | Generate overloaded field accessors.+--+-- /e.g/+--+-- @+-- data Foo a = Foo { _fooX :: 'Int', _fooY :: a }+-- newtype Bar = Bar { _barX :: 'Char' }+-- makeFields ''Foo+-- makeFields ''Bar+-- @+--+-- will create+--+-- @+-- class HasX s a | s -> a where+-- x :: Lens' s a+--+-- instance HasX (Foo a) Int where+-- x = lensVL $ \\f s -> case s of+-- Foo x1 x2 -> fmap (\\y -> Foo y x2) (f x1)+--+-- class HasY s a | s -> a where+-- y :: Lens' s a+--+-- instance HasY (Foo a) a where+-- y = lensVL $ \\f s -> case s of+-- Foo x1 x2 -> fmap (\\y -> Foo x1 y) (f x2)+--+-- instance HasX Bar Char where+-- x = lensVL $ \\f s -> case s of+-- Bar x1 -> fmap (\\y -> Bar y) (f x1)+-- @+--+-- For details, see 'camelCaseFields'.+--+-- @+-- makeFields = 'makeLensesWith' 'defaultFieldRules'+-- @+makeFields :: Name -> DecsQ+makeFields = makeFieldOptics camelCaseFields++-- | Generate overloaded field accessors based on field names which+-- are only prefixed with an underscore (e.g. '_name'), not+-- additionally with the type name (e.g. '_fooName').+--+-- This might be the desired behaviour in case the+-- @DuplicateRecordFields@ language extension is used in order to get+-- rid of the necessity to prefix each field name with the type name.+--+-- As an example:+--+-- @+-- data Foo a = Foo { _x :: 'Int', _y :: a }+-- newtype Bar = Bar { _x :: 'Char' }+-- makeFieldsNoPrefix ''Foo+-- makeFieldsNoPrefix ''Bar+-- @+--+-- will create classes+--+-- @+-- class HasX s a | s -> a where+-- x :: Lens' s a+-- class HasY s a | s -> a where+-- y :: Lens' s a+-- @+--+-- together with instances+--+-- @+-- instance HasX (Foo a) Int+-- instance HasY (Foo a) a where+-- instance HasX Bar Char where+-- @+--+-- For details, see 'classUnderscoreNoPrefixFields'.+--+-- @+-- makeFieldsNoPrefix = 'makeLensesWith' 'classUnderscoreNoPrefixFields'+-- @+makeFieldsNoPrefix :: Name -> DecsQ+makeFieldsNoPrefix = makeFieldOptics classUnderscoreNoPrefixFields++-- | @ declareFields = 'declareLensesWith' 'defaultFieldRules' @+declareFields :: DecsQ -> DecsQ+declareFields = declareLensesWith defaultFieldRules++defaultFieldRules :: LensRules+defaultFieldRules = LensRules+ { _simpleLenses = True+ , _generateSigs = True+ , _generateClasses = True -- classes will still be skipped if they already exist+ , _allowIsos = False -- generating Isos would hinder field class reuse+ , _allowUpdates = True+ , _lazyPatterns = False+ , _classyLenses = const Nothing+ , _fieldToDef = camelCaseNamer+ }++----------------------------------------+-- Prisms++-- | Generate a 'Control.Lens.Type.Prism' for each constructor of each data type.+--+-- /e.g./+--+-- @+-- declarePrisms [d|+-- data Exp = Lit Int | Var String | Lambda{ bound::String, body::Exp }+-- |]+-- @+--+-- will create+--+-- @+-- data Exp = Lit Int | Var String | Lambda { bound::String, body::Exp }+-- _Lit :: 'Prism'' Exp Int+-- _Var :: 'Prism'' Exp String+-- _Lambda :: 'Prism'' Exp (String, Exp)+-- @+declarePrisms :: DecsQ -> DecsQ+declarePrisms = declareWith $ \dec -> do+ emit =<< liftDeclare (makeDecPrisms True dec)+ return dec++----------------------------------------+-- Customization of rules++-- | Generate "simple" optics even when type-changing optics are possible.+-- (e.g. 'Lens'' instead of 'Lens')+simpleLenses :: Lens' LensRules Bool+simpleLenses = lensVL $ \f r ->+ fmap (\x -> r { _simpleLenses = x}) (f (_simpleLenses r))++-- | Indicate whether or not to supply the signatures for the generated lenses.+--+-- Disabling this can be useful if you want to provide a more restricted type+-- signature or if you want to supply hand-written haddocks.+generateSignatures :: Lens' LensRules Bool+generateSignatures = lensVL $ \f r ->+ fmap (\x -> r { _generateSigs = x}) (f (_generateSigs r))++-- | Generate "updateable" optics when 'True'. When 'False', (affine) folds will+-- be generated instead of (affine) traversals and getters will be generated+-- instead of lenses. This mode is intended to be used for types with invariants+-- which must be maintained by "smart" constructors.+generateUpdateableOptics :: Lens' LensRules Bool+generateUpdateableOptics = lensVL $ \f r ->+ fmap (\x -> r { _allowUpdates = x}) (f (_allowUpdates r))++-- | Generate optics using lazy pattern matches. This can+-- allow fields of an undefined value to be initialized with lenses:+--+-- @+-- data Foo = Foo {_x :: Int, _y :: Bool}+-- deriving Show+--+-- 'makeLensesWith' ('lensRules' & 'generateLazyPatterns' .~ True) ''Foo+-- @+--+-- @+-- > undefined & x .~ 8 & y .~ True+-- Foo {_x = 8, _y = True}+-- @+--+-- The downside of this flag is that it can lead to space-leaks and+-- code-size/compile-time increases when generated for large records. By default+-- this flag is turned off, and strict optics are generated.+--+-- When using lazy optics the strict optic can be recovered by composing with+-- 'equality'':+--+-- @+-- strictOptic = equality' % lazyOptic+-- @+generateLazyPatterns :: Lens' LensRules Bool+generateLazyPatterns = lensVL $ \f r ->+ fmap (\x -> r { _lazyPatterns = x}) (f (_lazyPatterns r))++-- | Create the class if the constructor if generated lenses would be+-- type-preserving and the 'lensClass' rule matches.+createClass :: Lens' LensRules Bool+createClass = lensVL $ \f r ->+ fmap (\x -> r { _generateClasses = x}) (f (_generateClasses r))++-- | 'Lens'' to access the convention for naming fields in our 'LensRules'.+lensField :: Lens' LensRules FieldNamer+lensField = lensVL $ \f r ->+ fmap (\x -> r { _fieldToDef = x}) (f (_fieldToDef r))++-- | 'Lens'' to access the option for naming "classy" lenses.+lensClass :: Lens' LensRules ClassyNamer+lensClass = lensVL $ \f r ->+ fmap (\x -> r { _classyLenses = x }) (f (_classyLenses r))++----------------------------------------+-- Common sets of rules++abbreviatedFieldLabels :: LensRules+abbreviatedFieldLabels = fieldLabelsRules { _fieldToDef = abbreviatedNamer }++-- | Field rules for fields in the form @ _prefix_fieldname @+underscoreFields :: LensRules+underscoreFields = defaultFieldRules & lensField .~ underscoreNamer++-- | Field rules for fields in the form @ prefixFieldname or _prefixFieldname @+--+-- If you want all fields to be lensed, then there is no reason to use an @_@+-- before the prefix. If any of the record fields leads with an @_@ then it is+-- assume a field without an @_@ should not have a lens created.+--+-- __Note__: The @prefix@ must be the same as the typename (with the first+-- letter lowercased). This is a change from lens versions before lens 4.5. If+-- you want the old behaviour, use 'makeLensesWith' 'abbreviatedFields'+camelCaseFields :: LensRules+camelCaseFields = defaultFieldRules++-- | Field rules for fields in the form @ _fieldname @ (the leading+-- underscore is mandatory).+--+-- __Note__: The primary difference to 'camelCaseFields' is that for+-- @classUnderscoreNoPrefixFields@ the field names are not expected to+-- be prefixed with the type name. This might be the desired behaviour+-- when the @DuplicateRecordFields@ extension is enabled.+classUnderscoreNoPrefixFields :: LensRules+classUnderscoreNoPrefixFields =+ defaultFieldRules & lensField .~ classUnderscoreNoPrefixNamer++-- | Field rules fields in the form @ prefixFieldname or _prefixFieldname @+-- If you want all fields to be lensed, then there is no reason to use an @_@ before the prefix.+-- If any of the record fields leads with an @_@ then it is assume a field without an @_@ should not have a lens created.+--+-- Note that @prefix@ may be any string of characters that are not uppercase+-- letters. (In particular, it may be arbitrary string of lowercase letters+-- and numbers) This is the behavior that 'defaultFieldRules' had in lens+-- 4.4 and earlier.+abbreviatedFields :: LensRules+abbreviatedFields = defaultFieldRules { _fieldToDef = abbreviatedNamer }++----------------------------------------+-- Namers++-- | A 'FieldNamer' that strips the _ off of the field name, lowercases the+-- name, and skips the field if it doesn't start with an '_'.+underscoreNoPrefixNamer :: FieldNamer+underscoreNoPrefixNamer _ _ n =+ case nameBase n of+ '_':x:xs -> [TopName (mkName (toLower x:xs))]+ _ -> []+++-- | Create a 'FieldNamer' from explicit pairings of @(fieldName, lensName)@.+lookingupNamer :: [(String,String)] -> FieldNamer+lookingupNamer kvs _ _ field =+ [ TopName (mkName v) | (k,v) <- kvs, k == nameBase field]++-- | Create a 'FieldNamer' from a mapping function. If the function returns+-- @[]@, it creates no lens for the field.+mappingNamer :: (String -> [String]) -- ^ A function that maps a @fieldName@ to+ -- @lensName@s.+ -> FieldNamer+mappingNamer mapper _ _ = fmap (TopName . mkName) . mapper . nameBase++-- | A 'FieldNamer' for 'underscoreFields'.+underscoreNamer :: FieldNamer+underscoreNamer _ _ field = maybeToList $ do+ _ <- prefix field'+ method <- niceLens+ cls <- classNaming+ return (MethodName (mkName cls) (mkName method))+ where+ field' = nameBase field+ prefix ('_':xs) | '_' `List.elem` xs = Just (takeWhile (/= '_') xs)+ prefix _ = Nothing+ niceLens = prefix field' <&> \n -> drop (length n + 2) field'+ classNaming = niceLens <&> ("Has_" ++)++-- | A 'FieldNamer' for 'camelCaseFields'.+camelCaseNamer :: FieldNamer+camelCaseNamer tyName fields field = maybeToList $ do++ fieldPart <- stripPrefix expectedPrefix (nameBase field)+ method <- computeMethod fieldPart+ let cls = "Has" ++ fieldPart+ return (MethodName (mkName cls) (mkName method))++ where+ expectedPrefix = optUnderscore ++ over _head toLower (nameBase tyName)++ optUnderscore = ['_' | any (isPrefixOf "_" . nameBase) fields ]++ computeMethod (x:xs) | isUpper x = Just (toLower x : xs)+ computeMethod _ = Nothing++-- | A 'FieldNamer' for 'classUnderscoreNoPrefixFields'.+classUnderscoreNoPrefixNamer :: FieldNamer+classUnderscoreNoPrefixNamer _ _ field = maybeToList $ do+ fieldUnprefixed <- stripPrefix "_" (nameBase field)+ let className = "Has" ++ over _head toUpper fieldUnprefixed+ methodName = fieldUnprefixed+ return (MethodName (mkName className) (mkName methodName))++-- | A 'FieldNamer' for 'abbreviatedFields'.+abbreviatedNamer :: FieldNamer+abbreviatedNamer _ fields field = maybeToList $ do++ fieldPart <- stripMaxLc (nameBase field)+ method <- computeMethod fieldPart+ let cls = "Has" ++ fieldPart+ return (MethodName (mkName cls) (mkName method))++ where+ stripMaxLc f = do x <- stripPrefix optUnderscore f+ case break isUpper x of+ (p,s) | List.null p || List.null s -> Nothing+ | otherwise -> Just s+ optUnderscore = ['_' | any (isPrefixOf "_" . nameBase) fields ]++ computeMethod (x:xs) | isUpper x = Just (toLower x : xs)+ computeMethod _ = Nothing++----------------------------------------+-- Internal TH Implementation++-- Declaration quote stuff++declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ+declareWith fun = (runDeclare . traverseDataAndNewtype fun =<<)++-- | Monad for emitting top-level declarations as a side effect. We also track+-- the set of field class 'Name's that have been created and consult them to+-- avoid creating duplicate classes.++-- See #463 for more information.+type Declare = WriterT (Endo [Dec]) (StateT (Set Name) Q)++liftDeclare :: Q a -> Declare a+liftDeclare = lift . lift++runDeclare :: Declare [Dec] -> DecsQ+runDeclare dec = do+ (out, endo) <- evalStateT (runWriterT dec) Set.empty+ return $ out ++ appEndo endo []++emit :: [Dec] -> Declare ()+emit decs = tell $ Endo (decs++)++-- | Traverse each data, newtype, data instance or newtype instance+-- declaration.+traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec]+traverseDataAndNewtype f decs = traverse go decs+ where+ go dec = case dec of+ DataD{} -> f dec+ NewtypeD{} -> f dec+ DataInstD{} -> f dec+ NewtypeInstD{} -> f dec++ -- Recurse into instance declarations because they main contain+ -- associated data family instances.+ InstanceD moverlap ctx inst body -> InstanceD moverlap ctx inst <$> traverse go body+ _ -> pure dec++stripFields :: Dec -> Dec+stripFields dec = case dec of+ DataD ctx tyName tyArgs kind cons derivings ->+ DataD ctx tyName tyArgs kind (map deRecord cons) derivings+ NewtypeD ctx tyName tyArgs kind con derivings ->+ NewtypeD ctx tyName tyArgs kind (deRecord con) derivings+ DataInstD ctx tyName tyArgs kind cons derivings ->+ DataInstD ctx tyName tyArgs kind (map deRecord cons) derivings+ NewtypeInstD ctx tyName tyArgs kind con derivings ->+ NewtypeInstD ctx tyName tyArgs kind (deRecord con) derivings+ _ -> dec++deRecord :: Con -> Con+deRecord con@NormalC{} = con+deRecord con@InfixC{} = con+deRecord (ForallC tyVars ctx con) = ForallC tyVars ctx $ deRecord con+deRecord (RecC conName fields) = NormalC conName (map dropFieldName fields)+deRecord con@GadtC{} = con+deRecord (RecGadtC ns fields retTy) = GadtC ns (map dropFieldName fields) retTy++dropFieldName :: VarBangType -> BangType+dropFieldName (_, str, typ) = (str, typ)
+ src/Optics/TH/Internal/Product.hs view
@@ -0,0 +1,838 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+module Optics.TH.Internal.Product+ ( LensRules(..)+ , FieldNamer+ , DefName(..)+ , ClassyNamer+ , makeFieldOptics+ , makeFieldOpticsForDec+ , makeFieldOpticsForDec'+ , makeFieldLabelsWith+ , makeFieldLabelsForDec+ , HasFieldClasses+ ) where++import Control.Monad+import Control.Monad.State+import Data.Either+import Data.List+import Data.Maybe+import Language.Haskell.TH+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Traversable as T+import qualified Language.Haskell.TH.Datatype as D++import Data.Either.Optics+import Data.Tuple.Optics+import Data.Set.Optics+import Language.Haskell.TH.Optics.Internal+import Optics.Core hiding (cons)+import Optics.TH.Internal.Utils++------------------------------------------------------------------------+-- Utilities+------------------------------------------------------------------------++typeSelf :: Traversal' Type Type+typeSelf = traversalVL $ \f -> \case+ ForallT tyVarBndrs ctx ty ->+ let go (KindedTV nam kind) = KindedTV <$> pure nam <*> f kind+ go (PlainTV nam) = pure (PlainTV nam)+ in ForallT <$> traverse go tyVarBndrs <*> traverse f ctx <*> f ty+ AppT ty1 ty2 -> AppT <$> f ty1 <*> f ty2+ SigT ty kind -> SigT <$> f ty <*> f kind+ InfixT ty1 nam ty2 -> InfixT <$> f ty1 <*> pure nam <*> f ty2+ UInfixT ty1 nam ty2 -> UInfixT <$> f ty1 <*> pure nam <*> f ty2+ ParensT ty -> ParensT <$> f ty+ ty -> pure ty++------------------------------------------------------------------------+-- Field generation entry point+------------------------------------------------------------------------++-- | 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 = (`evalStateT` S.empty) . makeFieldOpticsForDatatype rules <=< D.reifyDatatype++makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ+makeFieldOpticsForDec rules = (`evalStateT` S.empty) . makeFieldOpticsForDec' rules++makeFieldOpticsForDec' :: LensRules -> Dec -> HasFieldClasses [Dec]+makeFieldOpticsForDec' rules = makeFieldOpticsForDatatype rules <=< lift . D.normalizeDec++-- | Compute the field optics for a deconstructed datatype Dec+-- When possible build an Iso otherwise build one optic per field.+makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec]+makeFieldOpticsForDatatype rules info =+ do perDef <- lift $ 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+ T.sequenceA (M.fromSet (buildScaffold True rules s defCons) allDefs)++ let defs = M.toList perDef+ case _classyLenses rules tyName of+ Just (className, methodName) ->+ makeClassyDriver rules className methodName s 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+ normFieldLabels = traversed % _2 % traversed % _1++ -- Map a (possibly missing) field's name to zero-to-many optic definitions+ expandName :: [Name] -> Maybe Name -> [DefName]+ expandName allFields = concatMap (_fieldToDef rules tyName allFields) . maybeToList++makeFieldLabelsForDec :: LensRules -> Dec -> DecsQ+makeFieldLabelsForDec rules = makeFieldLabelsForDatatype rules <=< D.normalizeDec++-- | Build field optics as labels with a custom configuration.+makeFieldLabelsWith :: LensRules -> Name -> DecsQ+makeFieldLabelsWith rules = D.reifyDatatype >=> makeFieldLabelsForDatatype rules++-- | Compute the field optics for a deconstructed datatype Dec+-- When possible build an Iso otherwise build one optic per field.+makeFieldLabelsForDatatype :: LensRules -> D.DatatypeInfo -> Q [Dec]+makeFieldLabelsForDatatype rules info =+ do perDef <- 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+ T.sequenceA (M.fromSet (buildScaffold False rules s defCons) allDefs)++ let defs = filter isRank1 $ M.toList perDef+ traverse (makeFieldLabel rules) defs++ where+ -- LabelOptic doesn't support higher rank fields because of functional+ -- dependencies (s -> a, t -> b), so just skip them.+ isRank1 = \case+ (_, (OpticSa rank1 _ _ _ _, _)) -> rank1+ _ -> True++ 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+ normFieldLabels = traversed % _2 % traversed % _1++ -- Map a (possibly missing) field's name to zero-to-many optic definitions+ expandName :: [Name] -> Maybe Name -> [DefName]+ expandName allFields = concatMap (_fieldToDef rules tyName allFields) . maybeToList++makeFieldLabel+ :: LensRules+ -> (DefName, (OpticStab, [(Name, Int, [Int])]))+ -> Q Dec+makeFieldLabel rules (defName, (defType, cons)) = do+ (context, instHead) <- case defType of+ OpticSa _ _ otype s a -> do+ (a', cxtA) <- eqSubst a "a"+ (b', cxtB) <- eqSubst a "b"+ pure (pure [cxtA, cxtB], pure $ conAppsT ''LabelOptic+ [LitT (StrTyLit fieldName), ConT $ opticTypeToTag otype, s, s, a', b'])+ OpticStab otype s t a b -> do+ ambiguousTypeFamilies <- containsAmbiguousTypeFamilyApplications s a+ -- If 'a' contains ambiguous type family applications, generate type+ -- preserving version as functional dependencies on LabelOptic demand it.+ let t' = if ambiguousTypeFamilies then s else t+ (a', cxtA) <- eqSubst a "a"+ (b', cxtB) <- if ambiguousTypeFamilies+ then eqSubst a "b"+ else eqSubst b "b"+ pure (pure [cxtA, cxtB], pure $ conAppsT ''LabelOptic+ [LitT (StrTyLit fieldName), ConT $ opticTypeToTag otype, s, t', a', b'])+ instanceD context instHead (fun 'labelOptic)+ where+ opticTypeToTag AffineFoldType = ''An_AffineFold+ opticTypeToTag AffineTraversalType = ''An_AffineTraversal+ opticTypeToTag FoldType = ''A_Fold+ opticTypeToTag GetterType = ''A_Getter+ opticTypeToTag IsoType = ''An_Iso+ opticTypeToTag LensType = ''A_Lens+ opticTypeToTag TraversalType = ''A_Traversal++ -- TODO: check for injectivity of encountered type families.+ containsAmbiguousTypeFamilyApplications s a = do+ -- We consider type family application ambiguous only if it's applied to a+ -- type variable not referenced anywhere else.+ (hasTypeFamilies, bareVars) <- (`runStateT` setOf typeVars s) $+ go =<< lift (D.resolveTypeSynonyms a)+ pure $ hasTypeFamilies && not (S.null bareVars)+ where+ go (ConT nm) = has (_FamilyI % _1 % _TypeFamilyD) <$> lift (reify nm)+ go (VarT n) = modify' (S.delete n) *> pure False+ go ty = or <$> traverse go (toListOf typeSelf ty)++ fieldName = case defName of+ TopName fname -> nameBase fname+ MethodName _ fname -> nameBase fname++ fun :: Name -> [DecQ]+ fun n = funD n [funDef] : inlinePragma n++ funDef :: ClauseQ+ funDef = makeFieldClause rules (stabToOpticType defType) cons++-- | Normalized the Con type into a uniform positional representation,+-- eliminating the variance between records, infix constructors, and normal+-- constructors.+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 `S.member` used) unallowable+ = (Nothing, fieldtype)+ where+ used = setOf typeVars fieldtype+ unallowable = D.constructorVars con+ checkForExistentials fieldname fieldtype = (fieldname, fieldtype)++-- | 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+-- with.+buildScaffold ::+ Bool {- ^ allow change of phantom type parameters -} ->+ LensRules ->+ Type {- ^ outer type -} ->+ [(Name, [([DefName], Type)])] {- ^ normalized constructors -} ->+ DefName {- ^ target definition -} ->+ Q (OpticStab, [(Name, Int, [Int])])+ {- ^ optic type, definition type, field count, target fields -}+buildScaffold allowPhantomsChange rules s cons defName =++ do (s',t,a,b) <- buildStab allowPhantomsChange s (concatMap snd consForDef)++ let defType+ | Just (tyvars,cx,a') <- preview _ForallT a =+ let optic | lensCase = GetterType+ | affineCase = AffineFoldType+ | otherwise = FoldType+ in OpticSa (null tyvars) cx optic s' a'++ -- Getter and Fold are always simple+ | not (_allowUpdates rules) =+ let optic | lensCase = GetterType+ | affineCase = AffineFoldType+ | otherwise = FoldType+ in OpticSa True [] optic s' a++ -- Generate simple Lens and Traversal where possible+ | _simpleLenses rules || s' == t && a == b =+ let optic | isoCase && _allowIsos rules = IsoType+ | lensCase = LensType+ | affineCase = AffineTraversalType+ | otherwise = TraversalType+ in OpticSa True [] optic s' a++ -- Generate type-changing Lens and Traversal otherwise+ | otherwise =+ let optic | isoCase && _allowIsos rules = IsoType+ | lensCase = LensType+ | affineCase = AffineTraversalType+ | otherwise = TraversalType+ in OpticStab optic s' t a b++ return (defType, scaffolds)+ where+ consForDef :: [(Name, [Either Type Type])]+ consForDef = over (mapped % _2 % mapped) categorize cons++ scaffolds :: [(Name, Int, [Int])]+ scaffolds = [ (n, length ts, rightIndices ts) | (n,ts) <- consForDef ]++ rightIndices :: [Either Type Type] -> [Int]+ rightIndices = findIndices (has _Right)++ -- Right: types for this definition+ -- Left : other types+ categorize :: ([DefName], Type) -> Either Type Type+ categorize (defNames, t)+ | defName `elem` defNames = Right t+ | otherwise = Left t++ affectedFields :: [Int]+ affectedFields = toListOf (folded % _3 % to length) scaffolds++ lensCase :: Bool+ lensCase = all (== 1) affectedFields++ affineCase :: Bool+ affineCase = all (<= 1) affectedFields++ isoCase :: Bool+ isoCase = case scaffolds of+ [(_,1,[0])] -> True+ _ -> False++data OpticType+ = AffineFoldType+ | AffineTraversalType+ | FoldType+ | GetterType+ | IsoType+ | LensType+ | TraversalType+ deriving Show++opticTypeName :: Bool -> OpticType -> Name+opticTypeName typeChanging AffineTraversalType = if typeChanging+ then ''AffineTraversal+ else ''AffineTraversal'+opticTypeName _typeChanging AffineFoldType = ''AffineFold+opticTypeName _typeChanging FoldType = ''Fold+opticTypeName _typeChanging GetterType = ''Getter+opticTypeName typeChanging IsoType = if typeChanging+ then ''Iso+ else ''Iso'+opticTypeName typeChanging LensType = if typeChanging+ then ''Lens+ else ''Lens'+opticTypeName typeChanging TraversalType = if typeChanging+ then ''Traversal+ else ''Traversal'++data OpticStab = OpticStab OpticType Type Type Type Type+ | OpticSa Bool Cxt OpticType Type Type++stabToType :: OpticStab -> Type+stabToType (OpticStab c s t a b) =+ quantifyType [] (opticTypeName True c `conAppsT` [s,t,a,b])+stabToType (OpticSa _ cx c s a ) =+ quantifyType cx (opticTypeName False c `conAppsT` [s,a])++stabToContext :: OpticStab -> Cxt+stabToContext OpticStab{} = []+stabToContext (OpticSa _ cx _ _ _) = cx++stabToOpticType :: OpticStab -> OpticType+stabToOpticType (OpticStab c _ _ _ _) = c+stabToOpticType (OpticSa _ _ c _ _) = c++stabToOptic :: OpticStab -> Name+stabToOptic (OpticStab c _ _ _ _) = opticTypeName True c+stabToOptic (OpticSa _ _ c _ _) = opticTypeName False c++stabToS :: OpticStab -> Type+stabToS (OpticStab _ s _ _ _) = s+stabToS (OpticSa _ _ _ s _) = s++stabToA :: OpticStab -> Type+stabToA (OpticStab _ _ _ a _) = a+stabToA (OpticSa _ _ _ _ a) = a++-- | Compute the s t a b types given the outer type 's' and the+-- categorized field types. Left for fixed and Right for visited.+-- These types are "raw" and will be packaged into an 'OpticStab'+-- shortly after creation.+buildStab :: Bool -> Type -> [Either Type Type] -> Q (Type,Type,Type,Type)+buildStab allowPhantomsChange s categorizedFields = do+ -- compute possible type changes+ sub <- T.sequenceA (M.fromSet (newName . nameBase) unfixedTypeVars)+ let (t, b) = over each (substTypeVars sub) (s, a)+ pure (s, t, a, b)+ where+ -- Just take the type of the first field and let GHC do the unification.+ a = fromMaybe+ (error "buildStab: unexpected empty list of fields")+ (preview _head targetFields)++ phantomTypeVars =+ let allTypeVars = folded % chosen % typeVars+ in setOf typeVars s S.\\ setOf allTypeVars categorizedFields++ (fixedFields, targetFields) = partitionEithers categorizedFields+ unfixedTypeVars =+ let fixedTypeVars = setOf typeVars fixedFields+ in if allowPhantomsChange+ then setOf typeVars s S.\\ fixedTypeVars+ else setOf typeVars s S.\\ fixedTypeVars S.\\ phantomTypeVars++-- | 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, (OpticStab, [(Name, Int, [Int])])) ->+ HasFieldClasses [Dec]+makeFieldOptic rules (defName, (defType, cons)) = do+ locals <- get+ addName+ lift $ do cls <- mkCls locals+ T.sequenceA (cls ++ sig ++ def)+ where+ mkCls locals = case defName of+ MethodName c n | _generateClasses rules ->+ do classExists <- isJust <$> lookupTypeName (show c)+ return (if classExists || S.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))]+ MethodName{} -> []++ fun n = funD n [funDef] : inlinePragma n++ def = case defName of+ TopName n -> fun n+ MethodName c n -> [makeFieldInstance defType c (fun n)]++ funDef = makeFieldClause rules (stabToOpticType defType) cons++------------------------------------------------------------------------+-- Classy class generator+------------------------------------------------------------------------+++makeClassyDriver ::+ LensRules ->+ Name ->+ Name ->+ Type {- ^ Outer 's' type -} ->+ [(DefName, (OpticStab, [(Name, Int, [Int])]))] ->+ HasFieldClasses [Dec]+makeClassyDriver rules className methodName s defs = T.sequenceA (cls ++ inst)++ where+ cls | _generateClasses rules = [lift $ makeClassyClass className methodName s defs]+ | otherwise = []++ inst = [makeClassyInstance rules className methodName s defs]+++makeClassyClass ::+ Name ->+ Name ->+ Type {- ^ Outer 's' type -} ->+ [(DefName, (OpticStab, [(Name, Int, [Int])]))] ->+ DecQ+makeClassyClass className methodName s defs = do+ c <- newName "c"+ let vars = toListOf typeVars s+ fd | null vars = []+ | otherwise = [FunDep [c] vars]+++ classD (cxt[]) className (map PlainTV (c:vars)) fd+ $ sigD methodName (return (''Lens' `conAppsT` [VarT c, s]))+ : concat+ [ [sigD defName (return ty)+ ,valD (varP defName) (normalB body) []+ ] +++ inlinePragma defName+ | (TopName defName, (stab, _)) <- defs+ , let body = infixApp (varE methodName) (varE '(%)) (varE defName)+ , let ty = quantifyType' (S.fromList (c:vars))+ (stabToContext stab)+ $ stabToOptic stab `conAppsT`+ [VarT c, stabToA stab]+ ]+++makeClassyInstance ::+ LensRules ->+ Name ->+ Name ->+ Type {- ^ Outer 's' type -} ->+ [(DefName, (OpticStab, [(Name, Int, [Int])]))] ->+ HasFieldClasses Dec+makeClassyInstance rules className methodName s defs = do+ methodss <- traverse (makeFieldOptic rules') defs++ lift $ instanceD (cxt[]) (return instanceHead)+ $ valD (varP methodName) (normalB (varE 'lensVL `appE` varE 'id)) []+ : map return (concat methodss)++ where+ instanceHead = className `conAppsT` (s : map VarT vars)+ vars = toListOf typeVars s+ rules' = rules { _generateSigs = False+ , _generateClasses = False+ }++------------------------------------------------------------------------+-- Field class generation+------------------------------------------------------------------------++makeFieldClass :: OpticStab -> Name -> Name -> DecQ+makeFieldClass defType className methodName =+ classD (cxt []) className [PlainTV s, PlainTV a] [FunDep [s] [a]]+ [sigD methodName (return methodType)]+ where+ methodType = quantifyType' (S.fromList [s,a])+ (stabToContext defType)+ $ stabToOptic defType `conAppsT` [VarT s,VarT a]+ 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 decs =+ containsTypeFamilies a >>= pickInstanceDec+ where+ s = stabToS defType+ a = stabToA defType++ containsTypeFamilies = go <=< D.resolveTypeSynonyms+ where+ go (ConT nm) = has (_FamilyI % _1 % _TypeFamilyD) <$> reify nm+ go ty = or <$> traverse go (toListOf typeSelf 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+------------------------------------------------------------------------++makeFieldClause :: LensRules -> OpticType -> [(Name, Int, [Int])] -> ClauseQ+makeFieldClause rules opticType cons =+ case opticType of+ AffineFoldType -> makeAffineFoldClause cons+ AffineTraversalType -> makeAffineTraversalClause cons irref+ FoldType -> makeFoldClause cons+ IsoType -> makeIsoClause cons irref+ GetterType -> makeGetterClause cons+ LensType -> makeLensClause cons irref+ TraversalType -> makeTraversalClause cons irref+ where+ irref = _lazyPatterns rules && length cons == 1++makeAffineFoldClause :: [(Name, Int, [Int])] -> ClauseQ+makeAffineFoldClause cons = do+ s <- newName "s"+ clause+ []+ (normalB $ appsE+ [ varE 'afolding+ , lamE [varP s] $ caseE (varE s)+ [ makeAffineFoldMatch conName fieldCount fields+ | (conName, fieldCount, fields) <- cons+ ]+ ])+ []+ where+ makeAffineFoldMatch conName fieldCount fields = do+ xs <- newNames "x" $ length fields++ let args = foldr (\(i, x) -> set (ix i) (varP x))+ (replicate fieldCount wildP)+ (zip fields xs)++ body = case xs of+ -- Con _ .. _ -> Nothing+ [] -> conE 'Nothing+ -- Con _ .. x_i .. _ -> Just x_i+ [x] -> conE 'Just `appE` varE x+ _ -> error "AffineFold focuses on at most one field"++ match (conP conName args)+ (normalB body)+ []++makeFoldClause :: [(Name, Int, [Int])] -> ClauseQ+makeFoldClause cons = do+ f <- newName "f"+ s <- newName "s"+ clause+ []+ (normalB $ appsE+ [ varE 'foldVL+ , lamE [varP f, varP s] $ caseE (varE s)+ [ makeFoldMatch f conName fieldCount fields+ | (conName, fieldCount, fields) <- cons+ ]+ ])+ []+ where+ makeFoldMatch f conName fieldCount fields = do+ xs <- newNames "x" $ length fields++ let args = foldr (\(i, x) -> set (ix i) (varP x))+ (replicate fieldCount wildP)+ (zip fields xs)++ fxs = case xs of+ [] -> [varE 'pure `appE` conE '()]+ _ -> map (\x -> varE f `appE` varE x) xs++ -- Con _ .. x_1 .. _ .. x_k .. _ -> f x_1 *> .. f x_k+ body = appsE+ [ foldr1 (\fx -> infixApp fx (varE '(*>))) fxs+ ]++ match (conP conName args)+ (normalB body)+ []++-- | Build a getter clause that retrieves the field at the given index.+makeGetterClause :: [(Name, Int, [Int])] -> ClauseQ+makeGetterClause cons = do+ s <- newName "s"+ clause+ []+ (normalB $ appsE+ [ varE 'to+ , lamE [varP s] $ caseE (varE s)+ [ makeGetterMatch conName fieldCount fields+ | (conName, fieldCount, fields) <- cons+ ]+ ])+ []+ where+ makeGetterMatch conName fieldCount = \case+ [field] -> do+ x <- newName "x"+ -- Con _ .. x_i .. _ -> x_i+ match (conP conName . set (ix field) (varP x) $ replicate fieldCount wildP)+ (normalB $ varE x)+ []+ _ -> error "Getter focuses on exactly one field"++-- | Build a clause that constructs an Iso.+makeIsoClause :: [(Name, Int, [Int])] -> Bool -> ClauseQ+makeIsoClause fields irref = case fields of+ [(conName, 1, [0])] -> do+ x <- newName "x"+ clause []+ (normalB $ appsE+ [ varE 'iso+ , lamE [irrefP $ conP conName [varP x]] (varE x)+ , conE conName+ ])+ []+ _ -> error "Iso works only for types with one constructor and one field"+ where+ irrefP = if irref then tildeP else id++-- | Build a lens clause that updates the field at the given index. When irref+-- is 'True' the value with be matched with an irrefutable pattern.+makeLensClause :: [(Name, Int, [Int])] -> Bool -> ClauseQ+makeLensClause cons irref = do+ f <- newName "f"+ s <- newName "s"+ clause+ []+ (normalB $ appsE+ [ varE 'lensVL+ , lamE [varP f, varP s] $ caseE (varE s)+ [ makeLensMatch irrefP f conName fieldCount fields+ | (conName, fieldCount, fields) <- cons+ ]+ ])+ []+ where+ irrefP = if irref then tildeP else id++-- | Make a lens match. Used for both lens and affine traversal generation.+makeLensMatch :: (PatQ -> PatQ) -> Name -> Name -> Int -> [Int] -> Q Match+makeLensMatch irrefP f conName fieldCount = \case+ [field] -> do+ xs <- newNames "x" fieldCount+ y <- newName "y"++ let body = appsE+ [ varE 'fmap+ , lamE [varP y] . appsE $+ conE conName : map varE (set (ix field) y xs)+ , appE (varE f) . varE $ xs !! field+ ]++ -- Con x_1 .. x_n -> fmap (\y_i -> Con x_1 .. y_i .. x_n) (f x_i)+ match (irrefP . conP conName $ map varP xs)+ (normalB body)+ []+ _ -> error "Lens focuses on exactly one field"++makeAffineTraversalClause :: [(Name, Int, [Int])] -> Bool -> ClauseQ+makeAffineTraversalClause cons irref = do+ point <- newName "point"+ f <- newName "f"+ s <- newName "s"+ clause+ []+ (normalB $ appsE+ [ varE 'atraversalVL+ , lamE [varP point, varP f, varP s] $ caseE (varE s)+ [ makeAffineTraversalMatch point f conName fieldCount fields+ | (conName, fieldCount, fields) <- cons+ ]+ ])+ []+ where+ irrefP = if irref then tildeP else id++ makeAffineTraversalMatch point f conName fieldCount = \case+ [] -> do+ xs <- newNames "x" fieldCount+ -- Con x_1 ... x_n -> point (Con x_1 .. x_n)+ match (irrefP . conP conName $ map varP xs)+ (normalB $ varE point `appE` appsE (conE conName : map varE xs))+ []+ [field] -> makeLensMatch irrefP f conName fieldCount [field]+ _ -> error "Affine traversal focuses on at most one field"++makeTraversalClause :: [(Name, Int, [Int])] -> Bool -> ClauseQ+makeTraversalClause cons irref = do+ f <- newName "f"+ s <- newName "s"+ clause+ []+ (normalB $ appsE+ [ varE 'traversalVL+ , lamE [varP f, varP s] $ caseE (varE s)+ [ makeTraversalMatch f conName fieldCount fields+ | (conName, fieldCount, fields) <- cons+ ]+ ])+ []+ where+ irrefP = if irref then tildeP else id++ makeTraversalMatch f conName fieldCount fields = do+ xs <- newNames "x" fieldCount+ case fields of+ [] -> -- Con x_1 .. x_n -> pure (Con x_1 .. x_n)+ match (irrefP . conP conName $ map varP xs)+ (normalB $ varE 'pure `appE` appsE (conE conName : map varE xs))+ []+ _ -> do+ ys <- newNames "y" $ length fields++ let xs' = foldr (\(i, x) -> set (ix i) x) xs (zip fields ys)++ mkFx i = varE f `appE` varE (xs !! i)++ body0 = appsE+ [ varE 'pure+ , lamE (map varP ys) $ appsE $ conE conName : map varE xs'+ ]++ body = foldl (\acc i -> infixApp acc (varE '(<*>)) $ mkFx i)+ body0+ fields++ -- Con x_1 .. x_n ->+ -- pure (\y_1 .. y_k -> Con x_1 .. y_1 .. x_l .. y_k .. x_n)+ -- <*> f x_i_y_1 <*> .. <*> f x_i_y_k+ match (irrefP . conP conName $ map varP xs)+ (normalB body)+ []++------------------------------------------------------------------------+-- Field generation parameters+------------------------------------------------------------------------++-- | Rules to construct lenses for data fields.+data LensRules = LensRules+ { _simpleLenses :: Bool+ , _generateSigs :: Bool+ , _generateClasses :: Bool+ , _allowIsos :: Bool+ , _allowUpdates :: Bool -- ^ Allow Lens/Traversal (otherwise Getter/Fold)+ , _lazyPatterns :: Bool+ , _fieldToDef :: FieldNamer+ -- ^ Type Name -> Field Names -> Target Field Name -> Definition Names+ , _classyLenses :: ClassyNamer+ -- type name to class name and top method+ }++-- | The rule to create function names of lenses for data fields.+--+-- Although it's sometimes useful, you won't need the first two+-- arguments most of the time.+type FieldNamer = Name -- ^ Name of the data type that lenses are being generated for.+ -> [Name] -- ^ Names of all fields (including the field being named) in the data type.+ -> Name -- ^ Name of the field being named.+ -> [DefName] -- ^ Name(s) of the lens functions. If empty, no lens is created for that field.++-- | Name to give to generated field optics.+data DefName+ = TopName Name -- ^ Simple top-level definiton name+ | MethodName Name Name -- ^ makeFields-style class name and method name+ deriving (Show, Eq, Ord)++-- | The optional rule to create a class and method around a+-- monomorphic data type. If this naming convention is provided, it+-- generates a "classy" lens.+type ClassyNamer = Name -- ^ Name of the data type that lenses are being generated for.+ -> Maybe (Name, Name) -- ^ Names of the class and the main method it generates, respectively.++-- | Tracks the field class 'Name's that have been created so far. We consult+-- these so that we may avoid creating duplicate classes.++-- See #643 for more information.+type HasFieldClasses = StateT (S.Set Name) Q++addFieldClassName :: Name -> HasFieldClasses ()+addFieldClassName n = modify $ S.insert n++------------------------------------------------------------------------+-- Miscellaneous utility functions+------------------------------------------------------------------------++ -- We want to catch type families, but not *data* families. See #799.+_TypeFamilyD :: AffineFold Dec ()+_TypeFamilyD = _OpenTypeFamilyD % united `afailing` _ClosedTypeFamilyD % united++-- | 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+quantifyType = quantifyType' S.empty++-- | This function works like 'quantifyType' except that it takes+-- a list of variables to exclude from quantification.+quantifyType' :: S.Set Name -> Cxt -> Type -> Type+quantifyType' exclude c t = ForallT vs c t+ where+ vs = map PlainTV+ $ filter (`S.notMember` exclude)+ $ nub -- stable order+ $ toListOf typeVars t
+ src/Optics/TH/Internal/Sum.hs view
@@ -0,0 +1,497 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+module Optics.TH.Internal.Sum+ ( makePrisms+ , makePrismLabels+ , makeClassyPrisms+ , makeDecPrisms+ ) where++import Data.Char+import Data.List+import Data.Maybe+import Data.Traversable+import Language.Haskell.TH+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Language.Haskell.TH.Datatype as D++import Data.Set.Optics+import Language.Haskell.TH.Optics.Internal+import Optics.Core hiding (cons)+import Optics.TH.Internal.Utils++-- | Generate a 'Prism' for each constructor of a data type. Isos generated when+-- possible. Reviews are created for constructors with existentially quantified+-- constructors and GADTs.+--+-- /e.g./+--+-- @+-- data FooBarBaz a+-- = Foo Int+-- | Bar a+-- | Baz Int Char+-- makePrisms ''FooBarBaz+-- @+--+-- will create+--+-- @+-- _Foo :: Prism' (FooBarBaz a) Int+-- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b+-- _Baz :: Prism' (FooBarBaz a) (Int, Char)+-- @+makePrisms :: Name {- ^ Type constructor name -} -> DecsQ+makePrisms = makePrisms' True++-- | Generate a 'Prism' for each constructor of a data type and combine them+-- into a single class. No Isos are created. Reviews are created for+-- constructors with existentially quantified constructors and GADTs.+--+-- /e.g./+--+-- @+-- data FooBarBaz a+-- = Foo Int+-- | Bar a+-- | Baz Int Char+-- makeClassyPrisms ''FooBarBaz+-- @+--+-- will create+--+-- @+-- class AsFooBarBaz s a | s -> a where+-- _FooBarBaz :: Prism' s (FooBarBaz a)+-- _Foo :: Prism' s Int+-- _Bar :: Prism' s a+-- _Baz :: Prism' s (Int,Char)+--+-- _Foo = _FooBarBaz % _Foo+-- _Bar = _FooBarBaz % _Bar+-- _Baz = _FooBarBaz % _Baz+--+-- instance AsFooBarBaz (FooBarBaz a) a+-- @+--+-- Generate an "As" class of prisms. Names are selected by prefixing the+-- constructor name with an underscore. Constructors with multiple fields will+-- construct Prisms to tuples of those fields.+makeClassyPrisms :: Name {- ^ Type constructor name -} -> DecsQ+makeClassyPrisms = makePrisms' False++makePrismLabels :: Name -> DecsQ+makePrismLabels typeName = do+ info <- D.reifyDatatype typeName+ let cons = map normalizeCon $ D.datatypeCons info+ catMaybes <$> traverse (makeLabel info cons) cons+ where+ makeLabel :: D.DatatypeInfo -> [NCon] -> NCon -> Q (Maybe Dec)+ makeLabel info cons con = do+ stab@(Stab cx otype s t a b) <- computeOpticType labelConfig ty cons con+ case otype of+ -- Reviews are for existentially quantified types and these don't fit+ -- into OpticLabel because of functional dependencies, just skip them.+ ReviewType -> pure Nothing+ _ -> do+ (a', cxtA) <- eqSubst a "a"+ (b', cxtB) <- eqSubst b "b"+ let label = nameBase . prismName $ view nconName con+ instHead = pure $ conAppsT ''LabelOptic+ [LitT (StrTyLit label), ConT $ opticTypeToTag otype, s, t, a', b']+ Just <$> instanceD (pure $ cx ++ [cxtA, cxtB]) instHead (fun stab 'labelOptic)+ where+ ty = D.datatypeType info+ isNewtype = D.datatypeVariant info == D.Newtype++ opticTypeToTag IsoType = ''An_Iso+ opticTypeToTag PrismType = ''A_Prism+ opticTypeToTag ReviewType = ''A_Review -- for complete match++ fun :: Stab -> Name -> [DecQ]+ fun stab n = valD (varP n) (normalB $ funDef stab) [] : inlinePragma n++ funDef :: Stab -> ExpQ+ funDef stab+ | isNewtype = varE 'coerced+ | otherwise = makeConOpticExp stab cons con++-- | Main entry point into Prism generation for a given type constructor name.+makePrisms' :: Bool -> Name -> DecsQ+makePrisms' normal typeName =+ do info <- D.reifyDatatype typeName+ let cls | normal = Nothing+ | otherwise = Just (D.datatypeName info)+ cons = D.datatypeCons info+ makeConsPrisms info (map normalizeCon cons) cls+++-- | Generate prisms for the given 'Dec'+makeDecPrisms :: Bool {- ^ generate top-level definitions -} -> Dec -> DecsQ+makeDecPrisms normal dec =+ do info <- D.normalizeDec dec+ let cls | normal = Nothing+ | otherwise = Just (D.datatypeName info)+ cons = D.datatypeCons info+ makeConsPrisms info (map normalizeCon cons) cls++-- | Generate prisms for the given type, normalized constructors, and an+-- optional name to be used for generating a prism class. This function+-- dispatches between Iso generation, normal top-level prisms, and classy+-- prisms.+makeConsPrisms :: D.DatatypeInfo -> [NCon] -> Maybe Name -> DecsQ++-- top-level definitions+makeConsPrisms info cons Nothing = fmap concat . for cons $ \con -> do+ stab <- computeOpticType defaultConfig ty cons con+ let n = prismName $ view nconName con+ body = if isNewtype+ then varE 'coerced+ else makeConOpticExp stab cons con+ sequenceA $+ [ sigD n (close (stabToType stab))+ , valD (varP n) (normalB body) []+ ] ++ inlinePragma n+ where+ ty = D.datatypeType info+ isNewtype = D.datatypeVariant info == D.Newtype++-- classy prism class and instance+makeConsPrisms info cons (Just typeName) =+ sequenceA+ [ makeClassyPrismClass ty className methodName cons+ , makeClassyPrismInstance ty className methodName cons+ ]+ where+ ty = D.datatypeType info+ className = mkName ("As" ++ nameBase typeName)+ methodName = prismName typeName++----------------------------------------++data StabConfig = StabConfig+ { scAllowPhantomsChange :: Bool+ , scAllowIsos :: Bool+ }++defaultConfig :: StabConfig+defaultConfig = StabConfig+ { scAllowPhantomsChange = True+ , scAllowIsos = True+ }++classyConfig :: StabConfig+classyConfig = StabConfig+ { scAllowPhantomsChange = True+ , scAllowIsos = False+ }++labelConfig :: StabConfig+labelConfig = StabConfig+ { scAllowPhantomsChange = False+ , scAllowIsos = True+ }++data OpticType = IsoType | PrismType | ReviewType+data Stab = Stab Cxt OpticType Type Type Type Type++simplifyStab :: Stab -> Stab+simplifyStab (Stab cx ty _ t _ b) = Stab cx ty t t b b+ -- simplification uses t and b because those types+ -- are interesting in the Review case++stabSimple :: Stab -> Bool+stabSimple (Stab _ _ s t a b) = s == t && a == b++stabToType :: Stab -> Type+stabToType stab@(Stab cx ty s t a b) = ForallT vs cx $+ case ty of+ IsoType | stabSimple stab -> ''Iso' `conAppsT` [s,a]+ | otherwise -> ''Iso `conAppsT` [s,t,a,b]+ PrismType | stabSimple stab -> ''Prism' `conAppsT` [s,a]+ | otherwise -> ''Prism `conAppsT` [s,t,a,b]+ ReviewType -> ''Review `conAppsT` [t,b]++ where+ vs = map PlainTV+ $ nub -- stable order+ $ toListOf typeVars cx++stabType :: Stab -> OpticType+stabType (Stab _ o _ _ _ _) = o++computeOpticType :: StabConfig -> Type -> [NCon] -> NCon -> Q Stab+computeOpticType conf t cons con =+ do let cons' = delete con cons+ if null (_nconVars con)+ then computePrismType conf t (view nconCxt con) cons' con+ else computeReviewType t (view nconCxt con) (view nconTypes con)+++computeReviewType :: Type -> Cxt -> [Type] -> Q Stab+computeReviewType t cx tys = do+ b <- toTupleT (map return tys)+ return (Stab cx ReviewType t t b b)++-- | Compute the full type-changing Prism type given an outer type, list of+-- constructors, and target constructor name.+computePrismType :: StabConfig -> Type -> Cxt -> [NCon] -> NCon -> Q Stab+computePrismType conf t cx cons con = do+ let ts = view nconTypes con+ fixed = setOf typeVars cons+ phantoms = setOf typeVars t S.\\ (setOf typeVars con `S.union` fixed)+ unbound = if scAllowPhantomsChange conf+ then setOf typeVars t S.\\ fixed+ else setOf typeVars t S.\\ fixed S.\\ phantoms+ sub <- sequenceA (M.fromSet (newName . nameBase) unbound)+ b <- toTupleT (map return ts)+ a <- toTupleT (map return (substTypeVars sub ts))+ let s = substTypeVars sub t+ otype = if null cons && scAllowIsos conf+ then IsoType+ else PrismType+ return (Stab cx otype s t a b)++-- | Construct either a Review or Prism as appropriate+makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ+makeConOpticExp stab cons con =+ case stabType stab of+ IsoType -> makeConIsoExp con+ PrismType -> makeConPrismExp stab cons con+ ReviewType -> makeConReviewExp con++-- | Construct prism expression+--+-- prism <<reviewer>> <<remitter>>+makeConPrismExp ::+ Stab ->+ [NCon] {- ^ constructors -} ->+ NCon {- ^ target constructor -} ->+ ExpQ+makeConPrismExp stab cons con = appsE [varE 'prism, reviewer, remitter]+ where+ ts = view nconTypes con+ fields = length ts+ conName = view nconName con++ reviewer = makeReviewer conName fields+ remitter | stabSimple stab = makeSimpleRemitter conName fields+ | otherwise = makeFullRemitter cons conName+++-- | Construct an Iso expression+--+-- iso <<reviewer>> <<remitter>>+makeConIsoExp :: NCon -> ExpQ+makeConIsoExp con = appsE [varE 'iso, remitter, reviewer]+ where+ conName = view nconName con+ fields = length (view nconTypes con)++ reviewer = makeReviewer conName fields+ remitter = makeIsoRemitter conName fields+++-- | Construct a Review expression+--+-- unto (\(x,y,z) -> Con x y z)+makeConReviewExp :: NCon -> ExpQ+makeConReviewExp con = appE (varE 'unto) reviewer+ where+ conName = view nconName con+ fields = length (view nconTypes con)++ reviewer = makeReviewer conName fields+++------------------------------------------------------------------------+-- Prism and Iso component builders+------------------------------------------------------------------------+++-- | Construct the review portion of a prism.+--+-- (\(x,y,z) -> Con x y z) :: b -> t+makeReviewer :: Name -> Int -> ExpQ+makeReviewer conName fields =+ do xs <- newNames "x" fields+ lam1E (toTupleP (map varP xs))+ (conE conName `appsE1` map varE xs)+++-- | Construct the remit portion of a prism.+-- Pattern match only target constructor, no type changing+--+-- (\x -> case s of+-- Con x y z -> Right (x,y,z)+-- _ -> Left x+-- ) :: s -> Either s a+makeSimpleRemitter :: Name -> Int -> ExpQ+makeSimpleRemitter conName fields =+ do x <- newName "x"+ xs <- newNames "y" fields+ let matches =+ [ match (conP conName (map varP xs))+ (normalB (appE (conE 'Right) (toTupleE (map varE xs))))+ []+ , match wildP (normalB (appE (conE 'Left) (varE x))) []+ ]+ lam1E (varP x) (caseE (varE x) matches)+++-- | Pattern match all constructors to enable type-changing+--+-- (\x -> case s of+-- Con x y z -> Right (x,y,z)+-- Other_n w -> Left (Other_n w)+-- ) :: s -> Either t a+makeFullRemitter :: [NCon] -> Name -> ExpQ+makeFullRemitter cons target =+ do x <- newName "x"+ lam1E (varP x) (caseE (varE x) (map mkMatch cons))+ where+ mkMatch (NCon conName _ _ n) =+ do xs <- newNames "y" (length n)+ match (conP conName (map varP xs))+ (normalB+ (if conName == target+ then appE (conE 'Right) (toTupleE (map varE xs))+ else appE (conE 'Left) (conE conName `appsE1` map varE xs)))+ []+++-- | Construct the remitter suitable for use in an 'Iso'+--+-- (\(Con x y z) -> (x,y,z)) :: s -> a+makeIsoRemitter :: Name -> Int -> ExpQ+makeIsoRemitter conName fields =+ do xs <- newNames "x" fields+ lam1E (conP conName (map varP xs))+ (toTupleE (map varE xs))+++------------------------------------------------------------------------+-- Classy prisms+------------------------------------------------------------------------+++-- | Construct the classy prisms class for a given type and constructors.+--+-- class ClassName r <<vars in type>> | r -> <<vars in Type>> where+-- topMethodName :: Prism' r Type+-- conMethodName_n :: Prism' r conTypes_n+-- conMethodName_n = topMethodName . conMethodName_n+makeClassyPrismClass ::+ Type {- Outer type -} ->+ Name {- Class name -} ->+ Name {- Top method name -} ->+ [NCon] {- Constructors -} ->+ DecQ+makeClassyPrismClass t className methodName cons =+ do r <- newName "r"+ let methodType = appsT (conT ''Prism') [varT r,return t]+ methodss <- traverse (mkMethod (VarT r)) cons'+ classD (cxt[]) className (map PlainTV (r : vs)) (fds r)+ ( sigD methodName methodType+ : map return (concat methodss)+ )++ where+ mkMethod r con =+ do Stab cx o _ _ _ b <- computeOpticType classyConfig t cons con+ let stab' = Stab cx o r r b b+ defName = view nconName con+ body = appsE [varE '(%), varE methodName, varE defName]+ sequenceA+ [ sigD defName (return (stabToType stab'))+ , valD (varP defName) (normalB body) []+ ]++ cons' = map (over nconName prismName) cons+ vs = S.toList (setOf typeVars t)+ fds r+ | null vs = []+ | otherwise = [FunDep [r] vs]++++-- | Construct the classy prisms instance for a given type and constructors.+--+-- instance Classname OuterType where+-- topMethodName = id+-- conMethodName_n = <<prism>>+makeClassyPrismInstance ::+ Type ->+ Name {- Class name -} ->+ Name {- Top method name -} ->+ [NCon] {- Constructors -} ->+ DecQ+makeClassyPrismInstance s className methodName cons =+ do let vs = S.toList (setOf typeVars s)+ cls = className `conAppsT` (s : map VarT vs)++ instanceD (cxt[]) (return cls)+ ( valD (varP methodName)+ (normalB (varE 'castOptic `appE` varE 'equality)) []+ : [ do stab <- computeOpticType classyConfig s cons con+ let stab' = simplifyStab stab+ valD (varP (prismName conName))+ (normalB (makeConOpticExp stab' cons con)) []+ | con <- cons+ , let conName = view nconName con+ ]+ )+++------------------------------------------------------------------------+-- Utilities+------------------------------------------------------------------------+++-- | Normalized constructor+data NCon = NCon+ { _nconName :: Name+ , _nconVars :: [Name]+ , _nconCxt :: Cxt+ , _nconTypes :: [Type]+ }+ deriving (Eq)++instance HasTypeVars NCon where+ typeVarsEx s = traversalVL $ \f (NCon x vars y z) ->+ let s' = foldl' (flip S.insert) s vars+ in NCon x vars <$> traverseOf (typeVarsEx s') f y+ <*> traverseOf (typeVarsEx s') f z++nconName :: Lens' NCon Name+nconName = lensVL $ \f x -> fmap (\y -> x {_nconName = y}) (f (_nconName x))++nconCxt :: Lens' NCon Cxt+nconCxt = lensVL $ \f x -> fmap (\y -> x {_nconCxt = y}) (f (_nconCxt x))++nconTypes :: Lens' NCon [Type]+nconTypes = lensVL $ \f x -> fmap (\y -> x {_nconTypes = y}) (f (_nconTypes x))+++-- | Normalize a single 'Con' to its constructor name and field types.+normalizeCon :: D.ConstructorInfo -> NCon+normalizeCon info = NCon (D.constructorName info)+ (D.tvName <$> D.constructorVars info)+ (D.constructorContext info)+ (D.constructorFields info)+++-- | Compute a prism's name by prefixing an underscore for normal+-- constructors and period for operators.+prismName :: Name -> Name+prismName n = case nameBase n of+ [] -> error "prismName: empty name base?"+ x:xs | isUpper x -> mkName ('_':x:xs)+ | otherwise -> mkName ('.':x:xs) -- operator+++-- | Quantify all the free variables in a type.+close :: Type -> TypeQ+close t = forallT (map PlainTV (S.toList vs)) (cxt[]) (return t)+ where+ vs = setOf typeVars t
+ src/Optics/TH/Internal/Utils.hs view
@@ -0,0 +1,57 @@+module Optics.TH.Internal.Utils where++import Language.Haskell.TH+import qualified Language.Haskell.TH.Datatype as D++-- | Apply arguments to a type constructor+appsT :: TypeQ -> [TypeQ] -> TypeQ+appsT = foldl appT++-- | Apply arguments to a function+appsE1 :: ExpQ -> [ExpQ] -> ExpQ+appsE1 = foldl appE++-- | Construct a tuple type given a list of types.+toTupleT :: [TypeQ] -> TypeQ+toTupleT [x] = x+toTupleT xs = appsT (tupleT (length xs)) xs++-- | Construct a tuple value given a list of expressions.+toTupleE :: [ExpQ] -> ExpQ+toTupleE [x] = x+toTupleE xs = tupE xs++-- | Construct a tuple pattern given a list of patterns.+toTupleP :: [PatQ] -> PatQ+toTupleP [x] = x+toTupleP xs = tupP xs++-- | Apply arguments to a type constructor.+conAppsT :: Name -> [Type] -> Type+conAppsT conName = foldl AppT (ConT conName)++-- | Return 'Name' contained in a 'TyVarBndr'.+bndrName :: TyVarBndr -> Name+bndrName (PlainTV n ) = n+bndrName (KindedTV n _) = n++-- | Generate many new names from a given base name.+newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name]+newNames base n = sequence [ newName (base++show i) | i <- [1..n] ]++-- We substitute concrete types with type variables and match them with concrete+-- types in the instance context. This significantly improves type inference as+-- GHC can match the instance more easily, but costs dependence on TypeFamilies+-- and UndecidableInstances.+eqSubst :: Type -> String -> Q (Type, Pred)+eqSubst ty n = do+ placeholder <- VarT <$> newName n+ pure (placeholder, D.equalPred placeholder ty)+++------------------------------------------------------------------------+-- Support for generating inline pragmas+------------------------------------------------------------------------++inlinePragma :: Name -> [DecQ]+inlinePragma methodName = [pragInlD methodName Inline FunLike AllPhases]
+ tests/Optics/TH/Tests.hs view
@@ -0,0 +1,739 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- {-# OPTIONS_GHC -ddump-splices #-}+module Main where++import Data.Typeable++import Optics.Core+import Optics.TH+import Optics.TH.Tests.T799 ()++data Pair a b = Pair a b+makePrisms ''Pair+makePrismLabels ''Pair++checkPair :: Iso (Pair a b) (Pair a' b') (a, b) (a', b')+checkPair = _Pair++checkPair_ :: Iso (Pair a b) (Pair a' b') (a, b) (a', b')+checkPair_ = #_Pair++data Sum a b = SLeft a | SRight b | SWeird Int+makePrisms ''Sum+makePrismLabels ''Sum++checkSLeft :: Prism (Sum a c) (Sum b c) a b+checkSLeft = _SLeft++checkSLeft_ :: Prism (Sum a c) (Sum b c) a b+checkSLeft_ = #_SLeft++checkSRight :: Prism (Sum c a) (Sum c b) a b+checkSRight = _SRight++checkSRight_ :: Prism (Sum c a) (Sum c b) a b+checkSRight_ = #_SRight++checkSWeird :: Prism' (Sum a b) Int+checkSWeird = _SWeird++checkSWeird_ :: Prism' (Sum a b) Int+checkSWeird_ = #_SWeird++data PairEq a b c where+ PairEq :: (Eq a, Eq b) => a -> b -> PairEq a b c+makePrisms ''PairEq+makePrismLabels ''PairEq++checkPairEq+ :: (Eq a', Eq b')+ => Iso (PairEq a b c) (PairEq a' b' c') (a, b) (a', b')+checkPairEq = _PairEq++checkPairEq_+ :: (Eq a', Eq b')+ => Iso (PairEq a b c) (PairEq a' b' c) (a, b) (a', b')+checkPairEq_ = #_PairEq++data Brr a where+ BrrA :: a -> Brr a+ BrrInt :: Int -> Brr Int+makePrisms ''Brr+makePrismLabels ''Brr++checkBrrA :: Prism' (Brr a) a+checkBrrA = _BrrA++checkBrrA_ :: Prism' (Brr a) a+checkBrrA_ = #_BrrA++checkBrrInt :: Prism' (Brr Int) Int+checkBrrInt = _BrrInt++checkBrrInt_ :: Prism' (Brr Int) Int+checkBrrInt_ = #_BrrInt++data Bzzt a b c where+ BzztShow :: Show a => a -> Bzzt a b c+ BzztRead :: Read b => b -> Bzzt a b c+makePrisms ''Bzzt+makePrismLabels ''Bzzt++checkBzztShow :: Show a => Prism (Bzzt a b c) (Bzzt a b c') a a+checkBzztShow = _BzztShow++-- We can't change b because of LabelOptic fundeps.+checkBzztShow_ :: Show a => Prism' (Bzzt a b c) a+checkBzztShow_ = #_BzztShow++checkBzztRead :: Read b => Prism (Bzzt a b c) (Bzzt a b c') b b+checkBzztRead = _BzztRead++-- We can't change b because of LabelOptic fundeps.+checkBzztRead_ :: Read b => Prism' (Bzzt a b c) b+checkBzztRead_ = #_BzztRead++data FooX a where+ FooX1, FooX2 :: { fooX_, fooY_ :: Int } -> FooX a+makePrisms ''FooX+makePrismLabels ''FooX++checkFooX1 :: Prism (FooX a) (FooX b) (Int, Int) (Int, Int)+checkFooX1 = _FooX1++-- We can't change a because of LabelOptic fundeps.+checkFooX1_ :: Prism' (FooX a) (Int, Int)+checkFooX1_ = #_FooX1++checkFooX2 :: Prism (FooX a) (FooX b) (Int, Int) (Int, Int)+checkFooX2 = _FooX2++-- We can't change a because of LabelOptic fundeps.+checkFooX2_ :: Prism' (FooX a) (Int, Int)+checkFooX2_ = #_FooX2++data ClassyTest = ClassyT1 Int | ClassyT2 String | ClassyT3 Char+makeClassyPrisms ''ClassyTest++checkClassyTest :: AsClassyTest r => Prism' r ClassyTest+checkClassyTest = _ClassyTest++checkClassyT1 :: AsClassyTest r => Prism' r Int+checkClassyT1 = _ClassyT1++checkClassyT2 :: AsClassyTest r => Prism' r String+checkClassyT2 = _ClassyT2++checkClassyT3 :: AsClassyTest r => Prism' r Char+checkClassyT3 = _ClassyT3++----------------------------------------++data Bar a b c = Bar { _baz :: (a, b) }+makeLenses ''Bar+makeFieldLabelsWith lensRules ''Bar++checkBaz :: Iso (Bar a b c) (Bar a' b' c') (a, b) (a', b')+checkBaz = baz++-- We can't change c because of LabelOptic fundeps.+checkBaz_ :: Iso (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+makeFieldLabelsWith lensRules ''Quux++checkQuaffle :: Lens (Quux a b) (Quux a' b') Int Int+checkQuaffle = quaffle++-- We can't change a and b because of LabelOptic fundeps.+checkQuaffle_ :: Lens (Quux a b) (Quux a b) Int Int+checkQuaffle_ = #quaffle++checkQuartz :: Lens (Quux a b) (Quux a' b') Double Double+checkQuartz = quartz++-- We can't change a and b because of LabelOptic fundeps.+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+makeFieldLabelsWith lensRules ''Quark++checkGaffer :: Lens' (Quark a) a+checkGaffer = gaffer++checkGaffer_ :: Lens' (Quark a) a+checkGaffer_ = #gaffer++checkTape :: AffineTraversal' (Quark a) a+checkTape = tape++checkTape_ :: AffineTraversal' (Quark a) a+checkTape_ = #tape++data Hadron a b = Science { _a1 :: a, _a2 :: a, _c :: Either b [b] }+makeLenses ''Hadron+makeFieldLabelsWith lensRules ''Hadron++checkA1 :: Lens' (Hadron a b) a+checkA1 = a1++checkA1_ :: Lens' (Hadron a b) a+checkA1_ = #a1++checkA2 :: Lens' (Hadron a b) a+checkA2 = a2++checkA2_ :: Lens' (Hadron a b) a+checkA2_ = #a2++checkC :: Lens (Hadron a b) (Hadron a b') (Either b [b]) (Either b' [b'])+checkC = c++checkC_ :: Lens (Hadron a b) (Hadron a b') (Either b [b]) (Either b' [b'])+checkC_ = #c++data Perambulation a b+ = Mountains { _terrain :: a+ , _altitude :: b+ -- Having Eq here doesn't work with old unification logic because+ -- it was incomplete (and didn't seem to do anything).+ , _absurdity1 :: forall x y. Eq x => x -> y+ , _absurdity2 :: forall x y. Eq x => x -> y+ }+ | Beaches { _terrain :: a+ , _dunes :: a+ , _absurdity1 :: forall x y. Eq x => x -> y+ }+makeLenses ''Perambulation+makeFieldLabelsWith lensRules ''Perambulation++checkTerrain :: Lens' (Perambulation a b) a+checkTerrain = terrain++checkTerrain_ :: Lens' (Perambulation a b) a+checkTerrain_ = #terrain++checkAltitude :: AffineTraversal (Perambulation a b) (Perambulation a b') b b'+checkAltitude = altitude++checkAltitude_ :: AffineTraversal (Perambulation a b) (Perambulation a b') b b'+checkAltitude_ = #altitude++checkAbsurdity1 :: Eq x => Getter (Perambulation a b) (x -> y)+checkAbsurdity1 = absurdity1++checkAbsurdity2 :: Eq x => AffineFold (Perambulation a b) (x -> y)+checkAbsurdity2 = absurdity2++checkDunes :: AffineTraversal' (Perambulation a b) a+checkDunes = dunes++checkDunes_ :: AffineTraversal' (Perambulation a b) a+checkDunes_ = #dunes++makeLensesFor [ ("_terrain", "allTerrain")+ , ("_dunes", "allTerrain")+ , ("_absurdity1", "absurdities")+ , ("_absurdity2", "absurdities")+ ] ''Perambulation++makeFieldLabelsFor [ ("_terrain", "allTerrain")+ , ("_dunes", "allTerrain")+ ] ''Perambulation++checkAllTerrain :: Traversal (Perambulation a b) (Perambulation a' b) a a'+checkAllTerrain = allTerrain++checkAllTerrain_ :: Traversal (Perambulation a b) (Perambulation a' b) a a'+checkAllTerrain_ = #allTerrain++checkAbsurdities :: Eq x => Fold (Perambulation a b) (x -> y)+checkAbsurdities = absurdities++data LensCrafted a = Still { _still :: a }+ | Works { _still :: a }+makeLenses ''LensCrafted+makeFieldLabelsWith lensRules ''LensCrafted++checkStill :: Lens (LensCrafted a) (LensCrafted b) a b+checkStill = still++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++makeFieldLabelsFor [ ("taskOutput", "output")+ , ("taskState", "state")+ , ("taskStop", "stop")+ ] ''Task++checkOutputLens :: Lens' (Task a) (a -> IO ())+checkOutputLens = outputLens++checkOutput_ :: Lens' (Task a) (a -> IO ())+checkOutput_ = #output++checkStateLens :: Lens' (Task a) a+checkStateLens = stateLens++checkState_ :: Lens' (Task a) a+checkState_ = #state++checkStopLens :: Lens' (Task a) (IO ())+checkStopLens = stopLens++checkStop_ :: Lens' (Task a) (IO ())+checkStop_ = #stop++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+makeFieldLabels ''Foo++checkFoo :: HasFoo t => Lens' t Foo+checkFoo = foo++checkFoo' :: Lens' Foo Foo+checkFoo' = foo++checkFooX :: HasFoo t => Lens' t Int+checkFooX = fooX++checkFooX_ :: Lens' Foo Int+checkFooX_ = #x++checkFooY :: HasFoo t => Lens' t Int+checkFooY = fooY++checkFooY_ :: Lens' Foo Int+checkFooY_ = #y++data Dude a = Dude+ { dudeLevel :: Int+ , dudeAlias :: String+ , dudeLife :: ()+ , dudeThing :: a+ }+makeFields ''Dude+makeFieldLabels ''Dude++checkLevel :: HasLevel t a => Lens' t a+checkLevel = level++checkLevel' :: Lens' (Dude a) Int+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++checkAlias_ :: Lens' (Dude a) String+checkAlias_ = #alias++checkLife :: HasLife t a => Lens' t a+checkLife = life++checkLife' :: Lens' (Dude 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++checkThing_ :: Lens (Dude a) (Dude b) a b+checkThing_ = #thing++data Lebowski a = Lebowski+ { _lebowskiAlias :: String+ , _lebowskiLife :: Int+ , _lebowskiMansion :: String+ , _lebowskiThing :: Maybe a+ }+makeFields ''Lebowski+makeFieldLabels ''Lebowski++checkAlias2 :: Lens' (Lebowski a) String+checkAlias2 = alias++checkAlias2_ :: Lens' (Lebowski a) String+checkAlias2_ = #alias++checkLife2 :: Lens' (Lebowski a) Int+checkLife2 = life++checkLife2_ :: Lens' (Lebowski a) Int+checkLife2_ = #life++checkMansion :: HasMansion t a => Lens' t a+checkMansion = mansion++checkMansion' :: Lens' (Lebowski a) String+checkMansion' = mansion++checkMansion_ :: Lens' (Lebowski a) String+checkMansion_ = #mansion++checkThing2 :: Lens' (Lebowski a) (Maybe a)+checkThing2 = thing++checkThing2_ :: Lens (Lebowski a) (Lebowski b) (Maybe a) (Maybe b)+checkThing2_ = #thing++type family Fam a+type instance Fam Int = String++data FamRec1 a = FamRec1 { _famRec1Thing :: a -> Fam a }+makeFieldLabels ''FamRec1++checkFamRec1Thing :: Iso (FamRec1 a) (FamRec1 b) (a -> Fam a) (b -> Fam b)+checkFamRec1Thing = #thing++data FamRec a = FamRec+ { _famRecThing :: Fam a+ , _famRecUniqueToFamRec :: Fam a+ }+makeFields ''FamRec+makeFieldLabels ''FamRec++checkFamRecThing :: Lens' (FamRec a) (Fam a)+checkFamRecThing = thing++checkFamRecThing_ :: Lens' (FamRec a) (Fam a)+checkFamRecThing_ = #thing++checkFamRecUniqueToFamRec :: Lens' (FamRec a) (Fam a)+checkFamRecUniqueToFamRec = uniqueToFamRec++checkFamRecUniqueToFamRec_ :: Lens' (FamRec a) (Fam a)+checkFamRecUniqueToFamRec_ = #uniqueToFamRec++checkFamRecView :: FamRec Int -> String+checkFamRecView = view thing++checkFamRecView_ :: FamRec Int -> String+checkFamRecView_ = view #thing++data AbideConfiguration a = AbideConfiguration+ { _acLocation :: String+ , _acDuration :: Int+ , _acThing :: a+ }+makeLensesWith abbreviatedFields ''AbideConfiguration+makeFieldLabelsWith abbreviatedFieldLabels ''AbideConfiguration++checkLocation :: HasLocation t a => Lens' t a+checkLocation = location++checkLocation' :: Lens' (AbideConfiguration a) String+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++checkDuration_ :: Lens' (AbideConfiguration a) Int+checkDuration_ = #duration++checkThing3 :: Lens' (AbideConfiguration a) a+checkThing3 = thing++checkThing3_ :: Lens (AbideConfiguration a) (AbideConfiguration b) a b+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++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 :: AffineTraversal' (Quark1 a) a+checkTape1 = tape1++declareFieldLabels [d|+ data Quark2 a = Qualified2 { gaffer2 :: a }+ | Unqualified2 { gaffer2 :: a, tape2 :: a }+ |]++checkGaffer2 :: Lens' (Quark2 a) a+checkGaffer2 = #gaffer2++checkTape2 :: AffineTraversal' (Quark2 a) a+checkTape2 = #tape2++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++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++declareFieldLabels [d|+ data instance Family Char (a, b) a = FamilyChar { fm0 :: (b, a), fm1 :: Char }+ |]++checkFm0_ :: Lens (Family Char (a, b) a) (Family Char (a', b') a') (b, a) (b', a')+checkFm0_ = #fm0++checkFm1_ :: Lens' (Family Char (a, b) a) Char+checkFm1_ = #fm1++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++declareFieldLabels [d|+ instance Class Double where+ data Associated Double = AssociatedDouble { coffee :: Double }+ method = floor+ |]++-- instance Class Double where+-- data Associated Double = AssociatedDouble Double+-- method = floor++checkCoffee :: Iso' (Associated Double) Double+checkCoffee = #coffee++declareFields [d|+ data DeclaredFields f a+ = DeclaredField1 { declaredFieldsA0 :: f a , declaredFieldsB0 :: Int }+ | DeclaredField2 { declaredFieldsC0 :: String , declaredFieldsB0 :: Int }+ deriving (Show)+ |]++checkA0 :: HasA0 t a => AffineTraversal' t a+checkA0 = a0++checkB0 :: HasB0 t a => Lens' t a+checkB0 = b0++checkC0 :: HasC0 t a => AffineTraversal' t a+checkC0 = c0++checkA0' :: AffineTraversal' (DeclaredFields f a) (f a)+checkA0' = a0++checkB0' :: Lens' (DeclaredFields f a) Int+checkB0' = b0++checkC0' :: AffineTraversal' (DeclaredFields f a) String+checkC0' = c0++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+makeFieldLabelsWith lensRules ''Rank2Tests -- doesn't generate anything++checkR2length :: Getter Rank2Tests ([a] -> Int)+checkR2length = r2length++checkR2nub :: Eq a => AffineFold Rank2Tests ([a] -> [a])+checkR2nub = r2nub++data PureNoFields = PureNoFieldsA | PureNoFieldsB { _pureNoFields :: Int }+makeLenses ''PureNoFields+makeFieldLabels ''PureNoFields++data ReviewTest where+ ReviewTest :: (Typeable a, Typeable b) => a -> b -> ReviewTest+makePrisms ''ReviewTest+makePrismLabels ''ReviewTest -- doesn't generate anything++checkReviewTest :: (Typeable a, Typeable b) => Review ReviewTest (a, b)+checkReviewTest = _ReviewTest++-- test FieldNamers++data CheckUnderscoreNoPrefixNamer = CheckUnderscoreNoPrefixNamer+ { _fieldUnderscoreNoPrefix :: Int }+makeLensesWith (lensRules & lensField .~ underscoreNoPrefixNamer ) ''CheckUnderscoreNoPrefixNamer+checkUnderscoreNoPrefixNamer :: Iso' 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 :: Iso' CheckMappingNamer String+checkMappingNamer = hogehoge_fieldMappingNamer++data CheckLookingupNamer = CheckLookingupNamer+ { fieldLookingupNamer :: Int }+makeLensesWith (lensRules & lensField .~ (lookingupNamer [("fieldLookingupNamer", "foobarFieldLookingupNamer")])) ''CheckLookingupNamer+checkLookingupNamer :: Iso' 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++main :: IO ()+main = putStrLn "optics-th-tests: ok"
+ tests/Optics/TH/Tests/T799.hs view
@@ -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 Optics.TH.Tests.T799 where++import Optics.Lens+import Optics.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