{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
#ifdef TRUSTWORTHY
# if MIN_VERSION_template_haskell(2,12,0)
{-# LANGUAGE Safe #-}
# else
{-# LANGUAGE Trustworthy #-}
# endif
#endif
#include "lens-common.h"
module Control.Lens.TH
(
makeLenses, makeLensesFor
, makeClassy, makeClassyFor, makeClassy_
, makeFields
, makeFieldsNoPrefix
, makePrisms
, makeClassyPrisms
, makeWrapped
, declareLenses, declareLensesFor
, declareClassy, declareClassyFor
, declareFields
, declarePrisms
, declareWrapped
, makeLensesWith
, declareLensesWith
, LensRules
, lensRules
, lensRulesFor
, classyRules
, classyRules_
, defaultFieldRules
, camelCaseFields
, classUnderscoreNoPrefixFields
, underscoreFields
, abbreviatedFields
, lensField
, FieldNamer
, DefName(..)
, lensClass
, ClassyNamer
, simpleLenses
, createClass
, generateSignatures
, generateUpdateableOptics
, generateLazyPatterns
, underscoreNoPrefixNamer
, lookingupNamer
, mappingNamer
, camelCaseNamer
, classUnderscoreNoPrefixNamer
, underscoreNamer
, abbreviatedNamer
) where
import Prelude ()
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Lens
import Control.Lens.Setter
import Control.Lens.Traversal
import Control.Lens.Internal.Prelude as Prelude
import Control.Lens.Internal.TH
import Control.Lens.Internal.FieldTH
import Control.Lens.Internal.PrismTH
import Control.Lens.Wrapped ()
import Control.Lens.Type ()
import Data.Char (toLower, toUpper, isUpper)
import Data.Foldable hiding (concat, any)
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (maybeToList)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Traversable hiding (mapM)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lens
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax hiding (lift)
simpleLenses :: Lens' LensRules Bool
simpleLenses :: Lens' LensRules Bool
simpleLenses Bool -> f Bool
f LensRules
r = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _simpleLenses :: Bool
_simpleLenses = Bool
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 =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _generateSigs :: Bool
_generateSigs = Bool
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 =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _allowUpdates :: Bool
_allowUpdates = Bool
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 =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _lazyPatterns :: Bool
_lazyPatterns = Bool
x}) (Bool -> f Bool
f (LensRules -> Bool
_lazyPatterns LensRules
r))
createClass :: Lens' LensRules Bool
createClass :: Lens' LensRules Bool
createClass Bool -> f Bool
f LensRules
r =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
x -> LensRules
r { _generateClasses :: Bool
_generateClasses = Bool
x}) (Bool -> f Bool
f (LensRules -> Bool
_generateClasses LensRules
r))
lensField :: Lens' LensRules FieldNamer
lensField :: Lens' LensRules FieldNamer
lensField FieldNamer -> f FieldNamer
f LensRules
r = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldNamer
x -> LensRules
r { _fieldToDef :: FieldNamer
_fieldToDef = FieldNamer
x}) (FieldNamer -> f FieldNamer
f (LensRules -> FieldNamer
_fieldToDef LensRules
r))
lensClass :: Lens' LensRules ClassyNamer
lensClass :: Lens' LensRules ClassyNamer
lensClass ClassyNamer -> f ClassyNamer
f LensRules
r = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ClassyNamer
x -> LensRules
r { _classyLenses :: ClassyNamer
_classyLenses = ClassyNamer
x }) (ClassyNamer -> f ClassyNamer
f (LensRules -> ClassyNamer
_classyLenses LensRules
r))
lensRules :: LensRules
lensRules :: LensRules
lensRules = LensRules
{ _simpleLenses :: Bool
_simpleLenses = Bool
False
, _generateSigs :: Bool
_generateSigs = Bool
True
, _generateClasses :: Bool
_generateClasses = Bool
False
, _allowIsos :: Bool
_allowIsos = Bool
True
, _allowUpdates :: Bool
_allowUpdates = Bool
True
, _lazyPatterns :: Bool
_lazyPatterns = Bool
False
, _classyLenses :: ClassyNamer
_classyLenses = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
, _fieldToDef :: FieldNamer
_fieldToDef = FieldNamer
underscoreNoPrefixNamer
}
underscoreNoPrefixNamer :: FieldNamer
underscoreNoPrefixNamer :: FieldNamer
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
xforall a. a -> [a] -> [a]
:String
xs))]
String
_ -> []
lensRulesFor ::
[(String, String)] ->
LensRules
lensRulesFor :: [(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields = LensRules
lensRules forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(String, String)] -> FieldNamer
lookingupNamer [(String, String)]
fields
lookingupNamer :: [(String,String)] -> FieldNamer
lookingupNamer :: [(String, String)] -> FieldNamer
lookingupNamer [(String, String)]
kvs Name
_ [Name]
_ Name
field =
[ Name -> DefName
TopName (String -> Name
mkName String
v) | (String
k,String
v) <- [(String, String)]
kvs, String
k forall a. Eq a => a -> a -> Bool
== Name -> String
nameBase Name
field]
mappingNamer :: (String -> [String])
-> FieldNamer
mappingNamer :: (String -> [String]) -> FieldNamer
mappingNamer String -> [String]
mapper Name
_ [Name]
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> DefName
TopName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
mapper forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
classyRules :: LensRules
classyRules :: LensRules
classyRules = LensRules
{ _simpleLenses :: Bool
_simpleLenses = Bool
True
, _generateSigs :: Bool
_generateSigs = Bool
True
, _generateClasses :: Bool
_generateClasses = Bool
True
, _allowIsos :: Bool
_allowIsos = Bool
False
, _allowUpdates :: Bool
_allowUpdates = Bool
True
, _lazyPatterns :: Bool
_lazyPatterns = Bool
False
, _classyLenses :: ClassyNamer
_classyLenses = \Name
n ->
case Name -> String
nameBase Name
n of
Char
x:String
xs -> forall a. a -> Maybe a
Just (String -> Name
mkName (String
"Has" forall a. [a] -> [a] -> [a]
++ Char
xforall a. a -> [a] -> [a]
:String
xs), String -> Name
mkName (Char -> Char
toLower Char
xforall a. a -> [a] -> [a]
:String
xs))
[] -> forall a. Maybe a
Nothing
, _fieldToDef :: FieldNamer
_fieldToDef = FieldNamer
underscoreNoPrefixNamer
}
classyRulesFor
:: (String -> Maybe (String, String)) ->
[(String, String)] ->
LensRules
classyRulesFor :: (String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor String -> Maybe (String, String)
classFun [(String, String)]
fields = LensRules
classyRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules ClassyNamer
lensClass forall s t a b. ASetter s t a b -> b -> s -> t
.~ (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 (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both) String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (String, String)
classFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase)
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(String, String)] -> FieldNamer
lookingupNamer [(String, String)]
fields
classyRules_ :: LensRules
classyRules_ :: LensRules
classyRules_
= LensRules
classyRules forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName (String -> Name
mkName (Char
'_'forall a. a -> [a] -> [a]
:Name -> String
nameBase Name
n))]
makeLenses :: Name -> DecsQ
makeLenses :: Name -> DecsQ
makeLenses = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
lensRules
makeClassy :: Name -> DecsQ
makeClassy :: Name -> DecsQ
makeClassy = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classyRules
makeClassy_ :: Name -> DecsQ
makeClassy_ :: Name -> DecsQ
makeClassy_ = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classyRules_
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)
makeClassyFor :: String -> String -> [(String, String)] -> Name -> DecsQ
makeClassyFor :: String -> String -> [(String, String)] -> Name -> DecsQ
makeClassyFor String
clsName String
funName [(String, String)]
fields = LensRules -> Name -> DecsQ
makeFieldOptics forall a b. (a -> b) -> a -> b
$
(String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just (String
clsName, String
funName))) [(String, String)]
fields
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith :: LensRules -> Name -> DecsQ
makeLensesWith = LensRules -> Name -> DecsQ
makeFieldOptics
declareLenses :: DecsQ -> DecsQ
declareLenses :: DecsQ -> DecsQ
declareLenses
= LensRules -> DecsQ -> DecsQ
declareLensesWith
forall a b. (a -> b) -> a -> b
$ LensRules
lensRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName Name
n]
declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
declareLensesFor :: [(String, String)] -> DecsQ -> DecsQ
declareLensesFor [(String, String)]
fields
= LensRules -> DecsQ -> DecsQ
declareLensesWith
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName Name
n]
declareClassy :: DecsQ -> DecsQ
declareClassy :: DecsQ -> DecsQ
declareClassy
= LensRules -> DecsQ -> DecsQ
declareLensesWith
forall a b. (a -> b) -> a -> b
$ LensRules
classyRules
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName Name
n]
declareClassyFor ::
[(String, (String, String))] -> [(String, String)] -> DecsQ -> DecsQ
declareClassyFor :: [(String, (String, String))]
-> [(String, String)] -> DecsQ -> DecsQ
declareClassyFor [(String, (String, String))]
classes [(String, String)]
fields
= LensRules -> DecsQ -> DecsQ
declareLensesWith
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor (forall a b. Eq a => a -> [(a, b)] -> Maybe b
`Prelude.lookup`[(String, (String, String))]
classes) [(String, String)]
fields
forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName Name
n]
declarePrisms :: DecsQ -> DecsQ
declarePrisms :: DecsQ -> DecsQ
declarePrisms = (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
[Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) ()
emit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Q a -> Declare a
liftDeclare (Bool -> Dec -> DecsQ
makeDecPrisms Bool
True Dec
dec)
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
declareWrapped :: DecsQ -> DecsQ
declareWrapped :: DecsQ -> DecsQ
declareWrapped = (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
Maybe [Dec]
maybeDecs <- forall a. Q a -> Declare a
liftDeclare forall a b. (a -> b) -> a -> b
$ do
DatatypeInfo
inf <- Dec -> Q DatatypeInfo
normalizeDec Dec
dec
DatatypeInfo -> Q (Maybe [Dec])
makeWrappedForDatatypeInfo DatatypeInfo
inf
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe [Dec]
maybeDecs [Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) ()
emit
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
declareFields :: DecsQ -> DecsQ
declareFields :: DecsQ -> DecsQ
declareFields = LensRules -> DecsQ -> DecsQ
declareLensesWith LensRules
defaultFieldRules
declareLensesWith :: LensRules -> DecsQ -> DecsQ
declareLensesWith :: LensRules -> DecsQ -> DecsQ
declareLensesWith LensRules
rules = (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
[Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) ()
emit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LensRules -> Dec -> HasFieldClasses [Dec]
makeFieldOpticsForDec' LensRules
rules Dec
dec)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dec -> Dec
stripFields Dec
dec
freshMap :: Set Name -> Q (Map Name Name)
freshMap :: Set Name -> Q (Map Name Name)
freshMap Set Name
ns = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Name
ns) (\ Name
n -> (,) Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
n))
apps :: Type -> [Type] -> Type
apps :: Type -> [Type] -> Type
apps = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl Type -> Type -> Type
AppT
makeWrapped :: Name -> DecsQ
makeWrapped :: Name -> DecsQ
makeWrapped Name
nm = do
DatatypeInfo
inf <- Name -> Q DatatypeInfo
reifyDatatype Name
nm
Maybe [Dec]
maybeDecs <- DatatypeInfo -> Q (Maybe [Dec])
makeWrappedForDatatypeInfo DatatypeInfo
inf
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeWrapped: Unsupported data type") forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Dec]
maybeDecs
makeWrappedForDatatypeInfo :: DatatypeInfo -> Q (Maybe [Dec])
makeWrappedForDatatypeInfo :: DatatypeInfo -> Q (Maybe [Dec])
makeWrappedForDatatypeInfo dataInfo :: DatatypeInfo
dataInfo@(DatatypeInfo{datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons})
| [conInfo :: ConstructorInfo
conInfo@(ConstructorInfo{constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
fields})] <- [ConstructorInfo]
cons
, [Type
field] <- [Type]
fields
= do Dec
wrapped <- DatatypeInfo -> ConstructorInfo -> Type -> DecQ
makeWrappedInstance DatatypeInfo
dataInfo ConstructorInfo
conInfo Type
field
Dec
rewrapped <- DatatypeInfo -> DecQ
makeRewrappedInstance DatatypeInfo
dataInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [Dec
rewrapped, Dec
wrapped])
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
makeRewrappedInstance :: DatatypeInfo -> DecQ
makeRewrappedInstance :: DatatypeInfo -> DecQ
makeRewrappedInstance DatatypeInfo
dataInfo = do
Q Type
t <- forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
let typeArgs :: [Name]
typeArgs = forall a b. (a -> b) -> [a] -> [b]
map (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall t. HasName t => Lens' t Name
name) (DatatypeInfo -> [TyVarBndr ()]
datatypeVars DatatypeInfo
dataInfo)
[Name]
typeArgs' <- do
Map Name Name
m <- Set Name -> Q (Map Name Name)
freshMap (forall a. Ord a => [a] -> Set a
Set.fromList [Name]
typeArgs)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
m [Name]
typeArgs)
let appliedType :: Q Type
appliedType = forall (m :: * -> *) a. Monad m => a -> m a
return (DatatypeInfo -> [Type] -> Type
applyDatatypeToArgs DatatypeInfo
dataInfo (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
typeArgs))
appliedType' :: Q Type
appliedType' = forall (m :: * -> *) a. Monad m => a -> m a
return (DatatypeInfo -> [Type] -> Type
applyDatatypeToArgs DatatypeInfo
dataInfo (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
typeArgs'))
eq :: Q Type
eq = Type -> Type -> Type
AppTforall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
EqualityT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type
appliedType' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Type
t
klass :: Q Type
klass = forall (m :: * -> *). Quote m => Name -> m Type
conT Name
rewrappedTypeName Q Type -> [Q Type] -> Q Type
`appsT` [Q Type
appliedType, Q Type
t]
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt [Q Type
eq]) Q Type
klass []
makeWrappedInstance :: DatatypeInfo -> ConstructorInfo -> Type -> DecQ
makeWrappedInstance :: DatatypeInfo -> ConstructorInfo -> Type -> DecQ
makeWrappedInstance DatatypeInfo
dataInfo ConstructorInfo
conInfo Type
fieldType = do
let conName :: Name
conName = ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo
let typeArgs :: [Name]
typeArgs = forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf forall t. HasTypeVars t => Traversal' t Name
typeVars (DatatypeInfo -> [TyVarBndr ()]
datatypeVars DatatypeInfo
dataInfo)
let appliedType :: Type
appliedType = DatatypeInfo -> [Type] -> Type
applyDatatypeToArgs DatatypeInfo
dataInfo (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
typeArgs)
let unwrappedATF :: DecQ
unwrappedATF = Name -> Maybe [Q (TyVarBndr ())] -> [Q Type] -> Q Type -> DecQ
tySynInstDCompat Name
unwrappedTypeName forall a. Maybe a
Nothing
[forall (m :: * -> *) a. Monad m => a -> m a
return Type
appliedType] (forall (m :: * -> *) a. Monad m => a -> m a
return Type
fieldType)
let klass :: Q Type
klass = forall (m :: * -> *). Quote m => Name -> m Type
conT Name
wrappedTypeName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *) a. Monad m => a -> m a
return Type
appliedType
let wrapFun :: Q Exp
wrapFun = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName
let unwrapFun :: Q Exp
unwrapFun = forall (m :: * -> *). Quote m => String -> m Name
newName String
"x" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
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)
let body :: Q Exp
body = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
isoValName, Q Exp
unwrapFun, Q Exp
wrapFun]
let isoMethod :: DecQ
isoMethod = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
_wrapped'ValName [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []]
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) Q Type
klass [DecQ
unwrappedATF, DecQ
isoMethod]
applyDatatypeToArgs :: DatatypeInfo -> [Type] -> Type
applyDatatypeToArgs :: DatatypeInfo -> [Type] -> Type
applyDatatypeToArgs di :: DatatypeInfo
di@(DatatypeInfo { datatypeName :: DatatypeInfo -> Name
datatypeName = Name
nm
, datatypeVars :: DatatypeInfo -> [TyVarBndr ()]
datatypeVars = [TyVarBndr ()]
vars
, datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTypes
}) [Type]
args =
Type -> [Type] -> Type
apps (Name -> Type
ConT Name
nm) forall a b. (a -> b) -> a -> b
$
DatatypeInfo -> [Type] -> [Type]
dropSigsIfNonDataFam DatatypeInfo
di forall a b. (a -> b) -> a -> b
$
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr ()]
vars) [Type]
args)) [Type]
instTypes
overHead :: (a -> a) -> [a] -> [a]
overHead :: forall a. (a -> a) -> [a] -> [a]
overHead a -> a
_ [] = []
overHead a -> a
f (a
x:[a]
xs) = a -> a
f a
x forall a. a -> [a] -> [a]
: [a]
xs
underscoreFields :: LensRules
underscoreFields :: LensRules
underscoreFields = LensRules
defaultFieldRules forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField forall s t a b. ASetter s t a b -> b -> s -> t
.~ FieldNamer
underscoreNamer
underscoreNamer :: FieldNamer
underscoreNamer :: FieldNamer
underscoreNamer Name
_ [Name]
_ Name
field = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ do
String
_ <- String -> Maybe String
prefix String
field'
String
method <- Maybe String
niceLens
String
cls <- Maybe String
classNaming
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
cls) (String -> Name
mkName String
method))
where
field' :: String
field' = Name -> String
nameBase Name
field
prefix :: String -> Maybe String
prefix (Char
'_':String
xs) | Char
'_' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` String
xs = forall a. a -> Maybe a
Just (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'_') String
xs)
prefix String
_ = forall a. Maybe a
Nothing
niceLens :: Maybe String
niceLens = String -> Maybe String
prefix String
field' forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
n -> forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n forall a. Num a => a -> a -> a
+ Int
2) String
field'
classNaming :: Maybe String
classNaming = Maybe String
niceLens forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String
"Has_" forall a. [a] -> [a] -> [a]
++)
camelCaseFields :: LensRules
camelCaseFields :: LensRules
camelCaseFields = LensRules
defaultFieldRules
camelCaseNamer :: FieldNamer
camelCaseNamer :: FieldNamer
camelCaseNamer Name
tyName [Name]
fields Name
field = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ do
String
fieldPart <- forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
expectedPrefix (Name -> String
nameBase Name
field)
String
method <- String -> Maybe String
computeMethod String
fieldPart
let cls :: String
cls = String
"Has" forall a. [a] -> [a] -> [a]
++ String
fieldPart
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
cls) (String -> Name
mkName String
method))
where
expectedPrefix :: String
expectedPrefix = String
optUnderscore forall a. [a] -> [a] -> [a]
++ forall a. (a -> a) -> [a] -> [a]
overHead Char -> Char
toLower (Name -> String
nameBase Name
tyName)
optUnderscore :: String
optUnderscore = [Char
'_' | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"_" 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 = forall a. a -> Maybe a
Just (Char -> Char
toLower Char
x forall a. a -> [a] -> [a]
: String
xs)
computeMethod String
_ = forall a. Maybe a
Nothing
classUnderscoreNoPrefixFields :: LensRules
classUnderscoreNoPrefixFields :: LensRules
classUnderscoreNoPrefixFields =
LensRules
defaultFieldRules forall a b. a -> (a -> b) -> b
& Lens' LensRules FieldNamer
lensField forall s t a b. ASetter s t a b -> b -> s -> t
.~ FieldNamer
classUnderscoreNoPrefixNamer
classUnderscoreNoPrefixNamer :: FieldNamer
classUnderscoreNoPrefixNamer :: FieldNamer
classUnderscoreNoPrefixNamer Name
_ [Name]
_ Name
field = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ do
String
fieldUnprefixed <- forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
"_" (Name -> String
nameBase Name
field)
let className :: String
className = String
"Has" forall a. [a] -> [a] -> [a]
++ forall a. (a -> a) -> [a] -> [a]
overHead Char -> Char
toUpper String
fieldUnprefixed
methodName :: String
methodName = String
fieldUnprefixed
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
className) (String -> Name
mkName String
methodName))
abbreviatedFields :: LensRules
abbreviatedFields :: LensRules
abbreviatedFields = LensRules
defaultFieldRules { _fieldToDef :: FieldNamer
_fieldToDef = FieldNamer
abbreviatedNamer }
abbreviatedNamer :: FieldNamer
abbreviatedNamer :: FieldNamer
abbreviatedNamer Name
_ [Name]
fields Name
field = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ do
String
fieldPart <- String -> Maybe String
stripMaxLc (Name -> String
nameBase Name
field)
String
method <- String -> Maybe String
computeMethod String
fieldPart
let cls :: String
cls = String
"Has" forall a. [a] -> [a] -> [a]
++ String
fieldPart
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> DefName
MethodName (String -> Name
mkName String
cls) (String -> Name
mkName String
method))
where
stripMaxLc :: String -> Maybe String
stripMaxLc String
f = do String
x <- forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
optUnderscore String
f
case forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isUpper String
x of
(String
p,String
s) | forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null String
p Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null String
s -> forall a. Maybe a
Nothing
| Bool
otherwise -> forall a. a -> Maybe a
Just String
s
optUnderscore :: String
optUnderscore = [Char
'_' | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"_" 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 = forall a. a -> Maybe a
Just (Char -> Char
toLower Char
x forall a. a -> [a] -> [a]
: String
xs)
computeMethod String
_ = forall a. Maybe a
Nothing
makeFields :: Name -> DecsQ
makeFields :: Name -> DecsQ
makeFields = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
camelCaseFields
makeFieldsNoPrefix :: Name -> DecsQ
makeFieldsNoPrefix :: Name -> DecsQ
makeFieldsNoPrefix = LensRules -> Name -> DecsQ
makeFieldOptics LensRules
classUnderscoreNoPrefixFields
defaultFieldRules :: LensRules
defaultFieldRules :: LensRules
defaultFieldRules = LensRules
{ _simpleLenses :: Bool
_simpleLenses = Bool
True
, _generateSigs :: Bool
_generateSigs = Bool
True
, _generateClasses :: Bool
_generateClasses = Bool
True
, _allowIsos :: Bool
_allowIsos = Bool
False
, _allowUpdates :: Bool
_allowUpdates = Bool
True
, _lazyPatterns :: Bool
_lazyPatterns = Bool
False
, _classyLenses :: ClassyNamer
_classyLenses = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
, _fieldToDef :: FieldNamer
_fieldToDef = FieldNamer
camelCaseNamer
}
declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith :: (Dec -> Declare Dec) -> DecsQ -> DecsQ
declareWith Dec -> Declare Dec
fun = (Declare [Dec] -> DecsQ
runDeclare forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Applicative f =>
(Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype Dec -> Declare Dec
fun forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)
type Declare = WriterT (Endo [Dec]) (StateT (Set Name) Q)
liftDeclare :: Q a -> Declare a
liftDeclare :: forall a. Q a -> Declare a
liftDeclare = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
runDeclare :: Declare [Dec] -> DecsQ
runDeclare :: Declare [Dec] -> DecsQ
runDeclare Declare [Dec]
dec = do
([Dec]
out, Endo [Dec]
endo) <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT Declare [Dec]
dec) forall a. Set a
Set.empty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
out forall a. [a] -> [a] -> [a]
++ forall a. Endo a -> a -> a
appEndo Endo [Dec]
endo []
emit :: [Dec] -> Declare ()
emit :: [Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) ()
emit [Dec]
decs = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Endo a
Endo ([Dec]
decsforall a. [a] -> [a] -> [a]
++)
traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype :: forall (f :: * -> *).
Applicative f =>
(Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype Dec -> f Dec
f = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Dec -> f Dec
go
where
go :: Dec -> f Dec
go Dec
dec = case Dec
dec of
DataD{} -> Dec -> f Dec
f Dec
dec
NewtypeD{} -> Dec -> f Dec
f Dec
dec
DataInstD{} -> Dec -> f Dec
f Dec
dec
NewtypeInstD{} -> Dec -> f Dec
f Dec
dec
InstanceD Maybe Overlap
moverlap [Type]
ctx Type
inst [Dec]
body -> Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
moverlap [Type]
ctx Type
inst 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 Dec -> f Dec
go [Dec]
body
Dec
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec
stripFields :: Dec -> Dec
stripFields :: Dec -> Dec
stripFields Dec
dec = case Dec
dec of
DataD [Type]
ctx Name
tyName [TyVarBndr ()]
tyArgs Maybe Type
kind [Con]
cons [DerivClause]
derivings ->
[Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [Type]
ctx Name
tyName [TyVarBndr ()]
tyArgs Maybe Type
kind (forall a b. (a -> b) -> [a] -> [b]
map Con -> Con
deRecord [Con]
cons) [DerivClause]
derivings
NewtypeD [Type]
ctx Name
tyName [TyVarBndr ()]
tyArgs Maybe Type
kind Con
con [DerivClause]
derivings ->
[Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD [Type]
ctx Name
tyName [TyVarBndr ()]
tyArgs Maybe Type
kind (Con -> Con
deRecord Con
con) [DerivClause]
derivings
DataInstD [Type]
ctx Maybe [TyVarBndr ()]
tyName Type
tyArgs Maybe Type
kind [Con]
cons [DerivClause]
derivings ->
[Type]
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [Type]
ctx Maybe [TyVarBndr ()]
tyName Type
tyArgs Maybe Type
kind (forall a b. (a -> b) -> [a] -> [b]
map Con -> Con
deRecord [Con]
cons) [DerivClause]
derivings
NewtypeInstD [Type]
ctx Maybe [TyVarBndr ()]
tyName Type
tyArgs Maybe Type
kind Con
con [DerivClause]
derivings ->
[Type]
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD [Type]
ctx Maybe [TyVarBndr ()]
tyName Type
tyArgs Maybe Type
kind (Con -> Con
deRecord Con
con) [DerivClause]
derivings
Dec
_ -> Dec
dec
deRecord :: Con -> Con
deRecord :: Con -> Con
deRecord con :: Con
con@NormalC{} = Con
con
deRecord con :: Con
con@InfixC{} = Con
con
deRecord (ForallC [TyVarBndr Specificity]
tyVars [Type]
ctx Con
con) = [TyVarBndr Specificity] -> [Type] -> Con -> Con
ForallC [TyVarBndr Specificity]
tyVars [Type]
ctx forall a b. (a -> b) -> a -> b
$ Con -> Con
deRecord Con
con
deRecord (RecC Name
conName [VarBangType]
fields) = Name -> [BangType] -> Con
NormalC Name
conName (forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> BangType
dropFieldName [VarBangType]
fields)
deRecord con :: Con
con@GadtC{} = Con
con
deRecord (RecGadtC [Name]
ns [VarBangType]
fields Type
retTy) = [Name] -> [BangType] -> Type -> Con
GadtC [Name]
ns (forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> BangType
dropFieldName [VarBangType]
fields) Type
retTy
dropFieldName :: VarBangType -> BangType
dropFieldName :: VarBangType -> BangType
dropFieldName (Name
_, Bang
str, Type
typ) = (Bang
str, Type
typ)