{-# 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.Tuple
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.Set.Lens
import Data.Traversable hiding (mapM)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Datatype.TyVarBndr as D
import Language.Haskell.TH.Lens
import Language.Haskell.TH.Lib
#if MIN_VERSION_template_haskell(2,15,0)
import Language.Haskell.TH.Ppr (pprint)
#endif
import Language.Haskell.TH.Syntax hiding (lift)
simpleLenses :: Lens' LensRules Bool
simpleLenses :: (Bool -> f Bool) -> LensRules -> f LensRules
simpleLenses Bool -> f Bool
f LensRules
r = (Bool -> LensRules) -> f Bool -> f LensRules
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 :: (Bool -> f Bool) -> LensRules -> f LensRules
generateSignatures Bool -> f Bool
f LensRules
r =
(Bool -> LensRules) -> f Bool -> f LensRules
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 :: (Bool -> f Bool) -> LensRules -> f LensRules
generateUpdateableOptics Bool -> f Bool
f LensRules
r =
(Bool -> LensRules) -> f Bool -> f LensRules
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 :: (Bool -> f Bool) -> LensRules -> f LensRules
generateLazyPatterns Bool -> f Bool
f LensRules
r =
(Bool -> LensRules) -> f Bool -> f LensRules
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 :: (Bool -> f Bool) -> LensRules -> f LensRules
createClass Bool -> f Bool
f LensRules
r =
(Bool -> LensRules) -> f Bool -> f LensRules
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 :: (FieldNamer -> f FieldNamer) -> LensRules -> f LensRules
lensField FieldNamer -> f FieldNamer
f LensRules
r = (FieldNamer -> LensRules) -> f FieldNamer -> f LensRules
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 :: (ClassyNamer -> f ClassyNamer) -> LensRules -> f LensRules
lensClass ClassyNamer -> f ClassyNamer
f LensRules
r = (ClassyNamer -> LensRules) -> f ClassyNamer -> f LensRules
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 :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> FieldNamer
-> ClassyNamer
-> 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 = Maybe (Name, Name) -> ClassyNamer
forall a b. a -> b -> a
const Maybe (Name, Name)
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
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
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
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 String -> String -> Bool
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]
_ = (String -> DefName) -> [String] -> [DefName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> DefName
TopName (Name -> DefName) -> (String -> Name) -> String -> DefName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) ([String] -> [DefName]) -> (Name -> [String]) -> Name -> [DefName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
mapper (String -> [String]) -> (Name -> String) -> Name -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
classyRules :: LensRules
classyRules :: LensRules
classyRules = LensRules :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> FieldNamer
-> ClassyNamer
-> LensRules
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 -> (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 :: 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
LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (ClassyNamer -> Identity ClassyNamer)
-> LensRules -> Identity LensRules
Lens' LensRules ClassyNamer
lensClass ((ClassyNamer -> Identity ClassyNamer)
-> LensRules -> Identity LensRules)
-> ClassyNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (ASetter (Maybe (String, String)) (Maybe (Name, Name)) String Name
-> (String -> Name) -> Maybe (String, String) -> Maybe (Name, Name)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((String, String) -> Identity (Name, Name))
-> Maybe (String, String) -> Identity (Maybe (Name, Name))
forall (f :: * -> *) a b. Functor f => Setter (f a) (f b) a b
mapped (((String, String) -> Identity (Name, Name))
-> Maybe (String, String) -> Identity (Maybe (Name, Name)))
-> ((String -> Identity Name)
-> (String, String) -> Identity (Name, Name))
-> ASetter
(Maybe (String, String)) (Maybe (Name, Name)) String Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity Name)
-> (String, String) -> Identity (Name, Name)
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both) String -> Name
mkName (Maybe (String, String) -> Maybe (Name, Name))
-> (Name -> Maybe (String, String)) -> ClassyNamer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (String, String)
classFun (String -> Maybe (String, String))
-> (Name -> String) -> Name -> Maybe (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase)
LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
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 LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
n -> [Name -> DefName
TopName (String -> Name
mkName (Char
'_'Char -> String -> String
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 (LensRules -> Name -> DecsQ) -> LensRules -> Name -> DecsQ
forall a b. (a -> b) -> a -> b
$
(String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor (Maybe (String, String) -> String -> Maybe (String, String)
forall a b. a -> b -> a
const ((String, String) -> Maybe (String, String)
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
(LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ LensRules
lensRules
LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
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
(LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> LensRules
lensRulesFor [(String, String)]
fields
LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
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
(LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ LensRules
classyRules
LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
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
(LensRules -> DecsQ -> DecsQ) -> LensRules -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (String, String))
-> [(String, String)] -> LensRules
classyRulesFor (String -> [(String, (String, String))] -> Maybe (String, String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`Prelude.lookup`[(String, (String, String))]
classes) [(String, String)]
fields
LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
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 ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
-> (Dec -> Declare Dec) -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
[Dec] -> Declare ()
emit ([Dec] -> Declare ())
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> Declare ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DecsQ -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
forall a. Q a -> Declare a
liftDeclare (Bool -> Dec -> DecsQ
makeDecPrisms Bool
True Dec
dec)
Dec -> Declare 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 ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
-> (Dec -> Declare Dec) -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
Maybe [Dec]
maybeDecs <- Q (Maybe [Dec]) -> Declare (Maybe [Dec])
forall a. Q a -> Declare a
liftDeclare (Dec -> Q (Maybe [Dec])
makeWrappedForDec Dec
dec)
Maybe [Dec] -> ([Dec] -> Declare ()) -> Declare ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe [Dec]
maybeDecs [Dec] -> Declare ()
emit
Dec -> Declare Dec
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 ((Dec -> Declare Dec) -> DecsQ -> DecsQ)
-> (Dec -> Declare Dec) -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ \Dec
dec -> do
[Dec] -> Declare ()
emit ([Dec] -> Declare ())
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> Declare ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Set Name) Q [Dec]
-> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LensRules -> Dec -> StateT (Set Name) Q [Dec]
makeFieldOpticsForDec' LensRules
rules Dec
dec)
Dec -> Declare Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Declare Dec) -> Dec -> Declare Dec
forall a b. (a -> b) -> a -> b
$ Dec -> Dec
stripFields Dec
dec
deNewtype :: Dec -> Dec
#if MIN_VERSION_template_haskell(2,11,0)
deNewtype :: Dec -> Dec
deNewtype (NewtypeD Cxt
ctx Name
tyName [TyVarBndr]
args Maybe Kind
kind Con
c [DerivClause]
d) = Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
ctx Name
tyName [TyVarBndr]
args Maybe Kind
kind [Con
c] [DerivClause]
d
deNewtype (NewtypeInstD Cxt
ctx Maybe [TyVarBndr]
tyName Kind
args Maybe Kind
kind Con
c [DerivClause]
d) = Cxt
-> Maybe [TyVarBndr]
-> Kind
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataInstD Cxt
ctx Maybe [TyVarBndr]
tyName Kind
args Maybe Kind
kind [Con
c] [DerivClause]
d
#else
deNewtype (NewtypeD ctx tyName args c d) = DataD ctx tyName args [c] d
deNewtype (NewtypeInstD ctx tyName args c d) = DataInstD ctx tyName args [c] d
#endif
deNewtype Dec
d = Dec
d
freshMap :: Set Name -> Q (Map Name Name)
freshMap :: Set Name -> Q (Map Name Name)
freshMap Set Name
ns = [(Name, Name)] -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Name)] -> Map Name Name)
-> Q [(Name, Name)] -> Q (Map Name Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name] -> (Name -> Q (Name, Name)) -> Q [(Name, Name)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Set Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Name
ns) (\ Name
n -> (,) Name
n (Name -> (Name, Name)) -> Q Name -> Q (Name, Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName (Name -> String
nameBase Name
n))
apps :: Type -> [Type] -> Type
apps :: Kind -> Cxt -> Kind
apps = (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl Kind -> Kind -> Kind
AppT
makeDataDecl :: Dec -> Maybe DataDecl
makeDataDecl :: Dec -> Maybe DataDecl
makeDataDecl Dec
dec = case Dec -> Dec
deNewtype Dec
dec of
DataD Cxt
ctx Name
tyName [TyVarBndr]
args
#if MIN_VERSION_template_haskell(2,11,0)
Maybe Kind
_
#endif
[Con]
cons [DerivClause]
_ -> DataDecl -> Maybe DataDecl
forall a. a -> Maybe a
Just DataDecl :: Cxt
-> Maybe Name -> [TyVarBndr] -> (Cxt -> Kind) -> [Con] -> DataDecl
DataDecl
{ dataContext :: Cxt
dataContext = Cxt
ctx
, tyConName :: Maybe Name
tyConName = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
tyName
, dataParameters :: [TyVarBndr]
dataParameters = [TyVarBndr]
args
, fullType :: Cxt -> Kind
fullType = Kind -> Cxt -> Kind
apps (Kind -> Cxt -> Kind) -> Kind -> Cxt -> Kind
forall a b. (a -> b) -> a -> b
$ Name -> Kind
ConT Name
tyName
, constructors :: [Con]
constructors = [Con]
cons
}
#if MIN_VERSION_template_haskell(2,15,0)
DataInstD Cxt
ctx Maybe [TyVarBndr]
_ Kind
fnArgs Maybe Kind
_ [Con]
cons [DerivClause]
_
#else
DataInstD ctx familyName args
#if MIN_VERSION_template_haskell(2,11,0)
_
#endif
cons _
#endif
-> DataDecl -> Maybe DataDecl
forall a. a -> Maybe a
Just DataDecl :: Cxt
-> Maybe Name -> [TyVarBndr] -> (Cxt -> Kind) -> [Con] -> DataDecl
DataDecl
{ dataContext :: Cxt
dataContext = Cxt
ctx
, tyConName :: Maybe Name
tyConName = Maybe Name
forall a. Maybe a
Nothing
, dataParameters :: [TyVarBndr]
dataParameters = (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
D.plainTV [Name]
vars
, fullType :: Cxt -> Kind
fullType = \Cxt
tys -> Kind -> Cxt -> Kind
apps (Name -> Kind
ConT Name
familyName) (Cxt -> Kind) -> Cxt -> Kind
forall a b. (a -> b) -> a -> b
$
Map Name Kind -> Cxt -> Cxt
forall t. SubstType t => Map Name Kind -> t -> t
substType ([(Name, Kind)] -> Map Name Kind
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Kind)] -> Map Name Kind)
-> [(Name, Kind)] -> Map Name Kind
forall a b. (a -> b) -> a -> b
$ [Name] -> Cxt -> [(Name, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
vars Cxt
tys) Cxt
args
, constructors :: [Con]
constructors = [Con]
cons
}
where
vars :: [Name]
vars = Set Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set Name -> [Name]) -> Set Name -> [Name]
forall a b. (a -> b) -> a -> b
$ Getting (Set Name) Cxt Name -> Cxt -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Cxt Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Cxt
args
#if MIN_VERSION_template_haskell(2,15,0)
(Name
familyName, Cxt
args) =
case Kind -> (Kind, Cxt)
unfoldType Kind
fnArgs of
(ConT Name
familyName', Cxt
args') -> (Name
familyName', Cxt
args')
(Kind
_, Cxt
_) -> String -> (Name, Cxt)
forall a. HasCallStack => String -> a
error (String -> (Name, Cxt)) -> String -> (Name, Cxt)
forall a b. (a -> b) -> a -> b
$ String
"Illegal data instance LHS: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Ppr a => a -> String
pprint Kind
fnArgs
#endif
Dec
_ -> Maybe DataDecl
forall a. Maybe a
Nothing
data DataDecl = DataDecl
{ DataDecl -> Cxt
dataContext :: Cxt
, DataDecl -> Maybe Name
tyConName :: Maybe Name
, DataDecl -> [TyVarBndr]
dataParameters :: [TyVarBndrUnit]
, DataDecl -> Cxt -> Kind
fullType :: [Type] -> Type
, DataDecl -> [Con]
constructors :: [Con]
}
makeWrapped :: Name -> DecsQ
makeWrapped :: Name -> DecsQ
makeWrapped Name
nm = do
Info
inf <- Name -> Q Info
reify Name
nm
case Info
inf of
TyConI Dec
decl -> do
Maybe [Dec]
maybeDecs <- Dec -> Q (Maybe [Dec])
makeWrappedForDec Dec
decl
DecsQ -> ([Dec] -> DecsQ) -> Maybe [Dec] -> DecsQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> DecsQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeWrapped: Unsupported data type") [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Dec]
maybeDecs
Info
_ -> String -> DecsQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeWrapped: Expected the name of a newtype or datatype"
makeWrappedForDec :: Dec -> Q (Maybe [Dec])
makeWrappedForDec :: Dec -> Q (Maybe [Dec])
makeWrappedForDec Dec
decl = case Dec -> Maybe DataDecl
makeDataDecl Dec
decl of
Just DataDecl
dataDecl | [Con
con] <- DataDecl -> [Con]
constructors DataDecl
dataDecl
, [Kind
field] <- Getting (Endo Cxt) Con Kind -> Con -> Cxt
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf ((BangType -> Const (Endo Cxt) BangType)
-> Con -> Const (Endo Cxt) Con
Traversal' Con BangType
conFields((BangType -> Const (Endo Cxt) BangType)
-> Con -> Const (Endo Cxt) Con)
-> ((Kind -> Const (Endo Cxt) Kind)
-> BangType -> Const (Endo Cxt) BangType)
-> Getting (Endo Cxt) Con Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Kind -> Const (Endo Cxt) Kind)
-> BangType -> Const (Endo Cxt) BangType
forall s t a b. Field2 s t a b => Lens s t a b
_2) Con
con
-> do Dec
wrapped <- DataDecl -> Con -> Kind -> DecQ
makeWrappedInstance DataDecl
dataDecl Con
con Kind
field
Dec
rewrapped <- DataDecl -> DecQ
makeRewrappedInstance DataDecl
dataDecl
Maybe [Dec] -> Q (Maybe [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Maybe [Dec]
forall a. a -> Maybe a
Just [Dec
rewrapped, Dec
wrapped])
Maybe DataDecl
_ -> Maybe [Dec] -> Q (Maybe [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Dec]
forall a. Maybe a
Nothing
makeRewrappedInstance :: DataDecl -> DecQ
makeRewrappedInstance :: DataDecl -> DecQ
makeRewrappedInstance DataDecl
dataDecl = do
TypeQ
t <- Name -> TypeQ
varT (Name -> TypeQ) -> Q Name -> Q TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"t"
let typeArgs :: [Name]
typeArgs = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Getting Name TyVarBndr Name -> TyVarBndr -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name TyVarBndr Name
forall t. HasName t => Lens' t Name
name) (DataDecl -> [TyVarBndr]
dataParameters DataDecl
dataDecl)
[Name]
typeArgs' <- do
Map Name Name
m <- Set Name -> Q (Map Name Name)
freshMap ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name]
typeArgs)
[Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Name -> [Name] -> [Name]
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
m [Name]
typeArgs)
let appliedType :: TypeQ
appliedType = Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (DataDecl -> Cxt -> Kind
fullType DataDecl
dataDecl ((Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
VarT [Name]
typeArgs))
appliedType' :: TypeQ
appliedType' = Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (DataDecl -> Cxt -> Kind
fullType DataDecl
dataDecl ((Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
VarT [Name]
typeArgs'))
#if MIN_VERSION_template_haskell(2,10,0)
eq :: TypeQ
eq = Kind -> Kind -> Kind
AppT(Kind -> Kind -> Kind) -> (Kind -> Kind) -> Kind -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Kind -> Kind
AppT Kind
EqualityT (Kind -> Kind -> Kind) -> TypeQ -> Q (Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
appliedType' Q (Kind -> Kind) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeQ
t
#else
eq = equalP appliedType' t
#endif
klass :: TypeQ
klass = Name -> TypeQ
conT Name
rewrappedTypeName TypeQ -> [TypeQ] -> TypeQ
`appsT` [TypeQ
appliedType, TypeQ
t]
CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt [TypeQ
eq]) TypeQ
klass []
makeWrappedInstance :: DataDecl-> Con -> Type -> DecQ
makeWrappedInstance :: DataDecl -> Con -> Kind -> DecQ
makeWrappedInstance DataDecl
dataDecl Con
con Kind
fieldType = do
let conName :: Name
conName = Getting Name Con Name -> Con -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name Con Name
forall t. HasName t => Lens' t Name
name Con
con
let typeArgs :: [Name]
typeArgs = Getting (Endo [Name]) [TyVarBndr] Name -> [TyVarBndr] -> [Name]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [Name]) [TyVarBndr] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars (DataDecl -> [TyVarBndr]
dataParameters DataDecl
dataDecl)
let appliedType :: Kind
appliedType = DataDecl -> Cxt -> Kind
fullType DataDecl
dataDecl ((Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
VarT [Name]
typeArgs)
let unwrappedATF :: DecQ
unwrappedATF = Name -> Maybe [Q TyVarBndr] -> [TypeQ] -> TypeQ -> DecQ
tySynInstDCompat Name
unwrappedTypeName Maybe [Q TyVarBndr]
forall a. Maybe a
Nothing
[Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
appliedType] (Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
fieldType)
let klass :: TypeQ
klass = Name -> TypeQ
conT Name
wrappedTypeName TypeQ -> TypeQ -> TypeQ
`appT` Kind -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
appliedType
let wrapFun :: ExpQ
wrapFun = Name -> ExpQ
conE Name
conName
let unwrapFun :: ExpQ
unwrapFun = String -> Q Name
newName String
"x" Q Name -> (Name -> ExpQ) -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
x -> PatQ -> ExpQ -> ExpQ
lam1E (Name -> [PatQ] -> PatQ
conP Name
conName [Name -> PatQ
varP Name
x]) (Name -> ExpQ
varE Name
x)
let body :: ExpQ
body = [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
isoValName, ExpQ
unwrapFun, ExpQ
wrapFun]
let isoMethod :: DecQ
isoMethod = Name -> [ClauseQ] -> DecQ
funD Name
_wrapped'ValName [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt []) TypeQ
klass [DecQ
unwrappedATF, DecQ
isoMethod]
overHead :: (a -> a) -> [a] -> [a]
overHead :: (a -> a) -> [a] -> [a]
overHead a -> a
_ [] = []
overHead a -> a
f (a
x:[a]
xs) = a -> a
f a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
underscoreFields :: LensRules
underscoreFields :: LensRules
underscoreFields = LensRules
defaultFieldRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FieldNamer
underscoreNamer
underscoreNamer :: FieldNamer
underscoreNamer :: FieldNamer
underscoreNamer Name
_ [Name]
_ 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
String
_ <- String -> Maybe String
prefix String
field'
String
method <- Maybe String
niceLens
String
cls <- Maybe String
classNaming
DefName -> Maybe DefName
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
'_' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` String
xs = String -> Maybe String
forall a. a -> Maybe a
Just ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') String
xs)
prefix String
_ = Maybe String
forall a. Maybe a
Nothing
niceLens :: Maybe String
niceLens = String -> Maybe String
prefix String
field' Maybe String -> (String -> String) -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
n -> Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) String
field'
classNaming :: Maybe String
classNaming = Maybe String
niceLens Maybe String -> (String -> String) -> Maybe String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String
"Has_" String -> String -> String
forall a. [a] -> [a] -> [a]
++)
camelCaseFields :: LensRules
camelCaseFields :: LensRules
camelCaseFields = LensRules
defaultFieldRules
camelCaseNamer :: FieldNamer
camelCaseNamer :: FieldNamer
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
String
fieldPart <- String -> String -> Maybe String
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" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldPart
DefName -> Maybe DefName
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
overHead 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
List.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
classUnderscoreNoPrefixFields :: LensRules
classUnderscoreNoPrefixFields :: LensRules
classUnderscoreNoPrefixFields =
LensRules
defaultFieldRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FieldNamer
classUnderscoreNoPrefixNamer
classUnderscoreNoPrefixNamer :: FieldNamer
classUnderscoreNoPrefixNamer :: FieldNamer
classUnderscoreNoPrefixNamer Name
_ [Name]
_ 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
String
fieldUnprefixed <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
"_" (Name -> String
nameBase Name
field)
let className :: String
className = String
"Has" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
overHead Char -> Char
toUpper String
fieldUnprefixed
methodName :: String
methodName = String
fieldUnprefixed
DefName -> Maybe DefName
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 = Maybe DefName -> [DefName]
forall a. Maybe a -> [a]
maybeToList (Maybe DefName -> [DefName]) -> Maybe DefName -> [DefName]
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" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldPart
DefName -> Maybe DefName
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 <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
optUnderscore String
f
case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isUpper String
x of
(String
p,String
s) | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null String
p Bool -> Bool -> Bool
|| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.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
List.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
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 :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> FieldNamer
-> ClassyNamer
-> LensRules
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 = Maybe (Name, Name) -> ClassyNamer
forall a b. a -> b -> a
const Maybe (Name, Name)
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 = (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ
runDeclare (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ)
-> ([Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec])
-> [Dec]
-> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec -> Declare Dec)
-> [Dec] -> WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
forall (f :: * -> *).
Applicative f =>
(Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype Dec -> Declare Dec
fun ([Dec] -> DecsQ) -> DecsQ -> DecsQ
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 :: Q a -> Declare a
liftDeclare = StateT (Set Name) Q a -> Declare a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Set Name) Q a -> Declare a)
-> (Q a -> StateT (Set Name) Q a) -> Q a -> Declare a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q a -> StateT (Set Name) Q a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
runDeclare :: Declare [Dec] -> DecsQ
runDeclare :: WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec] -> DecsQ
runDeclare WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
dec = do
([Dec]
out, Endo [Dec]
endo) <- StateT (Set Name) Q ([Dec], Endo [Dec])
-> Set Name -> Q ([Dec], Endo [Dec])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
-> StateT (Set Name) Q ([Dec], Endo [Dec])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT (Endo [Dec]) (StateT (Set Name) Q) [Dec]
dec) Set Name
forall a. Set a
Set.empty
[Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [Dec]
out [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ Endo [Dec] -> [Dec] -> [Dec]
forall a. Endo a -> a -> a
appEndo Endo [Dec]
endo []
emit :: [Dec] -> Declare ()
emit :: [Dec] -> Declare ()
emit [Dec]
decs = Endo [Dec] -> Declare ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Endo [Dec] -> Declare ()) -> Endo [Dec] -> Declare ()
forall a b. (a -> b) -> a -> b
$ ([Dec] -> [Dec]) -> Endo [Dec]
forall a. (a -> a) -> Endo a
Endo ([Dec]
decs[Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++)
traverseDataAndNewtype :: (Applicative f) => (Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype :: (Dec -> f Dec) -> [Dec] -> f [Dec]
traverseDataAndNewtype Dec -> f Dec
f = (Dec -> f Dec) -> [Dec] -> f [Dec]
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
#if MIN_VERSION_template_haskell(2,11,0)
InstanceD Maybe Overlap
moverlap Cxt
ctx Kind
inst [Dec]
body -> Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
moverlap Cxt
ctx Kind
inst ([Dec] -> Dec) -> f [Dec] -> f Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dec -> f Dec) -> [Dec] -> f [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Dec -> f Dec
go [Dec]
body
#else
InstanceD ctx inst body -> InstanceD ctx inst <$> traverse go body
#endif
Dec
_ -> Dec -> f 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
#if MIN_VERSION_template_haskell(2,11,0)
DataD Cxt
ctx Name
tyName [TyVarBndr]
tyArgs Maybe Kind
kind [Con]
cons [DerivClause]
derivings ->
Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
ctx Name
tyName [TyVarBndr]
tyArgs Maybe Kind
kind ((Con -> Con) -> [Con] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Con
deRecord [Con]
cons) [DerivClause]
derivings
NewtypeD Cxt
ctx Name
tyName [TyVarBndr]
tyArgs Maybe Kind
kind Con
con [DerivClause]
derivings ->
Cxt
-> Name -> [TyVarBndr] -> Maybe Kind -> Con -> [DerivClause] -> Dec
NewtypeD Cxt
ctx Name
tyName [TyVarBndr]
tyArgs Maybe Kind
kind (Con -> Con
deRecord Con
con) [DerivClause]
derivings
DataInstD Cxt
ctx Maybe [TyVarBndr]
tyName Kind
tyArgs Maybe Kind
kind [Con]
cons [DerivClause]
derivings ->
Cxt
-> Maybe [TyVarBndr]
-> Kind
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataInstD Cxt
ctx Maybe [TyVarBndr]
tyName Kind
tyArgs Maybe Kind
kind ((Con -> Con) -> [Con] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Con
deRecord [Con]
cons) [DerivClause]
derivings
NewtypeInstD Cxt
ctx Maybe [TyVarBndr]
tyName Kind
tyArgs Maybe Kind
kind Con
con [DerivClause]
derivings ->
Cxt
-> Maybe [TyVarBndr]
-> Kind
-> Maybe Kind
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD Cxt
ctx Maybe [TyVarBndr]
tyName Kind
tyArgs Maybe Kind
kind (Con -> Con
deRecord Con
con) [DerivClause]
derivings
#else
DataD ctx tyName tyArgs cons derivings ->
DataD ctx tyName tyArgs (map deRecord cons) derivings
NewtypeD ctx tyName tyArgs con derivings ->
NewtypeD ctx tyName tyArgs (deRecord con) derivings
DataInstD ctx tyName tyArgs cons derivings ->
DataInstD ctx tyName tyArgs (map deRecord cons) derivings
NewtypeInstD ctx tyName tyArgs con derivings ->
NewtypeInstD ctx tyName tyArgs (deRecord con) derivings
#endif
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]
tyVars Cxt
ctx Con
con) = [TyVarBndr] -> Cxt -> Con -> Con
ForallC [TyVarBndr]
tyVars Cxt
ctx (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ Con -> Con
deRecord Con
con
deRecord (RecC Name
conName [VarBangType]
fields) = Name -> [BangType] -> Con
NormalC Name
conName ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> BangType
dropFieldName [VarBangType]
fields)
#if MIN_VERSION_template_haskell(2,11,0)
deRecord con :: Con
con@GadtC{} = Con
con
deRecord (RecGadtC [Name]
ns [VarBangType]
fields Kind
retTy) = [Name] -> [BangType] -> Kind -> Con
GadtC [Name]
ns ((VarBangType -> BangType) -> [VarBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> BangType
dropFieldName [VarBangType]
fields) Kind
retTy
#endif
#if MIN_VERSION_template_haskell(2,11,0)
dropFieldName :: VarBangType -> BangType
#else
dropFieldName :: VarStrictType -> StrictType
#endif
dropFieldName :: VarBangType -> BangType
dropFieldName (Name
_, Bang
str, Kind
typ) = (Bang
str, Kind
typ)