{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706)
#endif
#ifndef MIN_VERSION_containers
#define MIN_VERSION_containers(x,y,z) 1
#endif
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
module Lens.Micro.TH
(
makeLenses,
makeLensesFor,
makeLensesWith,
makeFields,
makeClassy,
LensRules,
DefName(..),
lensRules,
lensRulesFor,
classyRules,
camelCaseFields,
abbreviatedFields,
lensField,
lensClass,
createClass,
simpleLenses,
generateSignatures,
generateUpdateableOptics,
generateLazyPatterns,
)
where
import Control.Monad
import Control.Monad.Trans.State
import Data.Char
import Data.Data
import Data.Either
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.List (nub, findIndices, stripPrefix, isPrefixOf)
import Data.Maybe
import Lens.Micro
import Lens.Micro.Internal (phantom)
import Lens.Micro.TH.Internal
import Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import qualified Language.Haskell.TH.Datatype.TyVarBndr as D
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
import Data.Traversable (traverse, sequenceA)
#endif
rewrite :: (Data a, Data b) => (a -> Maybe a) -> b -> b
rewrite :: forall a b. (Data a, Data b) => (a -> Maybe a) -> b -> b
rewrite a -> Maybe a
f b
mbA = case b -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
mbA of
Maybe a
Nothing -> (forall b. Data b => b -> b) -> b -> b
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT ((a -> Maybe a) -> b -> b
forall a b. (Data a, Data b) => (a -> Maybe a) -> b -> b
rewrite a -> Maybe a
f) b
mbA
Just a
a -> let a' :: a
a' = (forall b. Data b => b -> b) -> a -> a
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT ((a -> Maybe a) -> b -> b
forall a b. (Data a, Data b) => (a -> Maybe a) -> b -> b
rewrite a -> Maybe a
f) a
a
in Maybe b -> b
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe b -> b) -> (a -> Maybe b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
a' (a -> Maybe a
f a
a')
children :: Data a => a -> [a]
children :: forall a. Data a => a -> [a]
children = [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe a] -> [a]) -> (a -> [Maybe a]) -> a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall d. Data d => d -> Maybe a) -> a -> [Maybe a]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> a -> [u]
gmapQ d -> Maybe a
forall d. Data d => d -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast
makeLenses :: Name -> DecsQ
makeLenses :: Name -> DecsQ
makeLenses = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
lensRules
makeLensesFor :: [(String, String)] -> Name -> DecsQ
makeLensesFor :: [(String, String)] -> Name -> DecsQ
makeLensesFor [(String, String)]
fields = LensRules -> Name -> DecsQ
makeFieldOptics ([(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields)
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith = LensRules -> Name -> DecsQ
makeFieldOptics
makeFields :: Name -> DecsQ
makeFields :: Name -> DecsQ
makeFields = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
camelCaseFields
makeClassy :: Name -> DecsQ
makeClassy :: Name -> DecsQ
makeClassy = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classyRules
simpleLenses :: Lens' LensRules Bool
simpleLenses :: Lens' LensRules Bool
simpleLenses Bool -> f Bool
f LensRules
r = (Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _simpleLenses = x}) (Bool -> f Bool
f (LensRules -> Bool
_simpleLenses LensRules
r))
generateSignatures :: Lens' LensRules Bool
generateSignatures :: Lens' LensRules Bool
generateSignatures Bool -> f Bool
f LensRules
r =
(Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _generateSigs = x}) (Bool -> f Bool
f (LensRules -> Bool
_generateSigs LensRules
r))
generateUpdateableOptics :: Lens' LensRules Bool
generateUpdateableOptics :: Lens' LensRules Bool
generateUpdateableOptics Bool -> f Bool
f LensRules
r =
(Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _allowUpdates = x}) (Bool -> f Bool
f (LensRules -> Bool
_allowUpdates LensRules
r))
generateLazyPatterns :: Lens' LensRules Bool
generateLazyPatterns :: Lens' LensRules Bool
generateLazyPatterns Bool -> f Bool
f LensRules
r =
(Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _lazyPatterns = x}) (Bool -> f Bool
f (LensRules -> Bool
_lazyPatterns LensRules
r))
lensField :: Lens' LensRules (Name -> [Name] -> Name -> [DefName])
lensField :: Lens' LensRules (Name -> [Name] -> Name -> [DefName])
lensField (Name -> [Name] -> Name -> [DefName])
-> f (Name -> [Name] -> Name -> [DefName])
f LensRules
r = ((Name -> [Name] -> Name -> [DefName]) -> LensRules)
-> f (Name -> [Name] -> Name -> [DefName]) -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name -> [Name] -> Name -> [DefName]
x -> LensRules
r { _fieldToDef = x}) ((Name -> [Name] -> Name -> [DefName])
-> f (Name -> [Name] -> Name -> [DefName])
f (LensRules -> Name -> [Name] -> Name -> [DefName]
_fieldToDef LensRules
r))
lensClass :: Lens' LensRules (Name -> Maybe (Name, Name))
lensClass :: Lens' LensRules (Name -> Maybe (Name, Name))
lensClass (Name -> Maybe (Name, Name)) -> f (Name -> Maybe (Name, Name))
f LensRules
r = ((Name -> Maybe (Name, Name)) -> LensRules)
-> f (Name -> Maybe (Name, Name)) -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name -> Maybe (Name, Name)
x -> LensRules
r { _classyLenses = x }) ((Name -> Maybe (Name, Name)) -> f (Name -> Maybe (Name, Name))
f (LensRules -> Name -> Maybe (Name, Name)
_classyLenses LensRules
r))
createClass :: Lens' LensRules Bool
createClass :: Lens' LensRules Bool
createClass Bool -> f Bool
f LensRules
r =
(Bool -> LensRules) -> f Bool -> f LensRules
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _generateClasses = x}) (Bool -> f Bool
f (LensRules -> Bool
_generateClasses LensRules
r))
lensRules :: LensRules
lensRules :: LensRules
lensRules = LensRules
{ _simpleLenses :: Bool
_simpleLenses = Bool
False
, _generateSigs :: Bool
_generateSigs = Bool
True
, _generateClasses :: Bool
_generateClasses = Bool
False
, _allowUpdates :: Bool
_allowUpdates = Bool
True
, _lazyPatterns :: Bool
_lazyPatterns = Bool
False
, _classyLenses :: Name -> Maybe (Name, Name)
_classyLenses = Maybe (Name, Name) -> Name -> Maybe (Name, Name)
forall a b. a -> b -> a
const Maybe (Name, Name)
forall a. Maybe a
Nothing
, _fieldToDef :: Name -> [Name] -> Name -> [DefName]
_fieldToDef = \Name
_ [Name]
_ Name
n ->
case Name -> String
nameBase Name
n of
Char
'_':Char
x:String
xs -> [Name -> DefName
TopName (String -> Name
mkName (Char -> Char
toLower Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs))]
String
_ -> []
}
lensRulesFor
:: [(String, String)]
-> LensRules
lensRulesFor :: [(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields = LensRules
lensRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& ((Name -> [Name] -> Name -> [DefName])
-> Identity (Name -> [Name] -> Name -> [DefName]))
-> LensRules -> Identity LensRules
Lens' LensRules (Name -> [Name] -> Name -> [DefName])
lensField (((Name -> [Name] -> Name -> [DefName])
-> Identity (Name -> [Name] -> Name -> [DefName]))
-> LensRules -> Identity LensRules)
-> (Name -> [Name] -> Name -> [DefName]) -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(String, String)] -> Name -> [Name] -> Name -> [DefName]
mkNameLookup [(String, String)]
fields
mkNameLookup :: [(String,String)] -> Name -> [Name] -> Name -> [DefName]
mkNameLookup :: [(String, String)] -> Name -> [Name] -> Name -> [DefName]
mkNameLookup [(String, String)]
kvs Name
_ [Name]
_ Name
field =
[ Name -> DefName
TopName (String -> Name
mkName String
v) | (String
k,String
v) <- [(String, String)]
kvs, String
k String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> String
nameBase Name
field]
camelCaseFields :: LensRules
camelCaseFields :: LensRules
camelCaseFields = LensRules
defaultFieldRules
camelCaseNamer :: Name -> [Name] -> Name -> [DefName]
camelCaseNamer :: Name -> [Name] -> Name -> [DefName]
camelCaseNamer Name
tyName [Name]
fields Name
field = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
forall a b. (a -> b) -> a -> b
$ do
fieldPart <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
expectedPrefix (Name -> String
nameBase Name
field)
method <- computeMethod fieldPart
let cls = String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldPart
return (MethodName (mkName cls) (mkName method))
where
expectedPrefix :: String
expectedPrefix = String
optUnderscore String -> String -> String
forall a. [a] -> [a] -> [a]
++ ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
Traversal' String Char
_head Char -> Char
toLower (Name -> String
nameBase Name
tyName)
optUnderscore :: String
optUnderscore = [Char
'_' | (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"_" (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
fields ]
computeMethod :: String -> Maybe String
computeMethod (Char
x:String
xs) | Char -> Bool
isUpper Char
x = String -> Maybe String
forall a. a -> Maybe a
Just (Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
computeMethod String
_ = Maybe String
forall a. Maybe a
Nothing
abbreviatedFields :: LensRules
abbreviatedFields :: LensRules
abbreviatedFields = LensRules
defaultFieldRules { _fieldToDef = abbreviatedNamer }
abbreviatedNamer :: Name -> [Name] -> Name -> [DefName]
abbreviatedNamer :: Name -> [Name] -> Name -> [DefName]
abbreviatedNamer Name
_ [Name]
fields Name
field = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
forall a b. (a -> b) -> a -> b
$ do
fieldPart <- String -> Maybe String
stripMaxLc (Name -> String
nameBase Name
field)
method <- computeMethod fieldPart
let cls = String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldPart
return (MethodName (mkName cls) (mkName method))
where
stripMaxLc :: String -> Maybe String
stripMaxLc String
f = do x <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
optUnderscore String
f
case break isUpper x of
(String
p,String
s) | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p Bool -> Bool -> Bool
|| String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s -> Maybe String
forall a. Maybe a
Nothing
| Bool
otherwise -> String -> Maybe String
forall a. a -> Maybe a
Just String
s
optUnderscore :: String
optUnderscore = [Char
'_' | (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"_" (String -> Bool) -> (Name -> String) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
fields ]
computeMethod :: String -> Maybe String
computeMethod (Char
x:String
xs) | Char -> Bool
isUpper Char
x = String -> Maybe String
forall a. a -> Maybe a
Just (Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs)
computeMethod String
_ = Maybe String
forall a. Maybe a
Nothing
defaultFieldRules :: LensRules
defaultFieldRules :: LensRules
defaultFieldRules = LensRules
{ _simpleLenses :: Bool
_simpleLenses = Bool
True
, _generateSigs :: Bool
_generateSigs = Bool
True
, _generateClasses :: Bool
_generateClasses = Bool
True
, _allowUpdates :: Bool
_allowUpdates = Bool
True
, _lazyPatterns :: Bool
_lazyPatterns = Bool
False
, _classyLenses :: Name -> Maybe (Name, Name)
_classyLenses = Maybe (Name, Name) -> Name -> Maybe (Name, Name)
forall a b. a -> b -> a
const Maybe (Name, Name)
forall a. Maybe a
Nothing
, _fieldToDef :: Name -> [Name] -> Name -> [DefName]
_fieldToDef = Name -> [Name] -> Name -> [DefName]
camelCaseNamer
}
underscoreNoPrefixNamer :: Name -> [Name] -> Name -> [DefName]
underscoreNoPrefixNamer :: Name -> [Name] -> Name -> [DefName]
underscoreNoPrefixNamer Name
_ [Name]
_ Name
n =
case Name -> String
nameBase Name
n of
Char
'_':Char
x:String
xs -> [Name -> DefName
TopName (String -> Name
mkName (Char -> Char
toLower Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs))]
String
_ -> []
classyRules :: LensRules
classyRules :: LensRules
classyRules = LensRules
{ _simpleLenses :: Bool
_simpleLenses = Bool
True
, _generateSigs :: Bool
_generateSigs = Bool
True
, _generateClasses :: Bool
_generateClasses = Bool
True
, _allowUpdates :: Bool
_allowUpdates = Bool
True
, _lazyPatterns :: Bool
_lazyPatterns = Bool
False
, _classyLenses :: Name -> Maybe (Name, Name)
_classyLenses = \Name
n ->
case Name -> String
nameBase Name
n of
Char
x:String
xs -> (Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
Just (String -> Name
mkName (String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs), String -> Name
mkName (Char -> Char
toLower Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs))
[] -> Maybe (Name, Name)
forall a. Maybe a
Nothing
, _fieldToDef :: Name -> [Name] -> Name -> [DefName]
_fieldToDef = Name -> [Name] -> Name -> [DefName]
underscoreNoPrefixNamer
}
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
type HasFieldClasses = StateT (Set Name) Q
addFieldClassName :: Name -> HasFieldClasses ()
addFieldClassName :: Name -> HasFieldClasses ()
addFieldClassName Name
n = (Set Name -> Set Name) -> HasFieldClasses ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT 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
makeFieldOpticsForDatatype :: LensRules -> D.DatatypeInfo -> HasFieldClasses [Dec]
makeFieldOpticsForDatatype :: LensRules -> DatatypeInfo -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDatatype LensRules
rules DatatypeInfo
info =
do perDef <- Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT
(Set Name)
Q
(Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
forall (m :: * -> *) a s. Monad m => m a -> StateT s m a
liftState (Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT
(Set Name)
Q
(Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])))
-> Q (Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT
(Set Name)
Q
(Map DefName (OpticType, OpticStab, [(Name, Int, [Int])]))
forall a b. (a -> b) -> a -> b
$ do
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ConstructorInfo -> Q (Name, [(Maybe Name, Type)])
normalizeConstructor [ConstructorInfo]
cons
let 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 (Getting
(Endo [Name])
[(Name, [(Maybe Name, Type)])]
(Name, [(Maybe Name, Type)])
SimpleFold
[(Name, [(Maybe Name, Type)])] (Name, [(Maybe Name, Type)])
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded Getting
(Endo [Name])
[(Name, [(Maybe Name, Type)])]
(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
Lens
(Name, [(Maybe Name, Type)])
(Name, [(Maybe Name, Type)])
[(Maybe Name, Type)]
[(Maybe Name, Type)]
_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
. Getting (Endo [Name]) [(Maybe Name, Type)] (Maybe Name, Type)
SimpleFold [(Maybe Name, Type)] (Maybe Name, Type)
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded Getting (Endo [Name]) [(Maybe Name, Type)] (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
Lens
(Maybe Name, Type) (Maybe Name, Type) (Maybe Name) (Maybe Name)
_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)
SimpleFold (Maybe Name) Name
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded) [(Name, [(Maybe Name, Type)])]
fieldCons
let defCons = ASetter
[(Name, [(Maybe Name, Type)])]
[(Name, [([DefName], Type)])]
(Maybe Name)
[DefName]
-> (Maybe Name -> [DefName])
-> [(Name, [(Maybe Name, Type)])]
-> [(Name, [([DefName], Type)])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
[(Name, [(Maybe Name, Type)])]
[(Name, [([DefName], Type)])]
(Maybe Name)
[DefName]
forall a b (f :: * -> *).
Applicative f =>
(a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
normFieldLabels ([Name] -> Maybe Name -> [DefName]
expandName [Name]
allFields) [(Name, [(Maybe Name, Type)])]
fieldCons
allDefs = Getting (Endo [DefName]) [(Name, [([DefName], Type)])] DefName
-> [(Name, [([DefName], Type)])] -> Set DefName
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf (([DefName] -> Const (Endo [DefName]) [DefName])
-> [(Name, [([DefName], Type)])]
-> Const (Endo [DefName]) [(Name, [([DefName], Type)])]
forall a b (f :: * -> *).
Applicative f =>
(a -> f b) -> [(Name, [(a, Type)])] -> f [(Name, [(b, Type)])]
normFieldLabels (([DefName] -> Const (Endo [DefName]) [DefName])
-> [(Name, [([DefName], Type)])]
-> Const (Endo [DefName]) [(Name, [([DefName], Type)])])
-> ((DefName -> Const (Endo [DefName]) DefName)
-> [DefName] -> Const (Endo [DefName]) [DefName])
-> Getting (Endo [DefName]) [(Name, [([DefName], Type)])] DefName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefName -> Const (Endo [DefName]) DefName)
-> [DefName] -> Const (Endo [DefName]) [DefName]
SimpleFold [DefName] DefName
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded) [(Name, [([DefName], Type)])]
defCons
sequenceA (Map.fromSet (buildScaffold rules s defCons) allDefs)
let defs = Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map DefName (OpticType, OpticStab, [(Name, Int, [Int])])
perDef
case _classyLenses rules 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 decss <- ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec])
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (LensRules
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules) [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
return (concat 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 (f :: * -> *).
Applicative f =>
(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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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
Lens
(Name, [(a, Type)]) (Name, [(b, Type)]) [(a, Type)] [(b, Type)]
_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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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
Lens (a, Type) (b, Type) a b
_1
expandName :: [Name] -> Maybe Name -> [DefName]
expandName :: [Name] -> Maybe Name -> [DefName]
expandName [Name]
allFields = (Name -> [DefName]) -> [Name] -> [DefName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LensRules -> Name -> [Name] -> Name -> [DefName]
_fieldToDef LensRules
rules Name
tyName [Name]
allFields) ([Name] -> [DefName])
-> (Maybe Name -> [Name]) -> Maybe Name -> [DefName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList
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 a. a -> Q a
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 {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 -> (Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
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 -> b -> (Maybe a, b)
checkForExistentials Maybe a
_ b
fieldtype
| (TyVarBndr_ () -> Bool) -> [TyVarBndr_ ()] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TyVarBndr_ ()
tv -> TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndr_ ()
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
used) [TyVarBndr_ ()]
unallowable
= (Maybe a
forall a. Maybe a
Nothing, b
fieldtype)
where
used :: Set Name
used = Getting (Endo [Name]) b Name -> b -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) b Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' b Name
typeVars b
fieldtype
unallowable :: [TyVarBndr_ ()]
unallowable = ConstructorInfo -> [TyVarBndr_ ()]
D.constructorVars ConstructorInfo
con
checkForExistentials Maybe a
fieldname b
fieldtype = (Maybe a
fieldname, b
fieldtype)
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 = [StateT (Set Name) Q Dec] -> StateT (Set Name) Q [Dec]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA ([StateT (Set Name) Q Dec]
forall {s}. [StateT s 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 s Q Dec]
cls | LensRules -> Bool
_generateClasses LensRules
rules = [Q Dec -> StateT s Q Dec
forall (m :: * -> *) a s. Monad m => m a -> StateT s m a
liftState (Q Dec -> StateT s Q Dec) -> Q Dec -> StateT s Q Dec
forall a b. (a -> b) -> a -> b
$ Name
-> Name
-> Type
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> Q Dec
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])]))]
-> Q Dec
makeClassyClass Name
className Name
methodName Type
s [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs = do
let ss :: [Type]
ss = ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])])) -> Type)
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (OpticStab -> Type
stabToS (OpticStab -> Type)
-> ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> OpticStab)
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Getting
OpticStab
(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
OpticStab
-> OpticStab
forall s a. s -> Getting a s a -> a
^. ((OpticType, OpticStab, [(Name, Int, [Int])])
-> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])]))
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Const
OpticStab (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
forall s t a b. Field2 s t a b => Lens s t a b
Lens
(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
(OpticType, OpticStab, [(Name, Int, [Int])])
(OpticType, OpticStab, [(Name, Int, [Int])])
_2(((OpticType, OpticStab, [(Name, Int, [Int])])
-> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])]))
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Const
OpticStab (DefName, (OpticType, OpticStab, [(Name, Int, [Int])])))
-> ((OpticStab -> Const OpticStab OpticStab)
-> (OpticType, OpticStab, [(Name, Int, [Int])])
-> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])]))
-> Getting
OpticStab
(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
OpticStab
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(OpticStab -> Const OpticStab OpticStab)
-> (OpticType, OpticStab, [(Name, Int, [Int])])
-> Const OpticStab (OpticType, OpticStab, [(Name, Int, [Int])])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
(OpticType, OpticStab, [(Name, Int, [Int])])
(OpticType, OpticStab, [(Name, Int, [Int])])
OpticStab
OpticStab
_2)) [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
(sub,s') <- [Type] -> Q (Map Name Type, Type)
unifyTypes (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ss)
c <- newName "c"
let vars = [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s']
varNames = (TyVarBndr_ () -> Name) -> [TyVarBndr_ ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName [TyVarBndr_ ()]
vars
fd | [TyVarBndr_ ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr_ ()]
vars = []
| Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
c] [Name]
varNames]
#if MIN_VERSION_template_haskell(2,21,0)
classD (cxt[]) className (D.plainTV c : D.changeTVFlags D.defaultBndrFlag vars) fd
#else
classD (cxt[]) className (D.plainTV c:vars) fd
#endif
$ sigD methodName (return (''Lens' `conAppsT` [VarT c, s']))
: concat
[ [sigD defName (return ty)
,valD (varP defName) (normalB body) []
] ++
inlinePragma defName
| (TopName defName, (_, stab, _)) <- defs
, let body = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(.), Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
methodName, Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
defName]
, let 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, [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
methodss <- ((DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec])
-> [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
-> StateT (Set Name) Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (LensRules
-> (DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))
-> StateT (Set Name) Q [Dec]
makeFieldOptic LensRules
rules') [(DefName, (OpticType, OpticStab, [(Name, Int, [Int])]))]
defs
liftState $ instanceD (cxt[]) (return instanceHead)
$ valD (varP methodName) (normalB (varE 'id)) []
: map return (concat methodss)
where
instanceHead :: Type
instanceHead = Name
className Name -> [Type] -> Type
`conAppsT` (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (TyVarBndr_ () -> Type) -> [TyVarBndr_ ()] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> Type
forall flag. TyVarBndr_ flag -> Type
tvbToType [TyVarBndr_ ()]
vars)
vars :: [TyVarBndr_ ()]
vars = [Type] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped [Type
s]
rules' :: LensRules
rules' = LensRules
rules { _generateSigs = False
, _generateClasses = False
}
data OpticType = GetterType | LensType
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 (s',t,a,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 Type])]
consForDef)
let defType
| Just ([TyVarBndrSpec]
_,[Type]
cx,Type
a') <- Type
a Type
-> Getting
(First ([TyVarBndrSpec], [Type], Type))
Type
([TyVarBndrSpec], [Type], Type)
-> Maybe ([TyVarBndrSpec], [Type], Type)
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting
(First ([TyVarBndrSpec], [Type], Type))
Type
([TyVarBndrSpec], [Type], Type)
Traversal' Type ([TyVarBndrSpec], [Type], Type)
_ForallT =
let optic :: Name
optic | Bool
lensCase = ''SimpleGetter
| Bool
otherwise = ''SimpleFold
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 = ''SimpleGetter
| Bool
otherwise = ''SimpleFold
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
lensCase = ''Lens'
| Bool
otherwise = ''Traversal'
in [Type] -> Name -> Type -> Type -> OpticStab
OpticSa [] Name
optic Type
s' Type
a
| Bool
otherwise =
let optic :: Name
optic
| Bool
lensCase = ''Lens
| Bool
otherwise = ''Traversal
in Name -> Type -> Type -> Type -> Type -> OpticStab
OpticStab Name
optic Type
s' Type
t Type
a Type
b
opticType | Getting Any Type ([TyVarBndrSpec], [Type], Type) -> Type -> Bool
forall s a. Getting Any s a -> s -> Bool
has Getting Any Type ([TyVarBndrSpec], [Type], Type)
Traversal' Type ([TyVarBndrSpec], [Type], Type)
_ForallT Type
a = OpticType
GetterType
| Bool -> Bool
not (LensRules -> Bool
_allowUpdates LensRules
rules) = OpticType
GetterType
| Bool
otherwise = OpticType
LensType
return (opticType, defType, scaffolds)
where
consForDef :: [(Name, [Either Type Type])]
consForDef :: [(Name, [Either Type Type])]
consForDef = ASetter
[(Name, [([DefName], Type)])]
[(Name, [Either Type Type])]
([DefName], Type)
(Either Type Type)
-> (([DefName], Type) -> Either Type Type)
-> [(Name, [([DefName], Type)])]
-> [(Name, [Either Type Type])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (ASetter
[(Name, [([DefName], Type)])]
[(Name, [Either Type Type])]
(Name, [([DefName], Type)])
(Name, [Either Type Type])
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mapped ASetter
[(Name, [([DefName], Type)])]
[(Name, [Either Type Type])]
(Name, [([DefName], Type)])
(Name, [Either Type Type])
-> ((([DefName], Type) -> Identity (Either Type Type))
-> (Name, [([DefName], Type)])
-> Identity (Name, [Either Type Type]))
-> ASetter
[(Name, [([DefName], Type)])]
[(Name, [Either Type Type])]
([DefName], Type)
(Either Type Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([([DefName], Type)] -> Identity [Either Type Type])
-> (Name, [([DefName], Type)])
-> Identity (Name, [Either Type Type])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
(Name, [([DefName], Type)])
(Name, [Either Type Type])
[([DefName], Type)]
[Either Type Type]
_2 (([([DefName], Type)] -> Identity [Either Type Type])
-> (Name, [([DefName], Type)])
-> Identity (Name, [Either Type Type]))
-> ((([DefName], Type) -> Identity (Either Type Type))
-> [([DefName], Type)] -> Identity [Either Type Type])
-> (([DefName], Type) -> Identity (Either Type Type))
-> (Name, [([DefName], Type)])
-> Identity (Name, [Either Type Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([DefName], Type) -> Identity (Either Type Type))
-> [([DefName], Type)] -> Identity [Either Type Type]
forall (f :: * -> *) a b. Functor f => ASetter (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, [Either Type Type] -> Int
forall a. [a] -> Int
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 = (Either Type Type -> Bool) -> [Either Type Type] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (Getting Any (Either Type Type) Type -> Either Type Type -> Bool
forall s a. Getting Any s a -> s -> Bool
has Getting Any (Either Type Type) Type
forall a b b' (f :: * -> *).
Applicative f =>
(b -> f b') -> Either a b -> f (Either a b')
_Right)
categorize :: ([DefName], Type) -> Either Type Type
categorize :: ([DefName], Type) -> Either Type Type
categorize ([DefName]
defNames, Type
t)
| DefName
defName DefName -> [DefName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DefName]
defNames = Type -> Either Type Type
forall a b. b -> Either a b
Right Type
t
| Bool
otherwise = Type -> Either Type Type
forall a b. a -> Either a b
Left Type
t
lensCase :: Bool
lensCase :: Bool
lensCase = ((Name, [Either Type Type]) -> Bool)
-> [(Name, [Either Type Type])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Name, [Either Type Type])
x -> Getting (Endo [Type]) (Name, [Either Type Type]) Type
-> (Name, [Either Type Type]) -> Int
forall a s. Getting (Endo [a]) s a -> s -> Int
lengthOf (([Either Type Type] -> Const (Endo [Type]) [Either Type Type])
-> (Name, [Either Type Type])
-> Const (Endo [Type]) (Name, [Either Type Type])
forall s t a b. Field2 s t a b => Lens s t a b
Lens
(Name, [Either Type Type])
(Name, [Either Type Type])
[Either Type Type]
[Either Type Type]
_2 (([Either Type Type] -> Const (Endo [Type]) [Either Type Type])
-> (Name, [Either Type Type])
-> Const (Endo [Type]) (Name, [Either Type Type]))
-> ((Type -> Const (Endo [Type]) Type)
-> [Either Type Type] -> Const (Endo [Type]) [Either Type Type])
-> Getting (Endo [Type]) (Name, [Either Type Type]) Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Type]) [Either Type Type] (Either Type Type)
SimpleFold [Either Type Type] (Either Type Type)
forall (f :: * -> *) a. Foldable f => SimpleFold (f a) a
folded Getting (Endo [Type]) [Either Type Type] (Either Type Type)
-> ((Type -> Const (Endo [Type]) Type)
-> Either Type Type -> Const (Endo [Type]) (Either Type Type))
-> (Type -> Const (Endo [Type]) Type)
-> [Either Type Type]
-> Const (Endo [Type]) [Either Type Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Const (Endo [Type]) Type)
-> Either Type Type -> Const (Endo [Type]) (Either Type Type)
forall a b b' (f :: * -> *).
Applicative f =>
(b -> f b') -> Either a b -> f (Either a b')
_Right) (Name, [Either Type Type])
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) [(Name, [Either Type Type])]
consForDef
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 (subA,a) <- [Type] -> Q (Map Name Type, Type)
unifyTypes [Type]
targetFields
let s' = Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
subA Type
s
sub <- sequenceA (Map.fromSet (newName . nameBase) unfixedTypeVars)
let (t,b) = over both (substTypeVars sub) (s',a)
return (s',t,a,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 (Endo [Name]) [Type] Name -> [Type] -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) [Type] Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' [Type] Name
typeVars [Type]
fixedFields
unfixedTypeVars :: Set Name
unfixedTypeVars = Getting (Endo [Name]) Type Name -> Type -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type 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 :: forall flag. TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb = (Name -> (Name, Set Name))
-> (Name -> Type -> (Name, Set Name))
-> TyVarBndr_ flag
-> (Name, Set Name)
forall r flag.
(Name -> r) -> (Name -> Type -> r) -> TyVarBndr_ flag -> r
D.elimTV (\Name
n -> (Name
n, Set Name
forall a. Set a
Set.empty))
(\Name
n Type
k -> (Name
n, Getting (Endo [Name]) Type Name -> Type -> Set Name
forall a s. Ord a => Getting (Endo [a]) s a -> s -> Set a
setOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type 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_ () -> (Name, Set Name))
-> [TyVarBndr_ ()] -> [(Name, Set Name)]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr_ () -> (Name, Set Name)
forall flag. TyVarBndr_ flag -> (Name, Set Name)
kindVarsOfTvb ([TyVarBndr_ ()] -> [(Name, Set Name)])
-> [TyVarBndr_ ()] -> [(Name, Set Name)]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndr_ ()]
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 a b. (a -> b -> a) -> a -> Set b -> a
Set.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, [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
locals <- StateT (Set Name) Q (Set Name)
forall (m :: * -> *) s. Monad m => StateT s m s
get
addName
liftState $ do
cls <- mkCls locals
sequenceA (cls ++ sig ++ def)
where
mkCls :: Set Name -> Q [Q Dec]
mkCls Set Name
locals = case DefName
defName of
MethodName Name
c Name
n | LensRules -> Bool
_generateClasses LensRules
rules ->
do 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)
return (if classExists || Set.member c locals then [] else [makeFieldClass defType c n])
DefName
_ -> [Q Dec] -> Q [Q Dec]
forall a. a -> Q a
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 a. a -> StateT (Set Name) Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sig :: [Q Dec]
sig = case DefName
defName of
DefName
_ | Bool -> Bool
not (LensRules -> Bool
_generateSigs LensRules
rules) -> []
TopName Name
n -> [Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
n (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpticStab -> Type
stabToType OpticStab
defType))]
MethodName{} -> []
fun :: Name -> [Q Dec]
fun Name
n = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [Q Clause]
clauses Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: Name -> [Q Dec]
inlinePragma Name
n
def :: [Q Dec]
def = case DefName
defName of
TopName Name
n -> Name -> [Q Dec]
fun Name
n
MethodName Name
c Name
n -> [OpticStab -> Name -> [Q Dec] -> Q Dec
makeFieldInstance OpticStab
defType Name
c (Name -> [Q Dec]
fun Name
n)]
clauses :: [Q Clause]
clauses = LensRules -> OpticType -> [(Name, Int, [Int])] -> [Q Clause]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [Int])]
cons
makeFieldClass :: OpticStab -> Name -> Name -> DecQ
makeFieldClass :: OpticStab -> Name -> Name -> Q Dec
makeFieldClass OpticStab
defType Name
className Name
methodName =
Q [Type]
-> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type]
-> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [m Dec] -> m Dec
classD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) Name
className [Name -> TyVarBndr BndrVis
forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
D.plainTV Name
s, Name -> TyVarBndr BndrVis
forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
D.plainTV Name
a] [[Name] -> [Name] -> FunDep
FunDep [Name
s] [Name
a]]
[Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
methodName (Type -> Q Type
forall a. a -> Q a
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 -> [Q Dec] -> Q Dec
makeFieldInstance OpticStab
defType Name
className [Q Dec]
decs =
Type -> Q Bool
containsTypeFamilies Type
a Q Bool -> (Bool -> Q Dec) -> Q Dec
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Q Dec
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 -> Q Type) -> Type -> Q Bool
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) = (\Info
i -> case Info
i of FamilyI Dec
d [Dec]
_ -> Dec -> Bool
isTypeFamily Dec
d; Info
_ -> Bool
False)
(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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Q Bool
go (Type -> [Type]
forall a. Data a => a -> [a]
children Type
ty)
#if MIN_VERSION_template_haskell(2,11,0)
isTypeFamily :: Dec -> Bool
isTypeFamily OpenTypeFamilyD{} = Bool
True
isTypeFamily ClosedTypeFamilyD{} = Bool
True
#elif MIN_VERSION_template_haskell(2,9,0)
isTypeFamily (FamilyD TypeFam _ _ _) = True
isTypeFamily ClosedTypeFamilyD{} = True
#else
isTypeFamily (FamilyD TypeFam _ _ _) = True
#endif
isTypeFamily Dec
_ = Bool
False
pickInstanceDec :: Bool -> Q Dec
pickInstanceDec Bool
hasFamilies
| Bool
hasFamilies = do
placeholder <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
mkInstanceDec
[return (D.equalPred placeholder a)]
[s, placeholder]
| Bool
otherwise = [Q Type] -> [Type] -> Q Dec
mkInstanceDec [] [Type
s, Type
a]
mkInstanceDec :: [Q Type] -> [Type] -> Q Dec
mkInstanceDec [Q Type]
context [Type]
headTys =
Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [Q Type]
context) (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
className Name -> [Type] -> Type
`conAppsT` [Type]
headTys)) [Q Dec]
decs
makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [ClauseQ]
makeFieldClauses :: LensRules -> OpticType -> [(Name, Int, [Int])] -> [Q Clause]
makeFieldClauses LensRules
rules OpticType
opticType [(Name, Int, [Int])]
cons =
case OpticType
opticType of
OpticType
GetterType -> [ Name -> Int -> [Int] -> Q Clause
makeGetterClause Name
conName Int
fieldCount [Int]
fields
| (Name
conName, Int
fieldCount, [Int]
fields) <- [(Name, Int, [Int])]
cons ]
OpticType
LensType -> [ Name -> Int -> [Int] -> Bool -> Q Clause
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
&& [(Name, Int, [Int])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int, [Int])]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
makePureClause :: Name -> Int -> ClauseQ
makePureClause :: Name -> Int -> Q Clause
makePureClause Name
conName Int
fieldCount =
do xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fieldCount
clause [wildP, conP conName (map varP xs)]
(normalB (appE (varE 'pure) (appsE (conE conName : map varE xs))))
[]
makeGetterClause :: Name -> Int -> [Int] -> ClauseQ
makeGetterClause :: Name -> Int -> [Int] -> Q Clause
makeGetterClause Name
conName Int
fieldCount [] = Name -> Int -> Q Clause
makePureClause Name
conName Int
fieldCount
makeGetterClause Name
conName Int
fieldCount [Int]
fields =
do f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
xs <- newNames "x" (length fields)
let pats (Int
i:[Int]
is) (Name
y:[Name]
ys)
| Int
i Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
fields = Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y m Pat -> [m Pat] -> [m Pat]
forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [m Pat]
pats [Int]
is [Name]
ys
| Bool
otherwise = m Pat
forall (m :: * -> *). Quote m => m Pat
wildP m Pat -> [m Pat] -> [m Pat]
forall a. a -> [a] -> [a]
: [Int] -> [Name] -> [m Pat]
pats [Int]
is (Name
yName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
ys)
pats [Int]
is [Name]
_ = (Int -> m Pat) -> [Int] -> [m Pat]
forall a b. (a -> b) -> [a] -> [b]
map (m Pat -> Int -> m Pat
forall a b. a -> b -> a
const m Pat
forall (m :: * -> *). Quote m => m Pat
wildP) [Int]
is
fxs = [ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) | Name
x <- [Name]
xs ]
body = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
a Q Exp
b -> [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<*>), Q Exp
a, Q Exp
b])
(Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'phantom) ([Q Exp] -> Q Exp
forall a. HasCallStack => [a] -> a
head [Q Exp]
fxs))
([Q Exp] -> [Q Exp]
forall a. HasCallStack => [a] -> [a]
tail [Q Exp]
fxs)
clause [varP f, conP conName (pats [0..fieldCount - 1] xs)]
(normalB body)
[]
makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> ClauseQ
makeFieldOpticClause :: Name -> Int -> [Int] -> Bool -> Q Clause
makeFieldOpticClause Name
conName Int
fieldCount [] Bool
_ =
Name -> Int -> Q Clause
makePureClause Name
conName Int
fieldCount
makeFieldOpticClause Name
conName Int
fieldCount (Int
field:[Int]
fields) Bool
irref =
do f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
xs <- newNames "x" fieldCount
ys <- newNames "y" (1 + length fields)
let xs' = ((Int, Name) -> [Name] -> [Name])
-> [Name] -> [(Int, Name)] -> [Name]
forall a b. (a -> b -> b) -> b -> [a] -> b
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
i = m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Name]
xs [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
i))
body0 = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fmap
, [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ys) ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
xs'))
, Int -> Q Exp
forall {m :: * -> *}. Quote m => Int -> m Exp
mkFx Int
field
]
body = (Q Exp -> Int -> Q Exp) -> Q Exp -> [Int] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
a Int
b -> [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<*>), Q Exp
a, Int -> Q Exp
forall {m :: * -> *}. Quote m => Int -> m Exp
mkFx Int
b]) Q Exp
body0 [Int]
fields
let wrap = if Bool
irref then Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP else Q Pat -> Q Pat
forall a. a -> a
id
clause [varP f, wrap (conP conName (map varP xs))]
(normalB body)
[]
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 a. String -> Q a
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 a. a -> Q a
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 (sub1, f) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
f1 Type
f2
(sub2, x) <- unify1 sub1 x1 x2
return (sub2, AppT (applyTypeSubst sub2 f) x)
unify1 Map Name Type
sub Type
x (VarT Name
y)
| Getting (Endo [Name]) Type Name -> Name -> Type -> Bool
forall a s. Eq a => Getting (Endo [a]) s a -> a -> s -> Bool
elemOf Getting (Endo [Name]) Type Name
forall t. HasTypeVars t => Traversal' t Name
Traversal' Type Name
typeVars Name
y (Map Name Type -> Type -> Type
applyTypeSubst Map Name Type
sub Type
x) =
String -> Q (Map Name Type, Type)
forall a. String -> Q a
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 a. a -> Q a
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 [TyVarBndrSpec]
v1 [] Type
t1) (ForallT [TyVarBndrSpec]
v2 [] Type
t2) =
do (sub1,t) <- Map Name Type -> Type -> Type -> Q (Map Name Type, Type)
unify1 Map Name Type
sub Type
t1 Type
t2
v <- fmap nub (traverse (limitedSubst sub1) (v1++v2))
return (sub1, ForallT v [] t)
unify1 Map Name Type
_ Type
x Type
y = String -> Q (Map Name Type, Type)
forall a. String -> Q a
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 -> TyVarBndrSpec -> Q TyVarBndrSpec
limitedSubst Map Name Type
sub TyVarBndrSpec
tv
| Just Type
r <- Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TyVarBndrSpec -> Name
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 ((Name -> Name) -> TyVarBndrSpec -> TyVarBndrSpec
forall flag. (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag
D.mapTVName (Name -> Name -> Name
forall a b. a -> b -> a
const Name
m) TyVarBndrSpec
tv)
Type
_ -> String -> Q TyVarBndrSpec
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to unify exotic higher-rank type"
| Bool
otherwise = TyVarBndrSpec -> Q TyVarBndrSpec
forall a. a -> Q a
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 = (Type -> Maybe Type) -> Type -> Type
forall a b. (Data a, Data b) => (a -> Maybe a) -> b -> b
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
_allowUpdates :: Bool
, LensRules -> Bool
_lazyPatterns :: Bool
, LensRules -> Name -> [Name] -> Name -> [DefName]
_fieldToDef :: Name -> [Name] -> Name -> [DefName]
, LensRules -> Name -> Maybe (Name, Name)
_classyLenses :: Name -> Maybe (Name, Name)
}
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
$cshowsPrec :: Int -> DefName -> String -> String
showsPrec :: Int -> DefName -> String -> String
$cshow :: DefName -> String
show :: DefName -> String
$cshowList :: [DefName] -> String -> String
showList :: [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
$c== :: DefName -> DefName -> Bool
== :: DefName -> DefName -> Bool
$c/= :: DefName -> DefName -> Bool
/= :: 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
$ccompare :: DefName -> DefName -> Ordering
compare :: DefName -> DefName -> Ordering
$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
>= :: DefName -> DefName -> Bool
$cmax :: DefName -> DefName -> DefName
max :: DefName -> DefName -> DefName
$cmin :: DefName -> DefName -> DefName
min :: DefName -> DefName -> DefName
Ord)
liftState :: Monad m => m a -> StateT s m a
liftState :: forall (m :: * -> *) a s. Monad m => m a -> StateT s m a
liftState m a
act = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (\s
s -> (a -> (a, s)) -> m a -> m (a, s)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((a -> s -> (a, s)) -> s -> a -> (a, s)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) s
s) m a
act)