diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/optics-th.cabal b/optics-th.cabal new file mode 100644 --- /dev/null +++ b/optics-th.cabal @@ -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 diff --git a/src/Language/Haskell/TH/Optics/Internal.hs b/src/Language/Haskell/TH/Optics/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Optics/Internal.hs @@ -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 diff --git a/src/Optics/TH.hs b/src/Optics/TH.hs new file mode 100644 --- /dev/null +++ b/src/Optics/TH.hs @@ -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) diff --git a/src/Optics/TH/Internal/Product.hs b/src/Optics/TH/Internal/Product.hs new file mode 100644 --- /dev/null +++ b/src/Optics/TH/Internal/Product.hs @@ -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 diff --git a/src/Optics/TH/Internal/Sum.hs b/src/Optics/TH/Internal/Sum.hs new file mode 100644 --- /dev/null +++ b/src/Optics/TH/Internal/Sum.hs @@ -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 <> <> +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 <> <> +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 <> | r -> <> 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 = <> +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 diff --git a/src/Optics/TH/Internal/Utils.hs b/src/Optics/TH/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Optics/TH/Internal/Utils.hs @@ -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] diff --git a/tests/Optics/TH/Tests.hs b/tests/Optics/TH/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Optics/TH/Tests.hs @@ -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" diff --git a/tests/Optics/TH/Tests/T799.hs b/tests/Optics/TH/Tests/T799.hs new file mode 100644 --- /dev/null +++ b/tests/Optics/TH/Tests/T799.hs @@ -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