{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
#ifdef TRUSTWORTHY
# if MIN_VERSION_template_haskell(2,12,0)
{-# LANGUAGE Safe #-}
# else
{-# LANGUAGE Trustworthy #-}
# endif
#endif
module Control.Lens.Internal.FieldTH
( LensRules(..)
, FieldNamer
, DefName(..)
, ClassyNamer
, makeFieldOptics
, makeFieldOpticsForDec
, makeFieldOpticsForDec'
, HasFieldClasses
) where
import Prelude ()
import Control.Lens.At
import Control.Lens.Fold
import Control.Lens.Indexed
import Control.Lens.Internal.TH
import Control.Lens.Internal.Prelude
import Control.Lens.Lens
import Control.Lens.Plated
import Control.Lens.Prism
import Control.Lens.Setter
import Control.Lens.Getter
import Control.Lens.Tuple
import Control.Lens.Traversal
import Control.Monad
import Control.Monad.State
import Language.Haskell.TH.Lens
import Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import qualified Language.Haskell.TH.Datatype.TyVarBndr as D
import Data.Maybe (fromMaybe,isJust,maybeToList)
import Data.List (nub)
import Data.Either (partitionEithers)
import Data.Semigroup (Any (..))
import Data.Set.Lens
import Data.Map ( Map )
import Data.Set ( Set )
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Traversable as T
makeFieldOptics :: LensRules -> Name -> DecsQ
makeFieldOptics :: LensRules -> Name -> DecsQ
makeFieldOptics LensRules
rules = (StateT (Set Name) Q [Dec] -> Set Name -> DecsQ
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Set Name
forall a. Set a
Set.empty) (StateT (Set Name) Q [Dec] -> DecsQ)
-> (DatatypeInfo -> StateT (Set Name) Q [Dec])
-> DatatypeInfo
-> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules (DatatypeInfo -> DecsQ)
-> (Name -> Q DatatypeInfo) -> Name -> DecsQ
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q DatatypeInfo
D.reifyDatatype
makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ
makeFieldOpticsForDec :: LensRules -> Dec -> DecsQ
makeFieldOpticsForDec LensRules
rules = (StateT (Set Name) Q [Dec] -> Set Name -> DecsQ
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Set Name
forall a. Set a
Set.empty) (StateT (Set Name) Q [Dec] -> DecsQ)
-> (Dec -> StateT (Set Name) Q [Dec]) -> Dec -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensRules -> Dec -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDec' LensRules
rules
makeFieldOpticsForDec' :: LensRules -> Dec -> HasFieldClasses [Dec]
makeFieldOpticsForDec' :: LensRules -> Dec -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDec' LensRules
rules = LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules (DatatypeInfo -> StateT (Set Name) Q [Dec])
-> (Dec -> StateT (Set Name) Q DatatypeInfo)
-> Dec
-> StateT (Set Name) Q [Dec]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Q DatatypeInfo -> StateT (Set Name) Q DatatypeInfo
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q DatatypeInfo -> StateT (Set Name) Q DatatypeInfo)
-> (Dec -> Q DatatypeInfo)
-> Dec
-> StateT (Set Name) Q DatatypeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> Q DatatypeInfo
D.normalizeDec
makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec]
makeFieldOpticsForDatatype :: LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules DatatypeInfo
info =
do Map
DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
perDef <- Q (Map
DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT
(Set Name)
Q
(Map
DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Map
DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT
(Set Name)
Q
(Map
DefName
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])))
-> Q (Map
DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT
(Set Name)
Q
(Map
DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall a b. (a -> b) -> a -> b
$ do
[(Name, [(Maybe Name, Type)])]
fieldCons <- (ConstructorInfo -> Q (Name, [(Maybe Name, Type)]))
-> [ConstructorInfo] -> Q [(Name, [(Maybe Name, Type)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor [ConstructorInfo]
cons
let allFields :: [Name]
allFields = Getting (Endo [Name]) [(Name, [(Maybe Name, Type)])] Name
-> [(Name, [(Maybe Name, Type)])] -> [Name]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (((Name, [(Maybe Name, Type)])
-> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> [(Name, [(Maybe Name, Type)])]
-> Const (Endo [Name]) [(Name, [(Maybe Name, Type)])]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded (((Name, [(Maybe Name, Type)])
-> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> [(Name, [(Maybe Name, Type)])]
-> Const (Endo [Name]) [(Name, [(Maybe Name, Type)])])
-> ((Name -> Const (Endo [Name]) Name)
-> (Name, [(Maybe Name, Type)])
-> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> Getting (Endo [Name]) [(Name, [(Maybe Name, Type)])] Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)])
-> (Name, [(Maybe Name, Type)])
-> Const (Endo [Name]) (Name, [(Maybe Name, Type)])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)])
-> (Name, [(Maybe Name, Type)])
-> Const (Endo [Name]) (Name, [(Maybe Name, Type)]))
-> ((Name -> Const (Endo [Name]) Name)
-> [(Maybe Name, Type)]
-> Const (Endo [Name]) [(Maybe Name, Type)])
-> (Name -> Const (Endo [Name]) Name)
-> (Name, [(Maybe Name, Type)])
-> Const (Endo [Name]) (Name, [(Maybe Name, Type)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> [(Maybe Name, Type)] -> Const (Endo [Name]) [(Maybe Name, Type)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded (((Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> [(Maybe Name, Type)]
-> Const (Endo [Name]) [(Maybe Name, Type)])
-> ((Name -> Const (Endo [Name]) Name)
-> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> (Name -> Const (Endo [Name]) Name)
-> [(Maybe Name, Type)]
-> Const (Endo [Name]) [(Maybe Name, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Name -> Const (Endo [Name]) (Maybe Name))
-> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((Maybe Name -> Const (Endo [Name]) (Maybe Name))
-> (Maybe Name, Type) -> Const (Endo [Name]) (Maybe Name, Type))
-> ((Name -> Const (Endo [Name]) Name)
-> Maybe Name -> Const (Endo [Name]) (Maybe Name))
-> (Name -> Const (Endo [Name]) Name)
-> (Maybe Name, Type)
-> Const (Endo [Name]) (Maybe Name, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const (Endo [Name]) Name)
-> Maybe Name -> Const (Endo [Name]) (Maybe Name)
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded) [(Name, [(Maybe Name, Type)])]
fieldCons
let defCons :: [(Name, [([(DefName, Maybe Name)], Type)])]
defCons = ASetter
[(Name, [(Maybe Name, Type)])]
[(Name, [([(DefName, Maybe Name)], Type)])]
(Maybe Name)
[(DefName, Maybe Name)]
-> (Maybe Name -> [(DefName, Maybe Name)])
-> [(Name, [(Maybe Name, Type)])]
-> [(Name, [([(DefName, Maybe Name)], Type)])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
[(Name, [(Maybe Name, Type)])]
[(Name, [([(DefName, Maybe Name)], Type)])]
(Maybe Name)
[(DefName, Maybe Name)]
forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels ([Name] -> Maybe Name -> [(DefName, Maybe Name)]
expandName [Name]
allFields) [(Name, [(Maybe Name, Type)])]
fieldCons
allDefs :: Set DefName
allDefs = Getting
(Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])] DefName
-> [(Name, [([(DefName, Maybe Name)], Type)])] -> Set DefName
forall a s. Getting (Set a) s a -> s -> Set a
setOf (([(DefName, Maybe Name)]
-> Const (Set DefName) [(DefName, Maybe Name)])
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> Const (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])]
forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels (([(DefName, Maybe Name)]
-> Const (Set DefName) [(DefName, Maybe Name)])
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> Const (Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])])
-> ((DefName -> Const (Set DefName) DefName)
-> [(DefName, Maybe Name)]
-> Const (Set DefName) [(DefName, Maybe Name)])
-> Getting
(Set DefName) [(Name, [([(DefName, Maybe Name)], Type)])] DefName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DefName, Maybe Name)
-> Const (Set DefName) (DefName, Maybe Name))
-> [(DefName, Maybe Name)]
-> Const (Set DefName) [(DefName, Maybe Name)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded (((DefName, Maybe Name)
-> Const (Set DefName) (DefName, Maybe Name))
-> [(DefName, Maybe Name)]
-> Const (Set DefName) [(DefName, Maybe Name)])
-> ((DefName -> Const (Set DefName) DefName)
-> (DefName, Maybe Name)
-> Const (Set DefName) (DefName, Maybe Name))
-> (DefName -> Const (Set DefName) DefName)
-> [(DefName, Maybe Name)]
-> Const (Set DefName) [(DefName, Maybe Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefName -> Const (Set DefName) DefName)
-> (DefName, Maybe Name)
-> Const (Set DefName) (DefName, Maybe Name)
forall s t a b. Field1 s t a b => Lens s t a b
_1) [(Name, [([(DefName, Maybe Name)], Type)])]
defCons
Map
DefName
(Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Q (Map
DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA ((DefName
-> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Set DefName
-> Map
DefName
(Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (LensRules
-> Type
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
buildScaffold LensRules
rules Type
s [(Name, [([(DefName, Maybe Name)], Type)])]
defCons) Set DefName
allDefs)
let defs :: [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs = Map
DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
DefName (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
perDef
case LensRules -> ClassyNamer
_classyLenses LensRules
rules Name
tyName of
Just (Name
className, Name
methodName) ->
LensRules
-> Name
-> Name
-> Type
-> [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
Maybe (Name, Name)
Nothing -> do [[Dec]]
decss <- ((DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT (Set Name) Q [Dec])
-> [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LensRules
-> (DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules) [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
[Dec] -> StateT (Set Name) Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decss)
where
tyName :: Name
tyName = DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info
s :: Type
s = DatatypeInfo -> Type
datatypeTypeKinded DatatypeInfo
info
cons :: [ConstructorInfo]
cons = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info
normFieldLabels :: Traversal [(Name,[(a,Type)])] [(Name,[(b,Type)])] a b
normFieldLabels :: (a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
normFieldLabels = ((Name, [(a, Type)]) -> f (Name, [(b, Type)]))
-> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Name, [(a, Type)]) -> f (Name, [(b, Type)]))
-> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])])
-> ((a -> f b) -> (Name, [(a, Type)]) -> f (Name, [(b, Type)]))
-> (a -> f b)
-> [(Name, [(a, Type)])]
-> f [(Name, [(b, Type)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(a, Type)] -> f [(b, Type)])
-> (Name, [(a, Type)]) -> f (Name, [(b, Type)])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([(a, Type)] -> f [(b, Type)])
-> (Name, [(a, Type)]) -> f (Name, [(b, Type)]))
-> ((a -> f b) -> [(a, Type)] -> f [(b, Type)])
-> (a -> f b)
-> (Name, [(a, Type)])
-> f (Name, [(b, Type)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Type) -> f (b, Type)) -> [(a, Type)] -> f [(b, Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((a, Type) -> f (b, Type)) -> [(a, Type)] -> f [(b, Type)])
-> ((a -> f b) -> (a, Type) -> f (b, Type))
-> (a -> f b)
-> [(a, Type)]
-> f [(b, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> (a, Type) -> f (b, Type)
forall s t a b. Field1 s t a b => Lens s t a b
_1
expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)]
expandName :: [Name] -> Maybe Name -> [(DefName, Maybe Name)]
expandName [Name]
allFields Maybe Name
mName = (\DefName
x -> (DefName
x, Maybe Name
mName)) (DefName -> (DefName, Maybe Name))
-> [DefName] -> [(DefName, Maybe Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList Maybe Name
mName [Name] -> (Name -> [DefName]) -> [DefName]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LensRules -> FieldNamer
_fieldToDef LensRules
rules Name
tyName [Name]
allFields)
normalizeConstructor ::
D.ConstructorInfo ->
Q (Name, [(Maybe Name, Type)])
normalizeConstructor :: ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor ConstructorInfo
con =
(Name, [(Maybe Name, Type)]) -> Q (Name, [(Maybe Name, Type)])
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorInfo -> Name
D.constructorName ConstructorInfo
con,
(Maybe Name -> Type -> (Maybe Name, Type))
-> [Maybe Name] -> [Type] -> [(Maybe Name, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe Name -> Type -> (Maybe Name, Type)
forall s a. HasTypeVars s => Maybe a -> s -> (Maybe a, s)
checkForExistentials [Maybe Name]
fieldNames (ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
con))
where
fieldNames :: [Maybe Name]
fieldNames =
case ConstructorInfo -> ConstructorVariant
D.constructorVariant ConstructorInfo
con of
D.RecordConstructor [Name]
xs -> (Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Maybe Name
forall a. a -> Maybe a
Just [Name]
xs
ConstructorVariant
D.NormalConstructor -> Maybe Name -> [Maybe Name]
forall a. a -> [a]
repeat Maybe Name
forall a. Maybe a
Nothing
ConstructorVariant
D.InfixConstructor -> Maybe Name -> [Maybe Name]
forall a. a -> [a]
repeat Maybe Name
forall a. Maybe a
Nothing
checkForExistentials :: Maybe a -> s -> (Maybe a, s)
checkForExistentials Maybe a
_ s
fieldtype
| (TyVarBndr_ Any -> Bool) -> [TyVarBndr_ Any] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TyVarBndr_ Any
tv -> TyVarBndr_ Any -> Name
forall flag. TyVarBndr_ Any -> Name
D.tvName TyVarBndr_ Any
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
used) [TyVarBndr_ Any]
unallowable
= (Maybe a
forall a. Maybe a
Nothing, s
fieldtype)
where
used :: Set Name
used = Getting (Set Name) s Name -> s -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) s Name
forall t. HasTypeVars t => Traversal' t Name
typeVars s
fieldtype
unallowable :: [TyVarBndr_ Any]
unallowable = ConstructorInfo -> [TyVarBndr_ Any]
D.constructorVars ConstructorInfo
con
checkForExistentials Maybe a
fieldname s
fieldtype = (Maybe a
fieldname, s
fieldtype)
data OpticType = GetterType | LensType | IsoType
buildScaffold ::
LensRules ->
Type ->
[(Name, [([(DefName, Maybe Name)], Type)])] ->
DefName ->
Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
buildScaffold :: LensRules
-> Type
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
buildScaffold LensRules
rules Type
s [(Name, [([(DefName, Maybe Name)], Type)])]
cons DefName
defName =
do (Type
s',Type
t,Type
a,Type
b) <- Type -> [Either Type Type] -> Q (Type, Type, Type, Type)
buildStab Type
s (((Name, [Either Type Type]) -> [Either Type Type])
-> [(Name, [Either Type Type])] -> [Either Type Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [Either Type Type]) -> [Either Type Type]
forall a b. (a, b) -> b
snd ([(Name, [Either Type (Maybe Name, Type)])]
consForDef [(Name, [Either Type (Maybe Name, Type)])]
-> ((Name, [Either Type (Maybe Name, Type)])
-> (Name, [Either Type Type]))
-> [(Name, [Either Type Type])]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
-> (Name, [Either Type (Maybe Name, Type)])
-> Identity (Name, [Either Type Type])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
-> (Name, [Either Type (Maybe Name, Type)])
-> Identity (Name, [Either Type Type]))
-> (((Maybe Name, Type) -> Identity Type)
-> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
-> ((Maybe Name, Type) -> Identity Type)
-> (Name, [Either Type (Maybe Name, Type)])
-> Identity (Name, [Either Type Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Type (Maybe Name, Type) -> Identity (Either Type Type))
-> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type]
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped ((Either Type (Maybe Name, Type) -> Identity (Either Type Type))
-> [Either Type (Maybe Name, Type)] -> Identity [Either Type Type])
-> (((Maybe Name, Type) -> Identity Type)
-> Either Type (Maybe Name, Type) -> Identity (Either Type Type))
-> ((Maybe Name, Type) -> Identity Type)
-> [Either Type (Maybe Name, Type)]
-> Identity [Either Type Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Name, Type) -> Identity Type)
-> Either Type (Maybe Name, Type) -> Identity (Either Type Type)
forall c a b. Prism (Either c a) (Either c b) a b
_Right (((Maybe Name, Type) -> Identity Type)
-> (Name, [Either Type (Maybe Name, Type)])
-> Identity (Name, [Either Type Type]))
-> ((Maybe Name, Type) -> Type)
-> (Name, [Either Type (Maybe Name, Type)])
-> (Name, [Either Type Type])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Maybe Name, Type) -> Type
forall a b. (a, b) -> b
snd))
let defType :: OpticStab
defType
| Just ([TyVarBndr_ Any]
_,[Type]
cx,Type
a') <- Getting
(First ([TyVarBndr_ Any], [Type], Type))
Type
([TyVarBndr_ Any], [Type], Type)
-> Type -> Maybe ([TyVarBndr_ Any], [Type], Type)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting
(First ([TyVarBndr_ Any], [Type], Type))
Type
([TyVarBndr_ Any], [Type], Type)
Prism' Type ([TyVarBndr_ Any], [Type], Type)
_ForallT Type
a =
let optic :: Name
optic | Bool
lensCase = Name
getterTypeName
| Bool
otherwise = Name
foldTypeName
in [Type] -> Name -> Type -> Type -> OpticStab
OpticSa [Type]
cx Name
optic Type
s' Type
a'
| Bool -> Bool
not (LensRules -> Bool
_allowUpdates LensRules
rules) =
let optic :: Name
optic | Bool
lensCase = Name
getterTypeName
| Bool
otherwise = Name
foldTypeName
in [Type] -> Name -> Type -> Type -> OpticStab
OpticSa [] Name
optic Type
s' Type
a
| LensRules -> Bool
_simpleLenses LensRules
rules Bool -> Bool -> Bool
|| Type
s' Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t Bool -> Bool -> Bool
&& Type
a Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
b =
let optic :: Name
optic | Bool
isoCase Bool -> Bool -> Bool
&& LensRules -> Bool
_allowIsos LensRules
rules = Name
iso'TypeName
| Bool
lensCase = Name
lens'TypeName
| Bool
otherwise = Name
traversal'TypeName
in [Type] -> Name -> Type -> Type -> OpticStab
OpticSa [] Name
optic Type
s' Type
a
| Bool
otherwise =
let optic :: Name
optic | Bool
isoCase Bool -> Bool -> Bool
&& LensRules -> Bool
_allowIsos LensRules
rules = Name
isoTypeName
| Bool
lensCase = Name
lensTypeName
| Bool
otherwise = Name
traversalTypeName
in Name -> Type -> Type -> Type -> Type -> OpticStab
OpticStab Name
optic Type
s' Type
t Type
a Type
b
opticType :: OpticType
opticType | Getting Any Type ([TyVarBndr_ Any], [Type], Type) -> Type -> Bool
forall s a. Getting Any s a -> s -> Bool
has Getting Any Type ([TyVarBndr_ Any], [Type], Type)
Prism' Type ([TyVarBndr_ Any], [Type], Type)
_ForallT Type
a = OpticType
GetterType
| Bool -> Bool
not (LensRules -> Bool
_allowUpdates LensRules
rules) = OpticType
GetterType
| Bool
isoCase = OpticType
IsoType
| Bool
otherwise = OpticType
LensType
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> Q (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticType
opticType, OpticStab
defType, [(Name, Int, [(Maybe Name, Int)])]
scaffolds)
where
consForDef :: [(Name, [Either Type (Maybe Name, Type)])]
consForDef :: [(Name, [Either Type (Maybe Name, Type)])]
consForDef = ASetter
[(Name, [([(DefName, Maybe Name)], Type)])]
[(Name, [Either Type (Maybe Name, Type)])]
([(DefName, Maybe Name)], Type)
(Either Type (Maybe Name, Type))
-> (([(DefName, Maybe Name)], Type)
-> Either Type (Maybe Name, Type))
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> [(Name, [Either Type (Maybe Name, Type)])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Name, [([(DefName, Maybe Name)], Type)])
-> Identity (Name, [Either Type (Maybe Name, Type)]))
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> Identity [(Name, [Either Type (Maybe Name, Type)])]
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((Name, [([(DefName, Maybe Name)], Type)])
-> Identity (Name, [Either Type (Maybe Name, Type)]))
-> [(Name, [([(DefName, Maybe Name)], Type)])]
-> Identity [(Name, [Either Type (Maybe Name, Type)])])
-> ((([(DefName, Maybe Name)], Type)
-> Identity (Either Type (Maybe Name, Type)))
-> (Name, [([(DefName, Maybe Name)], Type)])
-> Identity (Name, [Either Type (Maybe Name, Type)]))
-> ASetter
[(Name, [([(DefName, Maybe Name)], Type)])]
[(Name, [Either Type (Maybe Name, Type)])]
([(DefName, Maybe Name)], Type)
(Either Type (Maybe Name, Type))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([([(DefName, Maybe Name)], Type)]
-> Identity [Either Type (Maybe Name, Type)])
-> (Name, [([(DefName, Maybe Name)], Type)])
-> Identity (Name, [Either Type (Maybe Name, Type)])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([([(DefName, Maybe Name)], Type)]
-> Identity [Either Type (Maybe Name, Type)])
-> (Name, [([(DefName, Maybe Name)], Type)])
-> Identity (Name, [Either Type (Maybe Name, Type)]))
-> ((([(DefName, Maybe Name)], Type)
-> Identity (Either Type (Maybe Name, Type)))
-> [([(DefName, Maybe Name)], Type)]
-> Identity [Either Type (Maybe Name, Type)])
-> (([(DefName, Maybe Name)], Type)
-> Identity (Either Type (Maybe Name, Type)))
-> (Name, [([(DefName, Maybe Name)], Type)])
-> Identity (Name, [Either Type (Maybe Name, Type)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(DefName, Maybe Name)], Type)
-> Identity (Either Type (Maybe Name, Type)))
-> [([(DefName, Maybe Name)], Type)]
-> Identity [Either Type (Maybe Name, Type)]
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
categorize [(Name, [([(DefName, Maybe Name)], Type)])]
cons
scaffolds :: [(Name, Int, [(Maybe Name, Int)])]
scaffolds :: [(Name, Int, [(Maybe Name, Int)])]
scaffolds = [ (Name
n, [Either Type (Maybe Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Type (Maybe Name, Type)]
ts, (\(Int
a, Maybe Name
b) -> (Maybe Name
b, Int
a)) ((Int, Maybe Name) -> (Maybe Name, Int))
-> [(Int, Maybe Name)] -> [(Maybe Name, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either Type (Maybe Name, Type)]
ts [Either Type (Maybe Name, Type)]
-> IndexedGetting
Int
(Endo [(Int, Maybe Name)])
[Either Type (Maybe Name, Type)]
(Maybe Name)
-> [(Int, Maybe Name)]
forall s i a. s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]
^@.. Indexed
Int
(Either Type (Maybe Name, Type))
(Const (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
-> [Either Type (Maybe Name, Type)]
-> Const
(Endo [(Int, Maybe Name)]) [Either Type (Maybe Name, Type)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded (Indexed
Int
(Either Type (Maybe Name, Type))
(Const (Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
-> [Either Type (Maybe Name, Type)]
-> Const
(Endo [(Int, Maybe Name)]) [Either Type (Maybe Name, Type)])
-> ((Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
-> Either Type (Maybe Name, Type)
-> Const
(Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
-> IndexedGetting
Int
(Endo [(Int, Maybe Name)])
[Either Type (Maybe Name, Type)]
(Maybe Name)
forall i (p :: * -> * -> *) s t r a b.
Indexable i p =>
(Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
<. ((Maybe Name, Type)
-> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
-> Either Type (Maybe Name, Type)
-> Const
(Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type))
forall c a b. Prism (Either c a) (Either c b) a b
_Right (((Maybe Name, Type)
-> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
-> Either Type (Maybe Name, Type)
-> Const
(Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type)))
-> ((Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
-> (Maybe Name, Type)
-> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type))
-> (Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
-> Either Type (Maybe Name, Type)
-> Const
(Endo [(Int, Maybe Name)]) (Either Type (Maybe Name, Type))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Name -> Const (Endo [(Int, Maybe Name)]) (Maybe Name))
-> (Maybe Name, Type)
-> Const (Endo [(Int, Maybe Name)]) (Maybe Name, Type)
forall s t a b. Field1 s t a b => Lens s t a b
_1) | (Name
n,[Either Type (Maybe Name, Type)]
ts) <- [(Name, [Either Type (Maybe Name, Type)])]
consForDef ]
categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
categorize :: ([(DefName, Maybe Name)], Type) -> Either Type (Maybe Name, Type)
categorize ([(DefName, Maybe Name)]
defNames, Type
t) =
case DefName -> [(DefName, Maybe Name)] -> Maybe (Maybe Name)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup DefName
defName [(DefName, Maybe Name)]
defNames of
Just Maybe Name
c -> (Maybe Name, Type) -> Either Type (Maybe Name, Type)
forall a b. b -> Either a b
Right (Maybe Name
c, Type
t)
Maybe (Maybe Name)
Nothing -> Type -> Either Type (Maybe Name, Type)
forall a b. a -> Either a b
Left Type
t
lensCase :: Bool
lensCase :: Bool
lensCase = ((Name, [Either Type (Maybe Name, Type)]) -> Bool)
-> [(Name, [Either Type (Maybe Name, Type)])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Name, [Either Type (Maybe Name, Type)])
x -> Getting
(Endo (Endo Int))
(Name, [Either Type (Maybe Name, Type)])
(Maybe Name, Type)
-> (Name, [Either Type (Maybe Name, Type)]) -> Int
forall s a. Getting (Endo (Endo Int)) s a -> s -> Int
lengthOf (([Either Type (Maybe Name, Type)]
-> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
-> (Name, [Either Type (Maybe Name, Type)])
-> Const (Endo (Endo Int)) (Name, [Either Type (Maybe Name, Type)])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([Either Type (Maybe Name, Type)]
-> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
-> (Name, [Either Type (Maybe Name, Type)])
-> Const
(Endo (Endo Int)) (Name, [Either Type (Maybe Name, Type)]))
-> (((Maybe Name, Type)
-> Const (Endo (Endo Int)) (Maybe Name, Type))
-> [Either Type (Maybe Name, Type)]
-> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
-> Getting
(Endo (Endo Int))
(Name, [Either Type (Maybe Name, Type)])
(Maybe Name, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Type (Maybe Name, Type)
-> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type)))
-> [Either Type (Maybe Name, Type)]
-> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded ((Either Type (Maybe Name, Type)
-> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type)))
-> [Either Type (Maybe Name, Type)]
-> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)])
-> (((Maybe Name, Type)
-> Const (Endo (Endo Int)) (Maybe Name, Type))
-> Either Type (Maybe Name, Type)
-> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type)))
-> ((Maybe Name, Type)
-> Const (Endo (Endo Int)) (Maybe Name, Type))
-> [Either Type (Maybe Name, Type)]
-> Const (Endo (Endo Int)) [Either Type (Maybe Name, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Name, Type) -> Const (Endo (Endo Int)) (Maybe Name, Type))
-> Either Type (Maybe Name, Type)
-> Const (Endo (Endo Int)) (Either Type (Maybe Name, Type))
forall c a b. Prism (Either c a) (Either c b) a b
_Right) (Name, [Either Type (Maybe Name, Type)])
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) [(Name, [Either Type (Maybe Name, Type)])]
consForDef
isoCase :: Bool
isoCase :: Bool
isoCase = case [(Name, Int, [(Maybe Name, Int)])]
scaffolds of
[(Name
_,Int
1,[(Maybe Name
_, Int
0)])] -> Bool
True
[(Name, Int, [(Maybe Name, Int)])]
_ -> Bool
False
data OpticStab = OpticStab Name Type Type Type Type
| OpticSa Cxt Name Type Type
stabToType :: OpticStab -> Type
stabToType :: OpticStab -> Type
stabToType (OpticStab Name
c Type
s Type
t Type
a Type
b) = [Type] -> Type -> Type
quantifyType [] (Name
c Name -> [Type] -> Type
`conAppsT` [Type
s,Type
t,Type
a,Type
b])
stabToType (OpticSa [Type]
cx Name
c Type
s Type
a ) = [Type] -> Type -> Type
quantifyType [Type]
cx (Name
c Name -> [Type] -> Type
`conAppsT` [Type
s,Type
a])
stabToContext :: OpticStab -> Cxt
stabToContext :: OpticStab -> [Type]
stabToContext OpticStab{} = []
stabToContext (OpticSa [Type]
cx Name
_ Type
_ Type
_) = [Type]
cx
stabToOptic :: OpticStab -> Name
stabToOptic :: OpticStab -> Name
stabToOptic (OpticStab Name
c Type
_ Type
_ Type
_ Type
_) = Name
c
stabToOptic (OpticSa [Type]
_ Name
c Type
_ Type
_) = Name
c
stabToS :: OpticStab -> Type
stabToS :: OpticStab -> Type
stabToS (OpticStab Name
_ Type
s Type
_ Type
_ Type
_) = Type
s
stabToS (OpticSa [Type]
_ Name
_ Type
s Type
_) = Type
s
stabToA :: OpticStab -> Type
stabToA :: OpticStab -> Type
stabToA (OpticStab Name
_ Type
_ Type
_ Type
a Type
_) = Type
a
stabToA (OpticSa [Type]
_ Name
_ Type
_ Type
a) = Type
a
buildStab :: Type -> [Either Type Type] -> Q (Type,Type,Type,Type)
buildStab :: Type -> [Either Type Type] -> Q (Type, Type, Type, Type)
buildStab Type
s [Either Type Type]
categorizedFields =
do (Map Name Type
subA,Type
a) <- [Type] -> Q (Map Name Type, Type)
unifyTypes [Type]
targetFields
let s' :: Type
s' = Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
subA Type
s
Map Name Name
sub <- Map Name (Q Name) -> Q (Map Name Name)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (String -> Q Name
newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Set Name
unfixedTypeVars)
let (Type
t,Type
b) = ASetter (Type, Type) (Type, Type) Type Type
-> (Type -> Type) -> (Type, Type) -> (Type, Type)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Type, Type) (Type, Type) Type Type
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (Map Name Name -> Type -> Type
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub) (Type
s',Type
a)
(Type, Type, Type, Type) -> Q (Type, Type, Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
s',Type
t,Type
a,Type
b)
where
([Type]
fixedFields, [Type]
targetFields) = [Either Type Type] -> ([Type], [Type])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Type Type]
categorizedFields
fixedTypeVars, unfixedTypeVars :: Set Name
fixedTypeVars :: Set Name
fixedTypeVars = Set Name -> Set Name
closeOverKinds (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$ Getting (Set Name) [Type] Name -> [Type] -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) [Type] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [Type]
fixedFields
unfixedTypeVars :: Set Name
unfixedTypeVars = Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Name
fixedTypeVars
kindVarsOfTvb :: D.TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb :: TyVarBndr_ Any -> (Name, Set Name)
kindVarsOfTvb = (Name -> (Name, Set Name))
-> (Name -> Type -> (Name, Set Name))
-> TyVarBndr_ Any
-> (Name, Set Name)
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ Any -> r
D.elimTV (\Name
n -> (Name
n, Set Name
forall a. Set a
Set.empty))
(\Name
n Type
k -> (Name
n, Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
k))
sKindVarMap :: Map Name (Set Name)
sKindVarMap :: Map Name (Set Name)
sKindVarMap = [(Name, Set Name)] -> Map Name (Set Name)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Set Name)] -> Map Name (Set Name))
-> [(Name, Set Name)] -> Map Name (Set Name)
forall a b. (a -> b) -> a -> b
$ (TyVarBndr_ Any -> (Name, Set Name))
-> [TyVarBndr_ Any] -> [(Name, Set Name)]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ Any -> (Name, Set Name)
forall flag. TyVarBndr_ Any -> (Name, Set Name)
kindVarsOfTvb ([TyVarBndr_ Any] -> [(Name, Set Name)])
-> [TyVarBndr_ Any] -> [(Name, Set Name)]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ Any]
D.freeVariablesWellScoped [Type
s]
lookupSKindVars :: Name -> Set Name
lookupSKindVars :: Name -> Set Name
lookupSKindVars Name
n = Set Name -> Maybe (Set Name) -> Set Name
forall a. a -> Maybe a -> a
fromMaybe Set Name
forall a. Set a
Set.empty (Maybe (Set Name) -> Set Name) -> Maybe (Set Name) -> Set Name
forall a b. (a -> b) -> a -> b
$ Name -> Map Name (Set Name) -> Maybe (Set Name)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (Set Name)
sKindVarMap
closeOverKinds :: Set Name -> Set Name
closeOverKinds :: Set Name -> Set Name
closeOverKinds Set Name
st = (Set Name -> Set Name -> Set Name)
-> Set Name -> Set (Set Name) -> Set Name
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Name
forall a. Set a
Set.empty ((Name -> Set Name) -> Set Name -> Set (Set Name)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name -> Set Name
lookupSKindVars Set Name
st) Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Name
st
makeFieldOptic ::
LensRules ->
(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])) ->
HasFieldClasses [Dec]
makeFieldOptic :: LensRules
-> (DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules (DefName
defName, (OpticType
opticType, OpticStab
defType, [(Name, Int, [(Maybe Name, Int)])]
cons)) = do
Set Name
locals <- StateT (Set Name) Q (Set Name)
forall s (m :: * -> *). MonadState s m => m s
get
HasFieldClasses ()
addName
DecsQ -> StateT (Set Name) Q [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DecsQ -> StateT (Set Name) Q [Dec])
-> DecsQ -> StateT (Set Name) Q [Dec]
forall a b. (a -> b) -> a -> b
$ do [DecQ]
cls <- Set Name -> Q [DecQ]
mkCls Set Name
locals
[DecQ] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA ([DecQ]
cls [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++ [DecQ]
sig [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++ [DecQ]
def)
where
mkCls :: Set Name -> Q [DecQ]
mkCls Set Name
locals = case DefName
defName of
MethodName Name
c Name
n | LensRules -> Bool
_generateClasses LensRules
rules ->
do Bool
classExists <- Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Name -> Bool) -> Q (Maybe Name) -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupTypeName (Name -> String
forall a. Show a => a -> String
show Name
c)
[DecQ] -> Q [DecQ]
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
classExists Bool -> Bool -> Bool
|| Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
c Set Name
locals then [] else [OpticStab -> Name -> Name -> DecQ
makeFieldClass OpticStab
defType Name
c Name
n])
DefName
_ -> [DecQ] -> Q [DecQ]
forall (m :: * -> *) a. Monad m => a -> m a
return []
addName :: HasFieldClasses ()
addName = case DefName
defName of
MethodName Name
c Name
_ -> Name -> HasFieldClasses ()
addFieldClassName Name
c
DefName
_ -> () -> HasFieldClasses ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sig :: [DecQ]
sig = case DefName
defName of
DefName
_ | Bool -> Bool
not (LensRules -> Bool
_generateSigs LensRules
rules) -> []
TopName Name
n -> [Name -> TypeQ -> DecQ
sigD Name
n (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticStab -> Type
stabToType OpticStab
defType))]
MethodName{} -> []
fun :: Name -> [DecQ]
fun Name
n = Name -> [ClauseQ] -> DecQ
funD Name
n [ClauseQ]
clauses DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
: Name -> [DecQ]
inlinePragma Name
n
def :: [DecQ]
def = case DefName
defName of
TopName Name
n -> Name -> [DecQ]
fun Name
n
MethodName Name
c Name
n -> [OpticStab -> Name -> [DecQ] -> DecQ
makeFieldInstance OpticStab
defType Name
c (Name -> [DecQ]
fun Name
n)]
clauses :: [ClauseQ]
clauses = LensRules
-> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [ClauseQ]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [(Maybe Name, Int)])]
cons
makeClassyDriver ::
LensRules ->
Name ->
Name ->
Type ->
[(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] ->
HasFieldClasses [Dec]
makeClassyDriver :: LensRules
-> Name
-> Name
-> Type
-> [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs = [StateT (Set Name) Q Dec] -> StateT (Set Name) Q [Dec]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA ([StateT (Set Name) Q Dec]
cls [StateT (Set Name) Q Dec]
-> [StateT (Set Name) Q Dec] -> [StateT (Set Name) Q Dec]
forall a. [a] -> [a] -> [a]
++ [StateT (Set Name) Q Dec]
inst)
where
cls :: [StateT (Set Name) Q Dec]
cls | LensRules -> Bool
_generateClasses LensRules
rules = [DecQ -> StateT (Set Name) Q Dec
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DecQ -> StateT (Set Name) Q Dec)
-> DecQ -> StateT (Set Name) Q Dec
forall a b. (a -> b) -> a -> b
$ Name
-> Name
-> Type
-> [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> DecQ
makeClassyClass Name
className Name
methodName Type
s [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs]
| Bool
otherwise = []
inst :: [StateT (Set Name) Q Dec]
inst = [LensRules
-> Name
-> Name
-> Type
-> [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q Dec
makeClassyInstance LensRules
rules Name
className Name
methodName Type
s [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs]
makeClassyClass ::
Name ->
Name ->
Type ->
[(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] ->
DecQ
makeClassyClass :: Name
-> Name
-> Type
-> [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> DecQ
makeClassyClass Name
className Name
methodName Type
s [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs = do
let ss :: [Type]
ss = ((DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Type)
-> [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (OpticStab -> Type
stabToS (OpticStab -> Type)
-> ((DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> OpticStab)
-> (DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
OpticStab
(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
OpticStab
-> (DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> OpticStab
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (((OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> Const
OpticStab
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> (DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Const
OpticStab
(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
forall s t a b. Field2 s t a b => Lens s t a b
_2 (((OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> Const
OpticStab
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> (DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Const
OpticStab
(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])))
-> ((OpticStab -> Const OpticStab OpticStab)
-> (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> Const
OpticStab
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> Getting
OpticStab
(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
OpticStab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OpticStab -> Const OpticStab OpticStab)
-> (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
-> Const
OpticStab
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])])
forall s t a b. Field2 s t a b => Lens s t a b
_2)) [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
(Map Name Type
sub,Type
s') <- [Type] -> Q (Map Name Type, Type)
unifyTypes (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ss)
Name
c <- String -> Q Name
newName String
"c"
let vars :: [TyVarBndr_ Any]
vars = () -> [TyVarBndr_ Any] -> [TyVarBndr_ Any]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ Any] -> [TyVarBndr_ Any]
D.changeTVFlags ()
bndrReq ([TyVarBndr_ Any] -> [TyVarBndr_ Any])
-> [TyVarBndr_ Any] -> [TyVarBndr_ Any]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ Any]
D.freeVariablesWellScoped [Type
s']
varNames :: [Name]
varNames = (TyVarBndr_ Any -> Name) -> [TyVarBndr_ Any] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ Any -> Name
forall flag. TyVarBndr_ Any -> Name
D.tvName [TyVarBndr_ Any]
vars
fd :: [FunDep]
fd | [TyVarBndr_ Any] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr_ Any]
vars = []
| Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
c] [Name]
varNames]
CxtQ -> Name -> [TyVarBndr_ Any] -> [FunDep] -> [DecQ] -> DecQ
classD ([TypeQ] -> CxtQ
cxt[]) Name
className (Name -> TyVarBndr_ Any
D.plainTV Name
cTyVarBndr_ Any -> [TyVarBndr_ Any] -> [TyVarBndr_ Any]
forall a. a -> [a] -> [a]
:[TyVarBndr_ Any]
vars) [FunDep]
fd
([DecQ] -> DecQ) -> [DecQ] -> DecQ
forall a b. (a -> b) -> a -> b
$ Name -> TypeQ -> DecQ
sigD Name
methodName (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
lens'TypeName Name -> [Type] -> Type
`conAppsT` [Name -> Type
VarT Name
c, Type
s']))
DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
: [[DecQ]] -> [DecQ]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Name -> TypeQ -> DecQ
sigD Name
defName (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
,PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
defName) (ExpQ -> BodyQ
normalB ExpQ
body) []
] [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++
Name -> [DecQ]
inlinePragma Name
defName
| (TopName Name
defName, (OpticType
_, OpticStab
stab, [(Name, Int, [(Maybe Name, Int)])]
_)) <- [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
, let body :: ExpQ
body = [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
composeValName, Name -> ExpQ
varE Name
methodName, Name -> ExpQ
varE Name
defName]
, let ty :: Type
ty = Set Name -> [Type] -> Type -> Type
quantifyType' ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList (Name
cName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
varNames))
(OpticStab -> [Type]
stabToContext OpticStab
stab)
(Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ OpticStab -> Name
stabToOptic OpticStab
stab Name -> [Type] -> Type
`conAppsT`
[Name -> Type
VarT Name
c, Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub (OpticStab -> Type
stabToA OpticStab
stab)]
]
makeClassyInstance ::
LensRules ->
Name ->
Name ->
Type ->
[(DefName, (OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))] ->
HasFieldClasses Dec
makeClassyInstance :: LensRules
-> Name
-> Name
-> Type
-> [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q Dec
makeClassyInstance LensRules
rules Name
className Name
methodName Type
s [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs = do
[[Dec]]
methodss <- ((DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT (Set Name) Q [Dec])
-> [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LensRules
-> (DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules') [(DefName,
(OpticType, OpticStab, [(Name, Int, [(Maybe Name, Int)])]))]
defs
DecQ -> StateT (Set Name) Q Dec
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DecQ -> StateT (Set Name) Q Dec)
-> DecQ -> StateT (Set Name) Q Dec
forall a b. (a -> b) -> a -> b
$ CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt[]) (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceHead)
([DecQ] -> DecQ) -> [DecQ] -> DecQ
forall a b. (a -> b) -> a -> b
$ PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
methodName) (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
idValName)) []
DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
: (Dec -> DecQ) -> [Dec] -> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> DecQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
methodss)
where
instanceHead :: Type
instanceHead = Name
className Name -> [Type] -> Type
`conAppsT` (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (TyVarBndr_ Any -> Type) -> [TyVarBndr_ Any] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ Any -> Type
forall flag. TyVarBndr_ Any -> Type
tvbToType [TyVarBndr_ Any]
vars)
vars :: [TyVarBndr_ Any]
vars = [Type] -> [TyVarBndr_ Any]
D.freeVariablesWellScoped [Type
s]
rules' :: LensRules
rules' = LensRules
rules { _generateSigs :: Bool
_generateSigs = Bool
False
, _generateClasses :: Bool
_generateClasses = Bool
False
}
makeFieldClass :: OpticStab -> Name -> Name -> DecQ
makeFieldClass :: OpticStab -> Name -> Name -> DecQ
makeFieldClass OpticStab
defType Name
className Name
methodName =
CxtQ -> Name -> [TyVarBndr_ Any] -> [FunDep] -> [DecQ] -> DecQ
classD ([TypeQ] -> CxtQ
cxt []) Name
className [Name -> TyVarBndr_ Any
D.plainTV Name
s, Name -> TyVarBndr_ Any
D.plainTV Name
a] [[Name] -> [Name] -> FunDep
FunDep [Name
s] [Name
a]]
[Name -> TypeQ -> DecQ
sigD Name
methodName (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
methodType)]
where
methodType :: Type
methodType = Set Name -> [Type] -> Type -> Type
quantifyType' ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name
s,Name
a])
(OpticStab -> [Type]
stabToContext OpticStab
defType)
(Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ OpticStab -> Name
stabToOptic OpticStab
defType Name -> [Type] -> Type
`conAppsT` [Name -> Type
VarT Name
s,Name -> Type
VarT Name
a]
s :: Name
s = String -> Name
mkName String
"s"
a :: Name
a = String -> Name
mkName String
"a"
makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ
makeFieldInstance :: OpticStab -> Name -> [DecQ] -> DecQ
makeFieldInstance OpticStab
defType Name
className [DecQ]
decs =
Type -> Q Bool
containsTypeFamilies Type
a Q Bool -> (Bool -> DecQ) -> DecQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> DecQ
pickInstanceDec
where
s :: Type
s = OpticStab -> Type
stabToS OpticStab
defType
a :: Type
a = OpticStab -> Type
stabToA OpticStab
defType
containsTypeFamilies :: Type -> Q Bool
containsTypeFamilies = Type -> Q Bool
go (Type -> Q Bool) -> (Type -> TypeQ) -> Type -> Q Bool
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Type -> TypeQ
D.resolveTypeSynonyms
where
go :: Type -> Q Bool
go :: Type -> Q Bool
go (ConT Name
nm) =
Q Bool -> Q Bool -> Q Bool
forall a. Q a -> Q a -> Q a
recover
(Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
(Getting Any Info () -> Info -> Bool
forall s a. Getting Any s a -> s -> Bool
has (((Dec, [Dec]) -> Const Any (Dec, [Dec])) -> Info -> Const Any Info
Prism' Info (Dec, [Dec])
_FamilyI (((Dec, [Dec]) -> Const Any (Dec, [Dec]))
-> Info -> Const Any Info)
-> ((() -> Const Any ()) -> (Dec, [Dec]) -> Const Any (Dec, [Dec]))
-> Getting Any Info ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> Const Any Dec) -> (Dec, [Dec]) -> Const Any (Dec, [Dec])
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((Dec -> Const Any Dec) -> (Dec, [Dec]) -> Const Any (Dec, [Dec]))
-> ((() -> Const Any ()) -> Dec -> Const Any Dec)
-> (() -> Const Any ())
-> (Dec, [Dec])
-> Const Any (Dec, [Dec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> Const Any ()) -> Dec -> Const Any Dec
_TypeFamilyD) (Info -> Bool) -> Q Info -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
nm)
go Type
ty = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Bool) -> [Type] -> Q [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Q Bool
go (Type
ty Type -> Getting (Endo [Type]) Type Type -> [Type]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Type]) Type Type
forall a. Plated a => Traversal' a a
plate)
_TypeFamilyD :: Getting Any Dec ()
_TypeFamilyD :: (() -> Const Any ()) -> Dec -> Const Any Dec
_TypeFamilyD = (TypeFamilyHead -> Const Any TypeFamilyHead)
-> Dec -> Const Any Dec
Prism' Dec TypeFamilyHead
_OpenTypeFamilyD((TypeFamilyHead -> Const Any TypeFamilyHead)
-> Dec -> Const Any Dec)
-> ((() -> Const Any ())
-> TypeFamilyHead -> Const Any TypeFamilyHead)
-> (() -> Const Any ())
-> Dec
-> Const Any Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(() -> Const Any ()) -> TypeFamilyHead -> Const Any TypeFamilyHead
forall a. Lens' a ()
united ((() -> Const Any ()) -> Dec -> Const Any Dec)
-> ((() -> Const Any ()) -> Dec -> Const Any Dec)
-> (() -> Const Any ())
-> Dec
-> Const Any Dec
forall a. Semigroup a => a -> a -> a
<> ((TypeFamilyHead, [TySynEqn])
-> Const Any (TypeFamilyHead, [TySynEqn]))
-> Dec -> Const Any Dec
Prism' Dec (TypeFamilyHead, [TySynEqn])
_ClosedTypeFamilyD(((TypeFamilyHead, [TySynEqn])
-> Const Any (TypeFamilyHead, [TySynEqn]))
-> Dec -> Const Any Dec)
-> ((() -> Const Any ())
-> (TypeFamilyHead, [TySynEqn])
-> Const Any (TypeFamilyHead, [TySynEqn]))
-> (() -> Const Any ())
-> Dec
-> Const Any Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(() -> Const Any ())
-> (TypeFamilyHead, [TySynEqn])
-> Const Any (TypeFamilyHead, [TySynEqn])
forall a. Lens' a ()
united
pickInstanceDec :: Bool -> DecQ
pickInstanceDec Bool
hasFamilies
| Bool
hasFamilies = do
Type
placeholder <- Name -> Type
VarT (Name -> Type) -> Q Name -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"a"
[TypeQ] -> [Type] -> DecQ
mkInstanceDec
[Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
D.equalPred Type
placeholder Type
a)]
[Type
s, Type
placeholder]
| Bool
otherwise = [TypeQ] -> [Type] -> DecQ
mkInstanceDec [] [Type
s, Type
a]
mkInstanceDec :: [TypeQ] -> [Type] -> DecQ
mkInstanceDec [TypeQ]
context [Type]
headTys =
CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt [TypeQ]
context) (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
className Name -> [Type] -> Type
`conAppsT` [Type]
headTys)) [DecQ]
decs
makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [ClauseQ]
makeFieldClauses :: LensRules
-> OpticType -> [(Name, Int, [(Maybe Name, Int)])] -> [ClauseQ]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [(Maybe Name, Int)])]
cons =
case OpticType
opticType of
OpticType
IsoType -> [ Name -> ClauseQ
makeIsoClause Name
conName | (Name
conName, Int
_, [(Maybe Name, Int)]
_) <- [(Name, Int, [(Maybe Name, Int)])]
cons ]
OpticType
GetterType -> [ Name -> Int -> [Int] -> ClauseQ
makeGetterClause Name
conName Int
fieldCount ((Maybe Name, Int) -> Int
forall a b. (a, b) -> b
snd ((Maybe Name, Int) -> Int) -> [(Maybe Name, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Int)]
fields)
| (Name
conName, Int
fieldCount, [(Maybe Name, Int)]
fields) <- [(Name, Int, [(Maybe Name, Int)])]
cons ]
OpticType
LensType -> [ Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> ClauseQ
makeFieldOpticClause Name
conName Int
fieldCount [(Maybe Name, Int)]
fields Bool
irref Bool
recSyn
| (Name
conName, Int
fieldCount, [(Maybe Name, Int)]
fields) <- [(Name, Int, [(Maybe Name, Int)])]
cons ]
where
irref :: Bool
irref = LensRules -> Bool
_lazyPatterns LensRules
rules
Bool -> Bool -> Bool
&& [(Name, Int, [(Maybe Name, Int)])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [(Maybe Name, Int)])]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
recSyn :: Bool
recSyn = LensRules -> Bool
_recordSyntax LensRules
rules Bool -> Bool -> Bool
&& [(Name, Int, [(Maybe Name, Int)])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [(Maybe Name, Int)])]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
makePureClause :: Name -> Int -> ClauseQ
makePureClause :: Name -> Int -> ClauseQ
makePureClause Name
conName Int
fieldCount =
do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fieldCount
[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ
wildP, Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs)]
(ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
pureValName) ([ExpQ] -> ExpQ
appsE (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))))
[]
makeGetterClause :: Name -> Int -> [Int] -> ClauseQ
makeGetterClause :: Name -> Int -> [Int] -> ClauseQ
makeGetterClause Name
conName Int
fieldCount [] = Name -> Int -> ClauseQ
makePureClause Name
conName Int
fieldCount
makeGetterClause Name
conName Int
fieldCount [Int]
fields =
do Name
f <- String -> Q Name
newName String
"f"
[Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields)
NonEmpty Name
xs' <-
case [Name]
xs of
(Name
x:[Name]
xs') -> NonEmpty Name -> Q (NonEmpty Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
x Name -> [Name] -> NonEmpty Name
forall a. a -> [a] -> NonEmpty a
:| [Name]
xs')
[] -> String -> Q (NonEmpty Name)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeGetterClause: Internal check failed"
let pats :: [Int] -> [Name] -> [PatQ]
pats (Int
i:[Int]
is) (Name
y:[Name]
ys)
| Int
i Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
fields = Name -> PatQ
varP Name
y PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [PatQ]
pats [Int]
is [Name]
ys
| Bool
otherwise = PatQ
wildP PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [PatQ]
pats [Int]
is (Name
yName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
ys)
pats [Int]
is [Name]
_ = (Int -> PatQ) -> [Int] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (PatQ -> Int -> PatQ
forall a b. a -> b -> a
const PatQ
wildP) [Int]
is
(ExpQ
fx :| [ExpQ]
fxs) = (Name -> ExpQ) -> NonEmpty Name -> NonEmpty ExpQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
f) (ExpQ -> ExpQ) -> (Name -> ExpQ) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ExpQ
varE) NonEmpty Name
xs'
body :: ExpQ
body = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a ExpQ
b -> [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
apValName, ExpQ
a, ExpQ
b])
(ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
phantomValName) ExpQ
fx)
[ExpQ]
fxs
[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> PatQ
varP Name
f, Name -> [PatQ] -> PatQ
conP Name
conName ([Int] -> [Name] -> [PatQ]
pats [Int
0..Int
fieldCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] [Name]
xs)]
(ExpQ -> BodyQ
normalB ExpQ
body)
[]
makeFieldOpticClause :: Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> ClauseQ
makeFieldOpticClause :: Name -> Int -> [(Maybe Name, Int)] -> Bool -> Bool -> ClauseQ
makeFieldOpticClause Name
conName Int
fieldCount [] Bool
_ Bool
_ =
Name -> Int -> ClauseQ
makePureClause Name
conName Int
fieldCount
makeFieldOpticClause Name
_ Int
_ [(Just Name
fieldName, Int
_)] Bool
_ Bool
True =
do Name
f <- String -> Q Name
newName String
"f"
Name
r <- String -> Q Name
newName String
"r"
Name
x <- String -> Q Name
newName String
"x"
let body :: ExpQ
body = [ExpQ] -> ExpQ
appsE [ [| fmap |]
, [PatQ] -> ExpQ -> ExpQ
lamE [Name -> PatQ
varP Name
x] (ExpQ -> [Q (Name, Exp)] -> ExpQ
recUpdE (Name -> ExpQ
varE Name
r) [(,) Name
fieldName (Exp -> (Name, Exp)) -> ExpQ -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> ExpQ
varE Name
x])
, Name -> ExpQ
varE Name
f ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
varE Name
fieldName ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
r)
]
[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
r] (ExpQ -> BodyQ
normalB ExpQ
body) []
makeFieldOpticClause Name
conName Int
fieldCount ((Maybe Name
_, Int
field):[(Maybe Name, Int)]
fieldsWithNames) Bool
irref Bool
_ =
do Name
f <- String -> Q Name
newName String
"f"
[Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fieldCount
[Name]
ys <- String -> Int -> Q [Name]
newNames String
"y" (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(Maybe Name, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Name, Int)]
fieldsWithNames)
let fields :: [Int]
fields = (Maybe Name, Int) -> Int
forall a b. (a, b) -> b
snd ((Maybe Name, Int) -> Int) -> [(Maybe Name, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Int)]
fieldsWithNames
xs' :: [Name]
xs' = ((Int, Name) -> [Name] -> [Name])
-> [Name] -> [(Int, Name)] -> [Name]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i,Name
x) -> ASetter [Name] [Name] Name Name -> Name -> [Name] -> [Name]
forall s t a b. ASetter s t a b -> b -> s -> t
set (Index [Name] -> Traversal' [Name] (IxValue [Name])
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index [Name]
i) Name
x) [Name]
xs ([Int] -> [Name] -> [(Int, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int
fieldInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
fields) [Name]
ys)
mkFx :: Int -> ExpQ
mkFx Int
i = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
f) (Name -> ExpQ
varE ([Name]
xs [Name] -> Int -> Name
forall a. [a] -> Int -> a
!! Int
i))
body0 :: ExpQ
body0 = [ExpQ] -> ExpQ
appsE [ Name -> ExpQ
varE Name
fmapValName
, [PatQ] -> ExpQ -> ExpQ
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
ys) ([ExpQ] -> ExpQ
appsE (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs'))
, Int -> ExpQ
mkFx Int
field
]
body :: ExpQ
body = (ExpQ -> Int -> ExpQ) -> ExpQ -> [Int] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
a Int
b -> [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
apValName, ExpQ
a, Int -> ExpQ
mkFx Int
b]) ExpQ
body0 [Int]
fields
let wrap :: PatQ -> PatQ
wrap = if Bool
irref then PatQ -> PatQ
tildeP else PatQ -> PatQ
forall a. a -> a
id
[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> PatQ
varP Name
f, PatQ -> PatQ
wrap (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))]
(ExpQ -> BodyQ
normalB ExpQ
body)
[]
makeIsoClause :: Name -> ClauseQ
makeIsoClause :: Name -> ClauseQ
makeIsoClause Name
conName = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ([ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
isoValName, ExpQ
destruct, ExpQ
construct])) []
where
destruct :: ExpQ
destruct = do Name
x <- String -> Q Name
newName String
"x"
PatQ -> ExpQ -> ExpQ
lam1E (Name -> [PatQ] -> PatQ
conP Name
conName [Name -> PatQ
varP Name
x]) (Name -> ExpQ
varE Name
x)
construct :: ExpQ
construct = Name -> ExpQ
conE Name
conName
unifyTypes :: [Type] -> Q (Map Name Type, Type)
unifyTypes :: [Type] -> Q (Map Name Type, Type)
unifyTypes (Type
x:[Type]
xs) = ((Map Name Type, Type) -> Type -> Q (Map Name Type, Type))
-> (Map Name Type, Type) -> [Type] -> Q (Map Name Type, Type)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Map Name Type -> Type -> Type -> Q (Map Name Type, Type))
-> (Map Name Type, Type) -> Type -> Q (Map Name Type, Type)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1) (Map Name Type
forall k a. Map k a
Map.empty, Type
x) [Type]
xs
unifyTypes [] = String -> Q (Map Name Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unifyTypes: Bug: Unexpected empty list"
unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 :: Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub (VarT Name
x) Type
y
| Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x Map Name Type
sub = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
r Type
y
unify1 Map Name Type
sub Type
x (VarT Name
y)
| Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
y Map Name Type
sub = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
x Type
r
unify1 Map Name Type
sub Type
x Type
y
| Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
y = (Map Name Type, Type) -> Q (Map Name Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub, Type
x)
unify1 Map Name Type
sub (AppT Type
f1 Type
x1) (AppT Type
f2 Type
x2) =
do (Map Name Type
sub1, Type
f) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
f1 Type
f2
(Map Name Type
sub2, Type
x) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub1 Type
x1 Type
x2
(Map Name Type, Type) -> Q (Map Name Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub2, Type -> Type -> Type
AppT (Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub2 Type
f) Type
x)
unify1 Map Name Type
sub Type
x (VarT Name
y)
| Getting Any Type Name -> Name -> Type -> Bool
forall a s. Eq a => Getting Any s a -> a -> s -> Bool
elemOf Getting Any Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Name
y (Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub Type
x) =
String -> Q (Map Name Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to unify types: occurs check"
| Bool
otherwise = (Map Name Type, Type) -> Q (Map Name Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
y Type
x Map Name Type
sub, Type
x)
unify1 Map Name Type
sub (VarT Name
x) Type
y = Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
y (Name -> Type
VarT Name
x)
unify1 Map Name Type
sub (ForallT [TyVarBndr_ Any]
v1 [] Type
t1) (ForallT [TyVarBndr_ Any]
v2 [] Type
t2) =
do (Map Name Type
sub1,Type
t) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
t1 Type
t2
[TyVarBndr_ Any]
v <- ([TyVarBndr_ Any] -> [TyVarBndr_ Any])
-> Q [TyVarBndr_ Any] -> Q [TyVarBndr_ Any]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TyVarBndr_ Any] -> [TyVarBndr_ Any]
forall a. Eq a => [a] -> [a]
nub ((TyVarBndr_ Any -> Q (TyVarBndr_ Any))
-> [TyVarBndr_ Any] -> Q [TyVarBndr_ Any]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map Name Type -> TyVarBndr_ Any -> Q (TyVarBndr_ Any)
limitedSubst Map Name Type
sub1) ([TyVarBndr_ Any]
v1[TyVarBndr_ Any] -> [TyVarBndr_ Any] -> [TyVarBndr_ Any]
forall a. [a] -> [a] -> [a]
++[TyVarBndr_ Any]
v2))
(Map Name Type, Type) -> Q (Map Name Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub1, [TyVarBndr_ Any] -> [Type] -> Type -> Type
ForallT [TyVarBndr_ Any]
v [] Type
t)
unify1 Map Name Type
_ Type
x Type
y = String -> Q (Map Name Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to unify types: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Type, Type) -> String
forall a. Show a => a -> String
show (Type
x,Type
y))
limitedSubst :: Map Name Type -> D.TyVarBndrSpec -> Q D.TyVarBndrSpec
limitedSubst :: Map Name Type -> TyVarBndr_ Any -> Q (TyVarBndr_ Any)
limitedSubst Map Name Type
sub TyVarBndr_ Any
tv
| Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TyVarBndr_ Any -> Name
forall flag. TyVarBndr_ Any -> Name
D.tvName TyVarBndr_ Any
tv) Map Name Type
sub =
case Type
r of
VarT Name
m -> Map Name Type -> TyVarBndr_ Any -> Q (TyVarBndr_ Any)
limitedSubst Map Name Type
sub ((Name -> Name) -> TyVarBndr_ Any -> TyVarBndr_ Any
forall flag. (Name -> Name) -> TyVarBndr_ Any -> TyVarBndr_ Any
D.mapTVName (Name -> Name -> Name
forall a b. a -> b -> a
const Name
m) TyVarBndr_ Any
tv)
Type
_ -> String -> Q (TyVarBndr_ Any)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to unify exotic higher-rank type"
| Bool
otherwise = TyVarBndr_ Any -> Q (TyVarBndr_ Any)
forall (m :: * -> *) a. Monad m => a -> m a
return TyVarBndr_ Any
tv
applyTypeSubst :: Map Name Type -> Type -> Type
applyTypeSubst :: Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub = (Type -> Maybe Type) -> Type -> Type
forall a. Plated a => (a -> Maybe a) -> a -> a
rewrite Type -> Maybe Type
aux
where
aux :: Type -> Maybe Type
aux (VarT Name
n) = Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Type
sub
aux Type
_ = Maybe Type
forall a. Maybe a
Nothing
data LensRules = LensRules
{ LensRules -> Bool
_simpleLenses :: Bool
, LensRules -> Bool
_generateSigs :: Bool
, LensRules -> Bool
_generateClasses :: Bool
, LensRules -> Bool
_allowIsos :: Bool
, LensRules -> Bool
_allowUpdates :: Bool
, LensRules -> Bool
_lazyPatterns :: Bool
, LensRules -> Bool
_recordSyntax :: Bool
, LensRules -> FieldNamer
_fieldToDef :: FieldNamer
, LensRules -> ClassyNamer
_classyLenses :: ClassyNamer
}
type FieldNamer = Name
-> [Name]
-> Name
-> [DefName]
data DefName
= TopName Name
| MethodName Name Name
deriving (Int -> DefName -> String -> String
[DefName] -> String -> String
DefName -> String
(Int -> DefName -> String -> String)
-> (DefName -> String)
-> ([DefName] -> String -> String)
-> Show DefName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DefName] -> String -> String
$cshowList :: [DefName] -> String -> String
show :: DefName -> String
$cshow :: DefName -> String
showsPrec :: Int -> DefName -> String -> String
$cshowsPrec :: Int -> DefName -> String -> String
Show, DefName -> DefName -> Bool
(DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool) -> Eq DefName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefName -> DefName -> Bool
$c/= :: DefName -> DefName -> Bool
== :: DefName -> DefName -> Bool
$c== :: DefName -> DefName -> Bool
Eq, Eq DefName
Eq DefName
-> (DefName -> DefName -> Ordering)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> Bool)
-> (DefName -> DefName -> DefName)
-> (DefName -> DefName -> DefName)
-> Ord DefName
DefName -> DefName -> Bool
DefName -> DefName -> Ordering
DefName -> DefName -> DefName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DefName -> DefName -> DefName
$cmin :: DefName -> DefName -> DefName
max :: DefName -> DefName -> DefName
$cmax :: DefName -> DefName -> DefName
>= :: DefName -> DefName -> Bool
$c>= :: DefName -> DefName -> Bool
> :: DefName -> DefName -> Bool
$c> :: DefName -> DefName -> Bool
<= :: DefName -> DefName -> Bool
$c<= :: DefName -> DefName -> Bool
< :: DefName -> DefName -> Bool
$c< :: DefName -> DefName -> Bool
compare :: DefName -> DefName -> Ordering
$ccompare :: DefName -> DefName -> Ordering
$cp1Ord :: Eq DefName
Ord)
type ClassyNamer = Name
-> Maybe (Name, Name)
type HasFieldClasses = StateT (Set Name) Q
addFieldClassName :: Name -> HasFieldClasses ()
addFieldClassName :: Name -> HasFieldClasses ()
addFieldClassName Name
n = (Set Name -> Set Name) -> HasFieldClasses ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Set Name -> Set Name) -> HasFieldClasses ())
-> (Set Name -> Set Name) -> HasFieldClasses ()
forall a b. (a -> b) -> a -> b
$ Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert Name
n