{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
#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.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, findIndices)
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 = (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` forall a. Set a
Set.empty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules 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 = (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` forall a. Set a
Set.empty) 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 forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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, [Int])])
perDef <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
[(Name, [(Maybe Name, Type)])]
fieldCons <- 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 = forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded) [(Name, [(Maybe Name, Type)])]
fieldCons
let defCons :: [(Name, [([DefName], Type)])]
defCons = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels ([Name] -> Maybe Name -> [DefName]
expandName [Name]
allFields) [(Name, [(Maybe Name, Type)])]
fieldCons
allDefs :: Set DefName
allDefs = forall a s. Getting (Set a) s a -> s -> Set a
setOf (forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded) [(Name, [([DefName], Type)])]
defCons
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA (forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (LensRules
-> Type
-> [(Name, [([DefName], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [Int])])
buildScaffold LensRules
rules Type
s [(Name, [([DefName], Type)])]
defCons) Set DefName
allDefs)
let defs :: [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs = forall k a. Map k a -> [(k, a)]
Map.toList Map DefName (OpticType, OpticStab, [(Name, Int, [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, [Int])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
Maybe (Name, Name)
Nothing -> do [[Dec]]
decss <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LensRules
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules) [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall a b.
Traversal [(Name, [(a, Type)])] [(Name, [(b, Type)])] a b
normFieldLabels = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1
expandName :: [Name] -> Maybe Name -> [DefName]
expandName :: [Name] -> Maybe Name -> [DefName]
expandName [Name]
allFields = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LensRules -> FieldNamer
_fieldToDef LensRules
rules Name
tyName [Name]
allFields) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> [a]
maybeToList
normalizeConstructor ::
D.ConstructorInfo ->
Q (Name, [(Maybe Name, Type)])
normalizeConstructor :: ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor ConstructorInfo
con =
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorInfo -> Name
D.constructorName ConstructorInfo
con,
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {b} {a}. HasTypeVars b => Maybe a -> b -> (Maybe a, b)
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 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just [Name]
xs
ConstructorVariant
D.NormalConstructor -> forall a. a -> [a]
repeat forall a. Maybe a
Nothing
ConstructorVariant
D.InfixConstructor -> forall a. a -> [a]
repeat forall a. Maybe a
Nothing
checkForExistentials :: Maybe a -> b -> (Maybe a, b)
checkForExistentials Maybe a
_ b
fieldtype
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TyVarBndr_ ()
tv -> forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndr_ ()
tv forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
used) [TyVarBndr_ ()]
unallowable
= (forall a. Maybe a
Nothing, b
fieldtype)
where
used :: Set Name
used = forall a s. Getting (Set a) s a -> s -> Set a
setOf forall t. HasTypeVars t => Traversal' t Name
typeVars b
fieldtype
unallowable :: [TyVarBndr_ ()]
unallowable = ConstructorInfo -> [TyVarBndr_ ()]
D.constructorVars ConstructorInfo
con
checkForExistentials Maybe a
fieldname b
fieldtype = (Maybe a
fieldname, b
fieldtype)
data OpticType = GetterType | LensType | IsoType
buildScaffold ::
LensRules ->
Type ->
[(Name, [([DefName], Type)])] ->
DefName ->
Q (OpticType, OpticStab, [(Name, Int, [Int])])
buildScaffold :: LensRules
-> Type
-> [(Name, [([DefName], Type)])]
-> DefName
-> Q (OpticType, OpticStab, [(Name, Int, [Int])])
buildScaffold LensRules
rules Type
s [(Name, [([DefName], 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 (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Name, [Either Type Type])]
consForDef)
let defType :: OpticStab
defType
| Just ([TyVarBndrSpec]
_,[Type]
cx,Type
a') <- forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Prism' Type ([TyVarBndrSpec], [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' forall a. Eq a => a -> a -> Bool
== Type
t Bool -> Bool -> Bool
&& Type
a 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 | forall s a. Getting Any s a -> s -> Bool
has Prism' Type ([TyVarBndrSpec], [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
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticType
opticType, OpticStab
defType, [(Name, Int, [Int])]
scaffolds)
where
consForDef :: [(Name, [Either Type Type])]
consForDef :: [(Name, [Either Type Type])]
consForDef = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped) ([DefName], Type) -> Either Type Type
categorize [(Name, [([DefName], Type)])]
cons
scaffolds :: [(Name, Int, [Int])]
scaffolds :: [(Name, Int, [Int])]
scaffolds = [ (Name
n, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Type Type]
ts, [Either Type Type] -> [Int]
rightIndices [Either Type Type]
ts) | (Name
n,[Either Type Type]
ts) <- [(Name, [Either Type Type])]
consForDef ]
rightIndices :: [Either Type Type] -> [Int]
rightIndices :: [Either Type Type] -> [Int]
rightIndices = forall a. (a -> Bool) -> [a] -> [Int]
findIndices (forall s a. Getting Any s a -> s -> Bool
has forall c a b. Prism (Either c a) (Either c b) a b
_Right)
categorize :: ([DefName], Type) -> Either Type Type
categorize :: ([DefName], Type) -> Either Type Type
categorize ([DefName]
defNames, Type
t)
| DefName
defName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DefName]
defNames = forall a b. b -> Either a b
Right Type
t
| Bool
otherwise = forall a b. a -> Either a b
Left Type
t
lensCase :: Bool
lensCase :: Bool
lensCase = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Name, [Either Type Type])
x -> forall s a. Getting (Endo (Endo Int)) s a -> s -> Int
lengthOf (forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
_Right) (Name, [Either Type Type])
x forall a. Eq a => a -> a -> Bool
== Int
1) [(Name, [Either Type Type])]
consForDef
isoCase :: Bool
isoCase :: Bool
isoCase = case [(Name, Int, [Int])]
scaffolds of
[(Name
_,Int
1,[Int
0])] -> Bool
True
[(Name, Int, [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 <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA (forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Set Name
unfixedTypeVars)
let (Type
t,Type
b) = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub) (Type
s',Type
a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
s',Type
t,Type
a,Type
b)
where
([Type]
fixedFields, [Type]
targetFields) = 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 forall a b. (a -> b) -> a -> b
$ forall a s. Getting (Set a) s a -> s -> Set a
setOf forall t. HasTypeVars t => Traversal' t Name
typeVars [Type]
fixedFields
unfixedTypeVars :: Set Name
unfixedTypeVars = forall a s. Getting (Set a) s a -> s -> Set a
setOf forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Name
fixedTypeVars
kindVarsOfTvb :: D.TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb :: forall flag. TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb = forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
D.elimTV (\Name
n -> (Name
n, forall a. Set a
Set.empty))
(\Name
n Type
k -> (Name
n, forall a s. Getting (Set a) s a -> s -> Set a
setOf forall t. HasTypeVars t => Traversal' t Name
typeVars Type
k))
sKindVarMap :: Map Name (Set Name)
sKindVarMap :: Map Name (Set Name)
sKindVarMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s]
lookupSKindVars :: Name -> Set Name
lookupSKindVars :: Name -> Set Name
lookupSKindVars Name
n = forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Ord a => Set a -> Set a -> Set a
Set.union forall a. Set a
Set.empty (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Name -> Set Name
lookupSKindVars Set Name
st) forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Name
st
makeFieldOptic ::
LensRules ->
(DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) ->
HasFieldClasses [Dec]
makeFieldOptic :: LensRules
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules (DefName
defName, (OpticType
opticType, OpticStab
defType, [(Name, Int, [Int])]
cons)) = do
Set Name
locals <- forall s (m :: * -> *). MonadState s m => m s
get
HasFieldClasses ()
addName
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do [DecQ]
cls <- Set Name -> Q [DecQ]
mkCls Set Name
locals
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA ([DecQ]
cls forall a. [a] -> [a] -> [a]
++ [DecQ]
sig 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 <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupTypeName (forall a. Show a => a -> String
show Name
c)
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
classExists Bool -> Bool -> 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
_ -> 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
_ -> 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 -> [forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
n (forall (m :: * -> *) a. Monad m => a -> m a
return (OpticStab -> Type
stabToType OpticStab
defType))]
MethodName{} -> []
fun :: Name -> [DecQ]
fun Name
n = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [ClauseQ]
clauses 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, [Int])] -> [ClauseQ]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [Int])]
cons
makeClassyDriver ::
LensRules ->
Name ->
Name ->
Type ->
[(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->
HasFieldClasses [Dec]
makeClassyDriver :: LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [Dec]
makeClassyDriver LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs = forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
T.sequenceA ([StateT (Set Name) Q Dec]
cls forall a. [a] -> [a] -> [a]
++ [StateT (Set Name) Q Dec]
inst)
where
cls :: [StateT (Set Name) Q Dec]
cls | LensRules -> Bool
_generateClasses LensRules
rules = [forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> DecQ
makeClassyClass Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs]
| Bool
otherwise = []
inst :: [StateT (Set Name) Q Dec]
inst = [LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q Dec
makeClassyInstance LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs]
makeClassyClass ::
Name ->
Name ->
Type ->
[(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))] ->
DecQ
makeClassyClass :: Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> DecQ
makeClassyClass Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs = do
let ss :: [Type]
ss = forall a b. (a -> b) -> [a] -> [b]
map (OpticStab -> Type
stabToS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2)) [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
(Map Name Type
sub,Type
s') <- [Type] -> Q (Map Name Type, Type)
unifyTypes (Type
s forall a. a -> [a] -> [a]
: [Type]
ss)
Name
c <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"c"
let vars :: [TyVarBndr_ ()]
vars = [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s']
varNames :: [Name]
varNames = forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
D.tvName [TyVarBndr_ ()]
vars
fd :: [FunDep]
fd | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr_ ()]
vars = []
| Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
c] [Name]
varNames]
forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [m Dec] -> m Dec
classD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt[]) Name
className (Name -> TyVarBndr_ ()
D.plainTV Name
cforall a. a -> [a] -> [a]
:[TyVarBndr_ ()]
vars) [FunDep]
fd
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName (forall (m :: * -> *) a. Monad m => a -> m a
return (Name
lens'TypeName Name -> [Type] -> Type
`conAppsT` [Name -> Type
VarT Name
c, Type
s']))
forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
defName (forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
,forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
defName) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
] forall a. [a] -> [a] -> [a]
++
Name -> [DecQ]
inlinePragma Name
defName
| (TopName Name
defName, (OpticType
_, OpticStab
stab, [(Name, Int, [Int])]
_)) <- [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
, let body :: Q Exp
body = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
composeValName, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodName, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
defName]
, let ty :: Type
ty = Set Name -> [Type] -> Type -> Type
quantifyType' (forall a. Ord a => [a] -> Set a
Set.fromList (Name
cforall a. a -> [a] -> [a]
:[Name]
varNames))
(OpticStab -> [Type]
stabToContext OpticStab
stab)
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, [Int])]))] ->
HasFieldClasses Dec
makeClassyInstance :: LensRules
-> Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q Dec
makeClassyInstance LensRules
rules Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs = do
[[Dec]]
methodss <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LensRules
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules') [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt[]) (forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceHead)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
methodName) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
idValName)) []
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
methodss)
where
instanceHead :: Type
instanceHead = Name
className Name -> [Type] -> Type
`conAppsT` (Type
s forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Type
tvbToType [TyVarBndr_ ()]
vars)
vars :: [TyVarBndr_ ()]
vars = [Type] -> [TyVarBndr_ ()]
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 =
forall (m :: * -> *).
Quote m =>
m [Type] -> Name -> [TyVarBndr_ ()] -> [FunDep] -> [m Dec] -> m Dec
classD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) Name
className [Name -> TyVarBndr_ ()
D.plainTV Name
s, Name -> TyVarBndr_ ()
D.plainTV Name
a] [[Name] -> [Name] -> FunDep
FunDep [Name
s] [Name
a]]
[forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName (forall (m :: * -> *) a. Monad m => a -> m a
return Type
methodType)]
where
methodType :: Type
methodType = Set Name -> [Type] -> Type -> Type
quantifyType' (forall a. Ord a => [a] -> Set a
Set.fromList [Name
s,Name
a])
(OpticStab -> [Type]
stabToContext OpticStab
defType)
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 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 forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Type -> Q Type
D.resolveTypeSynonyms
where
go :: Type -> Q Bool
go (ConT Name
nm) = forall s a. Getting Any s a -> s -> Bool
has (Prism' Info (Dec, [Dec])
_FamilyI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Any Dec ()
_TypeFamilyD) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
nm
go Type
ty = forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Q Bool
go (Type
ty forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall a. Plated a => Traversal' a a
plate)
_TypeFamilyD :: Getting Any Dec ()
_TypeFamilyD :: Getting Any Dec ()
_TypeFamilyD = Prism' Dec TypeFamilyHead
_OpenTypeFamilyDforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Lens' a ()
united forall a. Semigroup a => a -> a -> a
<> Prism' Dec (TypeFamilyHead, [TySynEqn])
_ClosedTypeFamilyDforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Lens' a ()
united
pickInstanceDec :: Bool -> DecQ
pickInstanceDec Bool
hasFamilies
| Bool
hasFamilies = do
Type
placeholder <- Name -> Type
VarT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
[Q Type] -> [Type] -> DecQ
mkInstanceDec
[forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
D.equalPred Type
placeholder Type
a)]
[Type
s, Type
placeholder]
| Bool
otherwise = [Q Type] -> [Type] -> DecQ
mkInstanceDec [] [Type
s, Type
a]
mkInstanceDec :: [Q Type] -> [Type] -> DecQ
mkInstanceDec [Q Type]
context [Type]
headTys =
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [Q Type]
context) (forall (m :: * -> *) a. Monad m => a -> m a
return (Name
className Name -> [Type] -> Type
`conAppsT` [Type]
headTys)) [DecQ]
decs
makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ]
makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [Int])]
cons =
case OpticType
opticType of
OpticType
IsoType -> [ Name -> ClauseQ
makeIsoClause Name
conName | (Name
conName, Int
_, [Int]
_) <- [(Name, Int, [Int])]
cons ]
OpticType
GetterType -> [ Name -> Int -> [Int] -> ClauseQ
makeGetterClause Name
conName Int
fieldCount [Int]
fields
| (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons ]
OpticType
LensType -> [ Name -> Int -> [Int] -> Bool -> ClauseQ
makeFieldOpticClause Name
conName Int
fieldCount [Int]
fields Bool
irref
| (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons ]
where
irref :: Bool
irref = LensRules -> Bool
_lazyPatterns LensRules
rules
Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [Int])]
cons 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
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs)]
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pureValName) (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
[Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields)
let pats :: [Int] -> [Name] -> [m Pat]
pats (Int
i:[Int]
is) (Name
y:[Name]
ys)
| Int
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
fields = forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [m Pat]
pats [Int]
is [Name]
ys
| Bool
otherwise = forall (m :: * -> *). Quote m => m Pat
wildP forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [m Pat]
pats [Int]
is (Name
yforall a. a -> [a] -> [a]
:[Name]
ys)
pats [Int]
is [Name]
_ = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const forall (m :: * -> *). Quote m => m Pat
wildP) [Int]
is
fxs :: [Q Exp]
fxs = [ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) | Name
x <- [Name]
xs ]
body :: Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
a Q Exp
b -> forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
apValName, Q Exp
a, Q Exp
b])
(forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
phantomValName) (forall a. [a] -> a
head [Q Exp]
fxs))
(forall a. [a] -> [a]
tail [Q Exp]
fxs)
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName (forall {m :: * -> *}. Quote m => [Int] -> [Name] -> [m Pat]
pats [Int
0..Int
fieldCount forall a. Num a => a -> a -> a
- Int
1] [Name]
xs)]
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
[]
makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ
makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ
makeFieldOpticClause Name
conName Int
fieldCount [] Bool
_ =
Name -> Int -> ClauseQ
makePureClause Name
conName Int
fieldCount
makeFieldOpticClause Name
conName Int
fieldCount (Int
field:[Int]
fields) Bool
irref =
do Name
f <- forall (m :: * -> *). Quote m => String -> m 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 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fields)
let xs' :: [Name]
xs' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i,Name
x) -> forall s t a b. ASetter s t a b -> b -> s -> t
set (forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
i) Name
x) [Name]
xs (forall a b. [a] -> [b] -> [(a, b)]
zip (Int
fieldforall a. a -> [a] -> [a]
:[Int]
fields) [Name]
ys)
mkFx :: Int -> m Exp
mkFx Int
i = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) (forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Name]
xs forall a. [a] -> Int -> a
!! Int
i))
body0 :: Q Exp
body0 = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fmapValName
, forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ys) (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs'))
, forall {m :: * -> *}. Quote m => Int -> m Exp
mkFx Int
field
]
body :: Q Exp
body = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
a Int
b -> forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
apValName, Q Exp
a, forall {m :: * -> *}. Quote m => Int -> m Exp
mkFx Int
b]) Q Exp
body0 [Int]
fields
let wrap :: Q Pat -> Q Pat
wrap = if Bool
irref then forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP else forall a. a -> a
id
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Q Pat -> Q Pat
wrap (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
xs))]
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
[]
makeIsoClause :: Name -> ClauseQ
makeIsoClause :: Name -> ClauseQ
makeIsoClause Name
conName = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
isoValName, Q Exp
destruct, Q Exp
construct])) []
where
destruct :: Q Exp
destruct = do Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)
construct :: Q Exp
construct = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName
unifyTypes :: [Type] -> Q (Map Name Type, Type)
unifyTypes :: [Type] -> Q (Map Name Type, Type)
unifyTypes (Type
x:[Type]
xs) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1) (forall k a. Map k a
Map.empty, Type
x) [Type]
xs
unifyTypes [] = 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 <- 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 <- 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 forall a. Eq a => a -> a -> Bool
== Type
y = 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
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)
| forall a s. Eq a => Getting Any s a -> a -> s -> Bool
elemOf forall t. HasTypeVars t => Traversal' t Name
typeVars Name
y (Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub Type
x) =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to unify types: occurs check"
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (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 [TyVarBndrSpec]
v1 [] Type
t1) (ForallT [TyVarBndrSpec]
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
[TyVarBndrSpec]
v <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Eq a => [a] -> [a]
nub (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub1) ([TyVarBndrSpec]
v1forall a. [a] -> [a] -> [a]
++[TyVarBndrSpec]
v2))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Type
sub1, [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
v [] Type
t)
unify1 Map Name Type
_ Type
x Type
y = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to unify types: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Type
x,Type
y))
limitedSubst :: Map Name Type -> D.TyVarBndrSpec -> Q D.TyVarBndrSpec
limitedSubst :: Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub TyVarBndrSpec
tv
| Just Type
r <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndrSpec
tv) Map Name Type
sub =
case Type
r of
VarT Name
m -> Map Name Type -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub (forall flag. (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag
D.mapTVName (forall a b. a -> b -> a
const Name
m) TyVarBndrSpec
tv)
Type
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to unify exotic higher-rank type"
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return TyVarBndrSpec
tv
applyTypeSubst :: Map Name Type -> Type -> Type
applyTypeSubst :: Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub = forall a. Plated a => (a -> Maybe a) -> a -> a
rewrite Type -> Maybe Type
aux
where
aux :: Type -> Maybe Type
aux (VarT Name
n) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Type
sub
aux 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 -> FieldNamer
_fieldToDef :: FieldNamer
, LensRules -> ClassyNamer
_classyLenses :: ClassyNamer
}
type FieldNamer = Name
-> [Name]
-> Name
-> [DefName]
data DefName
= TopName Name
| MethodName Name Name
deriving (Int -> DefName -> ShowS
[DefName] -> ShowS
DefName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefName] -> ShowS
$cshowList :: [DefName] -> ShowS
show :: DefName -> String
$cshow :: DefName -> String
showsPrec :: Int -> DefName -> ShowS
$cshowsPrec :: Int -> DefName -> ShowS
Show, DefName -> DefName -> Bool
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
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
Ord)
type ClassyNamer = Name
-> Maybe (Name, Name)
type HasFieldClasses = StateT (Set Name) Q
addFieldClassName :: Name -> HasFieldClasses ()
addFieldClassName :: Name -> HasFieldClasses ()
addFieldClassName Name
n = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert Name
n